diff options
307 files changed, 3871 insertions, 1285 deletions
diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index 7bb714aa17..7513564cf0 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -69,6 +69,7 @@ let to_entry (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = in let mind_entry_template = Array.exists check_template mb.mind_packets in let () = if mind_entry_template then assert (Array.for_all check_template mb.mind_packets) in + let mind_entry_variance = Option.map (Array.map (fun v -> Some v)) mb.mind_variance in { mind_entry_record; mind_entry_finite = mb.mind_finite; @@ -76,7 +77,7 @@ let to_entry (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = mind_entry_inds; mind_entry_universes; mind_entry_template; - mind_entry_cumulative= Option.has_some mb.mind_variance; + mind_entry_variance; mind_entry_private = mb.mind_private; } diff --git a/checker/checker.ml b/checker/checker.ml index e2c90e2b93..08d92bb7b3 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -298,7 +298,9 @@ let explain_exn = function | DisallowedSProp -> str"DisallowedSProp" | BadRelevance -> str"BadRelevance" | BadInvert -> str"BadInvert" - | UndeclaredUniverse _ -> str"UndeclaredUniverse")) + | UndeclaredUniverse _ -> str"UndeclaredUniverse" + | BadVariance _ -> str "BadVariance" + )) | InductiveError e -> hov 0 (str "Error related to inductive types") diff --git a/coq-doc.opam b/coq-doc.opam index 2f4072955f..67cdbd8bf0 100644 --- a/coq-doc.opam +++ b/coq-doc.opam @@ -1,3 +1,6 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "dev" synopsis: "The Coq Proof Assistant --- Reference Manual" description: """ Coq is a formal proof management system. It provides @@ -5,37 +8,29 @@ 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." +This package provides the Coq Reference Manual.""" +maintainer: ["The Coq development team <coqdev@inria.fr>"] +authors: ["The Coq development team, INRIA, CNRS, and contributors"] +license: "OPL-1.0" homepage: "https://coq.inria.fr/" +doc: "https://coq.github.io/doc/" bug-reports: "https://github.com/coq/coq/issues" -dev-repo: "https://github.com/coq/coq.git" -license: "Open Publication License" - -version: "dev" - depends: [ - "dune" { build } - "coq" { build & = version } + "dune" {build & >= "2.5.0"} + "coq" {build & = version} ] - -build-env: [ - [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] -] - build: [ - [ "dune" "build" "-p" name "-j" jobs ] -] - -# Would be better to have a *-conf package? -depexts: [ - [ "sphinx" ] - [ "sphinx_rtd_theme" ] - [ "beautifulsoup4" ] - [ "antlr4-python3-runtime"] - [ "pexpect" ] - [ "sphinxcontrib-bibtex" ] + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] ] +dev-repo: "git+https://github.com/coq/coq.git" @@ -1,33 +1,45 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "dev" synopsis: "The Coq Proof Assistant" 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. Typical -applications include the certification of properties of programming -languages (e.g. the CompCert compiler certification project, or the -Bedrock verified low-level programming library), the formalization of -mathematics (e.g. the full formalization of the Feit-Thompson theorem -or homotopy type theory) and teaching. -""" -opam-version: "2.0" -maintainer: "The Coq development team <coqdev@inria.fr>" -authors: "The Coq development team, INRIA, CNRS, and contributors." +semi-interactive development of machine-checked proofs. + +Typical applications include the certification of properties of +programming languages (e.g. the CompCert compiler certification +project, or the Bedrock verified low-level programming library), the +formalization of mathematics (e.g. the full formalization of the +Feit-Thompson theorem or homotopy type theory) and teaching.""" +maintainer: ["The Coq development team <coqdev@inria.fr>"] +authors: ["The Coq development team, INRIA, CNRS, and contributors"] +license: "LGPL-2.1-only" homepage: "https://coq.inria.fr/" +doc: "https://coq.github.io/doc/" bug-reports: "https://github.com/coq/coq/issues" -dev-repo: "git+https://github.com/coq/coq.git" -license: "LGPL-2.1" - -version: "dev" - depends: [ - "ocaml" { >= "4.05.0" } - "dune" { >= "2.5.0" } - "ocamlfind" { build } - "zarith" { >= "1.10" } + "ocaml" {>= "4.05.0"} + "dune" {>= "2.5.0"} + "ocamlfind" {>= "1.8.1"} + "zarith" {>= "1.10"} ] - build: [ - [ "./configure" "-prefix" prefix "-native-compiler" "no" ] - [ "dune" "build" "-p" name "-j" jobs ] + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/coq/coq.git" +build-env: [ + [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] ] diff --git a/coq.opam.template b/coq.opam.template new file mode 100644 index 0000000000..c0efccdc0f --- /dev/null +++ b/coq.opam.template @@ -0,0 +1,3 @@ +build-env: [ + [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] +] diff --git a/coqide-server.opam b/coqide-server.opam index 4cec409f78..101cd4ad78 100644 --- a/coqide-server.opam +++ b/coqide-server.opam @@ -1,4 +1,7 @@ -synopsis: "The Coq Proof Assistant" +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "dev" +synopsis: "The Coq Proof Assistant, XML protocol server" description: """ Coq is a formal proof management system. It provides a formal language to write mathematical definitions, executable @@ -8,21 +11,29 @@ semi-interactive development of machine-checked proofs. This package provides the `coqidetop` language server, an implementation of Coq's [XML protocol](https://github.com/coq/coq/blob/master/dev/doc/xml-protocol.md) which allows clients, such as CoqIDE, to interact with Coq in a -structured way. -""" -opam-version: "2.0" -maintainer: "The Coq development team <coqdev@inria.fr>" -authors: "The Coq development team, INRIA, CNRS, and contributors." +structured way.""" +maintainer: ["The Coq development team <coqdev@inria.fr>"] +authors: ["The Coq development team, INRIA, CNRS, and contributors"] +license: "LGPL-2.1-only" homepage: "https://coq.inria.fr/" +doc: "https://coq.github.io/doc/" bug-reports: "https://github.com/coq/coq/issues" -dev-repo: "git+https://github.com/coq/coq.git" -license: "LGPL-2.1" - -version: "dev" - depends: [ - "dune" { >= "2.0.0" } - "coq" { = version } + "dune" {>= "2.5.0"} + "coq" {= version} ] - -build: [ [ "dune" "build" "-p" name "-j" jobs ] ] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/coq/coq.git" diff --git a/coqide.opam b/coqide.opam index 54b8dca98b..3007200fe5 100644 --- a/coqide.opam +++ b/coqide.opam @@ -1,4 +1,7 @@ -synopsis: "The Coq Proof Assistant" +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "dev" +synopsis: "The Coq Proof Assistant --- GTK3 IDE" description: """ Coq is a formal proof management system. It provides a formal language to write mathematical definitions, executable @@ -6,26 +9,29 @@ algorithms and theorems together with an environment for semi-interactive development of machine-checked proofs. This package provides the CoqIDE, a graphical user interface for the -development of interactive proofs. -""" -opam-version: "2.0" -maintainer: "The Coq development team <coqdev@inria.fr>" -authors: "The Coq development team, INRIA, CNRS, and contributors." +development of interactive proofs.""" +maintainer: ["The Coq development team <coqdev@inria.fr>"] +authors: ["The Coq development team, INRIA, CNRS, and contributors"] +license: "LGPL-2.1-only" homepage: "https://coq.inria.fr/" +doc: "https://coq.github.io/doc/" bug-reports: "https://github.com/coq/coq/issues" -dev-repo: "git+https://github.com/coq/coq.git" -license: "LGPL-2.1" - -version: "dev" - depends: [ - "dune" { >= "2.0.0" } - "coqide-server" { = version } - "lablgtk3" { >= "3.0.beta5" } - "lablgtk3-sourceview3" { >= "3.0.beta5" } + "dune" {>= "2.5.0"} + "coqide-server" {= version} ] - -build-env: [ - [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] +build: [ + ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] ] -build: [ [ "dune" "build" "-p" name "-j" jobs ] ] +dev-repo: "git+https://github.com/coq/coq.git" diff --git a/dev/ci/ci-iris.sh b/dev/ci/ci-iris.sh index 9616f3ce00..d29e6f1635 100755 --- a/dev/ci/ci-iris.sh +++ b/dev/ci/ci-iris.sh @@ -9,13 +9,15 @@ git_download iris_string_ident git_download iris_examples # Extract required version of Iris (avoiding "+" which does not work on MacOS :( *) -iris_CI_REF=$(grep -F '"coq-iris"' < "${CI_BUILD_DIR}/iris_examples/coq-iris-examples.opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') +iris_CI_REF=$(grep -F '"coq-iris-heap-lang"' < "${CI_BUILD_DIR}/iris_examples/coq-iris-examples.opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') +[ -n "$iris_CI_REF" ] || { echo "Could not find Iris dependency version" && exit 1; } # Setup Iris git_download iris # Extract required version of std++ stdpp_CI_REF=$(grep -F '"coq-stdpp"' < "${CI_BUILD_DIR}/iris/coq-iris.opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') +[ -n "$stdpp_CI_REF" ] || { echo "Could not find stdpp dependency version" && exit 1; } # Setup std++ git_download stdpp diff --git a/dev/ci/ci-perennial.sh b/dev/ci/ci-perennial.sh index f3be66e814..306cbdf63c 100755 --- a/dev/ci/ci-perennial.sh +++ b/dev/ci/ci-perennial.sh @@ -6,7 +6,4 @@ ci_dir="$(dirname "$0")" FORCE_GIT=1 git_download perennial -# required by Perennial's coqc.py build wrapper -export LC_ALL=C.UTF-8 - -( cd "${CI_BUILD_DIR}/perennial" && git submodule update --init --recursive && make TIMED=false ) +( cd "${CI_BUILD_DIR}/perennial" && git submodule update --init --recursive && make TIMED=false lite ) diff --git a/dev/ci/user-overlays/12611-ejgallego-record+refactor.sh b/dev/ci/user-overlays/12611-ejgallego-record+refactor.sh new file mode 100644 index 0000000000..b7d21ed59c --- /dev/null +++ b/dev/ci/user-overlays/12611-ejgallego-record+refactor.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "12611" ] || [ "$CI_BRANCH" = "record+refactor" ]; then + + elpi_CI_REF=record+refactor + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + +# mtac2_CI_REF=record+refactor +# mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 + +fi diff --git a/dev/ci/user-overlays/12653-SkySkimmer-cumul-syntax.sh b/dev/ci/user-overlays/12653-SkySkimmer-cumul-syntax.sh new file mode 100644 index 0000000000..1473f6df8b --- /dev/null +++ b/dev/ci/user-overlays/12653-SkySkimmer-cumul-syntax.sh @@ -0,0 +1,15 @@ +if [ "$CI_PULL_REQUEST" = "12653" ] || [ "$CI_BRANCH" = "cumul-syntax" ]; then + + overlay elpi https://github.com/SkySkimmer/coq-elpi cumul-syntax + + overlay equations https://github.com/SkySkimmer/Coq-Equations cumul-syntax + + overlay mtac2 https://github.com/SkySkimmer/Mtac2 cumul-syntax + + overlay paramcoq https://github.com/SkySkimmer/paramcoq cumul-syntax + + overlay rewriter https://github.com/SkySkimmer/rewriter cumul-syntax + + overlay metacoq https://github.com/SkySkimmer/metacoq cumul-syntax + +fi diff --git a/dev/ci/user-overlays/12873-master+minifix-unification-error-reporting-recheck-applications.sh b/dev/ci/user-overlays/12873-master+minifix-unification-error-reporting-recheck-applications.sh new file mode 100644 index 0000000000..7680e8da78 --- /dev/null +++ b/dev/ci/user-overlays/12873-master+minifix-unification-error-reporting-recheck-applications.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "12873" ] || [ "$CI_BRANCH" = "master+minifix-unification-error-reporting-recheck-applications" ]; then + + equations_CI_REF=master+fix12873-better-unification + equations_CI_GITURL=https://github.com/herbelin/Coq-Equations + +fi diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index 8b0bf216e3..de3d5a3d15 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -175,6 +175,12 @@ local copy of Coq. For this purpose, Dune supports the `-p` option, so version of Coq libs, and use a "release" profile that for example enables stronger compiler optimizations. +## OPAM file generation + +`.opam` files are automatically generated by Dune from the package +descriptions in the `dune-project` file; see Dune's manual for more +details. + ## Stanzas `dune` files contain the so-called "stanzas", that may declare: diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 6a6318f97a..5adeafaa38 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -30,6 +30,13 @@ Generic arguments: - Generic arguments: `wit_var` is deprecated, use `wit_hyp`. +Dumpglob: + +- The function `Dumpglob.pause` and `Dumpglob.continue` are replaced + by `Dumpglob.push_output` and `Dumpglob.pop_output`. This allows + plugins to temporarily change/pause the output of Dumpglob, and then + restore it to the original setting. + ## Changes between Coq 8.11 and Coq 8.12 ### Code formatting diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 066facd5db..37619833ac 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -312,6 +312,18 @@ Conversion machines risk: none without using -allow-sprop (off by default in 8.10.0), otherwise could be exploited by mistake +Side-effects + + component: side-effects + summary: polymorphic side-effects inside monomorphic definitions incorrectly handled as not inlined + introduced: ? + impacted released versions: at least from 8.6 to 8.12.0 + impacted coqchk versions: none (no side-effects in the checker) + found by: ppedrot + exploit: test-suite/bugs/closed/bug_13330.v + GH issue number: #13330 + risk: unlikely to be exploited by mistake, requires the use of unsafe tactics + Conflicts with axioms in library component: library of real numbers diff --git a/doc/changelog/01-kernel/13356-primarray-cumul.rst b/doc/changelog/01-kernel/13356-primarray-cumul.rst new file mode 100644 index 0000000000..978ca325bf --- /dev/null +++ b/doc/changelog/01-kernel/13356-primarray-cumul.rst @@ -0,0 +1,5 @@ +- **Changed:** Primitive arrays are now irrelevant in their single + polymorphic universe (same as a polymorphic cumulative list + inductive would be) (`#13356 + <https://github.com/coq/coq/pull/13356>`_, fixes `#13354 + <https://github.com/coq/coq/issues/13354>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/02-specification-language/12653-cumul-syntax.rst b/doc/changelog/02-specification-language/12653-cumul-syntax.rst new file mode 100644 index 0000000000..ba97f7c796 --- /dev/null +++ b/doc/changelog/02-specification-language/12653-cumul-syntax.rst @@ -0,0 +1,5 @@ +- **Added:** Commands :cmd:`Inductive`, :cmd:`Record` and synonyms now + support syntax `Inductive foo@{=i +j *k l}` to specify variance + information for their universes (in :ref:`Cumulative <cumulative>` + mode) (`#12653 <https://github.com/coq/coq/pull/12653>`_, by Gaëtan + Gilbert). diff --git a/doc/changelog/02-specification-language/13188-instance-gen.rst b/doc/changelog/02-specification-language/13188-instance-gen.rst new file mode 100644 index 0000000000..6a431f85ed --- /dev/null +++ b/doc/changelog/02-specification-language/13188-instance-gen.rst @@ -0,0 +1,6 @@ +- **Removed:** The type given to :cmd:`Instance` is no longer automatically + generalized over unbound and :ref:`generalizable <implicit-generalization>` variables. + Use :n:`Instance : \`{@type}` instead of :n:`Instance : @type` to get the old behaviour, or + enable the compatibility flag :flag:`Instance Generalized Output`. + (`#13188 <https://github.com/coq/coq/pull/13188>`_, fixes `#6042 + <https://github.com/coq/coq/issues/6042>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/02-specification-language/13290-master+grant13278-small-inversion-in-prop.rst b/doc/changelog/02-specification-language/13290-master+grant13278-small-inversion-in-prop.rst new file mode 100644 index 0000000000..bf792fda6d --- /dev/null +++ b/doc/changelog/02-specification-language/13290-master+grant13278-small-inversion-in-prop.rst @@ -0,0 +1,6 @@ +- **Added:** + Inference of return predicate of a :g:`match` by inversion takes + sort elimination constraints into account + (`#13290 <https://github.com/coq/coq/pull/13290>`_, + grants `#13278 <https://github.com/coq/coq/issues/13278>`_, + by Hugo Herbelin). diff --git a/doc/changelog/02-specification-language/13376-master+minifix-NotFoundInstance.rst b/doc/changelog/02-specification-language/13376-master+minifix-NotFoundInstance.rst new file mode 100644 index 0000000000..5758f35c3d --- /dev/null +++ b/doc/changelog/02-specification-language/13376-master+minifix-NotFoundInstance.rst @@ -0,0 +1,5 @@ +- **Fixed:** + A case of unification raising an anomaly IllTypedInstance + (`#13376 <https://github.com/coq/coq/pull/13376>`_, + fixes `#13266 <https://github.com/coq/coq/issues/13266>`_, + by Hugo Herbelin). diff --git a/doc/changelog/02-specification-language/13383-master+fix11816-wf-not-allowed-in-local-fixpoint.rst b/doc/changelog/02-specification-language/13383-master+fix11816-wf-not-allowed-in-local-fixpoint.rst new file mode 100644 index 0000000000..c0e5a81641 --- /dev/null +++ b/doc/changelog/02-specification-language/13383-master+fix11816-wf-not-allowed-in-local-fixpoint.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Using :n:`{wf ...}` in local fixpoints is an error, not an anomaly + (`#13383 <https://github.com/coq/coq/pull/13383>`_, + fixes `#11816 <https://github.com/coq/coq/issues/11816>`_, + by Hugo Herbelin). diff --git a/doc/changelog/02-specification-language/13387-master+fix12348-debruijn-bug-imitation.rst b/doc/changelog/02-specification-language/13387-master+fix12348-debruijn-bug-imitation.rst new file mode 100644 index 0000000000..eaf049dc97 --- /dev/null +++ b/doc/changelog/02-specification-language/13387-master+fix12348-debruijn-bug-imitation.rst @@ -0,0 +1,6 @@ +- **Fixed:** + A bug producing ill-typed instances of existential variables when let-ins + interleaved with assumptions + (`#13387 <https://github.com/coq/coq/pull/13387>`_, + fixes `#12348 <https://github.com/coq/coq/issues/13387>`_, + by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12685-master+propagate-scope-in-indirect-applied-ref.rst b/doc/changelog/03-notations/12685-master+propagate-scope-in-indirect-applied-ref.rst new file mode 100644 index 0000000000..048835a0e9 --- /dev/null +++ b/doc/changelog/03-notations/12685-master+propagate-scope-in-indirect-applied-ref.rst @@ -0,0 +1,6 @@ +- **Changed:** + Scope information is propagated in indirect applications to a + reference prefixed with :g:`@@`; this covers for instance the case + :g:`r.(@@p) t` where scope information from :g:`p` is now taken into + account for interpreting :g:`t` (`#12685 + <https://github.com/coq/coq/pull/12685>`_, by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12765-master+partial-app-in-recursive-notation.rst b/doc/changelog/03-notations/12765-master+partial-app-in-recursive-notation.rst new file mode 100644 index 0000000000..82cbefc60b --- /dev/null +++ b/doc/changelog/03-notations/12765-master+partial-app-in-recursive-notation.rst @@ -0,0 +1,4 @@ +- **Added:** + Added support for encoding notations of the form :g:`x ⪯ y ⪯ .. ⪯ z ⪯ t` + (`#12765 <https://github.com/coq/coq/pull/12765>`_, + by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/13337-master+improve-error-dependent-intro-wildcard.rst b/doc/changelog/04-tactics/13337-master+improve-error-dependent-intro-wildcard.rst new file mode 100644 index 0000000000..089647a4b2 --- /dev/null +++ b/doc/changelog/04-tactics/13337-master+improve-error-dependent-intro-wildcard.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Avoiding exposing an internal name of the form :n:`_tmp` when applying the + :n:`_` introduction pattern would break a dependency + (`#13337 <https://github.com/coq/coq/pull/13337>`_, + fixes `#13336 <https://github.com/coq/coq/issues/13336>`_, + by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/13373-master+fix13363-metas-posed-to-evars-in-wrong-env.rst b/doc/changelog/04-tactics/13373-master+fix13363-metas-posed-to-evars-in-wrong-env.rst new file mode 100644 index 0000000000..c02129a33f --- /dev/null +++ b/doc/changelog/04-tactics/13373-master+fix13363-metas-posed-to-evars-in-wrong-env.rst @@ -0,0 +1,6 @@ +- **Fixed:** + The case of tactics, such as :tacn:`eapply`, producing existential variables + under binders with an ill-formed instance + (`#13373 <https://github.com/coq/coq/pull/13373>`_, + fixes `#13363 <https://github.com/coq/coq/issues/13363>`_, + by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/13381-bfs_eauto.rst b/doc/changelog/04-tactics/13381-bfs_eauto.rst new file mode 100644 index 0000000000..a51f96d0a2 --- /dev/null +++ b/doc/changelog/04-tactics/13381-bfs_eauto.rst @@ -0,0 +1,6 @@ +- **Deprecated:** + Undocumented :n:`eauto @int_or_var @int_or_var` syntax in favor of new ``bfs eauto``. + Also deprecated 2-integer syntax for ``debug eauto`` and ``info_eauto``; + replacement TBD. + (`#13381 <https://github.com/coq/coq/pull/13381>`_, + by Jim Fehrle). diff --git a/doc/changelog/06-ssreflect/13317-ssr_dup_swap_apply_ipat.rst b/doc/changelog/06-ssreflect/13317-ssr_dup_swap_apply_ipat.rst new file mode 100644 index 0000000000..8d1564533d --- /dev/null +++ b/doc/changelog/06-ssreflect/13317-ssr_dup_swap_apply_ipat.rst @@ -0,0 +1,4 @@ +- **Added:** + SSReflect intro pattern ltac views ``/[dup]``, ``/[swap]`` and ``/[apply]`` + (`#13317 <https://github.com/coq/coq/pull/13317>`_, + by Cyril Cohen). diff --git a/doc/changelog/07-commands-and-options/12516-deprecate-grab-existentials.rst b/doc/changelog/07-commands-and-options/12516-deprecate-grab-existentials.rst new file mode 100644 index 0000000000..1c7c3102a3 --- /dev/null +++ b/doc/changelog/07-commands-and-options/12516-deprecate-grab-existentials.rst @@ -0,0 +1,4 @@ +- **Deprecated:** + :cmd:`Grab Existential Variables` and :cmd:`Existential` commands + (`#12516 <https://github.com/coq/coq/pull/12516>`_, + by Maxime Dénès). diff --git a/doc/changelog/07-commands-and-options/13040-gc+best_fit.rst b/doc/changelog/07-commands-and-options/13040-gc+best_fit.rst new file mode 100644 index 0000000000..74818f8464 --- /dev/null +++ b/doc/changelog/07-commands-and-options/13040-gc+best_fit.rst @@ -0,0 +1,9 @@ +- **Changed:** + When compiled with OCaml >= 4.10.0, Coq will use the new best-fit GC + policy, which should provide some performance benefits. Coq's policy + is optimized for speed, but could increase memory consumption in + some cases. You are welcome to tune it using the ``OCAMLRUNPARAM`` + variable and report back setting so we could optimize more. + (`#13040 <https://github.com/coq/coq/pull/13040>`_, + fixes `#11277 <https://github.com/coq/coq/issues/11277>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/07-commands-and-options/13339-proof-using-noinit.rst b/doc/changelog/07-commands-and-options/13339-proof-using-noinit.rst new file mode 100644 index 0000000000..9ae759be56 --- /dev/null +++ b/doc/changelog/07-commands-and-options/13339-proof-using-noinit.rst @@ -0,0 +1,5 @@ +- **Added:** + The :cmd:`Proof using` command can now be used without loading the + Ltac plugin (`-noinit` mode) + (`#13339 <https://github.com/coq/coq/pull/13339>`_, + by Théo Zimmermann). diff --git a/doc/changelog/07-commands-and-options/13345-master+doc-add-ml-path-not-exported.rst b/doc/changelog/07-commands-and-options/13345-master+doc-add-ml-path-not-exported.rst new file mode 100644 index 0000000000..dc8010b456 --- /dev/null +++ b/doc/changelog/07-commands-and-options/13345-master+doc-add-ml-path-not-exported.rst @@ -0,0 +1,5 @@ +- **Added:** + Clarify in the documentation that :cmd:`Add ML Path` is not exported to compiled files + (`#13345 <https://github.com/coq/coq/pull/13345>`_, + fixes `#13344 <https://github.com/coq/coq/issues/13344>`_, + by Hugo Herbelin). diff --git a/doc/changelog/07-commands-and-options/13384-warn-unqualified-hint.rst b/doc/changelog/07-commands-and-options/13384-warn-unqualified-hint.rst new file mode 100644 index 0000000000..8ec7198b72 --- /dev/null +++ b/doc/changelog/07-commands-and-options/13384-warn-unqualified-hint.rst @@ -0,0 +1,8 @@ +- **Deprecated:** + The default value for hint locality is currently :attr:`local` in a section and + :attr:`global` otherwise, but is scheduled to change in a future release. For the + time being, adding hints outside of sections without specifying an explicit + locality is therefore triggering a deprecation warning. It is recommended to + use :attr:`export` whenever possible + (`#13384 <https://github.com/coq/coq/pull/13384>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/07-commands-and-options/13388-export-locality-for-all-hint-commands.rst b/doc/changelog/07-commands-and-options/13388-export-locality-for-all-hint-commands.rst new file mode 100644 index 0000000000..df2bdfeabb --- /dev/null +++ b/doc/changelog/07-commands-and-options/13388-export-locality-for-all-hint-commands.rst @@ -0,0 +1,6 @@ +- **Changed:** + The :attr:`export` locality can now be used for all Hint commands, + including Hint Cut, Hint Mode, Hint Transparent / Opaque and + Remove Hints + (`#13388 <https://github.com/coq/coq/pull/13388>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/10-standard-library/12420-decidable.rst b/doc/changelog/10-standard-library/12420-decidable.rst new file mode 100644 index 0000000000..6a4da91fa3 --- /dev/null +++ b/doc/changelog/10-standard-library/12420-decidable.rst @@ -0,0 +1,4 @@ +- **Added:** + ``Decidable`` instance for negation + (`#12420 <https://github.com/coq/coq/pull/12420>`_, + by Yishuai Li). diff --git a/doc/changelog/10-standard-library/13365-axiom-free-wf.rst b/doc/changelog/10-standard-library/13365-axiom-free-wf.rst new file mode 100644 index 0000000000..1fc40894eb --- /dev/null +++ b/doc/changelog/10-standard-library/13365-axiom-free-wf.rst @@ -0,0 +1,4 @@ +- **Fixed:** + `Coq.Program.Wf.Fix_F_inv` and `Coq.Program.Wf.Fix_eq` are now axiom-free. They no longer assume proof irrelevance. + (`#13365 <https://github.com/coq/coq/pull/13365>`_, + by Li-yao Xia). diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index cdd31fcb86..2474c784b8 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -336,20 +336,23 @@ Summary of the commands .. cmd:: Instance {? @ident_decl {* @binder } } : @type {? @hint_info } {? {| := %{ {* @field_def } %} | := @term } } - .. insertprodn hint_info hint_info + .. insertprodn hint_info one_pattern .. prodn:: - hint_info ::= %| {? @natural } {? @one_term } + hint_info ::= %| {? @natural } {? @one_pattern } + one_pattern ::= @one_term Declares a typeclass instance named :token:`ident_decl` of the class :n:`@type` with the specified parameters and with fields defined by :token:`field_def`, where each field must be a declared field of the class. - Add one or more :token:`binder`\s to declare a parameterized instance. :token:`hint_info` - specifies the hint priority, where 0 is the highest priority as for + Adds one or more :token:`binder`\s to declare a parameterized instance. :token:`hint_info` + may be used to specify the hint priority, where 0 is the highest priority as for :tacn:`auto` hints. If the priority is not specified, the default is the number - of non-dependent binders of the instance. + of non-dependent binders of the instance. If :token:`one_pattern` is given, terms + matching that pattern will trigger use of the instance. Otherwise, + use is triggered based on the conclusion of the type. This command supports the :attr:`global` attribute that can be used on instances declared in a section so that their @@ -388,6 +391,16 @@ Summary of the commands equivalent to ``Hint Resolve ident : typeclass_instances``, except it registers instances for :cmd:`Print Instances`. + .. flag:: Instance Generalized Output + + .. deprecated:: 8.13 + + Disabled by default, this provides compatibility with Coq + version 8.12 and earlier. + + When enabled, the type of the instance is implicitly generalized + over unbound and :ref:`generalizable <implicit-generalization>` variables as though surrounded by ``\`{}``. + .. cmd:: Print Instances @reference Shows the list of instances associated with the typeclass :token:`reference`. diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 1fb337b30a..064107d088 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -246,6 +246,7 @@ The following is an example of a record with non-trivial subtyping relation: .. coqtop:: all Polymorphic Cumulative Record packType := {pk : Type}. + About packType. :g:`packType` binds a covariant universe, i.e. @@ -254,6 +255,27 @@ The following is an example of a record with non-trivial subtyping relation: E[Γ] ⊢ \mathsf{packType}@\{i\} =_{βδιζη} \mathsf{packType}@\{j\}~\mbox{ whenever }~i ≤ j +Specifying cumulativity +~~~~~~~~~~~~~~~~~~~~~~~ + +The variance of the universe parameters for a cumulative inductive may be specified by the user. + +For the following type, universe ``a`` has its variance automatically +inferred (it is irrelevant), ``b`` is required to be irrelevant, +``c`` is covariant and ``d`` is invariant. With these annotations +``c`` and ``d`` have less general variances than would be inferred. + +.. coqtop:: all + + Polymorphic Cumulative Inductive Dummy@{a *b +c =d} : Prop := dummy. + About Dummy. + +Insufficiently restrictive variance annotations lead to errors: + +.. coqtop:: all + + Fail Polymorphic Cumulative Record bad@{*a} := {p : Type@{a}}. + An example of a proof using cumulativity ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -280,7 +302,7 @@ An example of a proof using cumulativity End down. Cumulativity Weak Constraints ------------------------------ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. flag:: Cumulativity Weak Constraints @@ -383,6 +405,7 @@ Explicit Universes | _ | @qualid univ_decl ::= @%{ {* @ident } {? + } {? %| {*, @univ_constraint } {? + } } %} + cumul_univ_decl ::= @%{ {* {? {| = | + | * } } @ident } {? + } {? %| {*, @univ_constraint } {? + } } %} univ_constraint ::= @universe_name {| < | = | <= } @universe_name The syntax has been extended to allow users to explicitly bind names diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 8da5014125..de5dbe79cc 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -1224,6 +1224,13 @@ Changes in 8.12.1 <https://github.com/coq/coq/pull/12738>`_, fixes `#7015 <https://github.com/coq/coq/issues/7015>`_, by Gaëtan Gilbert). +- **Fixed:** + Polymorphic side-effects inside monomorphic definitions were incorrectly + handled as not inlined. This allowed deriving an inconsistency + (`#13331 <https://github.com/coq/coq/pull/13331>`_, + fixes `#13330 <https://github.com/coq/coq/issues/13330>`_, + by Pierre-Marie Pédrot). + **Notations** - **Fixed:** @@ -1282,6 +1289,12 @@ Changes in 8.12.1 (`#13301 <https://github.com/coq/coq/pull/13301>`_, fixes `#13298 <https://github.com/coq/coq/issues/13298>`_, by Hugo Herbelin). +- **Fixed:** + :cmd:`Search` supports filtering on parts of identifiers which are + not proper identifiers themselves, such as :n:`"1"` + (`#13351 <https://github.com/coq/coq/pull/13351>`_, + fixes `#13349 <https://github.com/coq/coq/issues/13349>`_, + by Hugo Herbelin). **Tools** diff --git a/doc/sphinx/language/core/definitions.rst b/doc/sphinx/language/core/definitions.rst index 4ea3ea5e6d..79489c85f6 100644 --- a/doc/sphinx/language/core/definitions.rst +++ b/doc/sphinx/language/core/definitions.rst @@ -13,15 +13,18 @@ Let-in definitions .. prodn:: term_let ::= let @name {? : @type } := @term in @term | let @name {+ @binder } {? : @type } := @term in @term - | let ( {*, @name } ) {? {? as @name } return @term100 } := @term in @term - | let ' @pattern := @term {? return @term100 } in @term - | let ' @pattern in @pattern := @term return @term100 in @term - -:n:`let @ident := @term in @term’` -denotes the local binding of :n:`@term` to the variable -:n:`@ident` in :n:`@term`’. There is a syntactic sugar for let-in -definition of functions: :n:`let @ident {+ @binder} := @term in @term’` -stands for :n:`let @ident := fun {+ @binder} => @term in @term’`. + | @destructuring_let + +:n:`let @ident := @term__1 in @term__2` represents the local binding of +the variable :n:`@ident` to the value :n:`@term__1` in :n:`@term__2`. + +:n:`let @ident {+ @binder} := @term__1 in @term__2` is an abbreviation +for :n:`let @ident := fun {+ @binder} => @term__1 in @term__2`. + +.. seealso:: + + Extensions of the `let ... in ...` syntax are described in + :ref:`irrefutable-patterns`. .. index:: single: ... : ... (type cast) diff --git a/doc/sphinx/language/core/inductive.rst b/doc/sphinx/language/core/inductive.rst index d3bd787587..ad7d6f3963 100644 --- a/doc/sphinx/language/core/inductive.rst +++ b/doc/sphinx/language/core/inductive.rst @@ -8,13 +8,14 @@ Inductive types .. cmd:: Inductive @inductive_definition {* with @inductive_definition } - .. insertprodn inductive_definition constructor + .. insertprodn inductive_definition cumul_ident_decl .. prodn:: - inductive_definition ::= {? > } @ident_decl {* @binder } {? %| {* @binder } } {? : @type } {? := {? @constructors_or_record } } {? @decl_notations } + inductive_definition ::= {? > } @cumul_ident_decl {* @binder } {? %| {* @binder } } {? : @type } {? := {? @constructors_or_record } } {? @decl_notations } constructors_or_record ::= {? %| } {+| @constructor } | {? @ident } %{ {*; @record_field } {? ; } %} constructor ::= @ident {* @binder } {? @of_type } + cumul_ident_decl ::= @ident {? @cumul_univ_decl } This command defines one or more inductive types and its constructors. Coq generates destructors diff --git a/doc/sphinx/language/extensions/match.rst b/doc/sphinx/language/extensions/match.rst index 23389eba3b..8e62c2af13 100644 --- a/doc/sphinx/language/extensions/match.rst +++ b/doc/sphinx/language/extensions/match.rst @@ -86,6 +86,13 @@ Pattern-matching on terms inhabiting inductive type having only one constructor can be alternatively written using :g:`let … in …` constructions. There are two variants of them. +.. insertprodn destructuring_let destructuring_let + +.. prodn:: + destructuring_let ::= let ( {*, @name } ) {? {? as @name } return @term100 } := @term in @term + | let ' @pattern := @term {? return @term100 } in @term + | let ' @pattern in @pattern := @term return @term100 in @term + First destructuring let syntax ++++++++++++++++++++++++++++++ diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 22544b2018..07c2d268c6 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -1647,7 +1647,10 @@ Notations can be used to name tactics, for example Notation "'myop'" := (ltac:(my ltac code)) : ssripat_scope. lets one write just ``/myop`` in the intro pattern. Note the scope -annotation: views are interpreted opening the ``ssripat`` scope. +annotation: views are interpreted opening the ``ssripat`` scope. We +provide the following ltac views: ``/[dup]`` to duplicate the top of +the stack, ``/[swap]`` to swap the two first elements and ``/[apply]`` +to apply the top of the stack to the next. Intro patterns `````````````` diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 36c722bf9b..86d1d25745 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -133,7 +133,7 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). .. prodn:: search_item ::= {? {| head | hyp | concl | headhyp | headconcl } : } @string {? % @scope_key } - | {? {| head | hyp | concl | headhyp | headconcl } : } @one_term + | {? {| head | hyp | concl | headhyp | headconcl } : } @one_pattern | is : @logical_kind Searched objects can be filtered by patterns, by the constants they @@ -141,9 +141,9 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). names. The location of the pattern or constant within a term - :n:`@one_term` + :n:`@one_pattern` Search for objects whose type contains a subterm matching the - pattern :n:`@one_term`. Holes of the pattern are indicated by + pattern :n:`@one_pattern`. Holes of the pattern are indicated by `_` or :n:`?@ident`. If the same :n:`?@ident` occurs more than once in the pattern, all occurrences in the subterm must be identical. See :ref:`this example <search-pattern>`. @@ -312,7 +312,7 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). Search is:Instance [ Reflexive | Symmetric ]. -.. cmd:: SearchHead @one_term {? {| inside | outside } {+ @qualid } } +.. cmd:: SearchHead @one_pattern {? {| inside | outside } {+ @qualid } } .. deprecated:: 8.12 @@ -320,8 +320,8 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). Displays the name and type of all hypotheses of the selected goal (if any) and theorems of the current context that have the - form :n:`{? forall {* @binder }, } {* P__i -> } C` where :n:`@one_term` - matches a subterm of `C` in head position. For example, a :n:`@one_term` of `f _ b` + form :n:`{? forall {* @binder }, } {* P__i -> } C` where :n:`@one_pattern` + matches a subterm of `C` in head position. For example, a :n:`@one_pattern` of `f _ b` matches `f a b`, which is a subterm of `C` in head position when `C` is `f a b c`. See :cmd:`Search` for an explanation of the `inside`/`outside` clauses. @@ -337,12 +337,12 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). SearchHead le. SearchHead (@eq bool). -.. cmd:: SearchPattern @one_term {? {| inside | outside } {+ @qualid } } +.. cmd:: SearchPattern @one_pattern {? {| inside | outside } {+ @qualid } } Displays the name and type of all hypotheses of the selected goal (if any) and theorems of the current context ending with :n:`{? forall {* @binder }, } {* P__i -> } C` that match the pattern - :n:`@one_term`. + :n:`@one_pattern`. See :cmd:`Search` for an explanation of the `inside`/`outside` clauses. @@ -362,11 +362,11 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). SearchPattern (?X1 + _ = _ + ?X1). -.. cmd:: SearchRewrite @one_term {? {| inside | outside } {+ @qualid } } +.. cmd:: SearchRewrite @one_pattern {? {| inside | outside } {+ @qualid } } Displays the name and type of all hypotheses of the selected goal (if any) and theorems of the current context that have the form - :n:`{? forall {* @binder }, } {* P__i -> } LHS = RHS` where :n:`@one_term` + :n:`{? forall {* @binder }, } {* P__i -> } LHS = RHS` where :n:`@one_pattern` matches either `LHS` or `RHS`. See :cmd:`Search` for an explanation of the `inside`/`outside` clauses. @@ -640,8 +640,9 @@ file is a particular case of a module called a *library file*. This commands dynamically loads OCaml compiled code from a :n:`.mllib` file. It is used to load plugins dynamically. The - files must be accessible in the current OCaml loadpath (see the - command :cmd:`Add ML Path`). The :n:`.mllib` suffix may be omitted. + files must be accessible in the current OCaml loadpath (see + :ref:`command line option <command-line-options>` :n:`-I` and command :cmd:`Add ML Path`). The + :n:`.mllib` suffix may be omitted. This command is reserved for plugin developers, who should provide a .v file containing the command. Users of the plugins will then generally @@ -719,17 +720,19 @@ the toplevel, and using them in source files is discouraged. .. cmd:: Add ML Path @string - This command adds the path :n:`@string` to the current OCaml - loadpath (cf. :cmd:`Declare ML Module`). - + Equivalent to the :ref:`command line option <command-line-options>` + :n:`-I @string`. Adds the path :n:`@string` to the current OCaml + loadpath (cf. :cmd:`Declare ML Module`). It is for + convenience, such as for use in an interactive session, and it + is not exported to compiled files. For separation of concerns with + respect to the relocability of files, we recommend using + :n:`-I @string`. .. cmd:: Print ML Path - This command displays the current OCaml loadpath. This - command makes sense only under the bytecode version of ``coqtop``, i.e. - using option ``-byte`` - (cf. :cmd:`Declare ML Module`). - + Displays the current OCaml loadpath, as provided by + the :ref:`command line option <command-line-options>` :n:`-I @string` or by the command :cmd:`Add + ML Path` `@string` (cf. :cmd:`Declare ML Module`). .. _backtracking_subsection: diff --git a/doc/sphinx/proofs/automatic-tactics/auto.rst b/doc/sphinx/proofs/automatic-tactics/auto.rst index e6dc6f6c51..cc4ab76502 100644 --- a/doc/sphinx/proofs/automatic-tactics/auto.rst +++ b/doc/sphinx/proofs/automatic-tactics/auto.rst @@ -123,6 +123,10 @@ Programmable proof search .. example:: + .. coqtop:: none + + Set Warnings "-deprecated-hint-without-locality". + .. coqtop:: all Hint Resolve ex_intro : core. @@ -280,13 +284,18 @@ automatically created. sections. + :attr:`export` are visible from other modules when they import the current - module. Requiring it is not enough. This attribute is only effective for - the :cmd:`Hint Resolve`, :cmd:`Hint Immediate`, :cmd:`Hint Unfold` and - :cmd:`Hint Extern` variants of the command. + module. Requiring it is not enough. + :attr:`global` hints are made available by merely requiring the current module. + .. deprecated:: 8.13 + + The default value for hint locality is scheduled to change in a future + release. For the time being, adding hints outside of sections without + specifying an explicit locality is therefore triggering a deprecation + warning. It is recommended to use :attr:`export` whenever possible + The various possible :production:`hint_definition`\s are given below. .. cmdv:: Hint @hint_definition @@ -407,6 +416,10 @@ automatically created. .. example:: + .. coqtop:: none + + Set Warnings "-deprecated-hint-without-locality". + .. coqtop:: in Hint Extern 4 (~(_ = _)) => discriminate : core. @@ -421,7 +434,11 @@ automatically created. .. example:: - .. coqtop:: reset all + .. coqtop:: reset none + + Set Warnings "-deprecated-hint-without-locality". + + .. coqtop:: all Require Import List. Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => generalize X1, X2; decide equality : eqdec. diff --git a/doc/sphinx/proofs/writing-proofs/proof-mode.rst b/doc/sphinx/proofs/writing-proofs/proof-mode.rst index fd8a0329d6..40d032543f 100644 --- a/doc/sphinx/proofs/writing-proofs/proof-mode.rst +++ b/doc/sphinx/proofs/writing-proofs/proof-mode.rst @@ -288,12 +288,18 @@ Name a set of section hypotheses for ``Proof using`` existential variables remain. To instantiate existential variables during proof edition, you should use the tactic :tacn:`instantiate`. + .. deprecated:: 8.13 + .. cmd:: Grab Existential Variables This command can be run when a proof has no more goal to be solved but has remaining uninstantiated existential variables. It takes every uninstantiated existential variable and turns it into a goal. + .. deprecated:: 8.13 + + Use :cmd:`Unshelve` instead. + Proof modes ``````````` diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index f36767b207..56b14d0935 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -787,20 +787,39 @@ nested iterating pattern, the second placeholder is finally filled with the terminating expression. In the example above, the iterator :math:`φ([~]_E , [~]_I)` is :math:`cons [~]_E\, [~]_I` -and the terminating expression is ``nil``. Here are other examples: +and the terminating expression is ``nil``. + +Here is another example with the pattern associating on the left: .. coqtop:: in Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) (at level 0). +Here is an example with more involved recursive patterns: + +.. coqtop:: in + Notation "[| t * ( x , y , .. , z ) ; ( a , b , .. , c ) * u |]" := (pair (pair .. (pair (pair t x) (pair t y)) .. (pair t z)) (pair .. (pair (pair a u) (pair b u)) .. (pair c u))) (t at level 39). -Notations with recursive patterns can be reserved like standard -notations, they can also be declared within -:ref:`notation scopes <Scopes>`. +To give a flavor of the extent and limits of the mechanism, here is an +example showing a notation for a chain of equalities. It relies on an +artificial expansion of the intended denotation so as to expose a +``φ(x, .. φ(y,t) ..)`` structure, with the drawback that if ever the +beta-redexes are contracted, the notations stops to be used for +printing. + +.. coqtop:: in + + Notation "x ⪯ y ⪯ .. ⪯ z ⪯ t" := + ((fun b A a => a <= b /\ A b) y .. ((fun b A a => a <= b /\ A b) z (fun b => b <= t)) .. x) + (at level 70, y at next level, z at next level, t at next level). + +Note finally that notations with recursive patterns can be reserved like +standard notations, they can also be declared within :ref:`notation +scopes <Scopes>`. .. _RecursiveNotationsWithBinders: diff --git a/doc/sphinx/using/tools/coqdoc.rst b/doc/sphinx/using/tools/coqdoc.rst index 7ab8f9d763..b68b2ed2a7 100644 --- a/doc/sphinx/using/tools/coqdoc.rst +++ b/doc/sphinx/using/tools/coqdoc.rst @@ -200,6 +200,14 @@ at the beginning of a line. if n <= 1 then 1 else n * fact (n-1) >> +Verbatim material on a single line is also possible (assuming that +``>>`` is not part of the text to be presented as verbatim). + +.. example:: + + :: + + Here is the corresponding caml expression: << fact (n-1) >> Hyperlinks diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 4ad32e15eb..4c1956d172 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -285,9 +285,12 @@ term_let: [ (* Don't need to document that "( )" is equivalent to "()" *) | REPLACE "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" term200 "in" term200 | WITH "let" "(" LIST0 name SEP "," ")" as_return_type ":=" term200 "in" term200 +| MOVETO destructuring_let "let" "(" LIST0 name SEP "," ")" as_return_type ":=" term200 "in" term200 | REPLACE "let" "'" pattern200 ":=" term200 "in" term200 -| WITH "let" "'" pattern200 ":=" term200 OPT case_type "in" term200 +| WITH "let" "'" pattern200 ":=" term200 OPT case_type "in" term200 | DELETE "let" "'" pattern200 ":=" term200 case_type "in" term200 +| MOVETO destructuring_let "let" "'" pattern200 ":=" term200 OPT case_type "in" term200 +| MOVETO destructuring_let "let" "'" pattern200 "in" pattern200 ":=" term200 case_type "in" term200 ] atomic_constr: [ @@ -2478,7 +2481,6 @@ SPLICE: [ | binders | casted_constr | check_module_types -| constr_pattern | decl_sep | function_fix_definition (* loses funind annotation *) | glob @@ -2652,6 +2654,7 @@ RENAME: [ | ssrfwd ssrdefbody | ssrclauses ssr_in | ssrcpat ssrblockpat +| constr_pattern one_pattern ] simple_tactic: [ diff --git a/doc/tools/docgram/dune b/doc/tools/docgram/dune index 2a7b283f55..1c07d00d4f 100644 --- a/doc/tools/docgram/dune +++ b/doc/tools/docgram/dune @@ -12,7 +12,6 @@ (glob_files %{project_root}/parsing/*.mlg) (glob_files %{project_root}/toplevel/*.mlg) (glob_files %{project_root}/vernac/*.mlg) - ; All plugins except SSReflect for now (mimicking what is done in Makefile.doc) (glob_files %{project_root}/plugins/btauto/*.mlg) (glob_files %{project_root}/plugins/cc/*.mlg) (glob_files %{project_root}/plugins/derive/*.mlg) @@ -23,8 +22,11 @@ (glob_files %{project_root}/plugins/micromega/*.mlg) (glob_files %{project_root}/plugins/nsatz/*.mlg) (glob_files %{project_root}/plugins/omega/*.mlg) - (glob_files %{project_root}/plugins/rtauto/*.mlg) (glob_files %{project_root}/plugins/ring/*.mlg) + (glob_files %{project_root}/plugins/rtauto/*.mlg) + (glob_files %{project_root}/plugins/ssr/*.mlg) + (glob_files %{project_root}/plugins/ssrmatching/*.mlg) + (glob_files %{project_root}/plugins/ssrsearch/*.mlg) (glob_files %{project_root}/plugins/syntax/*.mlg) (glob_files %{project_root}/user-contrib/Ltac2/*.mlg) ; Sphinx files diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index a787d769fb..033ece04de 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -1623,6 +1623,7 @@ simple_tactic: [ | "debug" "eauto" OPT int_or_var OPT int_or_var auto_using hintbases | "info_eauto" OPT int_or_var OPT int_or_var auto_using hintbases | "dfs" "eauto" OPT int_or_var auto_using hintbases +| "bfs" "eauto" OPT int_or_var auto_using hintbases | "autounfold" hintbases clause_dft_concl | "autounfold_one" hintbases "in" hyp | "autounfold_one" hintbases diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index c697043f27..dfd3a18908 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -434,6 +434,10 @@ univ_decl: [ | "@{" LIST0 ident OPT "+" OPT [ "|" LIST0 univ_constraint SEP "," OPT "+" ] "}" ] +cumul_univ_decl: [ +| "@{" LIST0 ( OPT [ "=" | "+" | "*" ] ident ) OPT "+" OPT [ "|" LIST0 univ_constraint SEP "," OPT "+" ] "}" +] + univ_constraint: [ | universe_name [ "<" | "=" | "<=" ] universe_name ] @@ -473,6 +477,10 @@ ssr_dpat: [ term_let: [ | "let" name OPT ( ":" type ) ":=" term "in" term | "let" name LIST1 binder OPT ( ":" type ) ":=" term "in" term +| destructuring_let +] + +destructuring_let: [ | "let" "(" LIST0 name SEP "," ")" OPT [ OPT [ "as" name ] "return" term100 ] ":=" term "in" term | "let" "'" pattern ":=" term OPT ( "return" term100 ) "in" term | "let" "'" pattern "in" pattern ":=" term "return" term100 "in" term @@ -691,7 +699,7 @@ field_def: [ ] inductive_definition: [ -| OPT ">" ident_decl LIST0 binder OPT [ "|" LIST0 binder ] OPT [ ":" type ] OPT ( ":=" OPT constructors_or_record ) OPT decl_notations +| OPT ">" cumul_ident_decl LIST0 binder OPT [ "|" LIST0 binder ] OPT [ ":" type ] OPT ( ":=" OPT constructors_or_record ) OPT decl_notations ] constructors_or_record: [ @@ -703,6 +711,10 @@ constructor: [ | ident LIST0 binder OPT of_type ] +cumul_ident_decl: [ +| ident OPT cumul_univ_decl +] + filtered_import: [ | qualid OPT [ "(" LIST1 ( qualid OPT [ "(" ".." ")" ] ) SEP "," ")" ] ] @@ -724,7 +736,11 @@ sort_family: [ ] hint_info: [ -| "|" OPT natural OPT one_term +| "|" OPT natural OPT one_pattern +] + +one_pattern: [ +| one_term ] module_binder: [ @@ -1011,7 +1027,7 @@ command: [ | "Prenex" "Implicits" LIST1 qualid (* SSR plugin *) | "Print" "Hint" "View" OPT ssrviewpos (* SSR plugin *) | "Hint" "View" OPT ssrviewpos LIST1 ( one_term OPT ( "|" natural ) ) (* SSR plugin *) -| "Search" OPT LIST1 ( "-" [ string OPT ( "%" ident ) | one_term ] ) OPT ( "in" LIST1 ( OPT "-" qualid ) ) (* SSR plugin *) +| "Search" OPT LIST1 ( "-" [ string OPT ( "%" ident ) | one_pattern ] ) OPT ( "in" LIST1 ( OPT "-" qualid ) ) (* SSR plugin *) | "Typeclasses" "Transparent" LIST1 qualid | "Typeclasses" "Opaque" LIST1 qualid | "Typeclasses" "eauto" ":=" OPT "debug" OPT ( "(" [ "bfs" | "dfs" ] ")" ) OPT natural @@ -1107,9 +1123,9 @@ command: [ | "Compute" term | "Check" term | "About" reference OPT univ_name_list -| "SearchHead" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) -| "SearchPattern" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) -| "SearchRewrite" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "SearchHead" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "SearchPattern" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "SearchRewrite" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "Search" LIST1 ( search_query ) OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "Ltac2" OPT "mutable" OPT "rec" tac2def_body LIST0 ( "with" tac2def_body ) | "Ltac2" "Type" OPT "rec" tac2typ_def LIST0 ( "with" tac2typ_def ) @@ -1167,7 +1183,7 @@ search_query: [ search_item: [ | OPT ( [ "head" | "hyp" | "concl" | "headhyp" | "headconcl" ] ":" ) string OPT ( "%" scope_key ) -| OPT ( [ "head" | "hyp" | "concl" | "headhyp" | "headconcl" ] ":" ) one_term +| OPT ( [ "head" | "hyp" | "concl" | "headhyp" | "headconcl" ] ":" ) one_pattern | "is" ":" logical_kind ] @@ -1196,7 +1212,7 @@ hint: [ | "Mode" qualid LIST1 [ "+" | "!" | "-" ] | "Unfold" LIST1 qualid | "Constructors" LIST1 qualid -| "Extern" natural OPT one_term "=>" ltac_expr +| "Extern" natural OPT one_pattern "=>" ltac_expr ] tacdef_body: [ @@ -1746,6 +1762,7 @@ simple_tactic: [ | "debug" "eauto" OPT int_or_var OPT int_or_var OPT auto_using OPT hintbases | "info_eauto" OPT int_or_var OPT int_or_var OPT auto_using OPT hintbases | "dfs" "eauto" OPT int_or_var OPT auto_using OPT hintbases +| "bfs" "eauto" OPT int_or_var OPT auto_using OPT hintbases | "autounfold" OPT hintbases OPT clause_dft_concl | "autounfold_one" OPT hintbases OPT ( "in" ident ) | "unify" one_term one_term OPT ( "with" ident ) @@ -2404,9 +2421,9 @@ tac2mode: [ | "Compute" term | "Check" term | "About" reference OPT univ_name_list -| "SearchHead" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) -| "SearchPattern" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) -| "SearchRewrite" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "SearchHead" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "SearchPattern" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "SearchRewrite" one_pattern OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "Search" LIST1 ( search_query ) OPT ( [ "inside" | "outside" ] LIST1 qualid ) ] diff --git a/dune-project b/dune-project index 873d03e8dd..1265c993b7 100644 --- a/dune-project +++ b/dune-project @@ -5,6 +5,79 @@ (formatting (enabled_for ocaml)) -; TODO -; -; (generate_opam_files true) +(generate_opam_files true) + +(license LGPL-2.1-only) +(maintainers "The Coq development team <coqdev@inria.fr>") +(authors "The Coq development team, INRIA, CNRS, and contributors") +; This generates bug-reports and dev-repo +(source (github coq/coq)) +(homepage https://coq.inria.fr/) +(documentation "https://coq.github.io/doc/") +(version dev) + +; Note that we use coq.opam.template to have dune add the correct opam +; prefix for configure +(package + (name coq) + (depends + (ocaml (>= 4.05.0)) + (dune (>= 2.5.0)) + (ocamlfind (>= 1.8.1)) + (zarith (>= 1.10))) + (synopsis "The Coq Proof Assistant") + (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. + +Typical applications include the certification of properties of +programming languages (e.g. the CompCert compiler certification +project, or the Bedrock verified low-level programming library), the +formalization of mathematics (e.g. the full formalization of the +Feit-Thompson theorem or homotopy type theory) and teaching.")) + +(package + (name coqide-server) + (depends + (dune (>= 2.5.0)) + (coq (= :version))) + (synopsis "The Coq Proof Assistant, XML protocol server") + (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 `coqidetop` language server, an +implementation of Coq's [XML protocol](https://github.com/coq/coq/blob/master/dev/doc/xml-protocol.md) +which allows clients, such as CoqIDE, to interact with Coq in a +structured way.")) + +(package + (name coqide) + (depends + (dune (>= 2.5.0)) + (coqide-server (= :version))) + (synopsis "The Coq Proof Assistant --- GTK3 IDE") + (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 CoqIDE, a graphical user interface for the +development of interactive proofs.")) + +(package + (name coq-doc) + (license "OPL-1.0") + (depends + (dune (and :build (>= 2.5.0))) + (coq (and :build (= :version)))) + (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.")) + diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 0c84dee572..c29de27efb 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -452,6 +452,9 @@ let eq_universes env sigma cstrs cv_pb refargs l l' = let open GlobRef in let open UnivProblem in match refargs with + | Some (ConstRef c, 1) when Environ.is_array_type env c -> + cstrs := compare_cumulative_instances cv_pb true [|Univ.Variance.Irrelevant|] l l' !cstrs; + true | None | Some (ConstRef _, _) -> cstrs := enforce_eq_instances_univs true l l' !cstrs; true | Some (VarRef _, _) -> assert false (* variables don't have instances *) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 771571fd3f..ba6a9ea6d9 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -371,7 +371,8 @@ let push_rel_decl_to_named_context let subst = update_var id0 id subst in let d = decl |> NamedDecl.of_rel_decl (fun _ -> id0) |> map_decl (csubst_subst subst) in let nc = replace_var_named_declaration id0 id nc in - (push_var id0 subst, Id.Set.add id avoid, push_named_context_val d nc) + let avoid = Id.Set.add id (Id.Set.add id0 avoid) in + (push_var id0 subst, avoid, push_named_context_val d nc) | Some id0 when hypnaming = FailIfConflict -> user_err Pp.(Id.print id0 ++ str " is already used.") | _ -> diff --git a/engine/evd.ml b/engine/evd.ml index 4ae1d034d7..498a9d9825 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -832,9 +832,9 @@ let empty = { extras = Store.empty; } -let from_env e = { empty with universes = UState.from_env e } +let from_env ?binders e = { empty with universes = UState.from_env ?binders e } -let from_ctx ctx = { empty with universes = ctx } +let from_ctx uctx = { empty with universes = uctx } let has_undefined evd = not (EvMap.is_empty evd.undf_evars) diff --git a/engine/evd.mli b/engine/evd.mli index fafaad9a04..1c5c65924c 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -153,12 +153,18 @@ type evar_map val empty : evar_map (** The empty evar map. *) -val from_env : env -> evar_map +val from_env : ?binders:lident list -> env -> evar_map (** The empty evar map with given universe context, taking its initial - universes from env. *) + universes from env, possibly with initial universe binders. This + is the main entry point at the beginning of the process of + interpreting a declaration (e.g. before entering the + interpretation of a Theorem statement). *) val from_ctx : UState.t -> evar_map -(** The empty evar map with given universe context *) +(** The empty evar map with given universe context. This is the main + entry point when resuming from a already interpreted declaration + (e.g. after having interpreted a Theorem statement and preparing + to open a goal). *) val is_empty : evar_map -> bool (** Whether an evarmap is empty. *) diff --git a/engine/uState.ml b/engine/uState.ml index 9557111cfd..103b552d86 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -25,8 +25,8 @@ module UPairSet = UnivMinim.UPairSet (* 2nd part used to check consistency on the fly. *) type t = - { names : UnivNames.universe_binders * uinfo LMap.t; - local : ContextSet.t; (** The local context of variables *) + { names : UnivNames.universe_binders * uinfo LMap.t; (** Printing/location information *) + local : ContextSet.t; (** The local graph of universes (variables and constraints) *) seff_univs : LSet.t; (** Local universes used through private constants *) univ_variables : UnivSubst.universe_opt_subst; (** The local universes that are unification variables *) @@ -56,18 +56,16 @@ let elaboration_sprop_cumul = Goptions.declare_bool_option_and_ref ~depr:false ~key:["Elaboration";"StrictProp";"Cumulativity"] ~value:true -let make ~lbound u = - let u = UGraph.set_cumulative_sprop (elaboration_sprop_cumul ()) u in +let make ~lbound univs = + let univs = UGraph.set_cumulative_sprop (elaboration_sprop_cumul ()) univs in { empty with - universes = u; + universes = univs; universes_lbound = lbound; - initial_universes = u} + initial_universes = univs} -let from_env e = make ~lbound:(Environ.universes_lbound e) (Environ.universes e) - -let is_empty ctx = - ContextSet.is_empty ctx.local && - LMap.is_empty ctx.univ_variables +let is_empty uctx = + ContextSet.is_empty uctx.local && + LMap.is_empty uctx.univ_variables let uname_union s t = if s == t then s @@ -77,42 +75,42 @@ let uname_union s t = | Some _, _ -> l | _, _ -> r) s t -let union ctx ctx' = - if ctx == ctx' then ctx - else if is_empty ctx' then ctx +let union uctx uctx' = + if uctx == uctx' then uctx + else if is_empty uctx' then uctx else - let local = ContextSet.union ctx.local ctx'.local in - let seff = LSet.union ctx.seff_univs ctx'.seff_univs in - let names = uname_union (fst ctx.names) (fst ctx'.names) in - let newus = LSet.diff (ContextSet.levels ctx'.local) - (ContextSet.levels ctx.local) in - let newus = LSet.diff newus (LMap.domain ctx.univ_variables) in - let weak = UPairSet.union ctx.weak_constraints ctx'.weak_constraints in + let local = ContextSet.union uctx.local uctx'.local in + let seff = LSet.union uctx.seff_univs uctx'.seff_univs in + let names = uname_union (fst uctx.names) (fst uctx'.names) in + let names_rev = LMap.lunion (snd uctx.names) (snd uctx'.names) in + let newus = LSet.diff (ContextSet.levels uctx'.local) + (ContextSet.levels uctx.local) in + let newus = LSet.diff newus (LMap.domain uctx.univ_variables) in + let weak = UPairSet.union uctx.weak_constraints uctx'.weak_constraints in let declarenew g = - LSet.fold (fun u g -> UGraph.add_universe u ~lbound:ctx.universes_lbound ~strict:false g) newus g + LSet.fold (fun u g -> UGraph.add_universe u ~lbound:uctx.universes_lbound ~strict:false g) newus g in - let names_rev = LMap.lunion (snd ctx.names) (snd ctx'.names) in { names = (names, names_rev); local = local; seff_univs = seff; univ_variables = - LMap.subst_union ctx.univ_variables ctx'.univ_variables; + LMap.subst_union uctx.univ_variables uctx'.univ_variables; univ_algebraic = - LSet.union ctx.univ_algebraic ctx'.univ_algebraic; - initial_universes = declarenew ctx.initial_universes; + LSet.union uctx.univ_algebraic uctx'.univ_algebraic; + initial_universes = declarenew uctx.initial_universes; universes = - (if local == ctx.local then ctx.universes + (if local == uctx.local then uctx.universes else - let cstrsr = ContextSet.constraints ctx'.local in - UGraph.merge_constraints cstrsr (declarenew ctx.universes)); - universes_lbound = ctx.universes_lbound; + let cstrsr = ContextSet.constraints uctx'.local in + UGraph.merge_constraints cstrsr (declarenew uctx.universes)); + universes_lbound = uctx.universes_lbound; weak_constraints = weak} -let context_set ctx = ctx.local +let context_set uctx = uctx.local -let constraints ctx = snd ctx.local +let constraints uctx = snd uctx.local -let context ctx = ContextSet.to_context ctx.local +let context uctx = ContextSet.to_context uctx.local let compute_instance_binders inst ubinders = let revmap = Id.Map.fold (fun id lvl accu -> LMap.add lvl id accu) ubinders LMap.empty in @@ -131,15 +129,15 @@ let univ_entry ~poly uctx = Polymorphic_entry (nas, uctx) else Monomorphic_entry (context_set uctx) -let of_context_set ctx = { empty with local = ctx } +let of_context_set local = { empty with local } -let subst ctx = ctx.univ_variables +let subst uctx = uctx.univ_variables -let ugraph ctx = ctx.universes +let ugraph uctx = uctx.universes -let initial_graph ctx = ctx.initial_universes +let initial_graph uctx = uctx.initial_universes -let algebraics ctx = ctx.univ_algebraic +let algebraics uctx = uctx.univ_algebraic let add_names ?loc s l (names, names_rev) = if UNameMap.mem s names @@ -152,14 +150,13 @@ let add_loc l loc (names, names_rev) = | None -> (names, names_rev) | Some _ -> (names, LMap.add l { uname = None; uloc = loc } names_rev) -let of_binders b = - let ctx = empty in - let rmap = +let of_binders names = + let rev_map = UNameMap.fold (fun id l rmap -> LMap.add l { uname = Some id; uloc = None } rmap) - b LMap.empty + names LMap.empty in - { ctx with names = b, rmap } + { empty with names = (names, rev_map) } let invent_name (named,cnt) u = let rec aux i = @@ -169,14 +166,14 @@ let invent_name (named,cnt) u = in aux cnt -let universe_binders ctx = - let named, rev = ctx.names in +let universe_binders uctx = + let named, rev = uctx.names in let named, _ = LSet.fold (fun u named -> match LMap.find u rev with | exception Not_found -> (* not sure if possible *) invent_name named u | { uname = None } -> invent_name named u | { uname = Some _ } -> named) - (ContextSet.levels ctx.local) (named, 0) + (ContextSet.levels uctx.local) (named, 0) in named @@ -192,12 +189,12 @@ let drop_weak_constraints = ~key:["Cumulativity";"Weak";"Constraints"] ~value:false -let process_universe_constraints ctx cstrs = +let process_universe_constraints uctx cstrs = let open UnivSubst in let open UnivProblem in - let univs = ctx.universes in - let vars = ref ctx.univ_variables in - let weak = ref ctx.weak_constraints in + let univs = uctx.universes in + let vars = ref uctx.univ_variables in + let weak = ref uctx.weak_constraints in let normalize u = normalize_univ_variable_opt_subst !vars u in let nf_constraint = function | ULub (u, v) -> ULub (level_subst_of normalize u, level_subst_of normalize v) @@ -231,7 +228,7 @@ let process_universe_constraints ctx cstrs = let equalize_universes l r local = match varinfo l, varinfo r with | Inr l', Inr r' -> equalize_variables false l l' r r' local | Inr l, Inl r | Inl r, Inr l -> - let alg = LSet.mem l ctx.univ_algebraic in + let alg = LSet.mem l uctx.univ_algebraic in let inst = univ_level_rem l r r in if alg && not (LSet.mem l (Universe.levels inst)) then (instantiate_variable l inst vars; local) @@ -295,8 +292,8 @@ let process_universe_constraints ctx cstrs = in !vars, !weak, local -let add_constraints ctx cstrs = - let univs, local = ctx.local in +let add_constraints uctx cstrs = + let univs, old_cstrs = uctx.local in let cstrs' = Constraint.fold (fun (l,d,r) acc -> let l = Universe.make l and r = Universe.make r in let cstr' = let open UnivProblem in @@ -308,27 +305,27 @@ let add_constraints ctx cstrs = in UnivProblem.Set.add cstr' acc) cstrs UnivProblem.Set.empty in - let vars, weak, local' = process_universe_constraints ctx cstrs' in - { ctx with - local = (univs, Constraint.union local local'); + let vars, weak, cstrs' = process_universe_constraints uctx cstrs' in + { uctx with + local = (univs, Constraint.union old_cstrs cstrs'); univ_variables = vars; - universes = UGraph.merge_constraints local' ctx.universes; + universes = UGraph.merge_constraints cstrs' uctx.universes; weak_constraints = weak; } (* let addconstrkey = CProfile.declare_profile "add_constraints_context";; *) (* let add_constraints_context = CProfile.profile2 addconstrkey add_constraints_context;; *) -let add_universe_constraints ctx cstrs = - let univs, local = ctx.local in - let vars, weak, local' = process_universe_constraints ctx cstrs in - { ctx with +let add_universe_constraints uctx cstrs = + let univs, local = uctx.local in + let vars, weak, local' = process_universe_constraints uctx cstrs in + { uctx with local = (univs, Constraint.union local local'); univ_variables = vars; - universes = UGraph.merge_constraints local' ctx.universes; + universes = UGraph.merge_constraints local' uctx.universes; weak_constraints = weak; } -let constrain_variables diff ctx = - let univs, local = ctx.local in +let constrain_variables diff uctx = + let univs, local = uctx.local in let univs, vars, local = LSet.fold (fun l (univs, vars, cstrs) -> @@ -340,9 +337,9 @@ let constrain_variables diff ctx = Constraint.add (l, Eq, Option.get (Universe.level u)) cstrs) | None -> (univs, vars, cstrs) with Not_found | Option.IsNone -> (univs, vars, cstrs)) - diff (univs, ctx.univ_variables, local) + diff (univs, uctx.univ_variables, local) in - { ctx with local = (univs, local); univ_variables = vars } + { uctx with local = (univs, local); univ_variables = vars } let qualid_of_level uctx = let map, map_rev = uctx.names in @@ -403,8 +400,8 @@ let universe_context ~names ~extensible uctx = let left = ContextSet.sort_levels (Array.of_list (LSet.elements left)) in let inst = Array.append (Array.of_list newinst) left in let inst = Instance.of_array inst in - let ctx = UContext.make (inst, ContextSet.constraints uctx.local) in - ctx + let uctx = UContext.make (inst, ContextSet.constraints uctx.local) in + uctx let check_universe_context_set ~names ~extensible uctx = if extensible then () @@ -439,27 +436,24 @@ let check_mono_univ_decl uctx decl = uctx.local let check_univ_decl ~poly uctx decl = - let ctx = - let names = decl.univdecl_instance in - let extensible = decl.univdecl_extensible_instance in - if poly then - let (binders, _) = uctx.names in - let uctx = universe_context ~names ~extensible uctx in - let nas = compute_instance_binders (UContext.instance uctx) binders in - Entries.Polymorphic_entry (nas, uctx) - else - let () = check_universe_context_set ~names ~extensible uctx in - Entries.Monomorphic_entry uctx.local - in if not decl.univdecl_extensible_constraints then check_implication uctx decl.univdecl_constraints (ContextSet.constraints uctx.local); - ctx + let names = decl.univdecl_instance in + let extensible = decl.univdecl_extensible_instance in + if poly then + let (binders, _) = uctx.names in + let uctx = universe_context ~names ~extensible uctx in + let nas = compute_instance_binders (UContext.instance uctx) binders in + Entries.Polymorphic_entry (nas, uctx) + else + let () = check_universe_context_set ~names ~extensible uctx in + Entries.Monomorphic_entry uctx.local let is_bound l lbound = match lbound with -| UGraph.Bound.Prop -> Level.is_prop l -| UGraph.Bound.Set -> Level.is_set l + | UGraph.Bound.Prop -> Level.is_prop l + | UGraph.Bound.Set -> Level.is_set l let restrict_universe_context ~lbound (univs, csts) keep = let removed = LSet.diff univs keep in @@ -476,13 +470,13 @@ let restrict_universe_context ~lbound (univs, csts) keep = not ((is_bound l lbound && d == Le) || (Level.is_prop l && d == Lt && Level.is_set r))) csts in (LSet.inter univs keep, csts) -let restrict ctx vars = - let vars = LSet.union vars ctx.seff_univs in +let restrict uctx vars = + let vars = LSet.union vars uctx.seff_univs in let vars = Names.Id.Map.fold (fun na l vars -> LSet.add l vars) - (fst ctx.names) vars + (fst uctx.names) vars in - let uctx' = restrict_universe_context ~lbound:ctx.universes_lbound ctx.local vars in - { ctx with local = uctx' } + let uctx' = restrict_universe_context ~lbound:uctx.universes_lbound uctx.local vars in + { uctx with local = uctx' } type rigid = | UnivRigid @@ -498,8 +492,8 @@ let univ_flexible_alg = UnivFlexible true context we merge comes from a side effect that is already inlined or defined separately. In the later case, there is no extension, see [emit_side_effects] for example. *) -let merge ?loc ~sideff rigid uctx ctx' = - let levels = ContextSet.levels ctx' in +let merge ?loc ~sideff rigid uctx uctx' = + let levels = ContextSet.levels uctx' in let uctx = match rigid with | UnivRigid -> uctx @@ -514,7 +508,7 @@ let merge ?loc ~sideff rigid uctx ctx' = univ_algebraic = LSet.union uctx.univ_algebraic levels } else { uctx with univ_variables = uvars' } in - let local = ContextSet.append ctx' uctx.local in + let local = ContextSet.append uctx' uctx.local in let declare g = LSet.fold (fun u g -> try UGraph.add_universe ~lbound:uctx.universes_lbound ~strict:false u g @@ -534,7 +528,7 @@ let merge ?loc ~sideff rigid uctx ctx' = in let initial = declare uctx.initial_universes in let univs = declare uctx.universes in - let universes = UGraph.merge_constraints (ContextSet.constraints ctx') univs in + let universes = UGraph.merge_constraints (ContextSet.constraints uctx') univs in { uctx with names; local; universes; initial_universes = initial } @@ -553,19 +547,18 @@ let demote_global_univs env uctx = ContextSet.(of_set global_univs |> add_constraints global_constraints) in { uctx with local = ContextSet.diff uctx.local promoted_uctx } -let merge_seff uctx ctx' = - let levels = ContextSet.levels ctx' in +let merge_seff uctx uctx' = + let levels = ContextSet.levels uctx' in let declare g = LSet.fold (fun u g -> try UGraph.add_universe ~lbound:uctx.universes_lbound ~strict:false u g with UGraph.AlreadyDeclared -> g) levels g in - let initial = declare uctx.initial_universes in + let initial_universes = declare uctx.initial_universes in let univs = declare uctx.universes in - let universes = UGraph.merge_constraints (ContextSet.constraints ctx') univs in - { uctx with universes; - initial_universes = initial } + let universes = UGraph.merge_constraints (ContextSet.constraints uctx') univs in + { uctx with universes; initial_universes } let emit_side_effects eff u = let uctx = Safe_typing.universes_of_private eff in @@ -581,60 +574,54 @@ let update_sigma_univs uctx ugraph = in merge_seff eunivs eunivs.local -let new_univ_variable ?loc rigid name - ({ local = ctx; univ_variables = uvars; univ_algebraic = avars} as uctx) = - let u = UnivGen.fresh_level () in - let ctx' = ContextSet.add_universe u ctx in - let uctx', pred = - match rigid with - | UnivRigid -> uctx, true - | UnivFlexible b -> - let uvars' = LMap.add u None uvars in - if b then {uctx with univ_variables = uvars'; - univ_algebraic = LSet.add u avars}, false - else {uctx with univ_variables = uvars'}, false - in +let add_universe ?loc name strict lbound uctx u = + let initial_universes = UGraph.add_universe ~lbound ~strict u uctx.initial_universes in + let universes = UGraph.add_universe ~lbound ~strict u uctx.universes in + let local = ContextSet.add_universe u uctx.local in let names = match name with | Some n -> add_names ?loc n u uctx.names | None -> add_loc u loc uctx.names in - let initial = - UGraph.add_universe ~lbound:uctx.universes_lbound ~strict:false u uctx.initial_universes + { uctx with names; local; initial_universes; universes } + +let new_univ_variable ?loc rigid name uctx = + let u = UnivGen.fresh_level () in + let uctx = + match rigid with + | UnivRigid -> uctx + | UnivFlexible allow_alg -> + let univ_variables = LMap.add u None uctx.univ_variables in + if allow_alg + then + let univ_algebraic = LSet.add u uctx.univ_algebraic in + { uctx with univ_variables; univ_algebraic } + else + { uctx with univ_variables } in - let uctx' = - {uctx' with names = names; local = ctx'; - universes = UGraph.add_universe ~lbound:uctx.universes_lbound ~strict:false - u uctx.universes; - initial_universes = initial} - in uctx', u - -let make_with_initial_binders ~lbound e us = - let uctx = make ~lbound e in + let uctx = add_universe ?loc name false uctx.universes_lbound uctx u in + uctx, u + +let add_global_univ uctx u = add_universe None true UGraph.Bound.Set uctx u + +let make_with_initial_binders ~lbound univs us = + let uctx = make ~lbound univs in List.fold_left (fun uctx { CAst.loc; v = id } -> fst (new_univ_variable ?loc univ_rigid (Some id) uctx)) uctx us -let add_global_univ uctx u = - let initial = - UGraph.add_universe ~lbound:UGraph.Bound.Set ~strict:true u uctx.initial_universes - in - let univs = - UGraph.add_universe ~lbound:UGraph.Bound.Set ~strict:true u uctx.universes - in - { uctx with local = ContextSet.add_universe u uctx.local; - initial_universes = initial; - universes = univs } +let from_env ?(binders=[]) env = + make_with_initial_binders ~lbound:(Environ.universes_lbound env) (Environ.universes env) binders -let make_flexible_variable ctx ~algebraic u = +let make_flexible_variable uctx ~algebraic u = let {local = cstrs; univ_variables = uvars; - univ_algebraic = avars; universes=g; } = ctx in + univ_algebraic = avars; universes=g; } = uctx in assert (try LMap.find u uvars == None with Not_found -> true); match UGraph.choose (fun v -> not (Level.equal u v) && (algebraic || not (LSet.mem v avars))) g u with | Some v -> let uvars' = LMap.add u (Some (Universe.make v)) uvars in - { ctx with univ_variables = uvars'; } + { uctx with univ_variables = uvars'; } | None -> let uvars' = LMap.add u None uvars in let avars' = @@ -652,14 +639,13 @@ let make_flexible_variable ctx ~algebraic u = then LSet.add u avars else avars else avars in - {ctx with univ_variables = uvars'; - univ_algebraic = avars'} + { uctx with univ_variables = uvars'; univ_algebraic = avars' } -let make_nonalgebraic_variable ctx u = - { ctx with univ_algebraic = LSet.remove u ctx.univ_algebraic } +let make_nonalgebraic_variable uctx u = + { uctx with univ_algebraic = LSet.remove u uctx.univ_algebraic } -let make_flexible_nonalgebraic ctx = - {ctx with univ_algebraic = LSet.empty} +let make_flexible_nonalgebraic uctx = + { uctx with univ_algebraic = LSet.empty } let is_sort_variable uctx s = match s with @@ -671,8 +657,8 @@ let is_sort_variable uctx s = | None -> None) | _ -> None -let subst_univs_context_with_def def usubst (ctx, cst) = - (LSet.diff ctx def, UnivSubst.subst_univs_constraints usubst cst) +let subst_univs_context_with_def def usubst (uctx, cst) = + (LSet.diff uctx def, UnivSubst.subst_univs_constraints usubst cst) let is_trivial_leq (l,d,r) = Level.is_prop l && (d == Le || d == Lt) && Level.is_set r @@ -696,9 +682,9 @@ let normalize_variables uctx = let normalized_variables, def, subst = UnivSubst.normalize_univ_variables uctx.univ_variables in - let ctx_local = subst_univs_context_with_def def (make_subst subst) uctx.local in - let ctx_local', univs = refresh_constraints uctx.initial_universes ctx_local in - subst, { uctx with local = ctx_local'; + let uctx_local = subst_univs_context_with_def def (make_subst subst) uctx.local in + let uctx_local', univs = refresh_constraints uctx.initial_universes uctx_local in + subst, { uctx with local = uctx_local'; univ_variables = normalized_variables; universes = univs } diff --git a/engine/uState.mli b/engine/uState.mli index 7fec03e3b2..bd3aac0d8b 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -23,25 +23,34 @@ type t (** {5 Constructors} *) +(** Different ways to create a new universe state *) + val empty : t val make : lbound:UGraph.Bound.t -> UGraph.t -> t +[@@ocaml.deprecated "Use from_env"] val make_with_initial_binders : lbound:UGraph.Bound.t -> UGraph.t -> lident list -> t +[@@ocaml.deprecated "Use from_env"] -val from_env : Environ.env -> t - -val is_empty : t -> bool +val from_env : ?binders:lident list -> Environ.env -> t +(** Main entry point at the beginning of a declaration declaring the + binding names as rigid universes. *) -val union : t -> t -> t +val of_binders : UnivNames.universe_binders -> t +(** Main entry point when only names matter, e.g. for printing. *) val of_context_set : Univ.ContextSet.t -> t +(** Main entry point when starting from the instance of a global + reference, e.g. when building a scheme. *) -val of_binders : UnivNames.universe_binders -> t +(** Misc *) -val universe_binders : t -> UnivNames.universe_binders +val is_empty : t -> bool + +val union : t -> t -> t -(** {5 Projections} *) +(** {5 Projections and other destructors} *) val context_set : t -> Univ.ContextSet.t (** The local context of the state, i.e. a set of bound variables together @@ -69,6 +78,9 @@ val context : t -> Univ.UContext.t val univ_entry : poly:bool -> t -> Entries.universes_entry (** Pick from {!context} or {!context_set} based on [poly]. *) +val universe_binders : t -> UnivNames.universe_binders +(** Return names of universes, inventing names if needed *) + (** {5 Constraints handling} *) val add_constraints : t -> Univ.Constraint.t -> t @@ -115,7 +127,7 @@ val emit_side_effects : Safe_typing.private_constants -> t -> t val demote_global_univs : Environ.env -> t -> t (** Removes from the uctx_local part of the UState the universes and constraints that are present in the universe graph in the input env (supposedly the - global ones *) + global ones) *) val demote_seff_univs : Univ.LSet.t -> t -> t (** Mark the universes as not local any more, because they have been @@ -123,6 +135,11 @@ val demote_seff_univs : Univ.LSet.t -> t -> t emit_side_effects instead. *) val new_univ_variable : ?loc:Loc.t -> rigid -> Id.t option -> t -> t * Univ.Level.t +(** Declare a new local universe; use rigid if a global or bound + universe; use flexible for a universe existential variable; use + univ_flexible_alg for a universe existential variable allowed to + be instantiated with an algebraic universe *) + val add_global_univ : t -> Univ.Level.t -> t (** [make_flexible_variable g algebraic l] diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index 235310660b..977cbbccf2 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -15,8 +15,11 @@ open Libnames (** [constr_expr] is the abstract syntax tree produced by the parser *) type universe_decl_expr = (lident list, Glob_term.glob_constraint list) UState.gen_universe_decl +type cumul_univ_decl_expr = + ((lident * Univ.Variance.t option) list, Glob_term.glob_constraint list) UState.gen_universe_decl type ident_decl = lident * universe_decl_expr option +type cumul_ident_decl = lident * cumul_univ_decl_expr option type name_decl = lname * universe_decl_expr option type notation_with_optional_scope = LastLonelyNotation | NotationInScope of string diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 8cc63c5d03..efc2a35b65 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -614,37 +614,3 @@ let rec coerce_to_cases_pattern_expr c = CAst.map_with_loc (fun ?loc -> function | _ -> CErrors.user_err ?loc ~hdr:"coerce_to_cases_pattern_expr" (str "This expression should be coercible to a pattern.")) c - -(** Local universe and constraint declarations. *) - -let interp_univ_constraints env evd cstrs = - let interp (evd,cstrs) (u, d, u') = - let ul = Pretyping.interp_known_glob_level evd u in - let u'l = Pretyping.interp_known_glob_level evd u' in - let cstr = (ul,d,u'l) in - let cstrs' = Univ.Constraint.add cstr cstrs in - try let evd = Evd.add_constraints evd (Univ.Constraint.singleton cstr) in - evd, cstrs' - with Univ.UniverseInconsistency e as exn -> - let _, info = Exninfo.capture exn in - CErrors.user_err ~hdr:"interp_constraint" ~info - (Univ.explain_universe_inconsistency (Termops.pr_evd_level evd) e) - in - List.fold_left interp (evd,Univ.Constraint.empty) cstrs - -let interp_univ_decl env decl = - let open UState in - let pl : lident list = decl.univdecl_instance in - let evd = Evd.from_ctx (UState.make_with_initial_binders ~lbound:(Environ.universes_lbound env) - (Environ.universes env) pl) in - let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in - let decl = { univdecl_instance = pl; - univdecl_extensible_instance = decl.univdecl_extensible_instance; - univdecl_constraints = cstrs; - univdecl_extensible_constraints = decl.univdecl_extensible_constraints } - in evd, decl - -let interp_univ_decl_opt env l = - match l with - | None -> Evd.from_env env, UState.default_univ_decl - | Some decl -> interp_univ_decl env decl diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index edf52c93e8..dfa51918d1 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -123,10 +123,3 @@ val patntn_loc : ?loc:Loc.t -> cases_pattern_notation_substitution -> notation - (** For cases pattern parsing errors *) val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a - -(** Local universe and constraint declarations. *) -val interp_univ_decl : Environ.env -> universe_decl_expr -> - Evd.evar_map * UState.universe_decl - -val interp_univ_decl_opt : Environ.env -> universe_decl_expr option -> - Evd.evar_map * UState.universe_decl diff --git a/interp/constrintern.ml b/interp/constrintern.ml index ecf2b951a2..b86ad7175a 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1972,9 +1972,9 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let env = restart_lambda_binders env in let idl_temp = Array.map (fun (id,recarg,bl,ty,_) -> - let recarg = Option.map (function { CAst.v = v } -> match v with + let recarg = Option.map (function { CAst.v = v; loc } -> match v with | CStructRec i -> i - | _ -> anomaly Pp.(str "Non-structural recursive argument in non-program fixpoint")) recarg + | _ -> user_err ?loc Pp.(str "Well-founded induction requires Program Fixpoint or Function.")) recarg in let before, after = split_at_annot bl recarg in let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in @@ -2092,9 +2092,13 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = assert (Option.is_empty isproj); let c = intern_notation intern env ntnvars loc ntn ntnargs in find_appl_head_data c, args - | _ -> assert (Option.is_empty isproj); (intern_no_implicit env f,[],[]), args in - apply_impargs c env impargs args_scopes - args loc + | _ -> + assert (Option.is_empty isproj); + let f = intern_no_implicit env f in + let f, _, args_scopes = find_appl_head_data f in + (f,[],args_scopes), args + in + apply_impargs c env impargs args_scopes args loc | CRecord fs -> let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in @@ -2405,8 +2409,9 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = and intern_args env subscopes = function | [] -> [] | a::args -> - let (enva,subscopes) = apply_scope_env env subscopes in - (intern_no_implicit enva a) :: (intern_args env subscopes args) + let (enva,subscopes) = apply_scope_env env subscopes in + let a = intern_no_implicit enva a in + a :: (intern_args env subscopes args) in intern env c @@ -2620,3 +2625,58 @@ let interp_context_evars ?program_mode ?(impl_env=empty_internalization_env) env let int_env,bl = intern_context env impl_env params in let sigma, x = interp_glob_context_evars ?program_mode env sigma bl in sigma, (int_env, x) + + +(** Local universe and constraint declarations. *) + +let interp_univ_constraints env evd cstrs = + let interp (evd,cstrs) (u, d, u') = + let ul = Pretyping.interp_known_glob_level evd u in + let u'l = Pretyping.interp_known_glob_level evd u' in + let cstr = (ul,d,u'l) in + let cstrs' = Univ.Constraint.add cstr cstrs in + try let evd = Evd.add_constraints evd (Univ.Constraint.singleton cstr) in + evd, cstrs' + with Univ.UniverseInconsistency e as exn -> + let _, info = Exninfo.capture exn in + CErrors.user_err ~hdr:"interp_constraint" ~info + (Univ.explain_universe_inconsistency (Termops.pr_evd_level evd) e) + in + List.fold_left interp (evd,Univ.Constraint.empty) cstrs + +let interp_univ_decl env decl = + let open UState in + let binders : lident list = decl.univdecl_instance in + let evd = Evd.from_env ~binders env in + let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in + let decl = { + univdecl_instance = binders; + univdecl_extensible_instance = decl.univdecl_extensible_instance; + univdecl_constraints = cstrs; + univdecl_extensible_constraints = decl.univdecl_extensible_constraints; + } + in evd, decl + +let interp_cumul_univ_decl env decl = + let open UState in + let binders = List.map fst decl.univdecl_instance in + let variances = Array.map_of_list snd decl.univdecl_instance in + let evd = Evd.from_ctx (UState.from_env ~binders env) in + let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in + let decl = { + univdecl_instance = binders; + univdecl_extensible_instance = decl.univdecl_extensible_instance; + univdecl_constraints = cstrs; + univdecl_extensible_constraints = decl.univdecl_extensible_constraints; + } + in + evd, decl, variances + +let interp_univ_decl_opt env l = + match l with + | None -> Evd.from_env env, UState.default_univ_decl + | Some decl -> interp_univ_decl env decl + +let interp_cumul_univ_decl_opt env = function + | None -> Evd.from_env env, UState.default_univ_decl, [| |] + | Some decl -> interp_cumul_univ_decl env decl diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 11d756803f..0de6c3e89d 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -197,3 +197,15 @@ val get_asymmetric_patterns : unit -> bool val check_duplicate : ?loc:Loc.t -> (qualid * constr_expr) list -> unit (** Check that a list of record field definitions doesn't contain duplicates. *) + +(** Local universe and constraint declarations. *) +val interp_univ_decl : Environ.env -> universe_decl_expr -> + Evd.evar_map * UState.universe_decl + +val interp_univ_decl_opt : Environ.env -> universe_decl_expr option -> + Evd.evar_map * UState.universe_decl + +val interp_cumul_univ_decl_opt : Environ.env -> cumul_univ_decl_expr option -> + Evd.evar_map * UState.universe_decl * Entries.variance_entry +(** BEWARE the variance entry needs to be adjusted by + [ComInductive.variance_of_entry] if the instance is extensible. *) diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index d57c05788d..3ec92cf691 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -26,19 +26,29 @@ type glob_output = | MultFiles | File of string -let glob_output = ref NoGlob +let glob_output = ref [] -let dump () = !glob_output <> NoGlob +let get_output () = match !glob_output with + | [] -> NoGlob + | g::_ -> g -let set_glob_output mode = - glob_output := mode +let push_output g = glob_output := g::!glob_output + +let pop_output () = glob_output := match !glob_output with + | [] -> CErrors.anomaly (Pp.str "No output left to pop") + | _::ds -> ds + +let pause () = push_output NoGlob +let continue = pop_output + +let dump () = get_output () <> NoGlob let dump_string s = - if dump () && !glob_output != Feedback then + if dump () && get_output () != Feedback then output_string !glob_file s let start_dump_glob ~vfile ~vofile = - match !glob_output with + match get_output () with | MultFiles -> open_glob_file (Filename.chop_extension vofile ^ ".glob"); output_string !glob_file "DIGEST "; @@ -51,14 +61,10 @@ let start_dump_glob ~vfile ~vofile = () let end_dump_glob () = - match !glob_output with + match get_output () with | MultFiles | File _ -> close_glob_file () | NoGlob | Feedback -> () -let previous_state = ref MultFiles -let pause () = previous_state := !glob_output; glob_output := NoGlob -let continue () = glob_output := !previous_state - open Decls open Declarations @@ -141,7 +147,7 @@ let interval loc = loc1, loc2-1 let dump_ref ?loc filepath modpath ident ty = - match !glob_output with + match get_output () with | Feedback -> Option.iter (fun loc -> Feedback.feedback (Feedback.GlobRef (loc, filepath, modpath, ident, ty)) @@ -247,7 +253,7 @@ let add_glob_kn ?loc kn = add_glob_gen ?loc sp lib_dp "syndef" let dump_def ?loc ty secpath id = Option.iter (fun loc -> - if !glob_output = Feedback then + if get_output () = Feedback then Feedback.feedback (Feedback.GlobDef (loc, id, secpath, ty)) else let bl,el = interval loc in diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index be1e3f05d2..857991cb3f 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -19,11 +19,19 @@ type glob_output = | MultFiles (* one glob file per .v file *) | File of string (* Single file for all coqc arguments *) -(* Default "NoGlob" *) -val set_glob_output : glob_output -> unit +(** [push_output o] temporarily overrides the output location to [o]. + The original output can be restored using [pop_output] *) +val push_output : glob_output -> unit +(** Restores the original output that was overridden by [push_output] *) +val pop_output : unit -> unit + +(** Alias for [push_output NoGlob] *) val pause : unit -> unit + +(** Deprecated alias for [pop_output] *) val continue : unit -> unit +[@@ocaml.deprecated "Use pop_output"] val add_glob : ?loc:Loc.t -> Names.GlobRef.t -> unit val add_glob_kn : ?loc:Loc.t -> Names.KerName.t -> unit diff --git a/interp/modintern.ml b/interp/modintern.ml index 50f90ebea7..5f17d3e284 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -106,7 +106,7 @@ let transl_with_decl env base kind = function | CWith_Module ({CAst.v=fqid},qid) -> WithMod (fqid,lookup_module qid), Univ.ContextSet.empty | CWith_Definition ({CAst.v=fqid},udecl,c) -> - let sigma, udecl = Constrexpr_ops.interp_univ_decl_opt env udecl in + let sigma, udecl = interp_univ_decl_opt env udecl in let c, ectx = interp_constr env sigma c in let poly = lookup_polymorphism env base kind fqid in begin match UState.check_univ_decl ~poly ectx udecl with diff --git a/interp/notation.ml b/interp/notation.ml index 8d05fab63c..1a361dc1a6 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -391,6 +391,10 @@ let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) | NBinderList (_,_,NApp (NRef ref,args),_,_) -> RefKey (canonical_gr ref), AppBoundedNotation (List.length args) | NRef ref -> RefKey(canonical_gr ref), NotAppNotation + | NApp (NList (_,_,NApp (NRef ref,args),_,_), args') -> + RefKey (canonical_gr ref), AppBoundedNotation (List.length args + List.length args') + | NApp (NList (_,_,NApp (_,args),_,_), args') -> + Oth, AppBoundedNotation (List.length args + List.length args') | NApp (_,args) -> Oth, AppBoundedNotation (List.length args) | NList (_,_,NApp (NVar x,_),_,_) when x = Notation_ops.ldots_var -> Oth, AppUnboundedNotation | _ -> Oth, NotAppNotation @@ -2035,12 +2039,12 @@ type symbol = | Break of int let rec symbol_eq s1 s2 = match s1, s2 with -| Terminal s1, Terminal s2 -> String.equal s1 s2 -| NonTerminal id1, NonTerminal id2 -> Id.equal id1 id2 -| SProdList (id1, l1), SProdList (id2, l2) -> - Id.equal id1 id2 && List.equal symbol_eq l1 l2 -| Break i1, Break i2 -> Int.equal i1 i2 -| _ -> false + | Terminal s1, Terminal s2 -> String.equal s1 s2 + | NonTerminal id1, NonTerminal id2 -> Id.equal id1 id2 + | SProdList (id1, l1), SProdList (id2, l2) -> + Id.equal id1 id2 && List.equal symbol_eq l1 l2 + | Break i1, Break i2 -> Int.equal i1 i2 + | _ -> false let rec string_of_symbol = function | NonTerminal _ -> ["_"] @@ -2202,23 +2206,114 @@ let rec raw_analyze_notation_tokens = function | WhiteSpace n :: sl -> Break n :: raw_analyze_notation_tokens sl -let decompose_raw_notation ntn = raw_analyze_notation_tokens (split_notation_string ntn) - -let possible_notations ntn = +let rec raw_analyze_anonymous_notation_tokens = function + | [] -> [] + | String ".." :: sl -> NonTerminal Notation_ops.ldots_var :: raw_analyze_anonymous_notation_tokens sl + | String "_" :: sl -> NonTerminal (Id.of_string "dummy") :: raw_analyze_anonymous_notation_tokens sl + | String s :: sl -> + Terminal (String.drop_simple_quotes s) :: raw_analyze_anonymous_notation_tokens sl + | WhiteSpace n :: sl -> raw_analyze_anonymous_notation_tokens sl + +(* Interpret notations with a recursive component *) + +let out_nt = function NonTerminal x -> x | _ -> assert false + +let msg_expected_form_of_recursive_notation = + "In the notation, the special symbol \"..\" must occur in\na configuration of the form \"x symbs .. symbs y\"." + +let rec find_pattern nt xl = function + | Break n as x :: l, Break n' :: l' when Int.equal n n' -> + find_pattern nt (x::xl) (l,l') + | Terminal s as x :: l, Terminal s' :: l' when String.equal s s' -> + find_pattern nt (x::xl) (l,l') + | [], NonTerminal x' :: l' -> + (out_nt nt,x',List.rev xl),l' + | _, Break s :: _ | Break s :: _, _ -> + user_err Pp.(str ("A break occurs on one side of \"..\" but not on the other side.")) + | _, Terminal s :: _ | Terminal s :: _, _ -> + user_err ~hdr:"Metasyntax.find_pattern" + (str "The token \"" ++ str s ++ str "\" occurs on one side of \"..\" but not on the other side.") + | _, [] -> + user_err Pp.(str msg_expected_form_of_recursive_notation) + | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) -> + anomaly (Pp.str "Only Terminal or Break expected on left, non-SProdList on right.") + +let rec interp_list_parser hd = function + | [] -> [], List.rev hd + | NonTerminal id :: tl when Id.equal id Notation_ops.ldots_var -> + if List.is_empty hd then user_err Pp.(str msg_expected_form_of_recursive_notation); + let hd = List.rev hd in + let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in + let xyl,tl'' = interp_list_parser [] tl' in + (* We remember each pair of variable denoting a recursive part to *) + (* remove the second copy of it afterwards *) + (x,y)::xyl, SProdList (x,sl) :: tl'' + | (Terminal _ | Break _) as s :: tl -> + if List.is_empty hd then + let yl,tl' = interp_list_parser [] tl in + yl, s :: tl' + else + interp_list_parser (s::hd) tl + | NonTerminal _ as x :: tl -> + let xyl,tl' = interp_list_parser [x] tl in + xyl, List.rev_append hd tl' + | SProdList _ :: _ -> anomaly (Pp.str "Unexpected SProdList in interp_list_parser.") + +let get_notation_vars l = + List.map_filter (function NonTerminal id | SProdList (id,_) -> Some id | _ -> None) l + +let decompose_raw_notation ntn = + let l = split_notation_string ntn in + let l = raw_analyze_notation_tokens l in + let recvars,l = interp_list_parser [] l in + let vars = get_notation_vars l in + recvars, vars, l + +let interpret_notation_string ntn = (* We collect the possible interpretations of a notation string depending on whether it is in "x 'U' y" or "_ U _" format *) let toks = split_notation_string ntn in - if List.exists (function String "_" -> true | _ -> false) toks then - (* Only "_ U _" format *) - [ntn] - else - let _,ntn' = make_notation_key None (raw_analyze_notation_tokens toks) in - if String.equal ntn ntn' then (* Only symbols *) [ntn] else [ntn;ntn'] + let toks = + if + List.exists (function String "_" -> true | _ -> false) toks || + List.for_all (function String id -> Id.is_valid id | _ -> false) toks + then + (* Only "_ U _" format *) + raw_analyze_anonymous_notation_tokens toks + else + (* Includes the case of only a subset of tokens or an "x 'U' y"-style format *) + raw_analyze_notation_tokens toks + in + let _,toks = interp_list_parser [] toks in + let _,ntn' = make_notation_key None toks in + ntn' + +(* Tell if a non-recursive notation is an instance of a recursive one *) +let is_approximation ntn ntn' = + let rec aux toks1 toks2 = match (toks1, toks2) with + | Terminal s1 :: toks1, Terminal s2 :: toks2 -> String.equal s1 s2 && aux toks1 toks2 + | NonTerminal _ :: toks1, NonTerminal _ :: toks2 -> aux toks1 toks2 + | SProdList (_,l1) :: toks1, SProdList (_, l2) :: toks2 -> aux l1 l2 && aux toks1 toks2 + | NonTerminal _ :: toks1, SProdList (_,l2) :: toks2 -> aux' toks1 l2 l2 toks2 || aux toks1 toks2 + | [], [] -> true + | (Break _ :: _, _) | (_, Break _ :: _) -> assert false + | (Terminal _ | NonTerminal _ | SProdList _) :: _, _ -> false + | [], _ -> false + and aux' toks1 l2 l2full toks2 = match (toks1, l2) with + | Terminal s1 :: toks1, Terminal s2 :: l2 when String.equal s1 s2 -> aux' toks1 l2 l2full toks2 + | NonTerminal _ :: toks1, [] -> aux' toks1 l2full l2full toks2 || aux toks1 toks2 + | _ -> false + in + let _,toks = interp_list_parser [] (raw_analyze_anonymous_notation_tokens (split_notation_string ntn)) in + let _,toks' = interp_list_parser [] (raw_analyze_anonymous_notation_tokens (split_notation_string ntn')) in + aux toks toks' let browse_notation strict ntn map = - let ntns = possible_notations ntn in - let find (from,ntn' as fullntn') ntn = - if String.contains ntn ' ' then String.equal ntn ntn' + let ntn = interpret_notation_string ntn in + let find (from,ntn' as fullntn') = + if String.contains ntn ' ' then + if String.string_contains ~where:ntn' ~what:".." then is_approximation ntn ntn' + else String.equal ntn ntn' else let _,toks = decompose_notation_key fullntn' in let get_terminals = function Terminal ntn -> Some ntn | _ -> None in @@ -2230,7 +2325,7 @@ let browse_notation strict ntn map = String.Map.fold (fun scope_name sc -> NotationMap.fold (fun ntn data l -> - if List.exists (find ntn) ntns + if find ntn then List.map (fun d -> (ntn,scope_name,d)) (extract_notation_data data) @ l else l) sc.notations) map [] in diff --git a/interp/notation.mli b/interp/notation.mli index b8939ff87b..97955bf92e 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -334,8 +334,10 @@ val symbol_eq : symbol -> symbol -> bool val make_notation_key : notation_entry -> symbol list -> notation val decompose_notation_key : notation -> notation_entry * symbol list -(** Decompose a notation of the form "a 'U' b" *) -val decompose_raw_notation : string -> symbol list +(** Decompose a notation of the form "a 'U' b" together with the lists + of pairs of recursive variables and the list of all variables + binding in the notation *) +val decompose_raw_notation : string -> (Id.t * Id.t) list * Id.t list * symbol list (** Prints scopes (expects a pure aconstr printer) *) val pr_scope_class : scope_class -> Pp.t diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 2e3fa0aa0e..7cb3ca25ee 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -275,6 +275,12 @@ type found_variables = { let add_id r id = r := { !r with vars = id :: (!r).vars } let add_name r = function Anonymous -> () | Name id -> add_id r id +let mkNApp1 (g,a) = + match g with + (* Ensure flattening of nested applicative nodes *) + | NApp (g,args') -> NApp (g,args'@[a]) + | _ -> NApp (g,[a]) + let is_gvar id c = match DAst.get c with | GVar id' -> Id.equal id id' | _ -> false @@ -443,7 +449,10 @@ let notation_constr_and_vars_of_glob_constr recvars a = aux' c and aux' x = DAst.with_val (function | GVar id -> if not (Id.equal id ldots_var) then add_id found id; NVar id - | GApp (g,args) -> NApp (aux g, List.map aux args) + | GApp (g,[]) -> NApp (aux g,[]) (* Encoding @foo *) + | GApp (g,args) -> + (* Treat applicative notes as binary nodes *) + let a,args = List.sep_last args in mkNApp1 (aux (DAst.make (GApp (g, args))), aux a) | GLambda (na,bk,ty,c) -> add_name found na; NLambda (na,aux ty,aux c) | GProd (na,bk,ty,c) -> add_name found na; NProd (na,aux ty,aux c) | GLetIn (na,b,t,c) -> add_name found na; NLetIn (na,aux b,Option.map aux t, aux c) diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 174125fc57..17feeb9b5a 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -1098,14 +1098,8 @@ module FNativeEntries = let defined_array = ref false - let farray = ref dummy - let init_array retro = - match retro.Retroknowledge.retro_array with - | Some c -> - defined_array := true; - farray := { mark = mark Norm KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } - | None -> defined_array := false + defined_array := Option.has_some retro.Retroknowledge.retro_array let init env = current_retro := env.retroknowledge; diff --git a/kernel/context.ml b/kernel/context.ml index 6a99f201f3..ab66898b59 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -365,6 +365,15 @@ struct let ty' = f ty in if v == v' && ty == ty' then decl else LocalDef (id, v', ty') + let map_constr_het f = function + | LocalAssum (id, ty) -> + let ty' = f ty in + LocalAssum (id, ty') + | LocalDef (id, v, ty) -> + let v' = f v in + let ty' = f ty in + LocalDef (id, v', ty') + (** Perform a given action on all terms in a given declaration. *) let iter_constr f = function | LocalAssum (_, ty) -> f ty diff --git a/kernel/context.mli b/kernel/context.mli index 76c4461760..29309daf34 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -231,6 +231,9 @@ sig (** Map all terms in a given declaration. *) val map_constr : ('c -> 'c) -> ('c, 'c) pt -> ('c, 'c) pt + (** Map all terms, with an heterogeneous function. *) + val map_constr_het : ('a -> 'b) -> ('a, 'a) pt -> ('b, 'b) pt + (** Perform a given action on all terms in a given declaration. *) val iter_constr : ('c -> unit) -> ('c, 'c) pt -> unit diff --git a/kernel/entries.ml b/kernel/entries.ml index ae64112e33..1bfc740017 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -20,6 +20,8 @@ type universes_entry = | Monomorphic_entry of Univ.ContextSet.t | Polymorphic_entry of Name.t array * Univ.UContext.t +type variance_entry = Univ.Variance.t option array + type 'a in_universes_entry = 'a * universes_entry (** {6 Declaration of inductive types. } *) @@ -50,9 +52,10 @@ type mutual_inductive_entry = { mind_entry_inds : one_inductive_entry list; mind_entry_universes : universes_entry; mind_entry_template : bool; (* Use template polymorphism *) - mind_entry_cumulative : bool; - (* universe constraints and the constraints for subtyping of - inductive types in the block. *) + mind_entry_variance : variance_entry option; + (* [None] if non-cumulative, otherwise associates each universe of + the entry to [None] if to be inferred or [Some v] if to be + checked. *) mind_entry_private : bool option; } diff --git a/kernel/environ.ml b/kernel/environ.ml index 914c951eb6..69edb1498c 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -43,7 +43,6 @@ type key = int CEphemeron.key option ref type link_info = | Linked of string - | LinkedInteractive of string | NotLinked type constant_key = Opaqueproof.opaque constant_body * (link_info ref * key) @@ -569,6 +568,11 @@ let is_primitive env c = | Declarations.Primitive _ -> true | _ -> false +let is_array_type env c = + match env.retroknowledge.Retroknowledge.retro_array with + | None -> false + | Some c' -> Constant.CanOrd.equal c c' + let polymorphic_constant cst env = Declareops.constant_is_polymorphic (lookup_constant cst env) diff --git a/kernel/environ.mli b/kernel/environ.mli index 60696184ef..6a8ddce835 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -37,7 +37,6 @@ val dummy_lazy_val : unit -> lazy_val (** Linking information for the native compiler *) type link_info = | Linked of string - | LinkedInteractive of string | NotLinked type key = int CEphemeron.key option ref @@ -250,6 +249,8 @@ val constant_opt_value_in : env -> Constant.t puniverses -> constr option val is_primitive : env -> Constant.t -> bool +val is_array_type : env -> Constant.t -> bool + (** {6 Primitive projections} *) (** Checks that the number of parameters is correct. *) diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml index b2520b780f..33ee8c325a 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -369,15 +369,20 @@ let typecheck_inductive env ~sec_univs (mie:mutual_inductive_entry) = data, Some None in - let variance = if not mie.mind_entry_cumulative then None - else match mie.mind_entry_universes with + let variance = match mie.mind_entry_variance with + | None -> None + | Some variances -> + match mie.mind_entry_universes with | Monomorphic_entry _ -> CErrors.user_err Pp.(str "Inductive cannot be both monomorphic and universe cumulative.") | Polymorphic_entry (_,uctx) -> let univs = Instance.to_array @@ UContext.instance uctx in + let univs = Array.map2 (fun a b -> a,b) univs variances in let univs = match sec_univs with | None -> univs - | Some sec_univs -> Array.append sec_univs univs + | Some sec_univs -> + let sec_univs = Array.map (fun u -> u, None) sec_univs in + Array.append sec_univs univs in let variances = InferCumulativity.infer_inductive ~env_params univs mie.mind_entry_inds in Some variances diff --git a/kernel/inferCumulativity.ml b/kernel/inferCumulativity.ml index 8191a5b0f3..d02f92ef26 100644 --- a/kernel/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -15,30 +15,82 @@ open Univ open Variance open Util -type inferred = IrrelevantI | CovariantI - -(** Throughout this module we modify a map [variances] from local - universes to [inferred]. It starts as a trivial mapping to - [Irrelevant] and every time we encounter a local universe we - restrict it accordingly. - [Invariant] universes are removed from the map. -*) exception TrivialVariance -let maybe_trivial variances = - if LMap.is_empty variances then raise TrivialVariance - else variances +(** Not the same as Type_errors.BadVariance because we don't have the env where we raise. *) +exception BadVariance of Level.t * Variance.t * Variance.t +(* some ocaml bug is triggered if we make this an inline record *) -let infer_level_eq u variances = - maybe_trivial (LMap.remove u variances) +module Inf : sig + type variances + val infer_level_eq : Level.t -> variances -> variances + val infer_level_leq : Level.t -> variances -> variances + val start : (Level.t * Variance.t option) array -> variances + val finish : variances -> Variance.t array +end = struct + type inferred = IrrelevantI | CovariantI + type mode = Check | Infer -let infer_level_leq u variances = - (* can only set Irrelevant -> Covariant so nontrivial *) - LMap.update u (function - | None -> None - | Some CovariantI as x -> x - | Some IrrelevantI -> Some CovariantI) - variances + (** + Each local universe is either in the [univs] map or is Invariant. + + If [univs] is empty all universes are Invariant and there is nothing more to do, + so we stop by raising [TrivialVariance]. The [soft] check comes before that. + *) + type variances = { + orig_array : (Level.t * Variance.t option) array; + univs : (mode * inferred) LMap.t; + } + + let to_variance = function + | IrrelevantI -> Irrelevant + | CovariantI -> Covariant + + let to_variance_opt o = Option.cata to_variance Invariant o + + let infer_level_eq u variances = + match LMap.find_opt u variances.univs with + | None -> variances + | Some (Check, expected) -> + let expected = to_variance expected in + raise (BadVariance (u, expected, Invariant)) + | Some (Infer, _) -> + let univs = LMap.remove u variances.univs in + if LMap.is_empty univs then raise TrivialVariance; + {variances with univs} + + let infer_level_leq u variances = + (* can only set Irrelevant -> Covariant so no TrivialVariance *) + let univs = + LMap.update u (function + | None -> None + | Some (_,CovariantI) as x -> x + | Some (Infer,IrrelevantI) -> Some (Infer,CovariantI) + | Some (Check,IrrelevantI) -> + raise (BadVariance (u, Irrelevant, Covariant))) + variances.univs + in + if univs == variances.univs then variances else {variances with univs} + + let start us = + let univs = Array.fold_left (fun univs (u,variance) -> + match variance with + | None -> LMap.add u (Infer,IrrelevantI) univs + | Some Invariant -> univs + | Some Covariant -> LMap.add u (Check,CovariantI) univs + | Some Irrelevant -> LMap.add u (Check,IrrelevantI) univs) + LMap.empty us + in + if LMap.is_empty univs then raise TrivialVariance; + {univs; orig_array=us} + + let finish variances = + Array.map + (fun (u,_check) -> to_variance_opt (Option.map snd (LMap.find_opt u variances.univs))) + variances.orig_array + +end +open Inf let infer_generic_instance_eq variances u = Array.fold_left (fun variances u -> infer_level_eq u variances) @@ -204,11 +256,7 @@ let infer_arity_constructor is_arity env variances arcn = open Entries let infer_inductive_core env univs entries = - if Array.is_empty univs then raise TrivialVariance; - let variances = - Array.fold_left (fun variances u -> LMap.add u IrrelevantI variances) - LMap.empty univs - in + let variances = Inf.start univs in let variances = List.fold_left (fun variances entry -> let variances = infer_arity_constructor true env variances entry.mind_entry_arity @@ -218,12 +266,11 @@ let infer_inductive_core env univs entries = variances entries in - Array.map (fun u -> match LMap.find u variances with - | exception Not_found -> Invariant - | IrrelevantI -> Irrelevant - | CovariantI -> Covariant) - univs + Inf.finish variances let infer_inductive ~env_params univs entries = try infer_inductive_core env_params univs entries - with TrivialVariance -> Array.make (Array.length univs) Invariant + with + | TrivialVariance -> Array.make (Array.length univs) Invariant + | BadVariance (lev, expected, actual) -> + Type_errors.error_bad_variance env_params ~lev ~expected ~actual diff --git a/kernel/inferCumulativity.mli b/kernel/inferCumulativity.mli index db5539a0ff..99d8f0c98d 100644 --- a/kernel/inferCumulativity.mli +++ b/kernel/inferCumulativity.mli @@ -12,8 +12,8 @@ val infer_inductive : env_params:Environ.env (** Environment containing the polymorphic universes and the parameters. *) - -> Univ.Level.t array - (** Universes whose cumulativity we want to infer. *) + -> (Univ.Level.t * Univ.Variance.t option) array + (** Universes whose cumulativity we want to infer or check. *) -> Entries.one_inductive_entry list (** The inductive block data we want to infer cumulativity for. NB: we ignore the template bool and the names, only the terms diff --git a/kernel/names.ml b/kernel/names.ml index 5b6064fa9f..13761ca245 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -44,6 +44,10 @@ struct | None -> true | Some _ -> false + let is_valid_ident_part s = match Unicode.ident_refutation ("x"^s) with + | None -> true + | Some _ -> false + let of_bytes s = let s = Bytes.to_string s in check_valid s; diff --git a/kernel/names.mli b/kernel/names.mli index 9a4ceef802..74a4e6f7d0 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -44,6 +44,9 @@ sig val is_valid : string -> bool (** Check that a string may be converted to an identifier. *) + val is_valid_ident_part : string -> bool + (** Check that a string is a valid part of an identifier *) + val of_bytes : bytes -> t val of_string : string -> t (** Converts a string into an identifier. diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 911a879394..09db29d222 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1933,7 +1933,7 @@ and compile_named env sigma univ auxdefs id = | LocalAssum _ -> Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs -let compile_constant env sigma prefix ~interactive con cb = +let compile_constant env sigma con cb = let no_univs = 0 = Univ.AUContext.size (Declareops.constant_polymorphic_context cb) in begin match cb.const_body with | Def t -> @@ -1942,10 +1942,6 @@ let compile_constant env sigma prefix ~interactive con cb = if !Flags.debug then Feedback.msg_debug (Pp.str "Generated lambda code"); let is_lazy = is_lazy t in let code = if is_lazy then mk_lazy code else code in - let name = - if interactive then LinkedInteractive prefix - else Linked prefix - in let l = Constant.label con in let auxdefs,code = if no_univs then compile_with_fv env sigma None [] (Some l) code @@ -1959,7 +1955,7 @@ let compile_constant env sigma prefix ~interactive con cb = optimize_stk (Glet(Gconstant ("", con),code)::auxdefs) in if !Flags.debug then Feedback.msg_debug (Pp.str "Optimized mllambda code"); - code, name + code | _ -> let i = push_symbol (SymbConst con) in let args = @@ -1969,9 +1965,7 @@ let compile_constant env sigma prefix ~interactive con cb = (* let t = mkMLlam [|univ|] (mkMLapp (MLprimitive Mk_const) *) - [Glet(Gconstant ("", con), mkMLapp (MLprimitive Mk_const) args)], - if interactive then LinkedInteractive prefix - else Linked prefix + [Glet(Gconstant ("", con), mkMLapp (MLprimitive Mk_const) args)] end module StringOrd = struct type t = string let compare = String.compare end @@ -1984,12 +1978,9 @@ let is_loaded_native_file s = StringSet.mem s !loaded_native_files let register_native_file s = loaded_native_files := StringSet.add s !loaded_native_files -let is_code_loaded ~interactive name = +let is_code_loaded name = match !name with | NotLinked -> false - | LinkedInteractive s -> - if (interactive && is_loaded_native_file s) then true - else (name := NotLinked; false) | Linked s -> if is_loaded_native_file s then true else (name := NotLinked; false) @@ -2049,8 +2040,11 @@ let compile_mind mb mind stack = in Array.fold_left_i f stack mb.mind_packets -type code_location_update = - link_info ref * link_info +type code_location_update = { + upd_info : link_info ref; + upd_prefix : string; +} + type code_location_updates = code_location_update Mindmap_env.t * code_location_update Cmap_env.t @@ -2058,35 +2052,34 @@ type linkable_code = global list * code_location_updates let empty_updates = Mindmap_env.empty, Cmap_env.empty -let compile_mind_deps env prefix ~interactive +let compile_mind_deps env prefix (comp_stack, (mind_updates, const_updates) as init) mind = let mib,nameref = lookup_mind_key mind env in - if is_code_loaded ~interactive nameref + if is_code_loaded nameref || Mindmap_env.mem mind mind_updates then init else let comp_stack = compile_mind mib mind comp_stack in - let name = - if interactive then LinkedInteractive prefix - else Linked prefix - in - let upd = (nameref, name) in + let upd = { + upd_info = nameref; + upd_prefix = prefix; + } in let mind_updates = Mindmap_env.add mind upd mind_updates in (comp_stack, (mind_updates, const_updates)) (* This function compiles all necessary dependencies of t, and generates code in reverse order, as well as linking information updates *) -let compile_deps env sigma prefix ~interactive init t = +let compile_deps env sigma prefix init t = let rec aux env lvl init t = match kind t with - | Ind ((mind,_),_u) -> compile_mind_deps env prefix ~interactive init mind + | Ind ((mind,_),_u) -> compile_mind_deps env prefix init mind | Const c -> let c,_u = get_alias env c in let cb,(nameref,_) = lookup_constant_key c env in let (_, (_, const_updates)) = init in - if is_code_loaded ~interactive nameref + if is_code_loaded nameref || (Cmap_env.mem c const_updates) then init else @@ -2096,19 +2089,21 @@ let compile_deps env sigma prefix ~interactive init t = aux env lvl init (Mod_subst.force_constr t) | _ -> init in - let code, name = - compile_constant env sigma prefix ~interactive c cb - in + let code = compile_constant env sigma c cb in + let upd = { + upd_info = nameref; + upd_prefix = prefix; + } in let comp_stack = code@comp_stack in - let const_updates = Cmap_env.add c (nameref, name) const_updates in + let const_updates = Cmap_env.add c upd const_updates in comp_stack, (mind_updates, const_updates) - | Construct (((mind,_),_),_u) -> compile_mind_deps env prefix ~interactive init mind + | Construct (((mind,_),_),_u) -> compile_mind_deps env prefix init mind | Proj (p,c) -> - let init = compile_mind_deps env prefix ~interactive init (Projection.mind p) in + let init = compile_mind_deps env prefix init (Projection.mind p) in aux env lvl init c | Case (ci, _p, _iv, _c, _ac) -> let mind = fst ci.ci_ind in - let init = compile_mind_deps env prefix ~interactive init mind in + let init = compile_mind_deps env prefix init mind in fold_constr_with_binders succ (aux env) lvl init t | Var id -> let open Context.Named.Declaration in @@ -2130,11 +2125,8 @@ let compile_deps env sigma prefix ~interactive init t = in aux env 0 init t -let compile_constant_field env prefix con acc cb = - let (gl, _) = - compile_constant ~interactive:false env empty_evars prefix - con cb - in +let compile_constant_field env _prefix con acc cb = + let gl = compile_constant env empty_evars con cb in gl@acc let compile_mind_field mp l acc mb = @@ -2152,11 +2144,11 @@ let mk_conv_code env sigma prefix t1 t2 = clear_global_tbl (); let gl, (mind_updates, const_updates) = let init = ([], empty_updates) in - compile_deps env sigma prefix ~interactive:true init t1 + compile_deps env sigma prefix init t1 in let gl, (mind_updates, const_updates) = let init = (gl, (mind_updates, const_updates)) in - compile_deps env sigma prefix ~interactive:true init t2 + compile_deps env sigma prefix init t2 in let code1 = lambda_of_constr env sigma t1 in let code2 = lambda_of_constr env sigma t2 in @@ -2179,7 +2171,7 @@ let mk_norm_code env sigma prefix t = clear_global_tbl (); let gl, (mind_updates, const_updates) = let init = ([], empty_updates) in - compile_deps env sigma prefix ~interactive:true init t + compile_deps env sigma prefix init t in let code = lambda_of_constr env sigma t in let (gl,code) = compile_with_fv env sigma None gl None code in @@ -2196,7 +2188,8 @@ let mk_library_header (symbols : Nativevalues.symbols) = let symbols = Format.sprintf "(str_decode \"%s\")" (str_encode symbols) in [Glet(Ginternal "symbols_tbl", MLglobal (Ginternal symbols))] -let update_location (r,v) = r := v +let update_location r = + r.upd_info := Linked r.upd_prefix let update_locations (ind_updates,const_updates) = Mindmap_env.iter (fun _ -> update_location) ind_updates; diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli index 913b3843c2..aab6e1d4a0 100644 --- a/kernel/nativecode.mli +++ b/kernel/nativecode.mli @@ -50,7 +50,6 @@ val get_proj : symbols -> int -> inductive * int val get_symbols : unit -> symbols -type code_location_update type code_location_updates type linkable_code = global list * code_location_updates diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index e98e97907a..18f16f427d 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -111,14 +111,12 @@ let get_mind_prefix env mind = match !name with | NotLinked -> "" | Linked s -> s - | LinkedInteractive s -> s let get_const_prefix env c = let _,(nameref,_) = lookup_constant_key c env in match !nameref with | NotLinked -> "" | Linked s -> s - | LinkedInteractive s -> s (* A generic map function *) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index c891b885c4..cf40263f61 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -280,11 +280,12 @@ let convert_constructors ctor nargs u1 u2 (s, check) = convert_constructors_gen (check.compare_instances ~flex:false) check.compare_cumul_instances ctor nargs u1 u2 s, check -let conv_table_key infos k1 k2 cuniv = +let conv_table_key infos ~nargs k1 k2 cuniv = if k1 == k2 then cuniv else match k1, k2 with | ConstKey (cst, u), ConstKey (cst', u') when Constant.CanOrd.equal cst cst' -> if Univ.Instance.equal u u' then cuniv + else if Int.equal nargs 1 && is_array_type (info_env infos) cst then cuniv else let flex = evaluable_constant cst (info_env infos) && RedFlags.red_set (info_flags infos) (RedFlags.fCONST cst) @@ -304,6 +305,11 @@ let unfold_ref_with_args infos tab fl v = Some (a, (Zupdate a::(Zprimitive(op,c,rargs,nargs)::v))) | Undef _ | OpaqueDef _ | Primitive _ -> None +let same_args_size sk1 sk2 = + let n = CClosure.stack_args_size sk1 in + if Int.equal n (CClosure.stack_args_size sk2) then n + else raise NotConvertible + type conv_tab = { cnv_inf : clos_infos; lft_tab : clos_tab; @@ -408,7 +414,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try - let cuniv = conv_table_key infos.cnv_inf fl1 fl2 cuniv in + let nargs = same_args_size v1 v2 in + let cuniv = conv_table_key infos.cnv_inf ~nargs fl1 fl2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with NotConvertible | Univ.UniverseInconsistency _ -> let r1 = unfold_ref_with_args infos.cnv_inf infos.lft_tab fl1 v1 in @@ -577,17 +584,14 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else let mind = Environ.lookup_mind (fst ind1) (info_env infos.cnv_inf) in - let nargs = CClosure.stack_args_size v1 in - if not (Int.equal nargs (CClosure.stack_args_size v2)) - then raise NotConvertible - else - match convert_inductives cv_pb (mind, snd ind1) nargs u1 u2 cuniv with - | cuniv -> convert_stacks l2r infos lft1 lft2 v1 v2 cuniv - | exception MustExpand -> - let env = info_env infos.cnv_inf in - let hd1 = eta_expand_ind env pind1 in - let hd2 = eta_expand_ind env pind2 in - eqappr cv_pb l2r infos (lft1,(hd1,v1)) (lft2,(hd2,v2)) cuniv + let nargs = same_args_size v1 v2 in + match convert_inductives cv_pb (mind, snd ind1) nargs u1 u2 cuniv with + | cuniv -> convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + | exception MustExpand -> + let env = info_env infos.cnv_inf in + let hd1 = eta_expand_ind env pind1 in + let hd2 = eta_expand_ind env pind2 in + eqappr cv_pb l2r infos (lft1,(hd1,v1)) (lft2,(hd2,v2)) cuniv else raise NotConvertible | (FConstruct ((ind1,j1),u1 as pctor1), FConstruct ((ind2,j2),u2 as pctor2)) -> @@ -597,17 +601,14 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else let mind = Environ.lookup_mind (fst ind1) (info_env infos.cnv_inf) in - let nargs = CClosure.stack_args_size v1 in - if not (Int.equal nargs (CClosure.stack_args_size v2)) - then raise NotConvertible - else - match convert_constructors (mind, snd ind1, j1) nargs u1 u2 cuniv with - | cuniv -> convert_stacks l2r infos lft1 lft2 v1 v2 cuniv - | exception MustExpand -> - let env = info_env infos.cnv_inf in - let hd1 = eta_expand_constructor env pctor1 in - let hd2 = eta_expand_constructor env pctor2 in - eqappr cv_pb l2r infos (lft1,(hd1,v1)) (lft2,(hd2,v2)) cuniv + let nargs = same_args_size v1 v2 in + match convert_constructors (mind, snd ind1, j1) nargs u1 u2 cuniv with + | cuniv -> convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + | exception MustExpand -> + let env = info_env infos.cnv_inf in + let hd1 = eta_expand_constructor env pctor1 in + let hd2 = eta_expand_constructor env pctor2 in + eqappr cv_pb l2r infos (lft1,(hd1,v1)) (lft2,(hd2,v2)) cuniv else raise NotConvertible (* Eta expansion of records *) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index bf02ceb2c2..6abd283f6c 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -671,7 +671,7 @@ let inline_side_effects env body side_eff = let side_eff = List.fold_left (fun accu (cb, _) -> cb :: accu) [] side_eff in let side_eff = List.rev side_eff in (** Most recent side-effects first in side_eff *) - if List.is_empty side_eff then (body, Univ.ContextSet.empty, sigs) + if List.is_empty side_eff then (body, Univ.ContextSet.empty, sigs, 0) else (** Second step: compute the lifts and substitutions to apply *) let cname c r = Context.make_annot (Name (Label.to_id (Constant.label c))) r in @@ -725,10 +725,10 @@ let inline_side_effects env body side_eff = else mkLetIn (na, b, ty, accu) in let body = List.fold_right fold_arg args body in - (body, ctx, sigs) + (body, ctx, sigs, len - 1) let inline_private_constants env ((body, ctx), side_eff) = - let body, ctx',_ = inline_side_effects env body side_eff in + let body, ctx', _, _ = inline_side_effects env body side_eff in let ctx' = Univ.ContextSet.union ctx ctx' in (body, ctx') @@ -880,11 +880,11 @@ let add_constant l decl senv = match decl with | OpaqueEntry ce -> let handle env body eff = - let body, uctx, signatures = inline_side_effects env body eff in + let body, uctx, signatures, skip = inline_side_effects env body eff in let trusted = check_signatures senv signatures in let trusted, uctx = match trusted with | None -> 0, uctx - | Some univs -> List.length signatures, Univ.ContextSet.union univs uctx + | Some univs -> skip, Univ.ContextSet.union univs uctx in body, uctx, trusted in diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index ae5c4b6880..bcb7aa88ca 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -69,6 +69,7 @@ type ('constr, 'types) ptype_error = | DisallowedSProp | BadRelevance | BadInvert + | BadVariance of { lev : Level.t; expected : Variance.t; actual : Variance.t } type type_error = (constr, types) ptype_error @@ -163,6 +164,9 @@ let error_bad_relevance env = let error_bad_invert env = raise (TypeError (env, BadInvert)) +let error_bad_variance env ~lev ~expected ~actual = + raise (TypeError (env, BadVariance {lev;expected;actual})) + let map_pguard_error f = function | NotEnoughAbstractionInFixBody -> NotEnoughAbstractionInFixBody | RecursionNotOnInductiveType c -> RecursionNotOnInductiveType (f c) @@ -207,3 +211,4 @@ let map_ptype_error f = function | DisallowedSProp -> DisallowedSProp | BadRelevance -> BadRelevance | BadInvert -> BadInvert +| BadVariance u -> BadVariance u diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index b1f7eb8a34..bcdcab9db7 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -70,6 +70,7 @@ type ('constr, 'types) ptype_error = | DisallowedSProp | BadRelevance | BadInvert + | BadVariance of { lev : Level.t; expected : Variance.t; actual : Variance.t } type type_error = (constr, types) ptype_error @@ -146,5 +147,7 @@ val error_bad_relevance : env -> 'a val error_bad_invert : env -> 'a +val error_bad_variance : env -> lev:Level.t -> expected:Variance.t -> actual:Variance.t -> 'a + 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 diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 0179215d6a..6464556e4e 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -108,7 +108,7 @@ let with_full_print f a = Constrextern.print_universes := old_printuniverses; Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name old_printallowmatchdefaultclause; - Dumpglob.continue (); + Dumpglob.pop_output (); res with reraise -> Impargs.make_implicit_args old_implicit_args; @@ -118,7 +118,7 @@ let with_full_print f a = Constrextern.print_universes := old_printuniverses; Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name old_printallowmatchdefaultclause; - Dumpglob.continue (); + Dumpglob.pop_output (); raise reraise (**********************) diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 44472a1995..7e8400910c 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -116,12 +116,25 @@ END let make_depth n = snd (Eauto.make_dimension n None) +(* deprecated in 8.13; the second int_or_var will be removed *) +let deprecated_eauto_bfs = + CWarnings.create + ~name:"eauto_bfs" ~category:"deprecated" + (fun () -> Pp.str "The syntax [eauto @int_or_var @int_or_var] is deprecated. Use [bfs eauto] instead.") + +let deprecated_bfs tacname = + CWarnings.create + ~name:"eauto_bfs" ~category:"deprecated" + (fun () -> Pp.str "The syntax [" ++ Pp.str tacname ++ Pp.str "@int_or_var @int_or_var] is deprecated. No replacement yet.") + } TACTIC EXTEND eauto | [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - { Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } + { + ( match n,p with Some _, Some _ -> deprecated_eauto_bfs () | _ -> () ); + Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } END TACTIC EXTEND new_eauto @@ -135,13 +148,17 @@ END TACTIC EXTEND debug_eauto | [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - { Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } + { + ( match n,p with Some _, Some _ -> (deprecated_bfs "debug eauto") () | _ -> () ); + Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } END TACTIC EXTEND info_eauto | [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - { Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } + { + ( match n,p with Some _, Some _ -> (deprecated_bfs "info_eauto") () | _ -> () ); + Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } END TACTIC EXTEND dfs_eauto @@ -150,6 +167,12 @@ TACTIC EXTEND dfs_eauto { Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db } END +TACTIC EXTEND bfs_eauto +| [ "bfs" "eauto" int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + { Eauto.gen_eauto (true, Eauto.make_depth p) (eval_uconstrs ist lems) db } +END + TACTIC EXTEND autounfold | [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> { Eauto.autounfold_tac db cl } END @@ -240,10 +263,21 @@ ARGUMENT EXTEND opthints END VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF -| #[ locality = Attributes.locality; ] [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> { - let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in - let locality = if Locality.make_section_locality locality then Goptions.OptLocal else Goptions.OptGlobal in - Hints.add_hints ~locality - (match dbnames with None -> ["core"] | Some l -> l) entry; +| #[ locality = Attributes.option_locality; ] [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> { + let open Goptions in + let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in + let () = match locality with + | OptGlobal -> + if Global.sections_are_opened () then + CErrors.user_err Pp.(str + "This command does not support the global attribute in sections."); + | OptExport -> + if Global.sections_are_opened () then + CErrors.user_err Pp.(str + "This command does not support the export attribute in sections."); + | OptDefault | OptLocal -> () + in + Hints.add_hints ~locality + (match dbnames with None -> ["core"] | Some l -> l) entry; } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index c54f8ffa78..c2e95c45f9 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -329,11 +329,11 @@ GRAMMAR EXTEND Gram ; command: [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; - l = OPT [ "using"; l = G_vernac.section_subset_expr -> { l } ] -> + l = OPT [ IDENT "using"; l = G_vernac.section_subset_expr -> { l } ] -> { Vernacexpr.VernacProof (Some (in_tac ta), l) } - | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; - ta = OPT [ "with"; ta = Pltac.tactic -> { in_tac ta } ] -> - { Vernacexpr.VernacProof (ta,Some l) } ] ] + | IDENT "Proof"; IDENT "using"; l = G_vernac.section_subset_expr; + "with"; ta = Pltac.tactic -> + { Vernacexpr.VernacProof (Some (in_tac ta),Some l) } ] ] ; hint: [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index ecfe6c1664..236de65462 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -450,6 +450,11 @@ GRAMMAR EXTEND Gram ; as_or_and_ipat: [ [ "as"; ipat = or_and_intropattern_loc -> { Some ipat } + | "as"; ipat = equality_intropattern -> + { match ipat with + | IntroRewrite _ -> user_err Pp.(str "Disjunctive/conjunctive pattern expected.") + | IntroInjection _ -> user_err Pp.(strbrk "Found an injection pattern while a disjunctive/conjunctive pattern was expected; use " ++ str "\"injection as pattern\"" ++ strbrk " instead.") + | _ -> assert false } | -> { None } ] ] ; eqn_ipat: diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 26e2b18a02..77162ce89a 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -13,7 +13,6 @@ open CErrors open Util open Names open Nameops -open Namegen open Constr open Context open EConstr @@ -485,7 +484,7 @@ let rec decompose_app_rel env evd t = let (f', argl, argr) = decompose_app_rel env evd arg in let ty = Retyping.get_type_of env evd argl in let r = Retyping.relevance_of_type env evd ty in - let f'' = mkLambda (make_annot (Name default_dependent_ident) r, ty, + let f'' = mkLambda (make_annot (Name Namegen.default_dependent_ident) r, ty, mkLambda (make_annot (Name (Id.of_string "y")) r, lift 1 ty, mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) in (f'', argl, argr) @@ -1119,7 +1118,14 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = *) | Lambda (n, t, b) when flags.under_lambdas -> - let n' = map_annot (Nameops.Name.map (fun id -> Tactics.fresh_id_in_env unfresh id env)) n in + let unfresh, n' = + let id = match n.binder_name with + | Anonymous -> Namegen.default_dependent_ident + | Name id -> id + in + let id = Tactics.fresh_id_in_env unfresh id env in + Id.Set.add id unfresh, {n with binder_name = Name id} + in let unfresh = match n'.binder_name with | Anonymous -> unfresh | Name id -> Id.Set.add id unfresh @@ -1542,7 +1548,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = (* For compatibility *) let beta = Tactics.reduct_in_concl ~check:false (Reductionops.nf_betaiota, DEFAULTcast) in let beta_hyp id = Tactics.reduct_in_hyp ~check:false ~reorder:false Reductionops.nf_betaiota (id, InHyp) in - let treat sigma res = + let treat sigma res state = match res with | None -> newfail 0 (str "Nothing to rewrite") | Some None -> @@ -1553,7 +1559,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let (undef, prf, newt) = res in let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in let gls = List.rev (Evd.fold_undefined fold undef []) in - let gls = List.map Proofview.with_empty_state gls in + let gls = List.map (fun gl -> Proofview.goal_with_state gl state) gls in match clause, prf with | Some id, Some p -> let tac = tclTHENLIST [ @@ -1583,6 +1589,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in + let state = Proofview.Goal.state gl in let sigma = Tacmach.New.project gl in let ty = match clause with | None -> concl @@ -1602,7 +1609,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = cl_rewrite_clause_aux ?abs strat env Id.Set.empty sigma ty clause in let sigma = match origsigma with None -> sigma | Some sigma -> sigma in - treat sigma res <*> + treat sigma res state <*> (* For compatibility *) beta <*> Proofview.shelve_unifiable with diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 3360a9a51c..21178a64a5 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -36,10 +36,8 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct module Table = Hashtbl.Make (Key) exception InvalidTableFormat - exception UnboundTable - type mode = Closed | Open - type 'a t = {outch : out_channel; mutable status : mode; htbl : 'a Table.t} + type 'a t = {outch : out_channel; htbl : 'a Table.t} (* XXX: Move to Fun.protect once in Ocaml 4.08 *) let fun_protect ~(finally : unit -> unit) work = @@ -118,7 +116,6 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct close_in_noerr inch; { outch = out_channel_of_descr (openfile f [O_WRONLY; O_APPEND; O_CREAT] 0o666) - ; status = Open ; htbl } with InvalidTableFormat -> (* The file is corrupted *) @@ -131,24 +128,20 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct (fun k e -> Marshal.to_channel outch (k, e) [Marshal.No_sharing]) htbl; flush outch); - {outch; status = Open; htbl} + {outch; htbl} let add t k e = - let {outch; status; htbl = tbl} = t in - if status == Closed then raise UnboundTable - else - let fd = descr_of_out_channel outch in - Table.add tbl k e; - do_under_lock Write fd (fun _ -> - Marshal.to_channel outch (k, e) [Marshal.No_sharing]; - flush outch) + let {outch; htbl = tbl} = t in + let fd = descr_of_out_channel outch in + Table.add tbl k e; + do_under_lock Write fd (fun _ -> + Marshal.to_channel outch (k, e) [Marshal.No_sharing]; + flush outch) let find t k = - let {outch; status; htbl = tbl} = t in - if status == Closed then raise UnboundTable - else - let res = Table.find tbl k in - res + let {outch; htbl = tbl} = t in + let res = Table.find tbl k in + res let memo cache f = let tbl = lazy (try Some (open_in cache) with _ -> None) in diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 5de0745d17..a793e217d4 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1784,25 +1784,24 @@ let abstract_tycon ?loc env sigma subst tycon extenv t = !evdref, ans let build_tycon ?loc env tycon_env s subst tycon extenv sigma t = - let sigma, t, tt = match t with + let s = mkSort s in + match t with | None -> (* This is the situation we are building a return predicate and we are in an impossible branch *) let n = Context.Rel.length (rel_context !!env) in let n' = Context.Rel.length (rel_context !!tycon_env) in - let sigma, (impossible_case_type, u) = - Evarutil.new_type_evar (reset_context !!env) ~src:(Loc.tag ?loc Evar_kinds.ImpossibleCase) - sigma univ_flexible_alg - in - (sigma, lift (n'-n) impossible_case_type, mkSort u) + let src = Loc.tag ?loc Evar_kinds.ImpossibleCase in + let sigma, impossible_case_type = + Evarutil.new_evar (reset_context !!env) sigma ~src ~typeclass_candidate:false s in + (sigma, { uj_val = lift (n'-n) impossible_case_type; uj_type = s }) | Some t -> let sigma, t = abstract_tycon ?loc tycon_env sigma subst tycon extenv t in let sigma, tt = Typing.type_of !!extenv sigma t in - (sigma, t, tt) in - match unify_leq_delay !!env sigma tt (mkSort s) with - | exception Evarconv.UnableToUnify _ -> anomaly (Pp.str "Build_tycon: should be a type."); - | sigma -> - sigma, { uj_val = t; uj_type = tt } + match unify_leq_delay !!env sigma tt s with + | exception Evarconv.UnableToUnify _ -> anomaly (Pp.str "Build_tycon: should be a type."); + | sigma -> (sigma, { uj_val = t; uj_type = tt }) + (* For a multiple pattern-matching problem Xi on t1..tn with return * type T, [build_inversion_problem Gamma Sigma (t1..tn) T] builds a return @@ -1915,9 +1914,24 @@ let build_inversion_problem ~program_mode loc env sigma tms t = it = None } } ] in (* [pb] is the auxiliary pattern-matching serving as skeleton for the return type of the original problem Xi *) - let s' = Retyping.get_sort_of !!env sigma t in - let sigma, s = Evd.new_sort_variable univ_flexible sigma in - let sigma = Evd.set_leq_sort !!env sigma s' s in + let s = Retyping.get_sort_of !!env sigma t in + let sigma, s = Sorts.(match s with + | SProp | Prop | Set -> + (* To anticipate a possible restriction on an elimination from + SProp, Prop or (impredicative) Set we preserve the sort of the + main branch, knowing that the default impossible case shall + always be coercible to one of those *) + sigma, s + | Type _ -> + (* If the sort has algebraic universes, we cannot use this sort a + type constraint for the impossible case; especially if the + default case is not the canonical one provided in Prop by Coq + but one given by the user, which may be in either sort (an + example is in Vector.caseS', even if this one can probably be + put in Prop too with some care) *) + let sigma, s' = Evd.new_sort_variable univ_flexible sigma in + let sigma = Evd.set_leq_sort !!env sigma s s' in + sigma, s') in let pb = { env = pb_env; pred = (*ty *) mkSort s; @@ -2066,6 +2080,15 @@ let prepare_predicate_from_arsign_tycon ~program_mode env sigma loc tomatchs ars Some (sigma', p, arsign) with e when precatchable_exception e -> None +let expected_elimination_sort env tomatchl = + List.fold_right (fun (_,tm) s -> + match tm with + | IsInd (_,IndType(indf,_),_) -> + (* Not a degenerated line, see coerce_to_indtype *) + let s' = Inductive.elim_sort (Inductive.lookup_mind_specif env (fst (fst (dest_ind_family indf)))) in + if Sorts.family_leq s s' then s else s' + | NotInd _ -> s) tomatchl Sorts.InType + (* Builds the predicate. If the predicate is dependent, its context is * made of 1+nrealargs assumptions for each matched term in an inductive * type and 1 assumption for each term not _syntactically_ in an @@ -2116,8 +2139,12 @@ let prepare_predicate ?loc ~program_mode typing_fun env sigma tomatchs arsign ty | Some rtntyp -> (* We extract the signature of the arity *) let building_arsign,envar = List.fold_right_map (push_rel_context ~hypnaming:KeepUserNameAndRenameExistingButSectionNames sigma) arsign env in - let sigma, newt = new_sort_variable univ_flexible sigma in - let sigma, predcclj = typing_fun (mk_tycon (mkSort newt)) envar sigma rtntyp in + (* We put a type constraint on the predicate so that one + branch type-checked first does not lead to a lower type than + another branch; we take into account the possible elimination + constraints on the predicate *) + let sigma, rtnsort = fresh_sort_in_family sigma (expected_elimination_sort !!env tomatchs) in + let sigma, predcclj = typing_fun (Some (mkSort rtnsort)) envar sigma rtntyp in let predccl = nf_evar sigma predcclj.uj_val in [sigma, predccl, building_arsign] in diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 90af143a2d..00d4c7b3d8 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -567,8 +567,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let compare_heads evd = match EConstr.kind evd term, EConstr.kind evd term' with | Const (c, u), Const (c', u') when QConstant.equal env c c' -> - let u = EInstance.kind evd u and u' = EInstance.kind evd u' in - check_strict evd u u' + if Int.equal (Stack.args_size sk) 1 && Environ.is_array_type env c + then + let u = EInstance.kind evd u and u' = EInstance.kind evd u' in + compare_cumulative_instances evd [|Univ.Variance.Irrelevant|] u u' + else + let u = EInstance.kind evd u and u' = EInstance.kind evd u' in + check_strict evd u u' | Const _, Const _ -> UnifFailure (evd, NotSameHead) | Ind ((mi,i) as ind , u), Ind (ind', u') when Names.Ind.CanOrd.equal ind ind' -> if EInstance.is_empty u && EInstance.is_empty u' then Success evd @@ -1312,6 +1317,7 @@ let check_selected_occs env sigma c occ occs = raise (PretypeError (env,sigma,NoOccurrenceFound (c,None))) else () +(* Error local to the module *) exception TypingFailed of evar_map let set_of_evctx l = @@ -1342,12 +1348,6 @@ let thin_evars env sigma sign c = let c' = applyrec (env,0) c in (!sigma, c') -exception NotFoundInstance of exn -let () = CErrors.register_handler (function - | NotFoundInstance e -> - Some Pp.(str "Failed to instantiate evar: " ++ CErrors.print e) - | _ -> None) - let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = try let evi = Evd.find_undefined evd evk in @@ -1490,9 +1490,8 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = List.exists (fun c -> isVarId evd id (EConstr.of_constr c)) l -> instantiate_evar evar_unify flags env_rhs evd ev vid | _ -> evd) - with e when CErrors.noncritical e -> - let e, info = Exninfo.capture e in - Exninfo.iraise (NotFoundInstance e, info) + with IllTypedInstance _ (* from instantiate_evar *) | TypingFailed _ -> + user_err (Pp.str "Cannot find an instance.") else ((if debug_ho_unification () then let evi = Evd.find evd evk in @@ -1621,12 +1620,15 @@ let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = in Success (solve_refl ~can_drop:true f flags env evd (position_problem true pbty) evk1 args1 args2) - | Evar ev1, Evar ev2 when app_empty -> + | Evar (evk1,_ as ev1), Evar ev2 when app_empty -> (* solve_evar_evar handles the cases ev1 and/or ev2 are frozen *) - Success (solve_evar_evar ~force:true + (try + Success (solve_evar_evar ~force:true (evar_define evar_unify flags ~choose:true) evar_unify flags env evd (position_problem true pbty) ev1 ev2) + with IllTypedInstance (env,t,u) -> + UnifFailure (evd,InstanceNotSameType (evk1,env,t,u))) | Evar ev1,_ when is_evar_allowed flags (fst ev1) && Array.length l1 <= Array.length l2 -> (* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *) (* and otherwise second-order matching *) @@ -1709,7 +1711,7 @@ let solve_unconstrained_impossible_cases env evd = let evd' = Evd.merge_context_set Evd.univ_flexible_alg ?loc evd' ctx in let ty = j_type j in let flags = default_flags env in - instantiate_evar evar_unify flags env evd' evk ty + instantiate_evar evar_unify flags env evd' evk ty (* should we protect from raising IllTypedInstance? *) | _ -> evd') evd evd let solve_unif_constraints_with_heuristics env diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 715b80f428..44414aa6a0 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -227,8 +227,7 @@ let recheck_applications unify flags env evdref t = (match unify flags TypeUnification env !evdref Reduction.CUMUL argsty.(i) dom with | Success evd -> evdref := evd; aux (succ i) (subst1 args.(i) codom) - | UnifFailure (evd, reason) -> - Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom)) + | UnifFailure (evd, reason) -> raise (IllTypedInstance (env, ty, argsty.(i)))) | _ -> raise (IllTypedInstance (env, ty, argsty.(i))) else () in aux 0 fty @@ -810,7 +809,8 @@ let check_evar_instance unify flags env evd evk1 body = (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) let ty = try Retyping.get_type_of ~lax:true evenv evd body - with Retyping.RetypeError _ -> user_err (Pp.(str "Ill-typed evar instance")) + with Retyping.RetypeError _ -> + let loc, _ = evi.evar_source in user_err ?loc (Pp.(str "Ill-typed evar instance")) in match unify flags TypeUnification evenv evd Reduction.CUMUL ty evi.evar_concl with | Success evd -> evd @@ -935,13 +935,6 @@ let project_with_effects aliases sigma t subst = in filter_solution (Int.Map.fold is_projectable subst []) -open Context.Named.Declaration -let rec find_solution_type evarenv = function - | (id,ProjectVar)::l -> get_type (lookup_named id evarenv) - | [id,ProjectEvar _] -> (* bugged *) get_type (lookup_named id evarenv) - | (id,ProjectEvar _)::l -> find_solution_type evarenv l - | [] -> assert false - (* In case the solution to a projection problem requires the instantiation of * subsidiary evars, [do_projection_effects] performs them; it * also try to instantiate the type of those subsidiary evars if their @@ -1552,10 +1545,10 @@ let rec invert_definition unify flags choose imitate_defs raise (NotEnoughInformationToProgress sols); (* No unique projection but still restrict to where it is possible *) (* materializing is necessary, but is restricting useful? *) - let ty = find_solution_type (evar_filtered_env env evi) sols in - let ty' = instantiate_evar_array evi ty argsv in + let t' = of_alias t in + let ty = Retyping.get_type_of env !evdref t' in let (evd,evar,(evk',argsv' as ev')) = - materialize_evar (evar_define unify flags ~choose) env !evdref 0 ev ty' in + materialize_evar (evar_define unify flags ~choose) env !evdref 0 ev ty in let ts = expansions_of_var evd aliases t in let test c = isEvar evd c || List.exists (is_alias evd c) ts in let filter = restrict_upon_filter evd evk test argsv' in @@ -1564,7 +1557,7 @@ let rec invert_definition unify flags choose imitate_defs let evd = match candidates with | NoUpdate -> let evd, ev'' = restrict_applied_evar evd ev' filter NoUpdate in - add_conv_oriented_pb ~tail:false (None,env,mkEvar ev'',of_alias t) evd + add_conv_oriented_pb ~tail:false (None,env,mkEvar ev'',t') evd | UpdateWith _ -> restrict_evar evd evk' filter candidates in @@ -1575,7 +1568,7 @@ let rec invert_definition unify flags choose imitate_defs match EConstr.kind !evdref t with | Rel i when i>k -> let open Context.Rel.Declaration in - (match Environ.lookup_rel (i-k) env' with + (match Environ.lookup_rel i env' with | LocalAssum _ -> project_variable (RelAlias (i-k)) | LocalDef (_,b,_) -> try project_variable (RelAlias (i-k)) diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 8ff2d7fc63..094dae4828 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -99,7 +99,9 @@ type conversion_check = unify_flags -> unification_kind -> Preconditions: - [ev] does not occur in [c]. - [c] does not contain any Meta(_) - *) + + If [ev] and [c] have non inferably convertible types, an exception + [IllTypedInstance] is raised *) val instantiate_evar : unifier -> unify_flags -> env -> evar_map -> Evar.t -> constr -> evar_map @@ -107,7 +109,9 @@ val instantiate_evar : unifier -> unify_flags -> env -> evar_map -> (** [evar_define choose env ev c] try to instantiate [ev] with [c] (typed in [env]), possibly solving related unification problems, possibly leaving open some problems that cannot be solved in a unique way (except if choose is - true); fails if the instance is not valid for the given [ev] *) + true); fails if the instance is not valid for the given [ev]; + If [ev] and [c] have non inferably convertible types, an exception + [IllTypedInstance] is raised *) val evar_define : unifier -> unify_flags -> ?choose:bool -> ?imitate_defs:bool -> env -> evar_map -> bool option -> existential -> constr -> evar_map @@ -129,6 +133,8 @@ val solve_evar_evar : ?force:bool -> (env -> evar_map -> bool option -> existential -> constr -> evar_map) -> unifier -> unify_flags -> env -> evar_map -> bool option -> existential -> existential -> evar_map + (** The two evars are expected to be in inferably convertible types; + if not, an exception IllTypedInstance is raised *) val solve_simple_eqn : unifier -> unify_flags -> ?choose:bool -> ?imitate_defs:bool -> env -> evar_map -> bool option * existential * constr -> unification_result @@ -147,9 +153,9 @@ val noccur_evar : env -> evar_map -> Evar.t -> constr -> bool exception IllTypedInstance of env * types * types -(* May raise IllTypedInstance if types are not convertible *) val check_evar_instance : unifier -> unify_flags -> env -> evar_map -> Evar.t -> constr -> evar_map + (** May raise IllTypedInstance if types are not convertible *) val remove_instance_local_defs : evar_map -> Evar.t -> 'a list -> 'a list diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 06f7d92e62..b70ff20e32 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -139,7 +139,7 @@ let interp_known_universe_level_name evd qid = let qid = Nametab.locate_universe qid in Univ.Level.make qid -let interp_universe_level_name ~anon_rigidity evd qid = +let interp_universe_level_name evd qid = try evd, interp_known_universe_level_name evd qid with Not_found -> if Libnames.qualid_is_ident qid then (* Undeclared *) @@ -162,21 +162,15 @@ let interp_universe_level_name ~anon_rigidity evd qid = with UGraph.AlreadyDeclared -> evd in evd, level -let interp_universe_name ?loc evd l = - (* [univ_flexible_alg] can produce algebraic universes in terms *) - let anon_rigidity = univ_flexible in - let evd', l = interp_universe_level_name ~anon_rigidity evd l in - evd', l - -let interp_sort_name ?loc sigma = function +let interp_sort_name sigma = function | GSProp -> sigma, Univ.Level.sprop | GProp -> sigma, Univ.Level.prop | GSet -> sigma, Univ.Level.set - | GType l -> interp_universe_name ?loc sigma l + | GType l -> interp_universe_level_name sigma l let interp_sort_info ?loc evd l = List.fold_left (fun (evd, u) (l,n) -> - let evd', u' = interp_sort_name ?loc evd l in + let evd', u' = interp_sort_name evd l in let u' = Univ.Universe.make u' in let u' = match n with | 0 -> u' @@ -410,7 +404,7 @@ let interp_known_glob_level ?loc evd = function let interp_glob_level ?loc evd : glob_level -> _ = function | UAnonymous {rigid} -> new_univ_level_variable ?loc (if rigid then univ_rigid else univ_flexible) evd - | UNamed s -> interp_sort_name ?loc evd s + | UNamed s -> interp_sort_name evd s let interp_instance ?loc evd l = let evd, l' = diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 982814fdfc..c352a6ac1f 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -38,7 +38,7 @@ type metabinding = (metavariable * EConstr.constr * (instance_constraint * insta type subst0 = (evar_map * metabinding list * - (Environ.env * EConstr.existential * EConstr.t) list) + ((Environ.env * int) * EConstr.existential * EConstr.t) list) module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration @@ -227,7 +227,7 @@ let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst : subst0) | Evar ev -> let env' = pop_rel_context nb env in let sigma,c = pose_all_metas_as_evars env' sigma c in - sigma,metasubst,(env,ev,solve_pattern_eqn env sigma l c)::evarsubst + sigma,metasubst,((env,nb),ev,solve_pattern_eqn env sigma l c)::evarsubst | _ -> assert false let push d (env,n) = (push_rel_assum d env,n+1) @@ -769,21 +769,21 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e | Some sigma -> sigma, metasubst, evarsubst | None -> - sigma,metasubst,((curenv,ev,cN)::evarsubst) + sigma,metasubst,((curenvnb,ev,cN)::evarsubst) end | Evar (evk,_ as ev), _ when is_evar_allowed flags evk && not (occur_evar sigma evk cN) -> let cmvars = free_rels sigma cM and cnvars = free_rels sigma cN in if Int.Set.subset cnvars cmvars then - sigma,metasubst,((curenv,ev,cN)::evarsubst) + sigma,metasubst,((curenvnb,ev,cN)::evarsubst) else error_cannot_unify_local curenv sigma (m,n,cN) | _, Evar (evk,_ as ev) when is_evar_allowed flags evk && not (occur_evar sigma evk cM) -> let cmvars = free_rels sigma cM and cnvars = free_rels sigma cN in if Int.Set.subset cmvars cnvars then - sigma,metasubst,((curenv,ev,cM)::evarsubst) + sigma,metasubst,((curenvnb,ev,cM)::evarsubst) else error_cannot_unify_local curenv sigma (m,n,cN) | Sort s1, Sort s2 -> (try @@ -1357,7 +1357,7 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = (* Process evars *) match evars with - | (curenv,(evk,_ as ev),rhs)::evars' -> + | ((curenv,nb),(evk,_ as ev),rhs)::evars' -> if Evd.is_defined evd evk then let v = mkEvar ev in let (evd,metas',evars'') = @@ -1376,7 +1376,8 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = w_merge_rec evd' metas evars eqns else let evd' = - let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in + let env' = pop_rel_context nb curenv in + let evd', rhs'' = pose_all_metas_as_evars env' evd rhs' in try solve_simple_evar_eqn eflags curenv evd' ev rhs'' with Retyping.RetypeError _ -> error_cannot_unify curenv evd' (mkEvar ev,rhs'') diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 5462e09359..077597c278 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -105,7 +105,7 @@ type metabinding = (metavariable * constr * (instance_constraint * instance_typi type subst0 = (evar_map * metabinding list * - (Environ.env * existential * t) list) + ((Environ.env * int) * existential * t) list) val w_merge : env -> bool -> core_unify_flags -> subst0 -> evar_map diff --git a/proofs/proof.ml b/proofs/proof.ml index d864aed25a..24f3ac3f29 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -409,14 +409,28 @@ module V82 = struct let top_evars p = Proofview.V82.top_evars p.entry p.proofview + let warn_deprecated_grab_existentials = + CWarnings.create ~name:"deprecated-grab-existentials" ~category:"deprecated" + Pp.(fun () -> str "The Grab Existential Variables command is " ++ + str"deprecated. Please use the Unshelve command or the unshelve tactical " ++ + str"instead.") + let grab_evars p = + warn_deprecated_grab_existentials (); if not (is_done p) then raise (OpenProof(None, UnfinishedProof)) else { p with proofview = Proofview.V82.grab p.proofview } + let warn_deprecated_existential = + CWarnings.create ~name:"deprecated-existential" ~category:"deprecated" + Pp.(fun () -> str "The Existential command is " ++ + str"deprecated. Please use the Unshelve command or the unshelve " ++ + str"tactical, and the instantiate tactic instead.") + (* Main component of vernac command Existential *) let instantiate_evar env n intern pr = + warn_deprecated_existential (); let tac = Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma -> let (evk, evi) = diff --git a/tactics/eauto.mli b/tactics/eauto.mli index 5fb038a767..f40bbc813e 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -30,4 +30,5 @@ val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic val autounfold_one : hint_db_name list -> Locus.hyp_location option -> unit Proofview.tactic +val make_depth : int option -> int val make_dimension : int option -> int option -> bool * int diff --git a/tactics/hints.ml b/tactics/hints.ml index 68229dbe26..6fab111e6f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1023,11 +1023,15 @@ let remove_hint dbname grs = type hint_action = | CreateDB of bool * TransparentState.t - | AddTransparency of evaluable_global_reference hints_transparency_target * bool + | AddTransparency of { + superglobal : bool; + grefs : evaluable_global_reference hints_transparency_target; + state : bool; + } | AddHints of { superglobal : bool; hints : hint_entry list } - | RemoveHints of GlobRef.t list - | AddCut of hints_path - | AddMode of GlobRef.t * hint_mode array + | RemoveHints of { superglobal : bool; hints : GlobRef.t list } + | AddCut of { superglobal : bool; paths : hints_path } + | AddMode of { superglobal : bool; gref : GlobRef.t; mode : hint_mode array } let add_cut dbname path = let db = get_db dbname in @@ -1049,12 +1053,16 @@ let load_autohint _ (kn, h) = let name = h.hint_name in match h.hint_action with | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty ~name st b) - | AddTransparency (grs, b) -> add_transparency name grs b + | AddTransparency { superglobal; grefs; state } -> + if superglobal then add_transparency name grefs state | AddHints { superglobal; hints } -> if superglobal then add_hint name hints - | RemoveHints grs -> remove_hint name grs - | AddCut path -> add_cut name path - | AddMode (l, m) -> add_mode name l m + | RemoveHints { superglobal; hints } -> + if superglobal then remove_hint name hints + | AddCut { superglobal; paths } -> + if superglobal then add_cut name paths + | AddMode { superglobal; gref; mode } -> + if superglobal then add_mode name gref mode let open_autohint i (kn, h) = if Int.equal i 1 then match h.hint_action with @@ -1067,7 +1075,15 @@ let open_autohint i (kn, h) = in let add (_, hint) = statustable := KNmap.add hint.code.uid true !statustable in List.iter add hints - | _ -> () + | AddCut { superglobal; paths } -> + if not superglobal then add_cut h.hint_name paths + | AddTransparency { superglobal; grefs; state } -> + if not superglobal then add_transparency h.hint_name grefs state + | RemoveHints { superglobal; hints } -> + if not superglobal then remove_hint h.hint_name hints + | AddMode { superglobal; gref; mode } -> + if not superglobal then add_mode h.hint_name gref mode + | CreateDB _ -> () let cache_autohint (kn, obj) = load_autohint 1 (kn, obj); open_autohint 1 (kn, obj) @@ -1124,7 +1140,7 @@ let subst_autohint (subst, obj) = in let action = match obj.hint_action with | CreateDB _ -> obj.hint_action - | AddTransparency (target, b) -> + | AddTransparency { superglobal; grefs = target; state = b } -> let target' = match target with | HintsVariables -> target @@ -1134,19 +1150,19 @@ let subst_autohint (subst, obj) = if grs == grs' then target else HintsReferences grs' in - if target' == target then obj.hint_action else AddTransparency (target', b) + if target' == target then obj.hint_action else AddTransparency { superglobal; grefs = target'; state = b } | AddHints { superglobal; hints } -> let hints' = List.Smart.map subst_hint hints in if hints' == hints then obj.hint_action else AddHints { superglobal; hints = hints' } - | RemoveHints grs -> + | RemoveHints { superglobal; hints = grs } -> let grs' = List.Smart.map (subst_global_reference subst) grs in - if grs == grs' then obj.hint_action else RemoveHints grs' - | AddCut path -> + if grs == grs' then obj.hint_action else RemoveHints { superglobal; hints = grs' } + | AddCut { superglobal; paths = path } -> let path' = subst_hints_path subst path in - if path' == path then obj.hint_action else AddCut path' - | AddMode (l,m) -> + if path' == path then obj.hint_action else AddCut { superglobal; paths = path' } + | AddMode { superglobal; gref = l; mode = m } -> let l' = subst_global_reference subst l in - if l' == l then obj.hint_action else AddMode (l', m) + if l' == l then obj.hint_action else AddMode { superglobal; gref = l'; mode = m } in if action == obj.hint_action then obj else { obj with hint_action = action } @@ -1173,11 +1189,17 @@ let create_hint_db l n st b = let hint = make_hint ~local:l n (CreateDB (b, st)) in Lib.add_anonymous_leaf (inAutoHint hint) -let remove_hints local dbnames grs = +let interp_locality = function +| Goptions.OptDefault | Goptions.OptGlobal -> false, true +| Goptions.OptExport -> false, false +| Goptions.OptLocal -> true, false + +let remove_hints ~locality dbnames grs = + let local, superglobal = interp_locality locality in let dbnames = if List.is_empty dbnames then ["core"] else dbnames in List.iter (fun dbname -> - let hint = make_hint ~local dbname (RemoveHints grs) in + let hint = make_hint ~local dbname (RemoveHints { superglobal; hints = grs }) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames @@ -1185,11 +1207,6 @@ let remove_hints local dbnames grs = (* The "Hint" vernacular command *) (**************************************************************************) -let check_no_export ~local ~superglobal () = - (* TODO: implement export for these entries *) - if not local && not superglobal then - CErrors.user_err Pp.(str "This command does not support the \"export\" attribute") - let add_resolves env sigma clist ~local ~superglobal dbnames = List.iter (fun dbname -> @@ -1229,27 +1246,24 @@ let add_unfolds l ~local ~superglobal dbnames = dbnames let add_cuts l ~local ~superglobal dbnames = - let () = check_no_export ~local ~superglobal () in List.iter (fun dbname -> - let hint = make_hint ~local dbname (AddCut l) in + let hint = make_hint ~local dbname (AddCut { superglobal; paths = l }) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames let add_mode l m ~local ~superglobal dbnames = - let () = check_no_export ~local ~superglobal () in List.iter (fun dbname -> let m' = make_mode l m in - let hint = make_hint ~local dbname (AddMode (l, m')) in + let hint = make_hint ~local dbname (AddMode { superglobal; gref = l; mode = m' }) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames let add_transparency l b ~local ~superglobal dbnames = - let () = check_no_export ~local ~superglobal () in List.iter (fun dbname -> - let hint = make_hint ~local dbname (AddTransparency (l, b)) in + let hint = make_hint ~local dbname (AddTransparency { superglobal; grefs = l; state = b }) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames @@ -1326,11 +1340,7 @@ let prepare_hint check env init (sigma,c) = (c', diff) let add_hints ~locality dbnames h = - let local, superglobal = match locality with - | Goptions.OptDefault | Goptions.OptGlobal -> false, true - | Goptions.OptExport -> false, false - | Goptions.OptLocal -> true, false - in + let local, superglobal = interp_locality locality in if String.List.mem "nocore" dbnames then user_err Pp.(str "The hint database \"nocore\" is meant to stay empty."); assert (not (List.is_empty dbnames)); diff --git a/tactics/hints.mli b/tactics/hints.mli index 3d4d9c7970..54f4716652 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -189,7 +189,7 @@ val searchtable_add : (hint_db_name * hint_db) -> unit val create_hint_db : bool -> hint_db_name -> TransparentState.t -> bool -> unit -val remove_hints : bool -> hint_db_name list -> GlobRef.t list -> unit +val remove_hints : locality:Goptions.option_locality -> hint_db_name list -> GlobRef.t list -> unit val current_db_names : unit -> String.Set.t diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index 9164a4ff26..b16153a39e 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -100,9 +100,9 @@ let check_scheme kind ind = Option.has_some (lookup_scheme kind ind) let define internal role id c poly univs = let id = compute_name internal id in - let ctx = UState.minimize univs in - let c = UnivSubst.nf_evars_and_universes_opt_subst (fun _ -> None) (UState.subst ctx) c in - let univs = UState.univ_entry ~poly ctx in + let uctx = UState.minimize univs in + let c = UnivSubst.nf_evars_and_universes_opt_subst (fun _ -> None) (UState.subst uctx) c in + let univs = UState.univ_entry ~poly uctx in !declare_definition_scheme ~internal ~univs ~role ~name:id c (* Assumes that dependencies are already defined *) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f3ecc2a9f0..e3369bc9be 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -198,22 +198,24 @@ let clear_in_global_msg = function | Some ref -> str " implicitly in " ++ Printer.pr_global ref let clear_dependency_msg env sigma id err inglobal = + let ppidupper = function Some id -> Id.print id | None -> str "This variable" in + let ppid = function Some id -> Id.print id | None -> str "this variable" in let pp = clear_in_global_msg inglobal in match err with | Evarutil.OccurHypInSimpleClause None -> - Id.print id ++ str " is used" ++ pp ++ str " in conclusion." + ppidupper id ++ str " is used" ++ pp ++ str " in conclusion." | Evarutil.OccurHypInSimpleClause (Some id') -> - Id.print id ++ strbrk " is used" ++ pp ++ str " in hypothesis " ++ Id.print id' ++ str"." + ppidupper id ++ strbrk " is used" ++ pp ++ str " in hypothesis " ++ Id.print id' ++ str"." | Evarutil.EvarTypingBreak ev -> - str "Cannot remove " ++ Id.print id ++ + str "Cannot remove " ++ ppid id ++ strbrk " without breaking the typing of " ++ Printer.pr_existential env sigma ev ++ str"." | Evarutil.NoCandidatesLeft ev -> - str "Cannot remove " ++ Id.print id ++ str " as it would leave the existential " ++ + str "Cannot remove " ++ ppid id ++ str " as it would leave the existential " ++ Printer.pr_existential_key sigma ev ++ str" without candidates." let error_clear_dependency env sigma id err inglobal = - user_err (clear_dependency_msg env sigma id err inglobal) + user_err (clear_dependency_msg env sigma (Some id) err inglobal) let replacing_dependency_msg env sigma id err inglobal = let pp = clear_in_global_msg inglobal in @@ -2130,7 +2132,9 @@ let clear_body ids = end let clear_wildcards ids = - Tacticals.New.tclMAP (fun {CAst.loc;v=id} -> clear [id]) ids + let clear_wildcards_msg ?loc env sigma _id err inglobal = + user_err ?loc (clear_dependency_msg env sigma None err inglobal) in + Tacticals.New.tclMAP (fun {CAst.loc;v=id} -> clear_gen (clear_wildcards_msg ?loc) [id]) ids (* Takes a list of booleans, and introduces all the variables * quantified in the goal which are associated with a value diff --git a/test-suite/bugs/closed/bug_11816.v b/test-suite/bugs/closed/bug_11816.v new file mode 100644 index 0000000000..82a317b250 --- /dev/null +++ b/test-suite/bugs/closed/bug_11816.v @@ -0,0 +1,2 @@ +(* This should be an error, not an anomaly *) +Fail Definition foo := fix foo (n : nat) { wf n n } := 0. diff --git a/test-suite/bugs/closed/bug_12348.v b/test-suite/bugs/closed/bug_12348.v new file mode 100644 index 0000000000..93ba6f17e0 --- /dev/null +++ b/test-suite/bugs/closed/bug_12348.v @@ -0,0 +1,11 @@ +(* Was raising an anomaly before 8.13 *) +Check let 'tt := tt in + let X := nat in + let b : bool := _ in + (fun n : nat => 0 : X) : _. + +(* Was raising an ill-typed instance error before 8.13 *) +Check let 'tt := tt in + let X := nat in + let b : bool := true in + (fun n : nat => 0 : X) : _. diff --git a/test-suite/bugs/closed/bug_13246.v b/test-suite/bugs/closed/bug_13246.v new file mode 100644 index 0000000000..11f5baaaf4 --- /dev/null +++ b/test-suite/bugs/closed/bug_13246.v @@ -0,0 +1,69 @@ +Axiom _0: Prop. + +From Coq Require Export Morphisms Setoid Utf8. + +Class Equiv A := equiv: relation A. + +Reserved Notation "P ⊢ Q" (at level 99, Q at level 200, right associativity). +Reserved Notation "P ⊣⊢ Q" (at level 95, no associativity). +Reserved Notation "■P" (at level 20, right associativity). + +(** Define the scope *) +Declare Scope bi_scope. +Delimit Scope bi_scope with I. + +Structure bi := + Bi { bi_car :> Type; + bi_entails : bi_car → bi_car → Prop; + bi_impl : bi_car → bi_car → bi_car; + bi_forall : ∀ A, (A → bi_car) → bi_car; }. + +Declare Instance bi_equiv `{PROP:bi} : Equiv (bi_car PROP). + +Arguments bi_car : simpl never. +Arguments bi_entails {PROP} _%I _%I : simpl never, rename. +Arguments bi_impl {PROP} _%I _%I : simpl never, rename. +Arguments bi_forall {PROP _} _%I : simpl never, rename. + +Notation "P ⊢ Q" := (bi_entails P%I Q%I) . +Notation "P ⊣⊢ Q" := (equiv (A:=bi_car _) P%I Q%I) . + +Infix "→" := bi_impl : bi_scope. +Notation "∀ x .. y , P" := + (bi_forall (λ x, .. (bi_forall (λ y, P)) ..)%I) : bi_scope. + +(* bug disappears if definitional class *) +Class Plainly (PROP : bi) := { plainly : PROP -> PROP; }. +Notation "■P" := (plainly P) : bi_scope. + +Section S. + Context {I : Type} {PROP : bi} `(Plainly PROP). + + Lemma plainly_forall `{Plainly PROP} {A} (Ψ : A → PROP) : (∀ a, ■(Ψ a)) ⊣⊢ ■(∀ a, Ψ a). + Proof. Admitted. + + Global Instance entails_proper : + Proper (equiv ==> equiv ==> iff) (bi_entails : relation PROP). + Proof. Admitted. + + Global Instance impl_proper : + Proper (equiv ==> equiv ==> equiv) (@bi_impl PROP). + Proof. Admitted. + + Global Instance forall_proper A : + Proper (pointwise_relation _ equiv ==> equiv) (@bi_forall PROP A). + Proof. Admitted. + + Declare Instance PROP_Equivalence: Equivalence (@equiv PROP _). + + Set Mangle Names. + Lemma foo (P : I -> PROP) K: + K ⊢ ∀ (j : I) + (_ : Prop) (* bug disappears if this is removed *) + , (∀ i0, ■P i0) → P j. + Proof. + setoid_rewrite plainly_forall. + (* retype in case the tactic did some nonsense *) + match goal with |- ?T => let _ := type of T in idtac end. + Abort. +End S. diff --git a/test-suite/bugs/closed/bug_13278.v b/test-suite/bugs/closed/bug_13278.v new file mode 100644 index 0000000000..9831a4d205 --- /dev/null +++ b/test-suite/bugs/closed/bug_13278.v @@ -0,0 +1,15 @@ +Inductive even: nat -> Prop := +| evenB: even 0 +| evenS: forall n, even n -> even (S (S n)). + +Goal even 1 -> False. +Proof. + refine (fun a => match a with end). +Qed. + +Goal even 1 -> False. +Proof. + refine (fun a => match a in even n + return match n with 1 => False | _ => True end : Prop + with evenB => I | evenS _ _ => I end). +Qed. diff --git a/test-suite/bugs/closed/bug_13330.v b/test-suite/bugs/closed/bug_13330.v new file mode 100644 index 0000000000..d13de2e58d --- /dev/null +++ b/test-suite/bugs/closed/bug_13330.v @@ -0,0 +1,17 @@ +Polymorphic Inductive path {A : Type} (x : A) : A -> Type := + refl : path x x. + +Goal False. +Proof. +simple refine (let H : False := _ in _). ++ exact_no_check I. ++ assert (path true false -> path false true). + (** Create a dummy polymorphic side-effect *) + { + intro IHn. + rewrite IHn. + reflexivity. + } + exact H. +Fail Qed. +Abort. diff --git a/test-suite/bugs/closed/bug_13348.v b/test-suite/bugs/closed/bug_13348.v new file mode 100644 index 0000000000..d3d5d3e5b4 --- /dev/null +++ b/test-suite/bugs/closed/bug_13348.v @@ -0,0 +1,10 @@ +Generalizable All Variables. + +Class Inhabited (A : Type) : Type := populate { inhabitant : A }. +Arguments populate {_} _. + +Set Mangle Names. +Axioms _0 _1 _2 : Prop. + +Instance impl_inhabited {A} {B} {_3:Inhabited B} : Inhabited (A -> B) + := populate (fun _ => inhabitant). diff --git a/test-suite/bugs/closed/bug_13354.v b/test-suite/bugs/closed/bug_13354.v new file mode 100644 index 0000000000..fbda10a9d2 --- /dev/null +++ b/test-suite/bugs/closed/bug_13354.v @@ -0,0 +1,10 @@ + +Primitive array := #array_type. + +Definition testArray : array nat := [| 1; 2; 4 | 0 : nat |]. + +Definition on_array {A:Type} (x:array A) : Prop := True. + +Check on_array testArray. + +Check @on_array nat testArray. diff --git a/test-suite/bugs/closed/bug_13363.v b/test-suite/bugs/closed/bug_13363.v new file mode 100644 index 0000000000..cc11aa93b6 --- /dev/null +++ b/test-suite/bugs/closed/bug_13363.v @@ -0,0 +1,17 @@ +Axiom X : Type. +Axiom P : (X -> unit) -> Prop. + +Axiom F: unit -> unit. +Axiom G : unit -> unit. + +Lemma Hyp ss': + P (fun y : X => ss') -> + P (fun y : X => G (F ss')). +Admitted. + +Lemma bug : exists x, P x. +Proof. +intros. +eexists (fun y : X => G _). +eapply Hyp. cbn beta. +Abort. diff --git a/test-suite/bugs/closed/bug_3513.v b/test-suite/bugs/closed/bug_3513.v index 462a615d91..f3a19c2b89 100644 --- a/test-suite/bugs/closed/bug_3513.v +++ b/test-suite/bugs/closed/bug_3513.v @@ -13,7 +13,7 @@ Infix "|--" := lentails (at level 79, no associativity). Class ILogic Frm {ILOps: ILogicOps Frm} := { lentailsPre:> PreOrder lentails }. Definition lequiv `{ILogic Frm} P Q := P |-- Q /\ Q |-- P. Infix "-|-" := lequiv (at level 85, no associativity). -Instance lequiv_inverse_lentails `{ILogic Frm} : subrelation lequiv (inverse lentails) := admit. +Instance lequiv_inverse_lentails `{ILogic Frm} {inverse} : subrelation lequiv (inverse lentails) := admit. Record ILFunFrm (T : Type) `{e : Equiv T} `{ILOps : ILogicOps Frm} := mkILFunFrm { ILFunFrm_pred :> T -> Frm }. Section ILogic_Fun. Context (T: Type) `{TType: type T}. diff --git a/test-suite/bugs/closed/bug_4095.v b/test-suite/bugs/closed/bug_4095.v index d667022e68..2d4d7d02cc 100644 --- a/test-suite/bugs/closed/bug_4095.v +++ b/test-suite/bugs/closed/bug_4095.v @@ -15,7 +15,7 @@ Infix "|--" := lentails (at level 79, no associativity). Class ILogic Frm {ILOps: ILogicOps Frm} := { lentailsPre:> PreOrder lentails }. Definition lequiv `{ILogic Frm} P Q := P |-- Q /\ Q |-- P. Infix "-|-" := lequiv (at level 85, no associativity). -Instance lequiv_inverse_lentails `{ILogic Frm} : subrelation lequiv (inverse lentails) := admit. +Instance lequiv_inverse_lentails `{ILogic Frm} {inverse} : subrelation lequiv (inverse lentails) := admit. Record ILFunFrm (T : Type) `{e : Equiv T} `{ILOps : ILogicOps Frm} := mkILFunFrm { ILFunFrm_pred :> T -> Frm }. Section ILogic_Fun. Context (T: Type) `{TType: type T}. diff --git a/test-suite/bugs/closed/bug_5512.v b/test-suite/bugs/closed/bug_5512.v new file mode 100644 index 0000000000..f885e31352 --- /dev/null +++ b/test-suite/bugs/closed/bug_5512.v @@ -0,0 +1,10 @@ +(* Check that an anomaly is not raised *) +(* It should however eventually succeed... *) +Goal exists x, x. +Proof. +simple refine (ex_intro _ _ _). +shelve. +(* The failure is due to Type(u)<=Prop for u an arbitrary sort + variable being rejected *) +Fail simple refine (_ _). +Abort. diff --git a/test-suite/bugs/closed/bug_6042.v b/test-suite/bugs/closed/bug_6042.v new file mode 100644 index 0000000000..72f612560b --- /dev/null +++ b/test-suite/bugs/closed/bug_6042.v @@ -0,0 +1,7 @@ +Class C (n: nat) := T{x:True}. +Generalizable All Variables. + +Fail Instance i : C n. + +Instance i : `(C n). +Proof. repeat constructor. Defined. diff --git a/test-suite/coqdoc/binder.tex.out b/test-suite/coqdoc/binder.tex.out index 2b5648aee6..aceccc25fd 100644 --- a/test-suite/coqdoc/binder.tex.out +++ b/test-suite/coqdoc/binder.tex.out @@ -20,7 +20,8 @@ \begin{coqdoccode} \end{coqdoccode} -Link binders \begin{coqdoccode} +Link binders +\begin{coqdoccode} \coqdocemptyline \coqdocnoindent \coqdockw{Definition} \coqdef{Coqdoc.binder.foo}{foo}{\coqdocdefinition{foo}} \coqdef{Coqdoc.binder.alpha:1}{alpha}{\coqdocbinder{alpha}} \coqdef{Coqdoc.binder.beta:2}{beta}{\coqdocbinder{beta}} := \coqref{Coqdoc.binder.alpha:1}{\coqdocvariable{alpha}} \coqexternalref{::nat scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocnotation{+}} \coqref{Coqdoc.binder.beta:2}{\coqdocvariable{beta}}.\coqdoceol diff --git a/test-suite/coqdoc/bug12742.tex.out b/test-suite/coqdoc/bug12742.tex.out index d7eba096fc..a8f4c254cb 100644 --- a/test-suite/coqdoc/bug12742.tex.out +++ b/test-suite/coqdoc/bug12742.tex.out @@ -46,6 +46,7 @@ Xxx xxxx xx xxxxx xxxxxxx xxxxx xxx xxxxxxxx xxxxxxx xxx xxx xxxx xxxxx xxxx xxxxxx. \end{itemize} + \begin{coqdoccode} \end{coqdoccode} \end{document} diff --git a/test-suite/coqdoc/bug5700.html.out b/test-suite/coqdoc/bug5700.html.out index 286e8bba4d..84214a73d3 100644 --- a/test-suite/coqdoc/bug5700.html.out +++ b/test-suite/coqdoc/bug5700.html.out @@ -22,8 +22,7 @@ </div> <div class="doc"> -<pre>foo (* bar *) </pre> - +<code> foo (* {bar_bar} *) </code> </div> <div class="code"> <span class="id" title="keyword">Definition</span> <a id="const1" class="idref" href="#const1"><span class="id" title="definition">const1</span></a> := 1.<br/> @@ -32,8 +31,7 @@ </div> <div class="doc"> -<pre>more (* nested (* comments *) within verbatim *) </pre> - +<code> more (* nested (* comments *) within verbatim *) </code> </div> <div class="code"> <span class="id" title="keyword">Definition</span> <a id="const2" class="idref" href="#const2"><span class="id" title="definition">const2</span></a> := 2.<br/> diff --git a/test-suite/coqdoc/bug5700.tex.out b/test-suite/coqdoc/bug5700.tex.out index 1a1af5dfdd..f2b12f0079 100644 --- a/test-suite/coqdoc/bug5700.tex.out +++ b/test-suite/coqdoc/bug5700.tex.out @@ -20,14 +20,14 @@ \begin{coqdoccode} \end{coqdoccode} -\begin{verbatim}foo (* bar *) \end{verbatim} - \begin{coqdoccode} +\texttt{ foo (* \{bar\_bar\} *) } +\begin{coqdoccode} \coqdocnoindent \coqdockw{Definition} \coqdef{Coqdoc.bug5700.const1}{const1}{\coqdocdefinition{const1}} := 1.\coqdoceol \coqdocemptyline \end{coqdoccode} -\begin{verbatim}more (* nested (* comments *) within verbatim *) \end{verbatim} - \begin{coqdoccode} +\texttt{ more (* nested (* comments *) within verbatim *) } +\begin{coqdoccode} \coqdocnoindent \coqdockw{Definition} \coqdef{Coqdoc.bug5700.const2}{const2}{\coqdocdefinition{const2}} := 2.\coqdoceol \end{coqdoccode} diff --git a/test-suite/coqdoc/bug5700.v b/test-suite/coqdoc/bug5700.v index 839034a48f..fc985276af 100644 --- a/test-suite/coqdoc/bug5700.v +++ b/test-suite/coqdoc/bug5700.v @@ -1,4 +1,4 @@ -(** << foo (* bar *) >> *) +(** << foo (* {bar_bar} *) >> *) Definition const1 := 1. (** << more (* nested (* comments *) within verbatim *) >> *) diff --git a/test-suite/coqdoc/links.tex.out b/test-suite/coqdoc/links.tex.out index 2304f5ecc1..412a9ca6ac 100644 --- a/test-suite/coqdoc/links.tex.out +++ b/test-suite/coqdoc/links.tex.out @@ -36,6 +36,7 @@ Various checks for coqdoc \item ``..'' should be rendered correctly \end{itemize} + \begin{coqdoccode} \coqdocemptyline \coqdocnoindent @@ -166,7 +167,8 @@ skip skip - skip \begin{coqdoccode} + skip +\begin{coqdoccode} \coqdocemptyline \end{coqdoccode} \end{document} diff --git a/test-suite/coqdoc/verbatim.html.out b/test-suite/coqdoc/verbatim.html.out new file mode 100644 index 0000000000..bf9f975ee8 --- /dev/null +++ b/test-suite/coqdoc/verbatim.html.out @@ -0,0 +1,114 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" +"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8" /> +<link href="coqdoc.css" rel="stylesheet" type="text/css" /> +<title>Coqdoc.verbatim</title> +</head> + +<body> + +<div id="page"> + +<div id="header"> +</div> + +<div id="main"> + +<h1 class="libtitle">Library Coqdoc.verbatim</h1> + +<div class="code"> +</div> + +<div class="doc"> + +<div class="paragraph"> </div> + +<pre> +uint32_t shift_right( uint32_t a, uint32_t shift ) +{ + return a >> shift; +} +</pre> + +<div class="paragraph"> </div> + +This line and the following shows <code>verbatim </code> text: + +<div class="paragraph"> </div> + +<code> A stand-alone inline verbatim </code> + +<div class="paragraph"> </div> + +<code> A non-ended inline verbatim to test line location +</code> + +<div class="paragraph"> </div> + +<ul class="doclist"> +<li> item 1 + +</li> +<li> item 2 is <code>verbatim</code> + +</li> +<li> item 3 is <code>verbatim</code> too +<br/> +<span class="inlinecode"><span class="id" title="var">A</span> <span class="id" title="var">coq</span> <span class="id" title="var">block</span> : <span class="id" title="keyword">∀</span> <span class="id" title="var">n</span>, <span class="id" title="var">n</span> = 0 +<div class="paragraph"> </div> + +</span> +</li> +<li> <code>verbatim</code> again, and a formula <span class="inlinecode"></span> <span class="inlinecode"><span class="id" title="var">True</span></span> <span class="inlinecode">→</span> <span class="inlinecode"><span class="id" title="var">False</span></span> <span class="inlinecode"></span> + +</li> +<li> +<pre> +multiline +verbatim +</pre> + +</li> +<li> last item + +</li> +</ul> + +<div class="paragraph"> </div> + +<center><table class="infrule"> +<tr class="infruleassumption"> + <td class="infrule">Γ ⊢ A</td> + <td class="infrulenamecol" rowspan="3"> + + </td></tr> +<tr class="infrulemiddle"> + <td class="infrule"><hr /></td> +</tr> +<tr class="infruleassumption"> + <td class="infrule">Γ ⊢ A ∨ B</td> + <td></td> +</td> +</table></center> +<div class="paragraph"> </div> + +<pre> +A non-ended block verbatim to test line location + +*) +</pre> +</div> +<div class="code"> +</div> +</div> + +<div id="footer"> +<hr/><a href="index.html">Index</a><hr/>This page has been generated by <a href="http://coq.inria.fr/">coqdoc</a> +</div> + +</div> + +</body> +</html>
\ No newline at end of file diff --git a/test-suite/coqdoc/verbatim.tex.out b/test-suite/coqdoc/verbatim.tex.out new file mode 100644 index 0000000000..b692f6ad6a --- /dev/null +++ b/test-suite/coqdoc/verbatim.tex.out @@ -0,0 +1,84 @@ +\documentclass[12pt]{report} +\usepackage[utf8x]{inputenc} + +%Warning: tipa declares many non-standard macros used by utf8x to +%interpret utf8 characters but extra packages might have to be added +%such as "textgreek" for Greek letters not already in tipa +%or "stmaryrd" for mathematical symbols. +%Utf8 codes missing a LaTeX interpretation can be defined by using +%\DeclareUnicodeCharacter{code}{interpretation}. +%Use coqdoc's option -p to add new packages or declarations. +\usepackage{tipa} + +\usepackage[T1]{fontenc} +\usepackage{fullpage} +\usepackage{coqdoc} +\usepackage{amsmath,amssymb} +\usepackage{url} +\begin{document} +\coqlibrary{Coqdoc.verbatim}{Library }{Coqdoc.verbatim} + +\begin{coqdoccode} +\end{coqdoccode} + + +\begin{verbatim} +uint32_t shift_right( uint32_t a, uint32_t shift ) +{ + return a >> shift; +} +\end{verbatim} + + +This line and the following shows \texttt{verbatim } text: + + +\texttt{ A stand-alone inline verbatim } + + +\texttt{ A non-ended inline verbatim to test line location +} + + + +\begin{itemize} +\item item 1 + +\item item 2 is \texttt{verbatim} + +\item item 3 is \texttt{verbatim} too +\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdocvar{A} \coqdocvar{coq} \coqdocvar{block} : \coqdockw{\ensuremath{\forall}} \coqdocvar{n}, \coqdocvar{n} = 0 + +\coqdocemptyline + +\item \texttt{verbatim} again, and a formula \coqdocvar{True} \ensuremath{\rightarrow} \coqdocvar{False} + +\item +\begin{verbatim} +multiline +verbatim +\end{verbatim} + +\item last item + +\end{itemize} + + +\begin{verbatim} +Γ ⊢ A +---- +Γ ⊢ A ∨ B +\end{verbatim} + + +\begin{verbatim} +A non-ended block verbatim to test line location + +*) +\end{verbatim} +\begin{coqdoccode} +\end{coqdoccode} +\end{document} diff --git a/test-suite/coqdoc/verbatim.v b/test-suite/coqdoc/verbatim.v new file mode 100644 index 0000000000..129a5117c9 --- /dev/null +++ b/test-suite/coqdoc/verbatim.v @@ -0,0 +1,40 @@ +(** + +<< +uint32_t shift_right( uint32_t a, uint32_t shift ) +{ + return a >> shift; +} +>> + +This line and the following shows << verbatim >> text: + +<< A stand-alone inline verbatim >> + +<< A non-ended inline verbatim to test line location + + +- item 1 +- item 2 is <<verbatim>> +- item 3 is <<verbatim>> too +[[ +A coq block : forall n, n = 0 +]] +- <<verbatim>> again, and a formula [ True -> False ] +- +<< +multiline +verbatim +>> +- last item + +[[[ +Γ ⊢ A +---- +Γ ⊢ A ∨ B +]]] + +<< +A non-ended block verbatim to test line location + +*) diff --git a/test-suite/misc/13330.sh b/test-suite/misc/13330.sh new file mode 100755 index 0000000000..7340559432 --- /dev/null +++ b/test-suite/misc/13330.sh @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +$coqc misc/13330/bug_13330.v +R=$? + +if [ $R == 0 ]; then + exit 1 +else + exit 0 +fi diff --git a/test-suite/misc/13330/bug_13330.v b/test-suite/misc/13330/bug_13330.v new file mode 100644 index 0000000000..acf6e80c48 --- /dev/null +++ b/test-suite/misc/13330/bug_13330.v @@ -0,0 +1,16 @@ +Polymorphic Inductive path {A : Type} (x : A) : A -> Type := + refl : path x x. + +Goal False. +Proof. +simple refine (let H : False := _ in _). ++ exact_no_check I. ++ assert (path true false -> path false true). + (** Create a dummy polymorphic side-effect *) + { + intro IHn. + rewrite IHn. + reflexivity. + } + exact H. +Qed. diff --git a/test-suite/output/HintLocality.out b/test-suite/output/HintLocality.out new file mode 100644 index 0000000000..37a0613b25 --- /dev/null +++ b/test-suite/output/HintLocality.out @@ -0,0 +1,92 @@ +Non-discriminated database +Unfoldable variable definitions: all +Unfoldable constant definitions: all except: id +Cut: _ +For any goal -> +For nat -> +For S (modes !) -> + +Non-discriminated database +Unfoldable variable definitions: all +Unfoldable constant definitions: all except: id +Cut: _ +For any goal -> +For nat -> +For S (modes !) -> + +Non-discriminated database +Unfoldable variable definitions: all +Unfoldable constant definitions: all except: id +Cut: _ +For any goal -> +For nat -> +For S (modes !) -> + +Non-discriminated database +Unfoldable variable definitions: all +Unfoldable constant definitions: all except: id +Cut: _ +For any goal -> +For nat -> +For S (modes !) -> + +Non-discriminated database +Unfoldable variable definitions: all +Unfoldable constant definitions: all +Cut: emp +For any goal -> +For nat -> simple apply 0 ; trivial(level 1, pattern nat, id 0) + +Non-discriminated database +Unfoldable variable definitions: all +Unfoldable constant definitions: all +Cut: emp +For any goal -> +For nat -> simple apply 0 ; trivial(level 1, pattern nat, id 0) + +Non-discriminated database +Unfoldable variable definitions: all +Unfoldable constant definitions: all except: id +Cut: _ +For any goal -> +For nat -> +For S (modes !) -> + +Non-discriminated database +Unfoldable variable definitions: all +Unfoldable constant definitions: all +Cut: emp +For any goal -> +For nat -> simple apply 0 ; trivial(level 1, pattern nat, id 0) + +Non-discriminated database +Unfoldable variable definitions: all +Unfoldable constant definitions: all except: id +Cut: _ +For any goal -> +For nat -> +For S (modes !) -> + +The command has indeed failed with message: +This command does not support the global attribute in sections. +The command has indeed failed with message: +This command does not support the global attribute in sections. +The command has indeed failed with message: +This command does not support the global attribute in sections. +The command has indeed failed with message: +This command does not support the global attribute in sections. +Non-discriminated database +Unfoldable variable definitions: all +Unfoldable constant definitions: all except: id +Cut: _ +For any goal -> +For nat -> +For S (modes !) -> + +Non-discriminated database +Unfoldable variable definitions: all +Unfoldable constant definitions: all +Cut: emp +For any goal -> +For nat -> simple apply 0 ; trivial(level 1, pattern nat, id 0) + diff --git a/test-suite/output/HintLocality.v b/test-suite/output/HintLocality.v new file mode 100644 index 0000000000..4481335907 --- /dev/null +++ b/test-suite/output/HintLocality.v @@ -0,0 +1,72 @@ +(** Test hint command locality w.r.t. modules *) + +Create HintDb foodb. +Create HintDb bardb. +Create HintDb quxdb. + +#[global] Hint Immediate O : foodb. +#[global] Hint Immediate O : bardb. +#[global] Hint Immediate O : quxdb. + +Module Test. + +#[global] Hint Cut [ _ ] : foodb. +#[global] Hint Mode S ! : foodb. +#[global] Hint Opaque id : foodb. +#[global] Remove Hints O : foodb. + +#[local] Hint Cut [ _ ] : bardb. +#[local] Hint Mode S ! : bardb. +#[local] Hint Opaque id : bardb. +#[local] Remove Hints O : bardb. + +#[export] Hint Cut [ _ ] : quxdb. +#[export] Hint Mode S ! : quxdb. +#[export] Hint Opaque id : quxdb. +#[export] Remove Hints O : quxdb. + +(** All three agree here *) + +Print HintDb foodb. +Print HintDb bardb. +Print HintDb quxdb. + +End Test. + +(** bardb and quxdb agree here *) + +Print HintDb foodb. +Print HintDb bardb. +Print HintDb quxdb. + +Import Test. + +(** foodb and quxdb agree here *) + +Print HintDb foodb. +Print HintDb bardb. +Print HintDb quxdb. + +(** Test hint command locality w.r.t. sections *) + +Create HintDb secdb. + +#[global] Hint Immediate O : secdb. + +Section Sec. + +Fail #[global] Hint Cut [ _ ] : secdb. +Fail #[global] Hint Mode S ! : secdb. +Fail #[global] Hint Opaque id : secdb. +Fail #[global] Remove Hints O : secdb. + +#[local] Hint Cut [ _ ] : secdb. +#[local] Hint Mode S ! : secdb. +#[local] Hint Opaque id : secdb. +#[local] Remove Hints O : secdb. + +Print HintDb secdb. + +End Sec. + +Print HintDb secdb. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index bd22d45059..623ca316c9 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -249,3 +249,5 @@ myfoo01 tt : nat myfoo01 tt : nat +1 ⪯ 2 ⪯ 3 ⪯ 4 + : Prop diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 839df99ea7..ce97d909a7 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -410,3 +410,13 @@ Check myfoo0 1 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] Check myfoo01 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] *) End Issue8126. + +Module RecursiveNotationPartialApp. + +(* Discussed on Coq Club, 28 July 2020 *) +Notation "x ⪯ y ⪯ .. ⪯ z ⪯ t" := + ((fun b A a => a <= b /\ A b) y .. ((fun b A a => a <= b /\ A b) z (fun b => b <= t)) .. x) + (at level 70, y at next level, z at next level, t at next level). +Check 1 ⪯ 2 ⪯ 3 ⪯ 4. + +End RecursiveNotationPartialApp. diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index ef4c6bac93..0f5fd91d93 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -462,3 +462,7 @@ inr: forall {A B : Type}, B -> A + B inl: forall {A B : Type}, A -> A + B (use "About" for full details on the implicit arguments of inl and inr) f: None = 0 +partition_cons1: + forall [A : Type] (f : A -> bool) (a : A) (l : list A) [l1 l2 : list A], + partition f l = (l1, l2) -> + f a = true -> partition f (a :: l) = (a :: l1, l2) diff --git a/test-suite/output/Search.v b/test-suite/output/Search.v index 2f29e1aff1..3419d5ac62 100644 --- a/test-suite/output/Search.v +++ b/test-suite/output/Search.v @@ -96,3 +96,9 @@ Module WithCoercions. Axiom f : None = 0. Search (None = 0). End WithCoercions. + +Require Import List. + +Module Wish13349. +Search partition "1" inside List. +End Wish13349. diff --git a/test-suite/output/Tactics.out b/test-suite/output/Tactics.out index 70427220ed..3f07261ca6 100644 --- a/test-suite/output/Tactics.out +++ b/test-suite/output/Tactics.out @@ -7,3 +7,5 @@ H is already used. The command has indeed failed with message: H is already used. a +The command has indeed failed with message: +This variable is used in hypothesis H. diff --git a/test-suite/output/Tactics.v b/test-suite/output/Tactics.v index 96b6d652c9..8526e43a23 100644 --- a/test-suite/output/Tactics.v +++ b/test-suite/output/Tactics.v @@ -30,3 +30,11 @@ Goal True. assert_succeeds should_not_loop. assert_succeeds (idtac "a" + idtac "b"). (* should only output "a" *) Abort. + +Module IntroWildcard. + +Theorem foo : { p:nat*nat & p = (0,0) } -> True. +Fail intros ((n,_),H). +Abort. + +End IntroWildcard. diff --git a/test-suite/output/TypeclassDebug.v b/test-suite/output/TypeclassDebug.v index 2e4008ae56..0bd3d5fa40 100644 --- a/test-suite/output/TypeclassDebug.v +++ b/test-suite/output/TypeclassDebug.v @@ -2,6 +2,7 @@ Parameter foo : Prop. Axiom H : foo -> foo. +#[global] Hint Resolve H : foo. Goal foo. Typeclasses eauto := debug. diff --git a/test-suite/output/UnboundRef.out b/test-suite/output/UnboundRef.out new file mode 100644 index 0000000000..a574e97e0f --- /dev/null +++ b/test-suite/output/UnboundRef.out @@ -0,0 +1,3 @@ +File "stdin", line 1, characters 11-12: +Error: The reference a was not found in the current environment. + diff --git a/test-suite/output/UnboundRef.v b/test-suite/output/UnboundRef.v new file mode 100644 index 0000000000..fd08ae0c5c --- /dev/null +++ b/test-suite/output/UnboundRef.v @@ -0,0 +1,2 @@ +Check Prop a b. +(* Prop is because we need a real head for the application *) diff --git a/test-suite/output/bug_13266.out b/test-suite/output/bug_13266.out new file mode 100644 index 0000000000..034830f1ac --- /dev/null +++ b/test-suite/output/bug_13266.out @@ -0,0 +1,12 @@ +The command has indeed failed with message: +Abstracting over the terms "S", "p" and "u" leads to a term +fun (S0 : Type) (p0 : proc S0) (_ : S0) => p0 = Tick -> True +which is ill-typed. +Reason is: Illegal application: +The term "@eq" of type "forall A : Type, A -> A -> Prop" +cannot be applied to the terms + "proc S0" : "Prop" + "p0" : "proc S0" + "Tick" : "proc unit" +The 3rd term has type "proc unit" which should be coercible to +"proc S0". diff --git a/test-suite/output/bug_13266.v b/test-suite/output/bug_13266.v new file mode 100644 index 0000000000..e59455a326 --- /dev/null +++ b/test-suite/output/bug_13266.v @@ -0,0 +1,18 @@ +Inductive proc : Type -> Type := +| Tick : proc unit +. + +Inductive exec : + forall T, proc T -> T -> Prop := +| ExecTick : + exec _ (Tick) tt +. + +Lemma foo : + exec _ Tick tt -> + True. +Proof. + intros H. + remember Tick as p. + Fail induction H. +Abort. diff --git a/test-suite/output/locate.out b/test-suite/output/locate.out index 93d9d6cf7b..0196ead5e4 100644 --- a/test-suite/output/locate.out +++ b/test-suite/output/locate.out @@ -1,2 +1,8 @@ Notation "b1 && b2" := (if b1 then b2 else false) (default interpretation) Notation "x && y" := (andb x y) : bool_scope +Notation "'U' t" := (S t) (default interpretation) +Notation "'_' t" := (S t) (default interpretation) +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope (default interpretation) +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope (default interpretation) +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope (default interpretation) +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope (default interpretation) diff --git a/test-suite/output/locate.v b/test-suite/output/locate.v index af8b0ee193..6995743531 100644 --- a/test-suite/output/locate.v +++ b/test-suite/output/locate.v @@ -1,3 +1,26 @@ Set Printing Width 400. Notation "b1 && b2" := (if b1 then b2 else false). Locate "&&". + +Module M. + +Notation "'U' t" := (S t) (at level 0). +Notation "'_' t" := (S t) (at level 0). +Locate "U". (* was wrongly returning also "'_' t" *) +Locate "_". + +End M. + +Module N. + +(* Was not working at some time *) +Locate "( t , u , .. , v )". + +(* Was working though *) +Locate "( _ , _ , .. , _ )". + +(* We also support this *) +Locate "( t , u )". +Locate "( t , u , v )". + +End N. diff --git a/test-suite/report.sh b/test-suite/report.sh index 5b74bee0c7..0b8497b809 100755 --- a/test-suite/report.sh +++ b/test-suite/report.sh @@ -21,7 +21,7 @@ cp summary.log "$SAVEDIR"/ rm "$FAILED" # print info -if [ -n "$APPVEYOR" ] || [ -n "$PRINT_LOGS" ]; then +if [ -n "$CI" ] || [ -n "$PRINT_LOGS" ]; then find logs/ -name '*.log' -not -name 'summary.log' -print0 | while IFS= read -r -d '' file; do printf '%s\n' "$file" cat "$file" diff --git a/test-suite/ssr/ipat_apply.v b/test-suite/ssr/ipat_apply.v new file mode 100644 index 0000000000..2f7986aea6 --- /dev/null +++ b/test-suite/ssr/ipat_apply.v @@ -0,0 +1,13 @@ +Require Import ssreflect. + +Section Apply. + +Variable P : nat -> Prop. +Lemma test_apply A B : forall (f : A -> B) (a : A), B. + +Proof. +move=> /[apply] b. +exact. +Qed. + +End Apply. diff --git a/test-suite/ssr/ipat_dup.v b/test-suite/ssr/ipat_dup.v new file mode 100644 index 0000000000..b1936df31d --- /dev/null +++ b/test-suite/ssr/ipat_dup.v @@ -0,0 +1,13 @@ +Require Import ssreflect. + +Section Dup. + +Variable P : nat -> Prop. + +Lemma test_dup1 : forall n : nat, P n. +Proof. move=> /[dup] m n; suff: P n by []. Abort. + +Lemma test_dup2 : let n := 1 in False. +Proof. move=> /[dup] m n; have : m = n := eq_refl. Abort. + +End Dup. diff --git a/test-suite/ssr/ipat_swap.v b/test-suite/ssr/ipat_swap.v new file mode 100644 index 0000000000..1d78a2a009 --- /dev/null +++ b/test-suite/ssr/ipat_swap.v @@ -0,0 +1,13 @@ +Require Import ssreflect. + +Section Swap. + +Definition P n := match n with 1 => true | _ => false end. + +Lemma test_swap1 : forall (n : nat) (b : bool), P n = b. +Proof. move=> /[swap] b n; suff: P n = b by []. Abort. + +Lemma test_swap1 : let n := 1 in let b := true in False. +Proof. move=> /[swap] b n; have : P n = b := eq_refl. Abort. + +End Swap. diff --git a/test-suite/success/CumulInd.v b/test-suite/success/CumulInd.v new file mode 100644 index 0000000000..f24d13b8af --- /dev/null +++ b/test-suite/success/CumulInd.v @@ -0,0 +1,20 @@ + +(* variances other than Invariant are forbidden for non-cumul inductives *) +Fail Inductive foo@{+u} : Prop := . +Fail Polymorphic Inductive foo@{*u} : Prop := . +Inductive foo@{=u} : Prop := . + +Set Universe Polymorphism. +Set Polymorphic Inductive Cumulativity. + +Inductive force_invariant@{=u} : Prop := . +Fail Definition lift@{u v | u < v} (x:force_invariant@{u}) : force_invariant@{v} := x. + +Inductive force_covariant@{+u} : Prop := . +Fail Definition lift@{u v | v < u} (x:force_covariant@{u}) : force_covariant@{v} := x. +Definition lift@{u v | u < v} (x:force_covariant@{u}) : force_covariant@{v} := x. + +Fail Inductive not_irrelevant@{*u} : Prop := nirr (_ : Type@{u}). +Inductive check_covariant@{+u} : Prop := cov (_ : Type@{u}). + +Fail Inductive not_covariant@{+u} : Prop := ncov (_ : Type@{u} -> nat). diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v index 382c252727..fb8bbfd043 100644 --- a/test-suite/success/Notations2.v +++ b/test-suite/success/Notations2.v @@ -51,8 +51,8 @@ Check fun A (x : prod' bool A) => match x with (@pair' _ 0) _ y 0%bool => 2 | _ Notation c3 x := ((@pair') _ x). Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. (* @ is blocking implicit and scopes *) Check ((@pair') _ 0%bool) _ 0%bool 0%bool : prod' bool bool. (* parentheses and @ are blocking implicit and scopes *) -Check c3 0 0 0 : prod' nat bool. (* First scope is blocked but not the last two scopes *) -Check fun A (x :prod' nat A) => match x with c3 0 y 0 => 2 | _ => 1 end. +Check c3 0 0 0 : prod' bool bool. +Check fun A (x :prod' bool A) => match x with c3 0 y 0 => 2 | _ => 1 end. (* 4. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) (* unless an atomic @ is given *) diff --git a/test-suite/success/Scopes.v b/test-suite/success/Scopes.v index 06697af901..8b7d239dcd 100644 --- a/test-suite/success/Scopes.v +++ b/test-suite/success/Scopes.v @@ -26,3 +26,15 @@ Definition c := ε : U. Goal True. assert (nat * nat). Abort. + +(* Check propagation of scopes in indirect applications to references *) + +Module PropagateIndirect. +Notation "0" := true : bool_scope. + +Axiom f : bool -> bool -> nat. +Check (@f 0) 0. + +Record R := { p : bool -> nat }. +Check fun r => r.(@p) 0. +End PropagateIndirect. diff --git a/test-suite/success/proof_using_noinit.v b/test-suite/success/proof_using_noinit.v new file mode 100644 index 0000000000..f99b49619c --- /dev/null +++ b/test-suite/success/proof_using_noinit.v @@ -0,0 +1,9 @@ +(* -*- coq-prog-args: ("-noinit"); -*- *) + +Section A. +Variable A : Prop. +Hypothesis a : A. +Lemma b : A. +Proof using a. +Admitted. +End A. diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v index 74d1e391c4..71c8f10755 100644 --- a/theories/Arith/Between.v +++ b/theories/Arith/Between.v @@ -24,6 +24,7 @@ Section Between. | bet_emp : between k k | bet_S : forall l, between k l -> P l -> between k (S l). + #[local] Hint Constructors between: arith. Lemma bet_eq : forall k l, l = k -> between k l. @@ -31,18 +32,21 @@ Section Between. intros * ->; auto with arith. Qed. + #[local] Hint Resolve bet_eq: arith. Lemma between_le : forall k l, between k l -> k <= l. Proof. induction 1; auto with arith. Qed. + #[local] Hint Immediate between_le: arith. Lemma between_Sk_l : forall k l, between k l -> S k <= l -> between (S k) l. Proof. induction 1 as [|* [|]]; auto with arith. Qed. + #[local] Hint Resolve between_Sk_l: arith. Lemma between_restr : @@ -57,6 +61,7 @@ Section Between. | exists_S : forall l, exists_between k l -> exists_between k (S l) | exists_le : forall l, k <= l -> Q l -> exists_between k (S l). + #[local] Hint Constructors exists_between: arith. Lemma exists_le_S : forall k l, exists_between k l -> S k <= l. @@ -66,12 +71,14 @@ Section Between. Lemma exists_lt : forall k l, exists_between k l -> k < l. Proof exists_le_S. + #[local] Hint Immediate exists_le_S exists_lt: arith. Lemma exists_S_le : forall k l, exists_between k (S l) -> k <= l. Proof. intros; apply le_S_n; auto with arith. Qed. + #[local] Hint Immediate exists_S_le: arith. Definition in_int p q r := p <= r /\ r < q. @@ -80,6 +87,7 @@ Section Between. Proof. split; assumption. Qed. + #[local] Hint Resolve in_int_intro: arith. Lemma in_int_lt : forall p q r, in_int p q r -> p < q. @@ -99,12 +107,14 @@ Section Between. Proof. intros * []; auto with arith. Qed. + #[local] Hint Resolve in_int_S: arith. Lemma in_int_Sp_q : forall p q r, in_int (S p) q r -> in_int p q r. Proof. intros * []; auto with arith. Qed. + #[local] Hint Immediate in_int_Sp_q: arith. Lemma between_in_int : @@ -188,6 +198,8 @@ Section Between. End Between. +#[global] Hint Resolve nth_O bet_S bet_emp bet_eq between_Sk_l exists_S exists_le in_int_S in_int_intro: arith. +#[global] Hint Immediate in_int_Sp_q exists_le_S exists_S_le: arith. diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index 2d34412908..c52edf9994 100644 --- a/theories/Arith/Div2.v +++ b/theories/Arith/Div2.v @@ -42,6 +42,7 @@ Qed. Lemma lt_div2 n : 0 < n -> div2 n < n. Proof. apply Nat.lt_div2. Qed. +#[global] Hint Resolve lt_div2: arith. (** Properties related to the parity *) @@ -73,6 +74,7 @@ Proof. symmetry in Ev'. elim (n_Sn _ Ev'). Qed. +#[global] Hint Resolve even_div2 div2_even odd_div2 div2_odd: arith. Lemma even_odd_div2 n : @@ -88,6 +90,7 @@ Qed. Notation double := Nat.double (only parsing). +#[global] Hint Unfold double Nat.double: arith. Lemma double_S n : double (S n) = S (S (double n)). @@ -100,6 +103,7 @@ Proof. apply Nat.add_shuffle1. Qed. +#[global] Hint Resolve double_S: arith. Lemma even_odd_double n : @@ -133,6 +137,7 @@ Proof proj1 (proj2 (even_odd_double n)). Lemma double_odd n : n = S (double (div2 n)) -> odd n. Proof proj2 (proj2 (even_odd_double n)). +#[global] Hint Resolve even_double double_even odd_double double_odd: arith. (** Application: diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v index 593d8c5934..66678b24f8 100644 --- a/theories/Arith/EqNat.v +++ b/theories/Arith/EqNat.v @@ -27,6 +27,7 @@ Theorem eq_nat_refl n : eq_nat n n. Proof. induction n; simpl; auto. Qed. +#[global] Hint Resolve eq_nat_refl: arith. (** [eq] restricted to [nat] and [eq_nat] are equivalent *) @@ -48,6 +49,7 @@ Proof. apply eq_nat_is_eq. Qed. +#[global] Hint Immediate eq_eq_nat eq_nat_eq: arith. Theorem eq_nat_elim : diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v index 3422596818..87d6a6ee64 100644 --- a/theories/Arith/Even.v +++ b/theories/Arith/Even.v @@ -31,7 +31,9 @@ Inductive even : nat -> Prop := with odd : nat -> Prop := odd_S : forall n, even n -> odd (S n). +#[global] Hint Constructors even: arith. +#[global] Hint Constructors odd: arith. (** * Equivalence with predicates [Nat.Even] and [Nat.odd] *) @@ -178,6 +180,7 @@ Proof. parity_binop. Qed. Lemma odd_mult_inv_r n m : odd (n * m) -> odd m. Proof. parity_binop. Qed. +#[global] Hint Resolve even_even_plus odd_even_plus odd_plus_l odd_plus_r even_mult_l even_mult_r even_mult_l even_mult_r odd_mult : arith. diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v index 05d585b9a2..492aeba66b 100644 --- a/theories/Arith/Gt.v +++ b/theories/Arith/Gt.v @@ -135,13 +135,21 @@ Qed. (** * Hints *) +#[global] Hint Resolve gt_Sn_O gt_Sn_n gt_n_S : arith. +#[global] Hint Immediate gt_S_n gt_pred : arith. +#[global] Hint Resolve gt_irrefl gt_asym : arith. +#[global] Hint Resolve le_not_gt gt_not_le : arith. +#[global] Hint Immediate le_S_gt gt_S_le : arith. +#[global] Hint Resolve gt_le_S le_gt_S : arith. +#[global] Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith. +#[global] Hint Resolve plus_gt_compat_l: arith. (* begin hide *) diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v index 4e71465452..3d176fb644 100644 --- a/theories/Arith/Le.v +++ b/theories/Arith/Le.v @@ -32,7 +32,9 @@ Notation le_refl := Nat.le_refl (only parsing). Notation le_trans := Nat.le_trans (only parsing). Notation le_antisym := Nat.le_antisymm (only parsing). +#[global] Hint Resolve le_trans: arith. +#[global] Hint Immediate le_antisym: arith. (** * Properties of [le] w.r.t 0 *) @@ -61,8 +63,11 @@ Notation le_Sn_n := Nat.nle_succ_diag_l (only parsing). (* ~ S n <= n *) Theorem le_Sn_le : forall n m, S n <= m -> n <= m. Proof Nat.lt_le_incl. +#[global] Hint Resolve le_0_n le_Sn_0: arith. +#[global] Hint Resolve le_n_S le_n_Sn le_Sn_n : arith. +#[global] Hint Immediate le_n_0_eq le_Sn_le le_S_n : arith. (** * Properties of [le] w.r.t predecessor *) @@ -70,6 +75,7 @@ Hint Immediate le_n_0_eq le_Sn_le le_S_n : arith. Notation le_pred_n := Nat.le_pred_l (only parsing). (* pred n <= n *) Notation le_pred := Nat.pred_le_mono (only parsing). (* n<=m -> pred n <= pred m *) +#[global] Hint Resolve le_pred_n: arith. (** * A different elimination principle for the order on natural numbers *) diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v index 60cc361e35..467420afb3 100644 --- a/theories/Arith/Lt.v +++ b/theories/Arith/Lt.v @@ -27,6 +27,7 @@ Local Open Scope nat_scope. Notation lt_irrefl := Nat.lt_irrefl (only parsing). (* ~ x < x *) +#[global] Hint Resolve lt_irrefl: arith. (** * Relationship between [le] and [lt] *) @@ -50,8 +51,11 @@ Qed. Register le_lt_n_Sm as num.nat.le_lt_n_Sm. +#[global] Hint Immediate lt_le_S: arith. +#[global] Hint Immediate lt_n_Sm_le: arith. +#[global] Hint Immediate le_lt_n_Sm: arith. Theorem le_not_lt n m : n <= m -> ~ m < n. @@ -64,6 +68,7 @@ Proof. apply Nat.lt_nge. Qed. +#[global] Hint Immediate le_not_lt lt_not_le: arith. (** * Asymmetry *) @@ -85,7 +90,9 @@ Proof. intros. now apply Nat.neq_sym, Nat.neq_0_lt_0. Qed. +#[global] Hint Resolve lt_0_Sn lt_n_0 : arith. +#[global] Hint Immediate neq_0_lt lt_0_neq: arith. (** * Order and successor *) @@ -105,7 +112,9 @@ Qed. Register lt_S_n as num.nat.lt_S_n. +#[global] Hint Resolve lt_n_Sn lt_S lt_n_S : arith. +#[global] Hint Immediate lt_S_n : arith. (** * Predecessor *) @@ -130,7 +139,9 @@ Proof. intros. now apply Nat.lt_pred_l, Nat.neq_0_lt_0. Qed. +#[global] Hint Immediate lt_pred: arith. +#[global] Hint Resolve lt_pred_n_n: arith. (** * Transitivity properties *) @@ -141,6 +152,7 @@ Notation le_lt_trans := Nat.le_lt_trans (only parsing). Register le_lt_trans as num.nat.le_lt_trans. +#[global] Hint Resolve lt_trans lt_le_trans le_lt_trans: arith. (** * Large = strict or equal *) @@ -154,6 +166,7 @@ Qed. Notation lt_le_weak := Nat.lt_le_incl (only parsing). +#[global] Hint Immediate lt_le_weak: arith. (** * Dichotomy *) diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v index 28fe51f9af..863b02ef2e 100644 --- a/theories/Arith/Max.v +++ b/theories/Arith/Max.v @@ -43,8 +43,10 @@ Notation max_case2 := max_case (only parsing). Notation max_SS := Nat.succ_max_distr (only parsing). (* end hide *) +#[global] Hint Resolve Nat.max_l Nat.max_r Nat.le_max_l Nat.le_max_r : arith. +#[global] Hint Resolve Nat.min_l Nat.min_r Nat.le_min_l Nat.le_min_r : arith. diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v index b8c7ac147a..6cbba63e1a 100644 --- a/theories/Arith/Minus.v +++ b/theories/Arith/Minus.v @@ -111,13 +111,23 @@ Qed. (** * Hints *) +#[global] Hint Resolve minus_n_O: arith. +#[global] Hint Resolve minus_Sn_m: arith. +#[global] Hint Resolve minus_diag_reverse: arith. +#[global] Hint Resolve minus_plus_simpl_l_reverse: arith. +#[global] Hint Immediate plus_minus: arith. +#[global] Hint Resolve minus_plus: arith. +#[global] Hint Resolve le_plus_minus: arith. +#[global] Hint Resolve le_plus_minus_r: arith. +#[global] Hint Resolve lt_minus: arith. +#[global] Hint Immediate lt_O_minus_lt: arith. diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v index d7f703e6e4..584b282f4d 100644 --- a/theories/Arith/Mult.v +++ b/theories/Arith/Mult.v @@ -33,12 +33,14 @@ Notation mult_0_r := Nat.mul_0_r (only parsing). (* n * 0 = 0 *) Notation mult_1_l := Nat.mul_1_l (only parsing). (* 1 * n = n *) Notation mult_1_r := Nat.mul_1_r (only parsing). (* n * 1 = n *) +#[global] Hint Resolve mult_1_l mult_1_r: arith. (** ** Commutativity *) Notation mult_comm := Nat.mul_comm (only parsing). (* n * m = m * n *) +#[global] Hint Resolve mult_comm: arith. (** ** Distributivity *) @@ -55,8 +57,11 @@ Notation mult_minus_distr_r := Notation mult_minus_distr_l := Nat.mul_sub_distr_l (only parsing). (* n*(m-p) = n*m - n*p *) +#[global] Hint Resolve mult_plus_distr_r: arith. +#[global] Hint Resolve mult_minus_distr_r: arith. +#[global] Hint Resolve mult_minus_distr_l: arith. (** ** Associativity *) @@ -68,7 +73,9 @@ Proof. symmetry. apply Nat.mul_assoc. Qed. +#[global] Hint Resolve mult_assoc_reverse: arith. +#[global] Hint Resolve mult_assoc: arith. (** ** Inversion lemmas *) @@ -94,12 +101,14 @@ Lemma mult_O_le n m : m = 0 \/ n <= m * n. Proof. destruct m; [left|right]; simpl; trivial using Nat.le_add_r. Qed. +#[global] Hint Resolve mult_O_le: arith. Lemma mult_le_compat_l n m p : n <= m -> p * n <= p * m. Proof. apply Nat.mul_le_mono_nonneg_l, Nat.le_0_l. (* TODO : get rid of 0<=n hyp *) Qed. +#[global] Hint Resolve mult_le_compat_l: arith. Lemma mult_le_compat_r n m p : n <= m -> n * p <= m * p. @@ -117,6 +126,7 @@ Proof. apply Nat.mul_lt_mono_pos_l, Nat.lt_0_succ. Qed. +#[global] Hint Resolve mult_S_lt_compat_l: arith. Lemma mult_lt_compat_l n m p : n < m -> 0 < p -> p * n < p * m. diff --git a/theories/Arith/PeanoNat.v b/theories/Arith/PeanoNat.v index 37704704a0..8d3b1b318a 100644 --- a/theories/Arith/PeanoNat.v +++ b/theories/Arith/PeanoNat.v @@ -765,7 +765,9 @@ Infix "?=" := Nat.compare (at level 70) : nat_scope. Infix "/" := Nat.div : nat_scope. Infix "mod" := Nat.modulo (at level 40, no associativity) : nat_scope. +#[global] Hint Unfold Nat.le : core. +#[global] Hint Unfold Nat.lt : core. Register Nat.le_trans as num.nat.le_trans. diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index 9a7a397023..2fc44ba592 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -23,6 +23,7 @@ Defined. Notation eq_nat_dec := Nat.eq_dec (only parsing). +#[global] Hint Resolve O_or_S eq_nat_dec: arith. Theorem dec_eq_nat n m : decidable (n = m). diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v index 5da7738adc..49e242276e 100644 --- a/theories/Arith/Plus.v +++ b/theories/Arith/Plus.v @@ -179,11 +179,17 @@ Proof (succ_plus_discr n 3). (** * Compatibility Hints *) +#[global] Hint Immediate plus_comm : arith. +#[global] Hint Resolve plus_assoc plus_assoc_reverse : arith. +#[global] Hint Resolve plus_le_compat_l plus_le_compat_r : arith. +#[global] Hint Resolve le_plus_l le_plus_r le_plus_trans : arith. +#[global] Hint Immediate lt_plus_trans : arith. +#[global] Hint Resolve plus_lt_compat_l plus_lt_compat_r : arith. (** For compatibility, we "Require" the same files as before *) diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index ebd909c1dc..a87eeba9b1 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -197,7 +197,9 @@ Proof. intros n H q; pattern q; apply lt_wf_ind; auto with arith. Qed. +#[global] Hint Resolve lt_wf: arith. +#[global] Hint Resolve well_founded_lt_compat: arith. Section LT_WF_REL. diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 0f62db42cf..8039c96efe 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -44,13 +44,16 @@ Lemma diff_true_false : true <> false. Proof. discriminate. Qed. +#[global] Hint Resolve diff_true_false : bool. Lemma diff_false_true : false <> true. Proof. discriminate. Qed. +#[global] Hint Resolve diff_false_true : bool. +#[global] Hint Extern 1 (false <> true) => exact diff_false_true : core. Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False. @@ -87,6 +90,7 @@ Qed. | true => b2 = true | false => True end. +#[global] Hint Unfold le: bool. Lemma le_implb : forall b1 b2, le b1 b2 <-> implb b1 b2 = true. @@ -104,6 +108,7 @@ Notation leb_implb := le_implb (only parsing). | true => False | false => b2 = true end. +#[global] Hint Unfold lt: bool. #[ local ] Definition compare (b1 b2 : bool) := @@ -271,6 +276,7 @@ Lemma orb_true_intro : Proof. intros; apply orb_true_iff; trivial. Qed. +#[global] Hint Resolve orb_true_intro: bool. Lemma orb_false_intro : @@ -278,6 +284,7 @@ Lemma orb_false_intro : Proof. intros. subst. reflexivity. Qed. +#[global] Hint Resolve orb_false_intro: bool. Lemma orb_false_elim : @@ -297,6 +304,7 @@ Lemma orb_true_r : forall b:bool, b || true = true. Proof. destr_bool. Qed. +#[global] Hint Resolve orb_true_r: bool. Lemma orb_true_l : forall b:bool, true || b = true. @@ -313,12 +321,14 @@ Lemma orb_false_r : forall b:bool, b || false = b. Proof. destr_bool. Qed. +#[global] Hint Resolve orb_false_r: bool. Lemma orb_false_l : forall b:bool, false || b = b. Proof. destr_bool. Qed. +#[global] Hint Resolve orb_false_l: bool. Notation orb_b_false := orb_false_r (only parsing). @@ -330,6 +340,7 @@ Lemma orb_negb_r : forall b:bool, b || negb b = true. Proof. destr_bool. Qed. +#[global] Hint Resolve orb_negb_r: bool. Lemma orb_negb_l : forall b:bool, negb b || b = true. @@ -352,6 +363,7 @@ Lemma orb_assoc : forall b1 b2 b3:bool, b1 || (b2 || b3) = b1 || b2 || b3. Proof. destr_bool. Qed. +#[global] Hint Resolve orb_comm orb_assoc: bool. (***************************) @@ -426,6 +438,7 @@ Lemma andb_false_elim : Proof. intro b1; destruct b1; simpl; auto. Defined. +#[global] Hint Resolve andb_false_elim: bool. (** Complementation *) @@ -434,6 +447,7 @@ Lemma andb_negb_r : forall b:bool, b && negb b = false. Proof. destr_bool. Qed. +#[global] Hint Resolve andb_negb_r: bool. Lemma andb_negb_l : forall b:bool, negb b && b = false. @@ -457,6 +471,7 @@ Proof. destr_bool. Qed. +#[global] Hint Resolve andb_comm andb_assoc: bool. (*****************************************) @@ -722,6 +737,7 @@ Qed. Notation bool_6 := eq_true_not_negb (only parsing). (* Compatibility *) +#[global] Hint Resolve eq_true_not_negb : bool. (* An interesting lemma for auto but too strong to keep compatibility *) @@ -737,6 +753,7 @@ Lemma absurd_eq_true : forall b, False -> b = true. Proof. contradiction. Qed. +#[global] Hint Resolve absurd_eq_true : core. (* A specific instance of eq_trans that preserves compatibility with @@ -746,6 +763,7 @@ Lemma trans_eq_bool : forall x y z:bool, x = y -> y = z -> x = z. Proof. apply eq_trans. Qed. +#[global] Hint Resolve trans_eq_bool : core. (***************************************) @@ -754,6 +772,7 @@ Hint Resolve trans_eq_bool : core. (** [Is_true] and equality *) +#[global] Hint Unfold Is_true: bool. Lemma Is_true_eq_true : forall x:bool, Is_true x -> x = true. @@ -773,6 +792,7 @@ Qed. Notation Is_true_eq_true2 := Is_true_eq_right (only parsing). +#[global] Hint Immediate Is_true_eq_right Is_true_eq_left: bool. Lemma eqb_refl : forall x:bool, Is_true (eqb x x). @@ -806,6 +826,7 @@ Lemma andb_prop_intro : Proof. destr_bool; tauto. Qed. +#[global] Hint Resolve andb_prop_intro: bool. Notation andb_true_intro2 := @@ -817,6 +838,7 @@ Lemma andb_prop_elim : Proof. destr_bool; auto. Qed. +#[global] Hint Resolve andb_prop_elim: bool. Notation andb_prop2 := andb_prop_elim (only parsing). @@ -901,6 +923,7 @@ Qed. Inductive reflect (P : Prop) : bool -> Set := | ReflectT : P -> reflect P true | ReflectF : ~ P -> reflect P false. +#[global] Hint Constructors reflect : bool. (** Interest: a case on a reflect lemma or hyp performs clever diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v index 1a41eb6bb5..7e9087c377 100644 --- a/theories/Bool/IfProp.v +++ b/theories/Bool/IfProp.v @@ -14,6 +14,7 @@ Inductive IfProp (A B:Prop) : bool -> Prop := | Iftrue : A -> IfProp A B true | Iffalse : B -> IfProp A B false. +#[global] Hint Resolve Iftrue Iffalse: bool. Lemma Iftrue_inv : forall (A B:Prop) (b:bool), IfProp A B b -> b = true -> A. diff --git a/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v index 52605a4667..49feda15ea 100644 --- a/theories/Bool/Sumbool.v +++ b/theories/Bool/Sumbool.v @@ -19,6 +19,7 @@ Definition sumbool_of_bool : forall b:bool, {b = true} + {b = false}. intros b; destruct b; auto. Defined. +#[global] Hint Resolve sumbool_of_bool: bool. Definition bool_eq_rec : @@ -57,7 +58,9 @@ Section connectives. End connectives. +#[global] Hint Resolve sumbool_and sumbool_or: core. +#[global] Hint Immediate sumbool_not : core. (** Any decidability function in type [sumbool] can be turned into a function diff --git a/theories/Bool/Zerob.v b/theories/Bool/Zerob.v index 3665a8c78d..aff5008410 100644 --- a/theories/Bool/Zerob.v +++ b/theories/Bool/Zerob.v @@ -23,6 +23,7 @@ Lemma zerob_true_intro : forall n:nat, n = 0 -> zerob n = true. Proof. destruct n; [ trivial with bool | inversion 1 ]. Qed. +#[global] Hint Resolve zerob_true_intro: bool. Lemma zerob_true_elim : forall n:nat, zerob n = true -> n = 0. @@ -34,6 +35,7 @@ Lemma zerob_false_intro : forall n:nat, n <> 0 -> zerob n = false. Proof. destruct n; [ destruct 1; auto with bool | trivial with bool ]. Qed. +#[global] Hint Resolve zerob_false_intro: bool. Lemma zerob_false_elim : forall n:nat, zerob n = false -> n <> 0. diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index 9a3a1d3709..9ff18ebe2c 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -1,4 +1,4 @@ -(* -*- coding: utf-8; coq-prog-args: ("-coqlib" "../.." "-R" ".." "Coq" "-top" "Coq.Classes.CMorphisms") -*- *) +(* -*- coding: utf-8; coq-prog-args: ("-top" "Coq.Classes.CMorphisms") -*- *) (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) (* v * Copyright INRIA, CNRS and contributors *) @@ -80,9 +80,11 @@ End Proper. (** We favor the use of Leibniz equality or a declared reflexive crelation when resolving [ProperProxy], otherwise, if the crelation is given (not an evar), we fall back to [Proper]. *) +#[global] Hint Extern 1 (ProperProxy _ _) => class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances. +#[global] Hint Extern 2 (ProperProxy ?R _) => not_evar R; class_apply @proper_proper_proxy : typeclass_instances. @@ -215,8 +217,11 @@ Typeclasses Opaque respectful pointwise_relation forall_relation. Arguments forall_relation {A P}%type sig%signature _ _. Arguments pointwise_relation A%type {B}%type R%signature _ _. +#[global] Hint Unfold Reflexive : core. +#[global] Hint Unfold Symmetric : core. +#[global] Hint Unfold Transitive : core. (** Resolution with subrelation: favor decomposing products over applying reflexivity @@ -225,6 +230,7 @@ Ltac subrelation_tac T U := (is_ground T ; is_ground U ; class_apply @subrelation_refl) || class_apply @subrelation_respectful || class_apply @subrelation_refl. +#[global] Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances. CoInductive apply_subrelation : Prop := do_subrelation. @@ -234,6 +240,7 @@ Ltac proper_subrelation := [ H : apply_subrelation |- _ ] => clear H ; class_apply @subrelation_proper end. +#[global] Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances. (** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *) @@ -254,6 +261,7 @@ Proof. firstorder. Qed. (** We use an extern hint to help unification. *) +#[global] Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) => apply (@forall_subrelation A B R S) ; intro : typeclass_instances. @@ -308,7 +316,7 @@ Section GenericInstances. Global Program Instance trans_contra_inv_impl_type_morphism - `(Transitive A R) : Proper (R --> flip arrow) (R x) | 3. + `(Transitive A R) {x} : Proper (R --> flip arrow) (R x) | 3. Next Obligation. Proof with auto. @@ -318,7 +326,7 @@ Section GenericInstances. Global Program Instance trans_co_impl_type_morphism - `(Transitive A R) : Proper (R ++> arrow) (R x) | 3. + `(Transitive A R) {x} : Proper (R ++> arrow) (R x) | 3. Next Obligation. Proof with auto. @@ -328,7 +336,7 @@ Section GenericInstances. Global Program Instance trans_sym_co_inv_impl_type_morphism - `(PER A R) : Proper (R ++> flip arrow) (R x) | 3. + `(PER A R) {x} : Proper (R ++> flip arrow) (R x) | 3. Next Obligation. Proof with auto. @@ -337,7 +345,7 @@ Section GenericInstances. Qed. Global Program Instance trans_sym_contra_arrow_morphism - `(PER A R) : Proper (R --> arrow) (R x) | 3. + `(PER A R) {x} : Proper (R --> arrow) (R x) | 3. Next Obligation. Proof with auto. @@ -346,7 +354,7 @@ Section GenericInstances. Qed. Global Program Instance per_partial_app_type_morphism - `(PER A R) : Proper (R ==> iffT) (R x) | 2. + `(PER A R) {x} : Proper (R ==> iffT) (R x) | 2. Next Obligation. Proof with auto. @@ -399,17 +407,17 @@ Section GenericInstances. (** Coq functions are morphisms for Leibniz equality, applied only if really needed. *) - Global Instance reflexive_eq_dom_reflexive `(Reflexive B R') : + Global Instance reflexive_eq_dom_reflexive `(Reflexive B R') {A} : Reflexive (@Logic.eq A ==> R'). Proof. simpl_crelation. Qed. (** [respectful] is a morphism for crelation equivalence . *) - Global Instance respectful_morphism : + Global Instance respectful_morphism {A B} : Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) (@respectful A B). Proof. - intros A B R R' HRR' S S' HSS' f g. + intros R R' HRR' S S' HSS' f g. unfold respectful , relation_equivalence in *; simpl in *. split ; intros H x y Hxy. - apply (fst (HSS' _ _)). apply H. now apply (snd (HRR' _ _)). @@ -511,9 +519,9 @@ Ltac partial_application_tactic := (** Bootstrap !!! *) -Instance proper_proper : Proper (relation_equivalence ==> eq ==> iffT) (@Proper A). +Instance proper_proper {A} : Proper (relation_equivalence ==> eq ==> iffT) (@Proper A). Proof. - intros A R R' HRR' x y <-. red in HRR'. + intros R R' HRR' x y <-. red in HRR'. split ; red ; intros. - now apply (fst (HRR' _ _)). - now apply (snd (HRR' _ _)). @@ -526,17 +534,23 @@ Ltac proper_reflexive := end. +#[global] Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances. +#[global] Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances. (* Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper *) (* : typeclass_instances. *) +#[global] Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper : typeclass_instances. +#[global] Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper : typeclass_instances. +#[global] Hint Extern 4 (@Proper _ _ _) => partial_application_tactic : typeclass_instances. +#[global] Hint Extern 7 (@Proper _ _ _) => proper_reflexive : typeclass_instances. @@ -586,7 +600,9 @@ Ltac proper_normalization := set(H:=did_normalization) ; class_apply @proper_normalizes_proper end. +#[global] Hint Extern 1 (Normalizes _ _ _) => normalizes : typeclass_instances. +#[global] Hint Extern 6 (@Proper _ _ _) => proper_normalization : typeclass_instances. @@ -690,6 +706,7 @@ split. + right. transitivity y; auto. Qed. +#[global] Hint Extern 4 (PreOrder (relation_disjunction _ _)) => class_apply StrictOrder_PreOrder : typeclass_instances. @@ -702,8 +719,10 @@ elim (StrictOrder_Irreflexive x). transitivity y; auto. Qed. +#[global] Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => class_apply PartialOrder_StrictOrder : typeclass_instances. +#[global] Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) => class_apply StrictOrder_PartialOrder : typeclass_instances. diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v index 72a196ca7a..236d35b68e 100644 --- a/theories/Classes/CRelationClasses.v +++ b/theories/Classes/CRelationClasses.v @@ -203,22 +203,35 @@ Defined. (** Hints to drive the typeclass resolution avoiding loops due to the use of full unification. *) +#[global] Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances. +#[global] Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. +#[global] Hint Extern 3 (Irreflexive (complement _)) => class_apply complement_Irreflexive : typeclass_instances. +#[global] Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. +#[global] Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. +#[global] Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. +#[global] Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. +#[global] Hint Extern 3 (Antisymmetric (flip _)) => class_apply flip_Antisymmetric : typeclass_instances. +#[global] Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. +#[global] Hint Extern 3 (StrictOrder (flip _)) => class_apply flip_StrictOrder : typeclass_instances. +#[global] Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_instances. +#[global] Hint Extern 4 (subrelation (flip _) _) => class_apply @subrelation_symmetric : typeclass_instances. +#[global] Hint Resolve irreflexivity : ord. Unset Implicit Arguments. @@ -231,6 +244,7 @@ Ltac solve_crelation := | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H end. +#[global] Hint Extern 4 => solve_crelation : crelations. (** We can already dualize all these properties. *) @@ -351,6 +365,7 @@ Section Binary. Qed. End Binary. +#[global] Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances. (** The partial order defined by subrelation and crelation equivalence. *) diff --git a/theories/Classes/DecidableClass.v b/theories/Classes/DecidableClass.v index 94fcd55aa5..7169aa673d 100644 --- a/theories/Classes/DecidableClass.v +++ b/theories/Classes/DecidableClass.v @@ -65,6 +65,16 @@ Tactic Notation "decide" constr(P) := Require Import Bool Arith ZArith. +Program Instance Decidable_not {P} `{Decidable P} : Decidable (~ P) := { + Decidable_witness := negb Decidable_witness +}. +Next Obligation. + split; intro Heq. + - apply negb_true_iff in Heq. + eapply Decidable_complete_alt; intuition. + - erewrite Decidable_sound_alt; intuition. +Qed. + Program Instance Decidable_eq_bool : forall (x y : bool), Decidable (eq x y) := { Decidable_witness := Bool.eqb x y }. diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v index 394f5dc4de..9ca465bbfd 100644 --- a/theories/Classes/Init.v +++ b/theories/Classes/Init.v @@ -36,4 +36,5 @@ Ltac unconvertible := | |- _ => exact tt end. +#[global] Hint Extern 0 (@Unconvertible _ _ _) => unconvertible : typeclass_instances. diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index c70e3fe478..87abc4a08f 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -1,4 +1,4 @@ -(* -*- coding: utf-8; coq-prog-args: ("-coqlib" "../.." "-R" ".." "Coq" "-top" "Coq.Classes.Morphisms") -*- *) +(* -*- coding: utf-8; coq-prog-args: ("-top" "Coq.Classes.Morphisms") -*- *) (************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) (* v * Copyright INRIA, CNRS and contributors *) @@ -81,9 +81,11 @@ End Proper. (** We favor the use of Leibniz equality or a declared reflexive relation when resolving [ProperProxy], otherwise, if the relation is given (not an evar), we fall back to [Proper]. *) +#[global] Hint Extern 1 (ProperProxy _ _) => class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances. +#[global] Hint Extern 2 (ProperProxy ?R _) => not_evar R; class_apply @proper_proper_proxy : typeclass_instances. @@ -213,8 +215,11 @@ Typeclasses Opaque respectful pointwise_relation forall_relation. Arguments forall_relation {A P}%type sig%signature _ _. Arguments pointwise_relation A%type {B}%type R%signature _ _. +#[global] Hint Unfold Reflexive : core. +#[global] Hint Unfold Symmetric : core. +#[global] Hint Unfold Transitive : core. (** Resolution with subrelation: favor decomposing products over applying reflexivity @@ -223,6 +228,7 @@ Ltac subrelation_tac T U := (is_ground T ; is_ground U ; class_apply @subrelation_refl) || class_apply @subrelation_respectful || class_apply @subrelation_refl. +#[global] Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances. CoInductive apply_subrelation : Prop := do_subrelation. @@ -232,6 +238,7 @@ Ltac proper_subrelation := [ H : apply_subrelation |- _ ] => clear H ; class_apply @subrelation_proper end. +#[global] Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances. (** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *) @@ -244,6 +251,7 @@ Proof. firstorder. Qed. (** We use an extern hint to help unification. *) +#[global] Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) => apply (@forall_subrelation A B R S) ; intro : typeclass_instances. @@ -309,7 +317,7 @@ Section GenericInstances. Global Program Instance trans_contra_inv_impl_morphism - `(Transitive A R) : Proper (R --> flip impl) (R x) | 3. + `(Transitive A R) {x} : Proper (R --> flip impl) (R x) | 3. Next Obligation. Proof with auto. @@ -319,7 +327,7 @@ Section GenericInstances. Global Program Instance trans_co_impl_morphism - `(Transitive A R) : Proper (R ++> impl) (R x) | 3. + `(Transitive A R) {x} : Proper (R ++> impl) (R x) | 3. Next Obligation. Proof with auto. @@ -329,7 +337,7 @@ Section GenericInstances. Global Program Instance trans_sym_co_inv_impl_morphism - `(PER A R) : Proper (R ++> flip impl) (R x) | 3. + `(PER A R) {x} : Proper (R ++> flip impl) (R x) | 3. Next Obligation. Proof with auto. @@ -338,7 +346,7 @@ Section GenericInstances. Qed. Global Program Instance trans_sym_contra_impl_morphism - `(PER A R) : Proper (R --> impl) (R x) | 3. + `(PER A R) {x} : Proper (R --> impl) (R x) | 3. Next Obligation. Proof with auto. @@ -347,7 +355,7 @@ Section GenericInstances. Qed. Global Program Instance per_partial_app_morphism - `(PER A R) : Proper (R ==> iff) (R x) | 2. + `(PER A R) {x} : Proper (R ==> iff) (R x) | 2. Next Obligation. Proof with auto. @@ -520,9 +528,9 @@ Ltac partial_application_tactic := (** Bootstrap !!! *) -Instance proper_proper : Proper (relation_equivalence ==> eq ==> iff) (@Proper A). +Instance proper_proper {A} : Proper (relation_equivalence ==> eq ==> iff) (@Proper A). Proof. - intros A x y H y0 y1 e; destruct e. + intros x y H y0 y1 e; destruct e. reduce in H. split ; red ; intros H0. - setoid_rewrite <- H. @@ -538,17 +546,24 @@ Ltac proper_reflexive := end. +#[global] Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances. +#[global] Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances. +#[global] Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper : typeclass_instances. +#[global] Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper : typeclass_instances. +#[global] Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper : typeclass_instances. +#[global] Hint Extern 4 (@Proper _ _ _) => partial_application_tactic : typeclass_instances. +#[global] Hint Extern 7 (@Proper _ _ _) => proper_reflexive : typeclass_instances. @@ -603,7 +618,9 @@ Ltac proper_normalization := set(H:=did_normalization) ; class_apply @proper_normalizes_proper end. +#[global] Hint Extern 1 (Normalizes _ _ _) => normalizes : typeclass_instances. +#[global] Hint Extern 6 (@Proper _ _ _) => proper_normalization : typeclass_instances. @@ -693,6 +710,7 @@ split. + right. transitivity y; auto. Qed. +#[global] Hint Extern 4 (PreOrder (relation_disjunction _ _)) => class_apply StrictOrder_PreOrder : typeclass_instances. @@ -705,8 +723,10 @@ elim (StrictOrder_Irreflexive x). transitivity y; auto. Qed. +#[global] Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => class_apply PartialOrder_StrictOrder : typeclass_instances. +#[global] Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) => class_apply StrictOrder_PartialOrder : typeclass_instances. diff --git a/theories/Classes/Morphisms_Relations.v b/theories/Classes/Morphisms_Relations.v index a168a8e7cd..964786d8e6 100644 --- a/theories/Classes/Morphisms_Relations.v +++ b/theories/Classes/Morphisms_Relations.v @@ -22,11 +22,11 @@ Generalizable Variables A l. (** Morphisms for relations *) -Instance relation_conjunction_morphism : Proper (relation_equivalence (A:=A) ==> +Instance relation_conjunction_morphism {A} : Proper (relation_equivalence (A:=A) ==> relation_equivalence ==> relation_equivalence) relation_conjunction. Proof. firstorder. Qed. -Instance relation_disjunction_morphism : Proper (relation_equivalence (A:=A) ==> +Instance relation_disjunction_morphism {A} : Proper (relation_equivalence (A:=A) ==> relation_equivalence ==> relation_equivalence) relation_disjunction. Proof. firstorder. Qed. @@ -43,11 +43,11 @@ Proof. do 2 red. unfold predicate_implication. auto. Qed. (** The instantiation at relation allows rewriting applications of relations [R x y] to [R' x y] when [R] and [R'] are in [relation_equivalence]. *) -Instance relation_equivalence_pointwise : +Instance relation_equivalence_pointwise {A} : Proper (relation_equivalence ==> pointwise_relation A (pointwise_relation A iff)) id. Proof. intro. apply (predicate_equivalence_pointwise (Tcons A (Tcons A Tnil))). Qed. -Instance subrelation_pointwise : +Instance subrelation_pointwise {A} : Proper (subrelation ==> pointwise_relation A (pointwise_relation A impl)) id. Proof. intro. apply (predicate_implication_pointwise (Tcons A (Tcons A Tnil))). Qed. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 5381e91997..54ee06343a 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -196,19 +196,31 @@ Defined. (** Hints to drive the typeclass resolution avoiding loops due to the use of full unification. *) +#[global] Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances. +#[global] Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. +#[global] Hint Extern 3 (Irreflexive (complement _)) => class_apply complement_Irreflexive : typeclass_instances. +#[global] Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. +#[global] Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. +#[global] Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. +#[global] Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. +#[global] Hint Extern 3 (Antisymmetric (flip _)) => class_apply flip_Antisymmetric : typeclass_instances. +#[global] Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. +#[global] Hint Extern 3 (StrictOrder (flip _)) => class_apply flip_StrictOrder : typeclass_instances. +#[global] Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_instances. +#[global] Hint Extern 4 (subrelation (flip _) _) => class_apply @subrelation_symmetric : typeclass_instances. @@ -218,6 +230,7 @@ Arguments asymmetry {A} {R} {_} [x] [y] _ _. Arguments transitivity {A} {R} {_} [x] [y] [z] _ _. Arguments Antisymmetric A eqA {_} _. +#[global] Hint Resolve irreflexivity : ord. Unset Implicit Arguments. @@ -230,6 +243,7 @@ Ltac solve_relation := | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H end. +#[global] Hint Extern 4 => solve_relation : relations. (** We can already dualize all these properties. *) @@ -395,7 +409,7 @@ Notation "∙⊥∙" := false_predicate : predicate_scope. (** Predicate equivalence is an equivalence, and predicate implication defines a preorder. *) -Program Instance predicate_equivalence_equivalence : +Program Instance predicate_equivalence_equivalence {l} : Equivalence (@predicate_equivalence l). Next Obligation. @@ -413,7 +427,7 @@ Program Instance predicate_equivalence_equivalence : firstorder. Qed. -Program Instance predicate_implication_preorder : +Program Instance predicate_implication_preorder {l} : PreOrder (@predicate_implication l). Next Obligation. intro l; induction l ; firstorder. @@ -476,11 +490,12 @@ Section Binary. Proof. firstorder. Qed. End Binary. +#[global] Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances. (** The partial order defined by subrelation and relation equivalence. *) -Program Instance subrelation_partial_order : +Program Instance subrelation_partial_order {A} : PartialOrder (@relation_equivalence A) subrelation. Next Obligation. diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v index b4034b9cf9..87e66a25dd 100644 --- a/theories/Classes/RelationPairs.v +++ b/theories/Classes/RelationPairs.v @@ -61,11 +61,9 @@ Class Measure {A B} (f : A -> B). (** Standard measures. *) -Instance fst_measure : @Measure (A * B) A Fst. -Defined. +Instance fst_measure {A B} : @Measure (A * B) A Fst := {}. -Instance snd_measure : @Measure (A * B) B Snd. -Defined. +Instance snd_measure {A B} : @Measure (A * B) B Snd := {}. (** We define a product relation over [A*B]: each components should satisfy the corresponding initial relation. *) @@ -96,11 +94,11 @@ Section RelCompFun_Instances. `(Measure A B f, Irreflexive _ R) : Irreflexive (R@@f). Proof. firstorder. Qed. - Global Program Instance RelCompFun_Equivalence - `(Measure A B f, Equivalence _ R) : Equivalence (R@@f). + Global Instance RelCompFun_Equivalence + `(Measure A B f, Equivalence _ R) : Equivalence (R@@f) := {}. - Global Program Instance RelCompFun_StrictOrder - `(Measure A B f, StrictOrder _ R) : StrictOrder (R@@f). + Global Instance RelCompFun_StrictOrder + `(Measure A B f, StrictOrder _ R) : StrictOrder (R@@f) := {}. End RelCompFun_Instances. @@ -160,6 +158,8 @@ Section RelProd_Instances. Proof. unfold RelCompFun; firstorder. Qed. End RelProd_Instances. +#[global] Hint Unfold RelProd RelCompFun : core. +#[global] Hint Extern 2 (RelProd _ _ _ _) => split : core. diff --git a/theories/Compat/Coq812.v b/theories/Compat/Coq812.v index f52b559f84..992b00e834 100644 --- a/theories/Compat/Coq812.v +++ b/theories/Compat/Coq812.v @@ -11,4 +11,6 @@ (** Compatibility file for making Coq act similar to Coq v8.12 *) Require Export Coq.Compat.Coq813. +Local Set Warnings "-deprecated". Set Firstorder Solver auto with *. +Export Set Instance Generalized Output. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index ad0124db6d..bfa50d7fae 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -41,6 +41,7 @@ Local Open Scope Int_scope. Local Notation int := I.t. Definition key := X.t. +#[global] Hint Transparent key : core. (** * Trees *) @@ -495,7 +496,9 @@ Functional Scheme map2_opt_ind := Induction for map2_opt Sort Prop. (** * Automation and dedicated tactics. *) +#[global] Hint Constructors tree MapsTo In bst : core. +#[global] Hint Unfold lt_tree gt_tree : core. Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) @@ -576,6 +579,7 @@ Lemma MapsTo_In : forall k e m, MapsTo k e m -> In k m. Proof. induction 1; auto. Qed. +#[local] Hint Resolve MapsTo_In : core. Lemma In_MapsTo : forall k m, In k m -> exists e, MapsTo k e m. @@ -595,6 +599,7 @@ Lemma MapsTo_1 : Proof. induction m; simpl; intuition_in; eauto with ordered_type. Qed. +#[local] Hint Immediate MapsTo_1 : core. Lemma In_1 : @@ -634,6 +639,7 @@ Proof. unfold gt_tree in *; intuition_in; order. Qed. +#[local] Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. Lemma lt_left : forall x y l r e h, @@ -660,6 +666,7 @@ Proof. intuition_in. Qed. +#[local] Hint Resolve lt_left lt_right gt_left gt_right : core. Lemma lt_tree_not_in : @@ -686,6 +693,7 @@ Proof. eauto with ordered_type. Qed. +#[local] Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. (** * Empty map *) @@ -818,6 +826,7 @@ Lemma create_bst : Proof. unfold create; auto. Qed. +#[local] Hint Resolve create_bst : core. Lemma create_in : @@ -835,6 +844,7 @@ Proof. (apply lt_tree_node || apply gt_tree_node); auto with ordered_type; (eapply lt_tree_trans || eapply gt_tree_trans); eauto with ordered_type. Qed. +#[local] Hint Resolve bal_bst : core. Lemma bal_in : forall l x e r y, @@ -876,6 +886,7 @@ Proof. apply MX.eq_lt with x; auto. apply MX.lt_eq with x; auto with ordered_type. Qed. +#[local] Hint Resolve add_bst : core. Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). @@ -956,6 +967,7 @@ Proof. destruct 1. apply H2; intuition. Qed. +#[local] Hint Resolve remove_min_bst : core. Lemma remove_min_gt_tree : forall l x e r h, @@ -975,6 +987,7 @@ Proof. assert (X.lt m#1 x) by order. decompose [or] H; order. Qed. +#[local] Hint Resolve remove_min_gt_tree : core. Lemma remove_min_find : forall l x e r h y, @@ -1127,6 +1140,7 @@ Proof. intuition; [ apply MX.lt_eq with x | ]; eauto with ordered_type. intuition; [ apply MX.eq_lt with x | ]; eauto with ordered_type. Qed. +#[local] Hint Resolve join_bst : core. Lemma join_find : forall l x d r y, @@ -1263,6 +1277,7 @@ Proof. rewrite remove_min_in, e1; simpl; auto with ordered_type. change (gt_tree (m2',xd)#2#1 (m2',xd)#1). rewrite <-e1; eauto. Qed. +#[local] Hint Resolve concat_bst : core. Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> @@ -1351,6 +1366,7 @@ Proof. intros; unfold elements; apply elements_aux_sort; auto. intros; inversion H0. Qed. +#[local] Hint Resolve elements_sort : core. Lemma elements_nodup : forall s : t elt, bst s -> NoDupA eqk (elements s). @@ -1620,6 +1636,7 @@ destruct (map_option_2 H) as (d0 & ? & ?). destruct (map_option_2 H') as (d0' & ? & ?). eapply X.lt_trans with x; eauto using MapsTo_In. Qed. +#[local] Hint Resolve map_option_bst : core. Ltac nonify e := @@ -1719,6 +1736,7 @@ apply X.lt_trans with x1. destruct (map2_opt_2 H1 H6 Hy); intuition. destruct (map2_opt_2 H2 H7 Hy'); intuition. Qed. +#[local] Hint Resolve map2_opt_bst : core. Ltac map2_aux := @@ -2075,6 +2093,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Proof. destruct c; simpl; intros; P.MX.elim_comp; auto with ordered_type. Qed. + #[global] Hint Resolve cons_Cmp : core. Lemma compare_end_Cmp : diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 2001201ec3..bb52166ca7 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -20,6 +20,7 @@ Require Export FMapInterface. Set Implicit Arguments. Unset Strict Implicit. +#[global] Hint Extern 1 (Equivalence _) => constructor; congruence : core. (** * Facts about weak maps *) @@ -371,6 +372,7 @@ Proof. intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff. apply add_neq_mapsto_iff; auto. Qed. +#[local] Hint Resolve add_neq_o : map. Lemma add_o : forall m x y e, @@ -404,6 +406,7 @@ Proof. intros. rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff, remove_mapsto_iff; now intuition. Qed. +#[local] Hint Resolve remove_eq_o : map. Lemma remove_neq_o : forall m x y, @@ -412,6 +415,7 @@ Proof. intros. rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff, remove_neq_mapsto_iff; now intuition. Qed. +#[local] Hint Resolve remove_neq_o : map. Lemma remove_o : forall m x y, @@ -1100,6 +1104,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). contradict Hnotin; rewrite <- Hnotin; exists e0; auto. Qed. + #[local] Hint Resolve NoDupA_eqk_eqke NoDupA_rev elements_3w : map. Lemma fold_Equal : forall m1 m2 i, Equal m1 m2 -> @@ -1232,6 +1237,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Proof. intros; rewrite cardinal_Empty; auto. Qed. + #[local] Hint Resolve cardinal_inv_1 : map. Lemma cardinal_inv_2 : @@ -1846,6 +1852,7 @@ Module OrdProperties (M:S). unfold leb; f_equal; apply gtb_compat; auto. Qed. + #[local] Hint Resolve gtb_compat leb_compat elements_3 : map. Lemma elements_split : forall p m, diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 03e8d270e9..d26510ab9d 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -63,6 +63,7 @@ Inductive avl : t elt -> Prop := (** * Automation and dedicated tactics about [avl]. *) +#[local] Hint Constructors avl : core. Lemma height_non_negative : forall (s : t elt), avl s -> @@ -100,6 +101,7 @@ Lemma avl_node : forall x e l r, avl l -> avl r -> Proof. intros; auto. Qed. +#[local] Hint Resolve avl_node : core. (** Results about [height] *) @@ -193,6 +195,7 @@ Lemma add_avl : forall m x e, avl m -> avl (add x e m). Proof. intros; generalize (add_avl_1 x e H); intuition. Qed. +#[local] Hint Resolve add_avl : core. (** * Extraction of minimum binding *) @@ -274,6 +277,7 @@ Lemma remove_avl : forall m x, avl m -> avl (remove x m). Proof. intros; generalize (remove_avl_1 x H); intuition. Qed. +#[local] Hint Resolve remove_avl : core. @@ -331,6 +335,7 @@ Lemma join_avl : forall l x d r, avl l -> avl r -> avl (join l x d r). Proof. intros; destruct (join_avl_1 x d H H0); auto. Qed. +#[local] Hint Resolve join_avl : core. (** concat *) @@ -341,6 +346,7 @@ Proof. intros; apply join_avl; auto. generalize (remove_min_avl H0); rewrite e1; simpl; auto. Qed. +#[local] Hint Resolve concat_avl : core. (** split *) @@ -355,6 +361,7 @@ Proof. Qed. End Elt. +#[global] Hint Constructors avl : core. Section Map. @@ -714,6 +721,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Proof. destruct c; simpl; intros; MX.elim_comp; auto with ordered_type. Qed. + #[global] Hint Resolve cons_Cmp : core. Lemma compare_aux_Cmp : forall e, diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v index ab87ba9722..77ce76721e 100644 --- a/theories/FSets/FMapInterface.v +++ b/theories/FSets/FMapInterface.v @@ -58,6 +58,7 @@ Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. Module Type WSfun (E : DecidableType). Definition key := E.t. + #[global] Hint Transparent key : core. Parameter t : Type -> Type. @@ -243,9 +244,11 @@ Module Type WSfun (E : DecidableType). (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. + #[global] Hint Immediate MapsTo_1 mem_2 is_empty_2 map_2 mapi_2 add_3 remove_3 find_2 : map. + #[global] Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1 remove_2 find_1 fold_1 map_1 mapi_1 mapi_2 : map. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index a5c00189c4..204e8d0199 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -51,6 +51,7 @@ Proof. intro abs. inversion abs. Qed. +#[local] Hint Resolve empty_1 : core. Lemma empty_sorted : Sort empty. @@ -216,6 +217,7 @@ Proof. compute in H0,H1. simpl; case (X.compare x x''); intuition. Qed. +#[local] Hint Resolve add_Inf : core. Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). @@ -302,6 +304,7 @@ Proof. inversion_clear Hm. apply Inf_lt with (x'',e''); auto. Qed. +#[local] Hint Resolve remove_Inf : core. Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). @@ -586,6 +589,7 @@ Proof. inversion_clear H; auto. Qed. +#[local] Hint Resolve map_lelistA : core. Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), @@ -655,6 +659,7 @@ Proof. inversion_clear H; auto. Qed. +#[local] Hint Resolve mapi_lelistA : core. Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), @@ -782,6 +787,7 @@ Proof. inversion_clear H; auto. inversion_clear H0; auto. Qed. +#[local] Hint Resolve combine_lelistA : core. Lemma combine_sorted : diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index c4bb67a52c..78e7ab69d8 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -49,6 +49,7 @@ Proof. inversion abs. Qed. +#[local] Hint Resolve empty_1 : core. Lemma empty_NoDup : NoDupA empty. @@ -621,6 +622,7 @@ Proof. inversion_clear 1. intros; apply add_NoDup; auto. Qed. +#[local] Hint Resolve fold_right_pair_NoDup : core. Lemma combine_NoDup : diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index 73021a84a3..4917fcb5fd 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -137,6 +137,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder. Qed. + #[global] Hint Resolve compat_P_aux : core. Definition filter : @@ -467,6 +468,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Proof. intros; unfold elements; case (M.elements s); firstorder. Qed. + #[global] Hint Resolve elements_3 : core. Lemma elements_3w : forall s : t, NoDupA E.eq (elements s). @@ -666,6 +668,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. rewrite <- H1; firstorder. Qed. + #[global] Hint Resolve compat_P_aux : core. Definition filter (f : elt -> bool) (s : t) : t := diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index 8a217a752a..d597c0404a 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -466,6 +466,7 @@ the above form: (** Here is the tactic that will throw away hypotheses that are not useful (for the intended scope of the [fsetdec] tactic). *) + #[global] Hint Constructors FSet_elt_Prop FSet_Prop : FSet_Prop. Ltac discard_nonFSet := repeat ( @@ -518,6 +519,7 @@ the above form: (** The hint database [FSet_decidability] will be given to the [push_neg] tactic from the module [Negation]. *) + #[global] Hint Resolve dec_In dec_eq : FSet_decidability. (** ** Normalizing Propositions About Equality diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index ac08351ad9..7618880bd2 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -460,9 +460,11 @@ Qed. End BasicProperties. +#[global] Hint Immediate empty_mem is_empty_equal_empty add_mem_1 remove_mem_1 singleton_equal_add union_mem inter_mem diff_mem equal_sym add_remove remove_add : set. +#[global] Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal subset_refl subset_equal subset_antisym diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v index dfe22b7831..848c27cba1 100644 --- a/theories/FSets/FSetInterface.v +++ b/theories/FSets/FSetInterface.v @@ -253,13 +253,16 @@ Module Type WSfun (E : DecidableType). End Spec. + #[global] Hint Transparent elt : core. + #[global] Hint Resolve mem_1 equal_1 subset_1 empty_1 is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 remove_2 singleton_2 union_1 union_2 union_3 inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 partition_1 partition_2 elements_1 elements_3w : set. + #[global] Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 filter_1 filter_2 for_all_2 exists_2 elements_2 @@ -336,7 +339,9 @@ Module Type Sfun (E : OrderedType). End Spec. + #[global] Hint Resolve elements_3 : set. + #[global] Hint Immediate min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3 : set. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 98b445580b..af034bbdd5 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -21,7 +21,9 @@ Require Import DecidableTypeEx FSetFacts FSetDecide. Set Implicit Arguments. Unset Strict Implicit. +#[global] Hint Unfold transpose compat_op Proper respectful : fset. +#[global] Hint Extern 1 (Equivalence _) => constructor; congruence : fset. (** First, a functor for Weak Sets in functorial version. *) @@ -269,7 +271,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). End BasicProperties. + #[global] Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. + #[global] Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal @@ -732,6 +736,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. intros; rewrite cardinal_Empty; auto. Qed. + #[global] Hint Resolve cardinal_inv_1 : fset. Lemma cardinal_inv_2 : @@ -769,6 +774,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). exact Equal_cardinal. Qed. + #[global] Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : fset. (** ** Cardinal and set operators *) @@ -778,6 +784,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). rewrite cardinal_fold; apply fold_1; auto with set fset. Qed. + #[global] Hint Immediate empty_cardinal cardinal_1 : set. Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1. @@ -788,6 +795,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply cardinal_2 with x; auto with set. Qed. + #[global] Hint Resolve singleton_cardinal: set. Lemma diff_inter_cardinal : @@ -887,6 +895,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). auto with set fset. Qed. + #[global] Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : fset. End WProperties_fun. @@ -952,6 +961,7 @@ Module OrdProperties (M:S). red; intros x a b H; unfold leb. f_equal; apply gtb_compat; auto. Qed. + #[global] Hint Resolve gtb_compat leb_compat : fset. Lemma elements_split : forall x s, diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 9984bff0c2..f013c857ea 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -83,6 +83,7 @@ Lemma andb_prop (a b:bool) : andb a b = true -> a = true /\ b = true. Proof. destruct a, b; repeat split; assumption. Qed. +#[global] Hint Resolve andb_prop: bool. Register andb_prop as core.bool.andb_prop. @@ -92,6 +93,7 @@ Lemma andb_true_intro (b1 b2:bool) : Proof. destruct b1; destruct b2; simpl; intros [? ?]; assumption. Qed. +#[global] Hint Resolve andb_true_intro: bool. Register andb_true_intro as core.bool.andb_true_intro. @@ -100,6 +102,7 @@ Register andb_true_intro as core.bool.andb_true_intro. Inductive eq_true : bool -> Prop := is_eq_true : eq_true true. +#[global] Hint Constructors eq_true : eq_true. Register eq_true as core.eq_true.type. @@ -142,6 +145,7 @@ Defined. Inductive BoolSpec (P Q : Prop) : bool -> Prop := | BoolSpecT : P -> BoolSpec P Q true | BoolSpecF : Q -> BoolSpec P Q false. +#[global] Hint Constructors BoolSpec : core. Register BoolSpec as core.BoolSpec.type. @@ -243,6 +247,7 @@ Section projections. End projections. +#[global] Hint Resolve pair inl inr: core. Lemma surjective_pairing (A B:Type) (p:A * B) : p = (fst p, snd p). @@ -380,6 +385,7 @@ Inductive CompareSpec (Peq Plt Pgt : Prop) : comparison -> Prop := | CompEq : Peq -> CompareSpec Peq Plt Pgt Eq | CompLt : Plt -> CompareSpec Peq Plt Pgt Lt | CompGt : Pgt -> CompareSpec Peq Plt Pgt Gt. +#[global] Hint Constructors CompareSpec : core. Register CompareSpec as core.CompareSpec.type. @@ -395,6 +401,7 @@ Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type := | CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq | CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt. +#[global] Hint Constructors CompareSpecT : core. Register CompareSpecT as core.CompareSpecT.type. @@ -417,6 +424,7 @@ Definition CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop := Definition CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type := CompareSpecT (eq x y) (lt x y) (lt y x). +#[global] Hint Unfold CompSpec CompSpecT : core. Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c, @@ -435,6 +443,7 @@ Proof. intros. apply CompareSpec2Type; assumption. Defined. Inductive identity (A:Type) (a:A) : A -> Type := identity_refl : identity a a. +#[global] Hint Resolve identity_refl: core. Arguments identity_ind [A] a P f y i. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 8012235143..023705e169 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -41,9 +41,12 @@ Register not as core.not.type. variables and constants explicitly. *) Create HintDb core. +#[global] Hint Variables Opaque : core. +#[global] Hint Constants Opaque : core. +#[global] Hint Unfold not: core. (** [and A B], written [A /\ B], is the conjunction of [A] and [B] @@ -119,6 +122,7 @@ Theorem iff_sym : forall A B:Prop, (A <-> B) -> (B <-> A). End Equivalence. +#[global] Hint Unfold iff: extcore. (** Backward direction of the equivalences above does not need assumptions *) @@ -364,8 +368,11 @@ Notation "x = y" := (eq x y) : type_scope. Notation "x <> y :> T" := (~ x = y :>T) : type_scope. Notation "x <> y" := (~ (x = y)) : type_scope. +#[global] Hint Resolve I conj or_introl or_intror : core. +#[global] Hint Resolve eq_refl: core. +#[global] Hint Resolve ex_intro ex_intro2: core. Register eq as core.eq.type. @@ -733,6 +740,7 @@ Notation sym_equal := eq_sym (only parsing). Notation trans_equal := eq_trans (only parsing). Notation sym_not_equal := not_eq_sym (only parsing). +#[global] Hint Immediate eq_sym not_eq_sym: core. (** Basic definitions about relations and properties *) @@ -801,6 +809,7 @@ Qed. Inductive inhabited (A:Type) : Prop := inhabits : A -> inhabited A. +#[global] Hint Resolve inhabits: core. Lemma exists_inhabited : forall (A:Type) (P:A->Prop), diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index 3d9937ae89..f8869615cd 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -72,6 +72,7 @@ Definition identity_rect_r : intros A x P H y H0; case identity_sym with (1 := H0); trivial. Defined. +#[global] Hint Immediate identity_sym not_identity_sym: core. Notation refl_id := identity_refl (only parsing). diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 98fd52f351..fb2a7a57fe 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -37,6 +37,7 @@ Local Notation "0" := O. Definition eq_S := f_equal S. Definition f_equal_nat := f_equal (A:=nat). +#[global] Hint Resolve f_equal_nat: core. (** The predecessor function *) @@ -53,12 +54,14 @@ Qed. (** Injectivity of successor *) Definition eq_add_S n m (H: S n = S m): n = m := f_equal pred H. +#[global] Hint Immediate eq_add_S: core. Theorem not_eq_S : forall n m:nat, n <> m -> S n <> S m. Proof. red; auto. Qed. +#[global] Hint Resolve not_eq_S: core. Definition IsSucc (n:nat) : Prop := @@ -73,12 +76,14 @@ Theorem O_S : forall n:nat, 0 <> S n. Proof. discriminate. Qed. +#[global] Hint Resolve O_S: core. Theorem n_Sn : forall n:nat, n <> S n. Proof. intro n; induction n; auto. Qed. +#[global] Hint Resolve n_Sn: core. (** Addition *) @@ -88,6 +93,7 @@ Infix "+" := Nat.add : nat_scope. Definition f_equal2_plus := f_equal2 plus. Definition f_equal2_nat := f_equal2 (A1:=nat) (A2:=nat). +#[global] Hint Resolve f_equal2_nat: core. Lemma plus_n_O : forall n:nat, n = n + 0. @@ -95,7 +101,9 @@ Proof. intro n; induction n; simpl; auto. Qed. +#[global] Remove Hints eq_refl : core. +#[global] Hint Resolve plus_n_O eq_refl: core. (* We want eq_refl to have higher priority than plus_n_O *) Lemma plus_O_n : forall n:nat, 0 + n = n. @@ -107,6 +115,7 @@ Lemma plus_n_Sm : forall n m:nat, S (n + m) = n + S m. Proof. intros n m; induction n; simpl; auto. Qed. +#[global] Hint Resolve plus_n_Sm: core. Lemma plus_Sn_m : forall n m:nat, S n + m = S (n + m). @@ -125,12 +134,14 @@ Notation mult := Nat.mul (only parsing). Infix "*" := Nat.mul : nat_scope. Definition f_equal2_mult := f_equal2 mult. +#[global] Hint Resolve f_equal2_mult: core. Lemma mult_n_O : forall n:nat, 0 = n * 0. Proof. intro n; induction n; simpl; auto. Qed. +#[global] Hint Resolve mult_n_O: core. Lemma mult_n_Sm : forall n m:nat, n * m + n = n * S m. @@ -139,6 +150,7 @@ Proof. destruct H; rewrite <- plus_n_Sm; apply eq_S. pattern m at 1 3; elim m; simpl; auto. Qed. +#[global] Hint Resolve mult_n_Sm: core. (** Standard associated names *) @@ -162,20 +174,24 @@ where "n <= m" := (le n m) : nat_scope. Register le_n as num.nat.le_n. +#[global] Hint Constructors le: core. (*i equivalent to : "Hints Resolve le_n le_S : core." i*) Definition lt (n m:nat) := S n <= m. +#[global] Hint Unfold lt: core. Infix "<" := lt : nat_scope. Definition ge (n m:nat) := m <= n. +#[global] Hint Unfold ge: core. Infix ">=" := ge : nat_scope. Definition gt (n m:nat) := m < n. +#[global] Hint Unfold gt: core. Infix ">" := gt : nat_scope. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 1fb6dabe6f..5d759f3234 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -797,5 +797,7 @@ Proof. apply (h2 h1). Defined. +#[global] Hint Resolve left right inleft inright: core. +#[global] Hint Resolve exist exist2 existT existT2: core. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 35bab1021e..8721b7c797 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -339,5 +339,6 @@ Tactic Notation "assert_fails" tactic3(tac) := assert_fails tac. Create HintDb rewrite discriminated. +#[global] Hint Variables Opaque : rewrite. Create HintDb typeclass_instances discriminated. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 4cc3597029..115c7cb365 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -163,6 +163,7 @@ Section Facts. Proof. auto using app_assoc. Qed. + #[local] Hint Resolve app_assoc_reverse : core. (* end hide *) @@ -385,10 +386,15 @@ Section Facts. End Facts. +#[global] Hint Resolve app_assoc app_assoc_reverse: datatypes. +#[global] Hint Resolve app_comm_cons app_cons_not_nil: datatypes. +#[global] Hint Immediate app_eq_nil: datatypes. +#[global] Hint Resolve app_eq_unit app_inj_tail: datatypes. +#[global] Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes. @@ -1928,6 +1934,7 @@ Section length_order. Qed. End length_order. +#[global] Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons: datatypes. @@ -1941,6 +1948,7 @@ Section SetIncl. Variable A : Type. Definition incl (l m:list A) := forall a:A, In a l -> In a m. + #[local] Hint Unfold incl : core. Lemma incl_nil_l : forall l, incl nil l. @@ -1959,12 +1967,14 @@ Section SetIncl. Proof. auto. Qed. + #[local] Hint Resolve incl_refl : core. Lemma incl_tl : forall (a:A) (l m:list A), incl l m -> incl l (a :: m). Proof. auto with datatypes. Qed. + #[local] Hint Immediate incl_tl : core. Lemma incl_tran : forall l m n:list A, incl l m -> incl m n -> incl l n. @@ -1976,12 +1986,14 @@ Section SetIncl. Proof. auto with datatypes. Qed. + #[local] Hint Immediate incl_appl : core. Lemma incl_appr : forall l m n:list A, incl l n -> incl l (m ++ n). Proof. auto with datatypes. Qed. + #[local] Hint Immediate incl_appr : core. Lemma incl_cons : @@ -1997,6 +2009,7 @@ Section SetIncl. now_show (In a0 l -> In a0 m). auto. Qed. + #[local] Hint Resolve incl_cons : core. Lemma incl_cons_inv : forall (a:A) (l m:list A), @@ -2012,6 +2025,7 @@ Section SetIncl. now_show (In a n). elim (in_app_or _ _ _ H1); auto. Qed. + #[local] Hint Resolve incl_app : core. Lemma incl_app_app : forall l1 l2 m1 m2:list A, @@ -2054,6 +2068,7 @@ Proof. apply in_map; intuition. Qed. +#[global] Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons incl_app incl_map: datatypes. @@ -2738,6 +2753,7 @@ Section Exists_Forall. | Exists_cons_hd : forall x l, P x -> Exists (x::l) | Exists_cons_tl : forall x l, Exists l -> Exists (x::l). + #[local] Hint Constructors Exists : core. Lemma Exists_exists (l:list A) : @@ -2815,6 +2831,7 @@ Section Exists_Forall. | Forall_nil : Forall nil | Forall_cons : forall x l, P x -> Forall l -> Forall (x::l). + #[local] Hint Constructors Forall : core. Lemma Forall_forall (l:list A): @@ -2999,7 +3016,9 @@ Section Exists_Forall. End Exists_Forall. +#[global] Hint Constructors Exists : core. +#[global] Hint Constructors Forall : core. Lemma exists_Forall A B : forall (P : A -> B -> Prop) l, @@ -3064,6 +3083,7 @@ Section Forall2. | Forall2_cons : forall x y l l', R x y -> Forall2 l l' -> Forall2 (x::l) (y::l'). + #[local] Hint Constructors Forall2 : core. Theorem Forall2_refl : Forall2 [] []. @@ -3098,6 +3118,7 @@ Section Forall2. Qed. End Forall2. +#[global] Hint Constructors Forall2 : core. Section ForallPairs. @@ -3119,6 +3140,7 @@ Section ForallPairs. | FOP_cons : forall a l, Forall (R a) l -> ForallOrdPairs l -> ForallOrdPairs (a::l). + #[local] Hint Constructors ForallOrdPairs : core. Lemma ForallOrdPairs_In : forall l, @@ -3344,6 +3366,7 @@ Notation rev_acc := rev_append (only parsing). Notation rev_acc_rev := rev_append_rev (only parsing). Notation AllS := Forall (only parsing). (* was formerly in TheoryList *) +#[global] Hint Resolve app_nil_end : datatypes. (* end hide *) diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v index 7f5148d0dd..458d08ccb9 100644 --- a/theories/Lists/ListSet.v +++ b/theories/Lists/ListSet.v @@ -193,6 +193,7 @@ Section first_definitions. | auto with datatypes ]. Qed. + #[local] Hint Resolve set_add_intro1 set_add_intro2 : core. Lemma set_add_intro : @@ -224,6 +225,7 @@ Section first_definitions. case H1; trivial. Qed. + #[local] Hint Resolve set_add_intro set_add_elim set_add_elim2 : core. Lemma set_add_not_empty : forall (a:A) (x:set), set_add a x <> empty_set. @@ -310,6 +312,7 @@ Section first_definitions. intros; elim H0; auto with datatypes. Qed. + #[local] Hint Resolve set_union_intro2 set_union_intro1 : core. Lemma set_union_intro : @@ -393,6 +396,7 @@ Section first_definitions. eauto with datatypes. Qed. + #[local] Hint Resolve set_inter_elim1 set_inter_elim2 : core. Lemma set_inter_elim : @@ -471,6 +475,7 @@ Section first_definitions. apply (set_diff_elim1 _ _ _ H). Qed. +#[local] Hint Resolve set_diff_intro set_diff_trivial : core. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index 48e9f992fd..826815410a 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -30,6 +30,7 @@ Inductive InA (x : A) : list A -> Prop := | InA_cons_hd : forall y l, eqA x y -> InA x (y :: l) | InA_cons_tl : forall y l, InA x l -> InA x (y :: l). +#[local] Hint Constructors InA : core. (** TODO: it would be nice to have a generic definition instead @@ -62,6 +63,7 @@ Inductive NoDupA : list A -> Prop := | NoDupA_nil : NoDupA nil | NoDupA_cons : forall x l, ~ InA x l -> NoDupA l -> NoDupA (x::l). +#[local] Hint Constructors NoDupA : core. (** An alternative definition of [NoDupA] based on [ForallOrdPairs] *) @@ -84,6 +86,7 @@ Definition equivlistA l l' := forall x, InA x l <-> InA x l'. Lemma incl_nil l : inclA nil l. Proof. intro. intros. inversion H. Qed. +#[local] Hint Resolve incl_nil : list. (** lists with same elements modulo [eqA] at the same place *) @@ -93,6 +96,7 @@ Inductive eqlistA : list A -> list A -> Prop := | eqlistA_cons : forall x x' l l', eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l'). +#[local] Hint Constructors eqlistA : core. (** We could also have written [eqlistA = Forall2 eqA]. *) @@ -107,7 +111,9 @@ Definition eqarefl := (@Equivalence_Reflexive _ _ eqA_equiv). Definition eqatrans := (@Equivalence_Transitive _ _ eqA_equiv). Definition eqasym := (@Equivalence_Symmetric _ _ eqA_equiv). +#[local] Hint Resolve eqarefl eqatrans : core. +#[local] Hint Immediate eqasym : core. Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA. @@ -154,6 +160,7 @@ Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l. Proof. intros l x y H H'. rewrite <- H. auto. Qed. +#[local] Hint Immediate InA_eqA : core. Lemma In_InA : forall l x, In x l -> InA x l. @@ -161,6 +168,7 @@ Proof. simple induction l; simpl; intuition. subst; auto. Qed. +#[local] Hint Resolve In_InA : core. Lemma InA_split : forall l x, InA x l -> @@ -786,11 +794,13 @@ Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA. Let sotrans := (@StrictOrder_Transitive _ _ ltA_strorder). +#[local] Hint Resolve sotrans : core. Notation InfA:=(lelistA ltA). Notation SortA:=(sort ltA). +#[local] Hint Constructors lelistA sort : core. Lemma InfA_ltA : @@ -814,6 +824,7 @@ Lemma InfA_eqA l x y : eqA x y -> InfA y l -> InfA x l. Proof using eqA_equiv ltA_compat. intros H; now rewrite H. Qed. +#[local] Hint Immediate InfA_ltA InfA_eqA : core. Lemma SortA_InfA_InA : @@ -1005,6 +1016,7 @@ Qed. End Filter. End Type_with_equality. +#[global] Hint Constructors InA eqlistA NoDupA sort lelistA : core. Arguments equivlistA_cons_nil {A} eqA {eqA_equiv} x l _. diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index 7a275a8231..f16d70a4c2 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -54,6 +54,7 @@ Lemma tl_nth_tl : Proof. simple induction n; simpl; auto. Qed. +#[local] Hint Resolve tl_nth_tl: datatypes. Lemma Str_nth_tl_plus : diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v index e5d364297d..b2b5985ff1 100644 --- a/theories/Logic/Classical_Prop.v +++ b/theories/Logic/Classical_Prop.v @@ -16,6 +16,7 @@ Require Import ClassicalFacts. +#[global] Hint Unfold not: core. Axiom classic : forall P:Prop, P \/ ~ P. diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v index 998497f13e..5fb6bb3907 100644 --- a/theories/Logic/Decidable.v +++ b/theories/Logic/Decidable.v @@ -206,6 +206,7 @@ Qed. (** With the following hint database, we can leverage [auto] to check decidability of propositions. *) +#[global] Hint Resolve dec_True dec_False dec_or dec_and dec_imp dec_not dec_iff : decidable_prop. diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v index f2e15c9abb..934806de93 100644 --- a/theories/Logic/Eqdep.v +++ b/theories/Logic/Eqdep.v @@ -35,5 +35,7 @@ Export EqdepTheory. (** Exported hints *) +#[global] Hint Resolve eq_dep_eq: eqdep. +#[global] Hint Resolve inj_pair2 inj_pairT2: eqdep. diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index a918d1ecd7..6589e75289 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -65,6 +65,7 @@ Section Dependent_Equality. Inductive eq_dep (p:U) (x:P p) : forall q:U, P q -> Prop := eq_dep_intro : eq_dep p x p x. + #[local] Hint Constructors eq_dep: core. Lemma eq_dep_refl : forall (p:U) (x:P p), eq_dep p x p x. @@ -75,6 +76,7 @@ Section Dependent_Equality. Proof. destruct 1; auto. Qed. + #[local] Hint Immediate eq_dep_sym: core. Lemma eq_dep_trans : @@ -221,7 +223,9 @@ Unset Implicit Arguments. (** Exported hints *) +#[global] Hint Resolve eq_dep_intro: core. +#[global] Hint Immediate eq_dep_sym: core. (************************************************************************) diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index ccd7db177c..7ee3a99d60 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -31,6 +31,7 @@ Arguments JMeq_refl {A x} , [A] x. Register JMeq as core.JMeq.type. Register JMeq_refl as core.JMeq.refl. +#[global] Hint Resolve JMeq_refl : core. Definition JMeq_hom {A : Type} (x y : A) := JMeq x y. @@ -42,6 +43,7 @@ Proof. intros; destruct H; trivial. Qed. +#[global] Hint Immediate JMeq_sym : core. Register JMeq_sym as core.JMeq.sym. diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v index 0f62a9419b..aa0c419f0e 100644 --- a/theories/MSets/MSetDecide.v +++ b/theories/MSets/MSetDecide.v @@ -466,6 +466,7 @@ the above form: (** Here is the tactic that will throw away hypotheses that are not useful (for the intended scope of the [fsetdec] tactic). *) + #[global] Hint Constructors MSet_elt_Prop MSet_Prop : MSet_Prop. Ltac discard_nonMSet := repeat ( @@ -518,6 +519,7 @@ the above form: (** The hint database [MSet_decidability] will be given to the [push_neg] tactic from the module [Negation]. *) + #[global] Hint Resolve dec_In dec_eq : MSet_decidability. (** ** Normalizing Propositions About Equality diff --git a/theories/MSets/MSetEqProperties.v b/theories/MSets/MSetEqProperties.v index dc22af4948..b439be9b3f 100644 --- a/theories/MSets/MSetEqProperties.v +++ b/theories/MSets/MSetEqProperties.v @@ -462,9 +462,11 @@ Qed. End BasicProperties. +#[global] Hint Immediate empty_mem is_empty_equal_empty add_mem_1 remove_mem_1 singleton_equal_add union_mem inter_mem diff_mem equal_sym add_remove remove_add : set. +#[global] Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal subset_refl subset_equal subset_antisym diff --git a/theories/MSets/MSetFacts.v b/theories/MSets/MSetFacts.v index 7dbb658e46..ea86c7a4d7 100644 --- a/theories/MSets/MSetFacts.v +++ b/theories/MSets/MSetFacts.v @@ -139,12 +139,14 @@ Notation choose_1 := choose_spec1 (only parsing). Notation choose_2 := choose_spec2 (only parsing). Notation elements_3w := elements_spec2w (only parsing). +#[global] Hint Resolve mem_1 equal_1 subset_1 empty_1 is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 remove_2 singleton_2 union_1 union_2 union_3 inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 partition_1 partition_2 elements_1 elements_3w : set. +#[global] Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 filter_1 filter_2 for_all_2 exists_2 elements_2 diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 58656b666e..37d20bffad 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -46,6 +46,7 @@ End InfoTyp. Module Type Ops (X:OrderedType)(Info:InfoTyp). Definition elt := X.t. +#[global] Hint Transparent elt : core. Inductive tree : Type := diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index fe5d721ffa..c0567f9ef1 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -442,6 +442,7 @@ Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E. Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}. Definition t := t_. Arguments Mkt this {is_ok}. + #[global] Hint Resolve is_ok : typeclass_instances. Definition In (x : elt)(s : t) := M.In x (this s). @@ -884,9 +885,11 @@ Module MakeListOrdering (O:OrderedType). O.lt x y -> lt_list (x :: s) (y :: s') | lt_cons_eq : forall x y s s', O.eq x y -> lt_list s s' -> lt_list (x :: s) (y :: s'). + #[global] Hint Constructors lt_list : core. Definition lt := lt_list. + #[global] Hint Unfold lt : core. Instance lt_strorder : StrictOrder lt. @@ -933,6 +936,7 @@ Module MakeListOrdering (O:OrderedType). left; MO.order. right; rewrite <- E12; auto. left; MO.order. right; rewrite E12; auto. Qed. + #[global] Hint Resolve eq_cons : core. Lemma cons_CompSpec : forall c x1 x2 l1 l2, O.eq x1 x2 -> @@ -940,6 +944,7 @@ Module MakeListOrdering (O:OrderedType). Proof. destruct c; simpl; inversion_clear 2; auto with relations. Qed. + #[global] Hint Resolve cons_CompSpec : core. End MakeListOrdering. diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v index d2878b4710..84cf620474 100644 --- a/theories/MSets/MSetList.v +++ b/theories/MSets/MSetList.v @@ -231,13 +231,16 @@ Module MakeRaw (X: OrderedType) <: RawSets X. Notation In := (InA X.eq). Existing Instance X.eq_equiv. + #[local] Hint Extern 20 => solve [order] : core. Definition IsOk s := Sort s. Class Ok (s:t) : Prop := ok : Sort s. + #[local] Hint Resolve ok : core. + #[local] Hint Unfold Ok : core. Instance Sort_Ok s `(Hs : Sort s) : Ok s := { ok := Hs }. @@ -276,6 +279,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. destruct H; constructor; tauto. Qed. + #[local] Hint Extern 1 (Ok _) => rewrite <- isok_iff : core. Ltac inv_ok := match goal with @@ -326,6 +330,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. intuition. intros; elim_compare x a; inv; intuition. Qed. + #[local] Hint Resolve add_inf : core. Global Instance add_ok s x : forall `(Ok s), Ok (add x s). @@ -353,6 +358,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. intros; elim_compare x a; inv; auto. apply Inf_lt with a; auto. Qed. + #[local] Hint Resolve remove_inf : core. Global Instance remove_ok s x : forall `(Ok s), Ok (remove x s). @@ -396,6 +402,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. Proof. induction2. Qed. + #[local] Hint Resolve union_inf : core. Global Instance union_ok s s' : forall `(Ok s, Ok s'), Ok (union s s'). @@ -422,6 +429,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. apply Hrec'; auto. apply Inf_lt with x'; auto. Qed. + #[local] Hint Resolve inter_inf : core. Global Instance inter_ok s s' : forall `(Ok s, Ok s'), Ok (inter s s'). @@ -452,6 +460,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. apply Hrec'; auto. apply Inf_lt with x'; auto. Qed. + #[local] Hint Resolve diff_inf : core. Global Instance diff_ok s s' : forall `(Ok s, Ok s'), Ok (diff s s'). diff --git a/theories/MSets/MSetProperties.v b/theories/MSets/MSetProperties.v index 51807e5cda..b49a91ed14 100644 --- a/theories/MSets/MSetProperties.v +++ b/theories/MSets/MSetProperties.v @@ -21,6 +21,7 @@ Require Import DecidableTypeEx OrdersLists MSetFacts MSetDecide. Set Implicit Arguments. Unset Strict Implicit. +#[global] Hint Unfold transpose : core. (** First, a functor for Weak Sets in functorial version. *) @@ -268,7 +269,9 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). End BasicProperties. + #[global] Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. + #[global] Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal @@ -735,6 +738,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). Proof. intros; rewrite cardinal_Empty; auto. Qed. + #[global] Hint Resolve cardinal_inv_1 : core. Lemma cardinal_inv_2 : @@ -774,6 +778,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). exact Equal_cardinal. Qed. + #[global] Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : core. (** ** Cardinal and set operators *) @@ -783,6 +788,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). rewrite cardinal_fold; apply fold_1; auto with *. Qed. + #[global] Hint Immediate empty_cardinal cardinal_1 : set. Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1. @@ -793,6 +799,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). apply cardinal_2 with x; auto with set. Qed. + #[global] Hint Resolve singleton_cardinal: set. Lemma diff_inter_cardinal : @@ -898,6 +905,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). auto with set. Qed. + #[global] Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : core. End WPropertiesOn. @@ -922,7 +930,9 @@ Module OrdProperties (M:Sets). Import M.E. Import M. + #[global] Hint Resolve elements_spec2 : core. + #[global] Hint Immediate min_elt_spec1 min_elt_spec2 min_elt_spec3 max_elt_spec1 max_elt_spec2 max_elt_spec3 : set. @@ -961,6 +971,7 @@ Module OrdProperties (M:Sets). Proof. intros a b H; unfold leb. rewrite H; auto. Qed. + #[global] Hint Resolve gtb_compat leb_compat : core. Lemma elements_split : forall x s, diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v index 2498d82889..8a5ba2d80f 100644 --- a/theories/MSets/MSetWeakList.v +++ b/theories/MSets/MSetWeakList.v @@ -123,14 +123,18 @@ Module MakeRaw (X:DecidableType) <: WRawSets X. Let eqr:= (@Equivalence_Reflexive _ _ X.eq_equiv). Let eqsym:= (@Equivalence_Symmetric _ _ X.eq_equiv). Let eqtrans:= (@Equivalence_Transitive _ _ X.eq_equiv). + #[local] Hint Resolve eqr eqtrans : core. + #[local] Hint Immediate eqsym : core. Definition IsOk := NoDup. Class Ok (s:t) : Prop := ok : NoDup s. + #[local] Hint Unfold Ok : core. + #[local] Hint Resolve ok : core. Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }. diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index f6b2544b6e..c5c75fc17a 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -467,6 +467,7 @@ Section Basics. apply phibis_aux_pos. Qed. + #[local] Hint Resolve phi_nonneg : zarith. Lemma phi_bounded : forall x, (0 <= phi x < 2 ^ (Z.of_nat size))%Z. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index 383c0aff3a..dbca2f0947 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -290,6 +290,7 @@ Proof. intros h; apply Z.lt_gt, Zpower_gt_0; lia. Qed. Lemma pow2_nz n : 0 <= n → 2 ^ n ≠0. Proof. intros h; generalize (pow2_pos _ h); lia. Qed. +#[global] Hint Resolve pow2_pos pow2_nz : zarith. (* =================================================== *) diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v index 5e486333b2..6aad65899a 100644 --- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -61,6 +61,7 @@ Section ZModulo. apply Z.lt_gt. unfold wB, base; auto with zarith. Qed. + #[local] Hint Resolve wB_pos : core. Lemma spec_to_Z_1 : forall x, 0 <= [|x|]. @@ -72,6 +73,7 @@ Section ZModulo. Proof. unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto. Qed. + #[local] Hint Resolve spec_to_Z_1 spec_to_Z_2 : core. Lemma spec_to_Z : forall x, 0 <= [|x|] < wB. @@ -706,6 +708,7 @@ Section ZModulo. Proof. induction p; simpl; auto with zarith. Qed. + #[local] Hint Resolve Ptail_pos : core. Lemma Ptail_bounded : forall p d, Zpos p < 2^(Zpos d) -> Ptail p < Zpos d. diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v index 019b138b4d..2f8fcc7290 100644 --- a/theories/Numbers/Natural/Abstract/NDefOps.v +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -383,6 +383,7 @@ f_equiv. apply E, half_decrease. rewrite two_succ, <- not_true_iff_false, ltb_lt, nlt_ge, le_succ_l in H. order'. Qed. +#[global] Hint Resolve log_good_step : core. Theorem log_init : forall n, n < 2 -> log n == 0. diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index 3e282f696a..3ecb5a5a61 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -26,6 +26,7 @@ Arguments id {A} x. Definition compose {A B C} (g : B -> C) (f : A -> B) := fun x : A => g (f x). +#[global] Hint Unfold compose : core. Declare Scope program_scope. diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index 5862a08838..25af2d5ffb 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -21,6 +21,7 @@ Ltac is_ground_goal := (** Try to find a contradiction. *) +#[global] Hint Extern 10 => is_ground_goal ; progress exfalso : exfalso. (** We will use the [block] definition to separate the goal from the @@ -308,6 +309,7 @@ Proof. intros. rewrite (UIP_refl A). assumption. Defined. (** This hint database and the following tactic can be used with [autounfold] to unfold everything to [eq_rect]s. *) +#[global] Hint Unfold solution_left solution_right deletion simplification_heq simplification_existT1 simplification_existT2 simplification_K eq_rect_r eq_rec eq_ind : dep_elim. diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index 50351d6a14..d1be8812e9 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -12,8 +12,6 @@ Require Import Coq.Init.Wf. Require Import Coq.Program.Utils. -Require Import ProofIrrelevance. -Require Import FunctionalExtensionality. Local Open Scope program_scope. @@ -51,7 +49,7 @@ Section Well_founded. Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F_sub x r = Fix_F_sub x s. Proof. intro x; induction (Rwf x); intros. - rewrite (proof_irrelevance (Acc R x) r s) ; auto. + rewrite <- 2 Fix_F_eq; intros. apply F_ext; intros []; auto. Qed. Lemma Fix_eq : forall x:A, Fix_sub x = F_sub x (fun y:{ y:A | R y x} => Fix_sub (proj1_sig y)). @@ -110,6 +108,7 @@ Section Measure_well_founded. End Measure_well_founded. +#[global] Hint Resolve measure_wf : core. Section Fix_rects. @@ -226,6 +225,7 @@ Ltac fold_sub f := (** This module provides the fixpoint equation provided one assumes functional extensionality. *) +Require Import FunctionalExtensionality. Module WfExtensionality. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index fa4f9134cc..b008c6c2aa 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -95,7 +95,9 @@ Proof. symmetry. apply Z.ge_le_iff. Qed. +#[global] Hint Unfold Qeq Qlt Qle : qarith. +#[global] Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith. Lemma Qcompare_antisym x y : CompOpp (x ?= y) = (y ?= x). @@ -127,7 +129,9 @@ apply Z.mul_reg_r with (QDen y); [auto with qarith|]. now rewrite Z.mul_shuffle0, XY, Z.mul_shuffle0, YZ, Z.mul_shuffle0. Qed. +#[global] Hint Immediate Qeq_sym : qarith. +#[global] Hint Resolve Qeq_refl Qeq_trans : qarith. (** In a word, [Qeq] is a setoid equality. *) @@ -203,6 +207,7 @@ Proof. rewrite !Qeq_bool_iff; apply Qeq_trans. Qed. +#[global] Hint Resolve Qnot_eq_sym : qarith. (** * Addition, multiplication and opposite *) @@ -783,6 +788,7 @@ Proof. Close Scope Z_scope. Qed. +#[global] Hint Resolve Qle_trans : qarith. Lemma Qlt_irrefl x : ~x<x. @@ -863,6 +869,7 @@ Proof. unfold Qle, Qlt, Qeq; intros; now apply Z.lt_eq_cases. Qed. +#[global] Hint Resolve Qle_not_lt Qlt_not_le Qnot_le_lt Qnot_lt_le Qlt_le_weak Qlt_not_eq Qle_antisym Qle_refl: qarith. @@ -904,6 +911,7 @@ Proof. Qed. +#[global] Hint Resolve Qopp_le_compat : qarith. Lemma Qle_minus_iff : forall p q, p <= q <-> 0 <= q+-p. diff --git a/theories/QArith/Qabs.v b/theories/QArith/Qabs.v index 13e88fc093..d1ff1fc794 100644 --- a/theories/QArith/Qabs.v +++ b/theories/QArith/Qabs.v @@ -11,6 +11,7 @@ Require Export QArith. Require Export Qreduction. +#[global] Hint Resolve Qlt_le_weak : qarith. Definition Qabs (x:Q) := let (n,d):=x in (Z.abs n#d). diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index 63b0a5afb7..bd43f901bb 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -66,6 +66,7 @@ Proof. rewrite hq, hq' in H'. subst q'. f_equal. apply eq_proofs_unicity. intros. repeat decide equality. Qed. +#[global] Hint Resolve Qc_is_canon : core. Theorem Qc_decomp: forall q q': Qc, (q:Q) = q' -> q = q'. diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index 20b5cb236b..5a23a20811 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -19,6 +19,7 @@ intros. now apply not_O_IZR. Qed. +#[global] Hint Resolve IZR_nz Rmult_integral_contrapositive : core. Lemma eqR_Qeq : forall x y : Q, Q2R x = Q2R y -> x==y. diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v index 8fd342ab15..06f4ca02d1 100644 --- a/theories/QArith/Qround.v +++ b/theories/QArith/Qround.v @@ -18,6 +18,7 @@ rewrite !Z.mul_opp_l. apply Z.opp_lt_mono. Qed. +#[global] Hint Resolve Qopp_lt_compat : qarith. (************) @@ -54,6 +55,7 @@ rewrite Z.mul_comm. now apply Z.mul_div_le. Qed. +#[global] Hint Resolve Qfloor_le : qarith. Lemma Qle_ceiling : forall x, x <= Qceiling x. @@ -66,6 +68,7 @@ change (Qceiling x:Q) with (-(Qfloor(-x))). auto with *. Qed. +#[global] Hint Resolve Qle_ceiling : qarith. Lemma Qle_floor_ceiling : forall x, Qfloor x <= Qceiling x. @@ -88,6 +91,7 @@ rewrite <- Z.lt_add_lt_sub_r. destruct (Z_mod_lt n (Zpos d)); auto with *. Qed. +#[global] Hint Resolve Qlt_floor : qarith. Lemma Qceiling_lt : forall x, (Qceiling x-1)%Z < x. @@ -101,6 +105,7 @@ rewrite Qopp_involutive. auto with *. Qed. +#[global] Hint Resolve Qceiling_lt : qarith. Lemma Qfloor_resp_le : forall x y, x <= y -> (Qfloor x <= Qfloor y)%Z. @@ -114,6 +119,7 @@ rewrite (Z.mul_comm (Zpos yd) (Zpos xd)). apply Z_div_le; auto with *. Qed. +#[global] Hint Resolve Qfloor_resp_le : qarith. Lemma Qceiling_resp_le : forall x y, x <= y -> (Qceiling x <= Qceiling y)%Z. @@ -123,6 +129,7 @@ unfold Qceiling. rewrite <- Z.opp_le_mono; auto with qarith. Qed. +#[global] Hint Resolve Qceiling_resp_le : qarith. Add Morphism Qfloor with signature Qeq ==> eq as Qfloor_comp. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 993b7b3ec4..fd8acf481a 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -37,10 +37,12 @@ Lemma Rle_refl : forall r, r <= r. Proof. intro; right; reflexivity. Qed. +#[global] Hint Immediate Rle_refl: rorders. Lemma Rge_refl : forall r, r <= r. Proof. exact Rle_refl. Qed. +#[global] Hint Immediate Rge_refl: rorders. (** Irreflexivity of the strict order *) @@ -49,6 +51,7 @@ Lemma Rlt_irrefl : forall r, ~ r < r. Proof. intros r H; eapply Rlt_asym; eauto. Qed. +#[global] Hint Resolve Rlt_irrefl: real. Lemma Rgt_irrefl : forall r, ~ r > r. @@ -72,6 +75,7 @@ Proof. - apply Rlt_not_eq in H1. eauto. - apply Rgt_not_eq in H1. eauto. Qed. +#[global] Hint Resolve Rlt_dichotomy_converse: real. (** Reasoning by case on equality and order *) @@ -82,6 +86,7 @@ Proof. intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse; unfold not; intuition eauto 3. Qed. +#[global] Hint Resolve Req_dec: real. (**********) @@ -110,6 +115,7 @@ Lemma Rlt_le : forall r1 r2, r1 < r2 -> r1 <= r2. Proof. intros; red; tauto. Qed. +#[global] Hint Resolve Rlt_le: real. Lemma Rgt_ge : forall r1 r2, r1 > r2 -> r1 >= r2. @@ -122,14 +128,18 @@ Lemma Rle_ge : forall r1 r2, r1 <= r2 -> r2 >= r1. Proof. destruct 1; red; auto with real. Qed. +#[global] Hint Immediate Rle_ge: real. +#[global] Hint Resolve Rle_ge: rorders. Lemma Rge_le : forall r1 r2, r1 >= r2 -> r2 <= r1. Proof. destruct 1; red; auto with real. Qed. +#[global] Hint Resolve Rge_le: real. +#[global] Hint Immediate Rge_le: rorders. (**********) @@ -137,12 +147,14 @@ Lemma Rlt_gt : forall r1 r2, r1 < r2 -> r2 > r1. Proof. trivial. Qed. +#[global] Hint Resolve Rlt_gt: rorders. Lemma Rgt_lt : forall r1 r2, r1 > r2 -> r2 < r1. Proof. trivial. Qed. +#[global] Hint Immediate Rgt_lt: rorders. (**********) @@ -151,6 +163,7 @@ Lemma Rnot_le_lt : forall r1 r2, ~ r1 <= r2 -> r2 < r1. Proof. intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rle; tauto. Qed. +#[global] Hint Immediate Rnot_le_lt: real. Lemma Rnot_ge_gt : forall r1 r2, ~ r1 >= r2 -> r2 > r1. @@ -183,6 +196,7 @@ Proof. generalize Rlt_asym Rlt_dichotomy_converse; unfold Rle. unfold not; intuition eauto 3. Qed. +#[global] Hint Immediate Rlt_not_le: real. Lemma Rgt_not_le : forall r1 r2, r1 > r2 -> ~ r1 <= r2. @@ -190,6 +204,7 @@ Proof. exact Rlt_not_le. Qed. Lemma Rlt_not_ge : forall r1 r2, r1 < r2 -> ~ r1 >= r2. Proof. red; intros; eapply Rlt_not_le; eauto with real. Qed. +#[global] Hint Immediate Rlt_not_ge: real. Lemma Rgt_not_ge : forall r1 r2, r2 > r1 -> ~ r1 >= r2. @@ -215,24 +230,28 @@ Lemma Req_le : forall r1 r2, r1 = r2 -> r1 <= r2. Proof. unfold Rle; tauto. Qed. +#[global] Hint Immediate Req_le: real. Lemma Req_ge : forall r1 r2, r1 = r2 -> r1 >= r2. Proof. unfold Rge; tauto. Qed. +#[global] Hint Immediate Req_ge: real. Lemma Req_le_sym : forall r1 r2, r2 = r1 -> r1 <= r2. Proof. unfold Rle; auto. Qed. +#[global] Hint Immediate Req_le_sym: real. Lemma Req_ge_sym : forall r1 r2, r2 = r1 -> r1 >= r2. Proof. unfold Rge; auto. Qed. +#[global] Hint Immediate Req_ge_sym: real. (** *** Asymmetry *) @@ -248,6 +267,7 @@ Lemma Rle_antisym : forall r1 r2, r1 <= r2 -> r2 <= r1 -> r1 = r2. Proof. intros r1 r2; generalize (Rlt_asym r1 r2); unfold Rle; intuition. Qed. +#[global] Hint Resolve Rle_antisym: real. Lemma Rge_antisym : forall r1 r2, r1 >= r2 -> r2 >= r1 -> r1 = r2. @@ -387,12 +407,14 @@ Lemma Rplus_0_r : forall r, r + 0 = r. Proof. intro; ring. Qed. +#[global] Hint Resolve Rplus_0_r: real. Lemma Rplus_ne : forall r, r + 0 = r /\ 0 + r = r. Proof. split; ring. Qed. +#[global] Hint Resolve Rplus_ne: real. (**********) @@ -403,6 +425,7 @@ Lemma Rplus_opp_l : forall r, - r + r = 0. Proof. intro; ring. Qed. +#[global] Hint Resolve Rplus_opp_l: real. (**********) @@ -415,6 +438,7 @@ Qed. Definition f_equal_R := (f_equal (A:=R)). +#[global] Hint Resolve f_equal_R : real. Lemma Rplus_eq_compat_l : forall r r1 r2, r1 = r2 -> r + r1 = r + r2. @@ -439,6 +463,7 @@ Proof. repeat rewrite Rplus_assoc; rewrite <- H; reflexivity. ring. Qed. +#[global] Hint Resolve Rplus_eq_reg_l: real. Lemma Rplus_eq_reg_r : forall r r1 r2, r1 + r = r2 + r -> r1 = r2. @@ -485,18 +510,21 @@ Lemma Rinv_r : forall r, r <> 0 -> r * / r = 1. Proof. intros; field; trivial. Qed. +#[global] Hint Resolve Rinv_r: real. Lemma Rinv_l_sym : forall r, r <> 0 -> 1 = / r * r. Proof. intros; field; trivial. Qed. +#[global] Hint Resolve Rinv_l_sym: real. Lemma Rinv_r_sym : forall r, r <> 0 -> 1 = r * / r. Proof. intros; field; trivial. Qed. +#[global] Hint Resolve Rinv_r_sym: real. (**********) @@ -504,6 +532,7 @@ Lemma Rmult_0_r : forall r, r * 0 = 0. Proof. intro; ring. Qed. +#[global] Hint Resolve Rmult_0_r: real. (**********) @@ -511,6 +540,7 @@ Lemma Rmult_0_l : forall r, 0 * r = 0. Proof. intro; ring. Qed. +#[global] Hint Resolve Rmult_0_l: real. (**********) @@ -518,6 +548,7 @@ Lemma Rmult_ne : forall r, r * 1 = r /\ 1 * r = r. Proof. intro; split; ring. Qed. +#[global] Hint Resolve Rmult_ne: real. (**********) @@ -525,6 +556,7 @@ Lemma Rmult_1_r : forall r, r * 1 = r. Proof. intro; ring. Qed. +#[global] Hint Resolve Rmult_1_r: real. (**********) @@ -572,6 +604,7 @@ Proof. intros r1 r2 [H| H]; rewrite H; auto with real. Qed. +#[global] Hint Resolve Rmult_eq_0_compat: real. (**********) @@ -599,6 +632,7 @@ Proof. red; intros r1 r2 [H1 H2] H. case (Rmult_integral r1 r2); auto with real. Qed. +#[global] Hint Resolve Rmult_integral_contrapositive: real. Lemma Rmult_integral_contrapositive_currified : @@ -640,6 +674,7 @@ Lemma Ropp_eq_compat : forall r1 r2, r1 = r2 -> - r1 = - r2. Proof. auto with real. Qed. +#[global] Hint Resolve Ropp_eq_compat: real. (**********) @@ -647,6 +682,7 @@ Lemma Ropp_0 : -0 = 0. Proof. ring. Qed. +#[global] Hint Resolve Ropp_0: real. (**********) @@ -654,6 +690,7 @@ Lemma Ropp_eq_0_compat : forall r, r = 0 -> - r = 0. Proof. intros; rewrite H; auto with real. Qed. +#[global] Hint Resolve Ropp_eq_0_compat: real. (**********) @@ -661,6 +698,7 @@ Lemma Ropp_involutive : forall r, - - r = r. Proof. intro; ring. Qed. +#[global] Hint Resolve Ropp_involutive: real. (*********) @@ -670,6 +708,7 @@ Proof. apply H. transitivity (- - r); auto with real. Qed. +#[global] Hint Resolve Ropp_neq_0_compat: real. (**********) @@ -677,6 +716,7 @@ Lemma Ropp_plus_distr : forall r1 r2, - (r1 + r2) = - r1 + - r2. Proof. intros; ring. Qed. +#[global] Hint Resolve Ropp_plus_distr: real. (*********************************************************) @@ -692,6 +732,7 @@ Lemma Ropp_mult_distr_l_reverse : forall r1 r2, - r1 * r2 = - (r1 * r2). Proof. intros; ring. Qed. +#[global] Hint Resolve Ropp_mult_distr_l_reverse: real. (**********) @@ -699,6 +740,7 @@ Lemma Rmult_opp_opp : forall r1 r2, - r1 * - r2 = r1 * r2. Proof. intros; ring. Qed. +#[global] Hint Resolve Rmult_opp_opp: real. Lemma Ropp_mult_distr_r : forall r1 r2, - (r1 * r2) = r1 * - r2. @@ -719,12 +761,14 @@ Lemma Rminus_0_r : forall r, r - 0 = r. Proof. intro; ring. Qed. +#[global] Hint Resolve Rminus_0_r: real. Lemma Rminus_0_l : forall r, 0 - r = - r. Proof. intro; ring. Qed. +#[global] Hint Resolve Rminus_0_l: real. (**********) @@ -732,6 +776,7 @@ Lemma Ropp_minus_distr : forall r1 r2, - (r1 - r2) = r2 - r1. Proof. intros; ring. Qed. +#[global] Hint Resolve Ropp_minus_distr: real. Lemma Ropp_minus_distr' : forall r1 r2, - (r2 - r1) = r1 - r2. @@ -744,6 +789,7 @@ Lemma Rminus_diag_eq : forall r1 r2, r1 = r2 -> r1 - r2 = 0. Proof. intros; rewrite H; ring. Qed. +#[global] Hint Resolve Rminus_diag_eq: real. Lemma Rminus_eq_0 x : x - x = 0. @@ -755,6 +801,7 @@ Proof. intros r1 r2; unfold Rminus; rewrite Rplus_comm; intro. rewrite <- (Ropp_involutive r2); apply (Rplus_opp_r_uniq (- r2) r1 H). Qed. +#[global] Hint Immediate Rminus_diag_uniq: real. Lemma Rminus_diag_uniq_sym : forall r1 r2, r2 - r1 = 0 -> r1 = r2. @@ -762,12 +809,14 @@ Proof. intros; generalize (Rminus_diag_uniq r2 r1 H); clear H; intro H; rewrite H; ring. Qed. +#[global] Hint Immediate Rminus_diag_uniq_sym: real. Lemma Rplus_minus : forall r1 r2, r1 + (r2 - r1) = r2. Proof. intros; ring. Qed. +#[global] Hint Resolve Rplus_minus: real. (**********) @@ -776,18 +825,21 @@ Proof. red; intros r1 r2 H H0. apply H; auto with real. Qed. +#[global] Hint Resolve Rminus_eq_contra: real. Lemma Rminus_not_eq : forall r1 r2, r1 - r2 <> 0 -> r1 <> r2. Proof. red; intros; elim H; apply Rminus_diag_eq; auto. Qed. +#[global] Hint Resolve Rminus_not_eq: real. Lemma Rminus_not_eq_right : forall r1 r2, r2 - r1 <> 0 -> r1 <> r2. Proof. red; intros; elim H; rewrite H0; ring. Qed. +#[global] Hint Resolve Rminus_not_eq_right: real. (**********) @@ -809,6 +861,7 @@ Lemma Rinv_1 : / 1 = 1. Proof. field. Qed. +#[global] Hint Resolve Rinv_1: real. (*********) @@ -817,6 +870,7 @@ Proof. red; intros; apply R1_neq_R0. replace 1 with (/ r * r); auto with real. Qed. +#[global] Hint Resolve Rinv_neq_0_compat: real. (*********) @@ -824,6 +878,7 @@ Lemma Rinv_involutive : forall r, r <> 0 -> / / r = r. Proof. intros; field; trivial. Qed. +#[global] Hint Resolve Rinv_involutive: real. (*********) @@ -857,6 +912,7 @@ Proof. transitivity (r2 * (r1 * / r1)); auto with real. ring. Qed. +#[global] Hint Resolve Rinv_r_simpl_l Rinv_r_simpl_r Rinv_r_simpl_m: real. (*********) @@ -878,6 +934,7 @@ Qed. Lemma Rplus_gt_compat_l : forall r r1 r2, r1 > r2 -> r + r1 > r + r2. Proof. eauto using Rplus_lt_compat_l with rorders. Qed. +#[global] Hint Resolve Rplus_gt_compat_l: real. (**********) @@ -886,6 +943,7 @@ Proof. intros. rewrite (Rplus_comm r1 r); rewrite (Rplus_comm r2 r); auto with real. Qed. +#[global] Hint Resolve Rplus_lt_compat_r: real. Lemma Rplus_gt_compat_r : forall r r1 r2, r1 > r2 -> r1 + r > r2 + r. @@ -901,6 +959,7 @@ Qed. Lemma Rplus_ge_compat_l : forall r r1 r2, r1 >= r2 -> r + r1 >= r + r2. Proof. auto using Rplus_le_compat_l with rorders. Qed. +#[global] Hint Resolve Rplus_ge_compat_l: real. (**********) @@ -911,6 +970,7 @@ Proof. right; rewrite <- H0; auto with real. Qed. +#[global] Hint Resolve Rplus_le_compat_l Rplus_le_compat_r: real. Lemma Rplus_ge_compat_r : forall r r1 r2, r1 >= r2 -> r1 + r >= r2 + r. @@ -922,6 +982,7 @@ Lemma Rplus_lt_compat : Proof. intros; apply Rlt_trans with (r2 + r3); auto with real. Qed. +#[global] Hint Immediate Rplus_lt_compat: real. Lemma Rplus_le_compat : @@ -929,6 +990,7 @@ Lemma Rplus_le_compat : Proof. intros; apply Rle_trans with (r2 + r3); auto with real. Qed. +#[global] Hint Immediate Rplus_le_compat: real. Lemma Rplus_gt_compat : @@ -952,6 +1014,7 @@ Proof. intros; apply Rle_lt_trans with (r2 + r3); auto with real. Qed. +#[global] Hint Immediate Rplus_lt_le_compat Rplus_le_lt_compat: real. Lemma Rplus_gt_ge_compat : @@ -1091,6 +1154,7 @@ Proof. apply CReal_opp_gt_lt_contravar. unfold Rgt in H. rewrite Rlt_def in H. apply CRealLtEpsilon. exact H. Qed. +#[global] Hint Resolve Ropp_gt_lt_contravar : core. Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2. @@ -1100,6 +1164,7 @@ Proof. apply CReal_opp_gt_lt_contravar. rewrite Rlt_def in H. apply CRealLtEpsilon. exact H. Qed. +#[global] Hint Resolve Ropp_lt_gt_contravar: real. (**********) @@ -1107,6 +1172,7 @@ Lemma Ropp_lt_contravar : forall r1 r2, r2 < r1 -> - r1 < - r2. Proof. auto with real. Qed. +#[global] Hint Resolve Ropp_lt_contravar: real. Lemma Ropp_gt_contravar : forall r1 r2, r2 > r1 -> - r1 > - r2. @@ -1117,12 +1183,14 @@ Lemma Ropp_le_ge_contravar : forall r1 r2, r1 <= r2 -> - r1 >= - r2. Proof. unfold Rge; intros r1 r2 [H| H]; auto with real. Qed. +#[global] Hint Resolve Ropp_le_ge_contravar: real. Lemma Ropp_ge_le_contravar : forall r1 r2, r1 >= r2 -> - r1 <= - r2. Proof. unfold Rle; intros r1 r2 [H| H]; auto with real. Qed. +#[global] Hint Resolve Ropp_ge_le_contravar: real. (**********) @@ -1130,6 +1198,7 @@ Lemma Ropp_le_contravar : forall r1 r2, r2 <= r1 -> - r1 <= - r2. Proof. intros r1 r2 H; elim H; auto with real. Qed. +#[global] Hint Resolve Ropp_le_contravar: real. Lemma Ropp_ge_contravar : forall r1 r2, r2 >= r1 -> - r1 >= - r2. @@ -1140,12 +1209,14 @@ Lemma Ropp_0_lt_gt_contravar : forall r, 0 < r -> 0 > - r. Proof. intros; replace 0 with (-0); auto with real. Qed. +#[global] Hint Resolve Ropp_0_lt_gt_contravar: real. Lemma Ropp_0_gt_lt_contravar : forall r, 0 > r -> 0 < - r. Proof. intros; replace 0 with (-0); auto with real. Qed. +#[global] Hint Resolve Ropp_0_gt_lt_contravar: real. (**********) @@ -1153,12 +1224,14 @@ Lemma Ropp_lt_gt_0_contravar : forall r, r > 0 -> - r < 0. Proof. intros; rewrite <- Ropp_0; auto with real. Qed. +#[global] Hint Resolve Ropp_lt_gt_0_contravar: real. Lemma Ropp_gt_lt_0_contravar : forall r, r < 0 -> - r > 0. Proof. intros; rewrite <- Ropp_0; auto with real. Qed. +#[global] Hint Resolve Ropp_gt_lt_0_contravar: real. (**********) @@ -1166,12 +1239,14 @@ Lemma Ropp_0_le_ge_contravar : forall r, 0 <= r -> 0 >= - r. Proof. intros; replace 0 with (-0); auto with real. Qed. +#[global] Hint Resolve Ropp_0_le_ge_contravar: real. Lemma Ropp_0_ge_le_contravar : forall r, 0 >= r -> 0 <= - r. Proof. intros; replace 0 with (-0); auto with real. Qed. +#[global] Hint Resolve Ropp_0_ge_le_contravar: real. (** *** Cancellation *) @@ -1182,6 +1257,7 @@ Proof. rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y); auto with real. Qed. +#[global] Hint Immediate Ropp_lt_cancel: real. Lemma Ropp_gt_cancel : forall r1 r2, - r2 > - r1 -> r1 > r2. @@ -1194,6 +1270,7 @@ Proof. intro H1; rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y); rewrite H1; auto with real. Qed. +#[global] Hint Immediate Ropp_le_cancel: real. Lemma Ropp_ge_cancel : forall r1 r2, - r2 >= - r1 -> r1 >= r2. @@ -1211,6 +1288,7 @@ Lemma Rmult_lt_compat_r : forall r r1 r2, 0 < r -> r1 < r2 -> r1 * r < r2 * r. Proof. intros; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r); auto with real. Qed. +#[global] Hint Resolve Rmult_lt_compat_r : core. Lemma Rmult_gt_compat_r : forall r r1 r2, r > 0 -> r1 > r2 -> r1 * r > r2 * r. @@ -1227,6 +1305,7 @@ Proof. auto with real. right; rewrite <- H; do 2 rewrite Rmult_0_l; reflexivity. Qed. +#[global] Hint Resolve Rmult_le_compat_l: real. Lemma Rmult_le_compat_r : @@ -1235,6 +1314,7 @@ Proof. intros r r1 r2 H; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r); auto with real. Qed. +#[global] Hint Resolve Rmult_le_compat_r: real. Lemma Rmult_ge_compat_l : @@ -1256,6 +1336,7 @@ Proof. apply Rmult_le_compat_l; auto. apply Rle_trans with z; auto. Qed. +#[global] Hint Resolve Rmult_le_compat: real. Lemma Rmult_ge_compat : @@ -1297,6 +1378,7 @@ Proof. do 2 rewrite (Ropp_mult_distr_l_reverse (- r)). apply Ropp_le_contravar; auto with real. Qed. +#[global] Hint Resolve Rmult_le_compat_neg_l: real. Lemma Rmult_le_ge_compat_neg_l : @@ -1304,6 +1386,7 @@ Lemma Rmult_le_ge_compat_neg_l : Proof. intros; apply Rle_ge; auto with real. Qed. +#[global] Hint Resolve Rmult_le_ge_compat_neg_l: real. Lemma Rmult_lt_gt_compat_neg_l : @@ -1368,6 +1451,7 @@ Proof. replace (r2 + (r1 - r2)) with r1 by ring. now rewrite Rplus_0_r. Qed. +#[global] Hint Resolve Rlt_minus: real. Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0. @@ -1436,6 +1520,7 @@ Proof. intros; apply not_eq_sym; apply Rlt_not_eq. rewrite Rplus_comm; replace 0 with (0 + 0); auto with real. Qed. +#[global] Hint Immediate tech_Rplus: real. (*********************************************************) @@ -1458,6 +1543,7 @@ Proof. replace 0 with (- r * 0); auto with real. replace 0 with (0 * r); auto with real. Qed. +#[global] Hint Resolve Rle_0_sqr Rlt_0_sqr: real. (***********) @@ -1485,6 +1571,7 @@ Proof. replace 1 with (Rsqr 1); auto with real. unfold Rsqr; auto with real. Qed. +#[global] Hint Resolve Rlt_0_1: real. Lemma Rle_0_1 : 0 <= 1. @@ -1504,6 +1591,7 @@ Proof. replace 1 with (r * / r); auto with real. replace 0 with (r * 0); auto with real. Qed. +#[global] Hint Resolve Rinv_0_lt_compat: real. (*********) @@ -1514,6 +1602,7 @@ Proof. replace 1 with (r * / r); auto with real. replace 0 with (r * 0); auto with real. Qed. +#[global] Hint Resolve Rinv_lt_0_compat: real. (*********) @@ -1543,6 +1632,7 @@ Proof. apply Rlt_dichotomy_converse; right. red; apply Rlt_trans with (r2 := x); auto with real. Qed. +#[global] Hint Resolve Rinv_1_lt_contravar: real. (*********************************************************) @@ -1556,6 +1646,7 @@ Proof. apply Rlt_le_trans with 1; auto with real. pattern 1 at 1; replace 1 with (0 + 1); auto with real. Qed. +#[global] Hint Resolve Rle_lt_0_plus_1: real. (**********) @@ -1564,6 +1655,7 @@ Proof. intros. pattern r at 1; replace r with (r + 0); auto with real. Qed. +#[global] Hint Resolve Rlt_plus_1: real. (**********) @@ -1598,6 +1690,7 @@ Proof. repeat rewrite S_INR. rewrite Hrecn; ring. Qed. +#[global] Hint Resolve plus_INR: real. (**********) @@ -1608,6 +1701,7 @@ Proof. intros; repeat rewrite S_INR; simpl. rewrite H0; ring. Qed. +#[global] Hint Resolve minus_INR: real. (*********) @@ -1618,6 +1712,7 @@ Proof. intros; repeat rewrite S_INR; simpl. rewrite plus_INR; rewrite Hrecn; ring. Qed. +#[global] Hint Resolve mult_INR: real. Lemma pow_INR (m n: nat) : INR (m ^ n) = pow (INR m) n. @@ -1629,6 +1724,7 @@ Proof. simple induction 1; intros; auto with real. rewrite S_INR; auto with real. Qed. +#[global] Hint Resolve lt_0_INR: real. Lemma lt_INR : forall n m:nat, (n < m)%nat -> INR n < INR m. @@ -1637,12 +1733,14 @@ Proof. rewrite S_INR; auto with real. rewrite S_INR; apply Rlt_trans with (INR m0); auto with real. Qed. +#[global] Hint Resolve lt_INR: real. Lemma lt_1_INR : forall n:nat, (1 < n)%nat -> 1 < INR n. Proof. apply lt_INR. Qed. +#[global] Hint Resolve lt_1_INR: real. (**********) @@ -1652,6 +1750,7 @@ Proof. simpl; auto with real. apply Pos2Nat.is_pos. Qed. +#[global] Hint Resolve pos_INR_nat_of_P: real. (**********) @@ -1661,6 +1760,7 @@ Proof. simpl; auto with real. auto with arith real. Qed. +#[global] Hint Resolve pos_INR: real. Lemma INR_lt : forall n m:nat, INR n < INR m -> (n < m)%nat. @@ -1676,6 +1776,7 @@ Proof. rewrite 2!S_INR in H. apply Rplus_lt_reg_r with (1 := H). Qed. +#[global] Hint Resolve INR_lt: real. (*********) @@ -1685,6 +1786,7 @@ Proof. rewrite S_INR. apply Rle_trans with (INR m0); auto with real. Qed. +#[global] Hint Resolve le_INR: real. (**********) @@ -1694,6 +1796,7 @@ Proof. apply H. rewrite H1; trivial. Qed. +#[global] Hint Immediate INR_not_0: real. (**********) @@ -1704,6 +1807,7 @@ Proof. intros; rewrite S_INR. apply Rgt_not_eq; red; auto with real. Qed. +#[global] Hint Resolve not_0_INR: real. Lemma not_INR : forall n m:nat, n <> m -> INR n <> INR m. @@ -1714,6 +1818,7 @@ Proof. exfalso; auto. apply not_eq_sym; apply Rlt_dichotomy_converse; auto with real. Qed. +#[global] Hint Resolve not_INR: real. Lemma INR_eq : forall n m:nat, INR n = INR m -> n = m. @@ -1730,6 +1835,7 @@ Proof. generalize (INR_lt n m H0); intro; auto with arith. generalize (INR_eq n m H0); intro; rewrite H1; auto. Qed. +#[global] Hint Resolve INR_le: real. Lemma not_1_INR : forall n:nat, n <> 1%nat -> INR n <> 1. @@ -1737,6 +1843,7 @@ Proof. intros n. apply not_INR. Qed. +#[global] Hint Resolve not_1_INR: real. (*********************************************************) @@ -1967,10 +2074,15 @@ Proof. intros; red; intro; elim H; apply eq_IZR; assumption. Qed. +#[global] Hint Extern 0 (IZR _ <= IZR _) => apply IZR_le, Zle_bool_imp_le, eq_refl : real. +#[global] Hint Extern 0 (IZR _ >= IZR _) => apply Rle_ge, IZR_le, Zle_bool_imp_le, eq_refl : real. +#[global] Hint Extern 0 (IZR _ < IZR _) => apply IZR_lt, eq_refl : real. +#[global] Hint Extern 0 (IZR _ > IZR _) => apply IZR_lt, eq_refl : real. +#[global] Hint Extern 0 (IZR _ <> IZR _) => apply IZR_neq, Zeq_bool_neq, eq_refl : real. Lemma one_IZR_lt1 : forall n:Z, -1 < IZR n < 1 -> n = 0%Z. diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index 338c939a06..f1c9eb8eee 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -119,6 +119,7 @@ Lemma Rplus_comm : forall r1 r2:R, r1 + r2 = r2 + r1. Proof. intros. apply Rquot1. do 2 rewrite Rrepr_plus. apply CReal_plus_comm. Qed. +#[global] Hint Resolve Rplus_comm: real. (**********) @@ -127,6 +128,7 @@ Proof. intros. apply Rquot1. repeat rewrite Rrepr_plus. apply CReal_plus_assoc. Qed. +#[global] Hint Resolve Rplus_assoc: real. (**********) @@ -135,6 +137,7 @@ Proof. intros. apply Rquot1. rewrite Rrepr_plus, Rrepr_opp, Rrepr_0. apply CReal_plus_opp_r. Qed. +#[global] Hint Resolve Rplus_opp_r: real. (**********) @@ -143,6 +146,7 @@ Proof. intros. apply Rquot1. rewrite Rrepr_plus, Rrepr_0. apply CReal_plus_0_l. Qed. +#[global] Hint Resolve Rplus_0_l: real. (***********************************************************) @@ -154,6 +158,7 @@ Lemma Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1. Proof. intros. apply Rquot1. do 2 rewrite Rrepr_mult. apply CReal_mult_comm. Qed. +#[global] Hint Resolve Rmult_comm: real. (**********) @@ -162,6 +167,7 @@ Proof. intros. apply Rquot1. repeat rewrite Rrepr_mult. apply CReal_mult_assoc. Qed. +#[global] Hint Resolve Rmult_assoc: real. (**********) @@ -171,6 +177,7 @@ Proof. - contradiction. - apply Rquot1. rewrite Rrepr_mult, Rquot2, Rrepr_1. apply CReal_inv_l. Qed. +#[global] Hint Resolve Rinv_l: real. (**********) @@ -179,6 +186,7 @@ Proof. intros. apply Rquot1. rewrite Rrepr_mult, Rrepr_1. apply CReal_mult_1_l. Qed. +#[global] Hint Resolve Rmult_1_l: real. (**********) @@ -197,6 +205,7 @@ Proof. pose proof (CRealLt_morph 0%CReal 0%CReal (CRealEq_refl _) 1%CReal 0%CReal H). apply (CRealLt_irrefl 0%CReal). apply H0. apply CRealLt_0_1. Qed. +#[global] Hint Resolve R1_neq_R0: real. (*********************************************************) @@ -211,6 +220,7 @@ Proof. rewrite Rrepr_mult, Rrepr_plus, Rrepr_plus, Rrepr_mult, Rrepr_mult. apply CReal_mult_plus_distr_l. Qed. +#[global] Hint Resolve Rmult_plus_distr_l: real. (*********************************************************) @@ -256,6 +266,7 @@ Proof. rewrite RbaseSymbolsImpl.Rlt_def in H0. apply CRealLtEpsilon. exact H0. Qed. +#[global] Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real. (**********************************************************) diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v index d64e635d0f..4aa6edb2c4 100644 --- a/theories/Reals/Rfunctions.v +++ b/theories/Reals/Rfunctions.v @@ -102,6 +102,7 @@ Proof. apply H; assumption. Qed. +#[global] Hint Resolve pow_O pow_1 pow_add pow_nonzero: real. Lemma pow_RN_plus : @@ -117,6 +118,7 @@ Proof. intros x n; elim n; simpl; auto with real. intros n0 H' H'0; replace 0 with (x * 0); auto with real. Qed. +#[global] Hint Resolve pow_lt: real. Lemma Rlt_pow_R1 : forall (x:R) (n:nat), 1 < x -> (0 < n)%nat -> 1 < x ^ n. @@ -132,6 +134,7 @@ Proof. apply Rlt_trans with (r2 := 1); auto with real. apply H'; auto with arith. Qed. +#[global] Hint Resolve Rlt_pow_R1: real. Lemma Rlt_pow : forall (x:R) (n m:nat), 1 < x -> (n < m)%nat -> x ^ n < x ^ m. @@ -153,6 +156,7 @@ Proof. rewrite le_plus_minus_r; auto with arith; rewrite <- plus_n_O; auto. rewrite plus_comm; auto with arith. Qed. +#[global] Hint Resolve Rlt_pow: real. (*********) @@ -628,6 +632,7 @@ Proof. rewrite pow_add; auto with real. apply Rinv_mult_distr; apply pow_nonzero; auto. Qed. +#[local] Hint Resolve powerRZ_O powerRZ_1 powerRZ_NOR powerRZ_add: real. Lemma Zpower_nat_powerRZ : @@ -661,12 +666,14 @@ Lemma powerRZ_lt : forall (x:R) (z:Z), 0 < x -> 0 < x ^Z z. Proof. intros x z; case z; simpl; auto with real. Qed. +#[local] Hint Resolve powerRZ_lt: real. Lemma powerRZ_le : forall (x:R) (z:Z), 0 < x -> 0 <= x ^Z z. Proof. intros x z H'; apply Rlt_le; auto with real. Qed. +#[local] Hint Resolve powerRZ_le: real. Lemma Zpower_nat_powerRZ_absolu : diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v index 7d0dffdd00..d0d633a0c4 100644 --- a/theories/Relations/Relation_Definitions.v +++ b/theories/Relations/Relation_Definitions.v @@ -68,10 +68,13 @@ Section Relation_Definition. End Relation_Definition. +#[global] Hint Unfold reflexive transitive antisymmetric symmetric: sets. +#[global] Hint Resolve Build_preorder Build_order Build_equivalence Build_PER preord_refl preord_trans ord_refl ord_trans ord_antisym equiv_refl equiv_trans equiv_sym per_sym per_trans: sets. +#[global] Hint Unfold inclusion same_relation commut: sets. diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v index f0f36149d1..520333332a 100644 --- a/theories/Relations/Relation_Operators.v +++ b/theories/Relations/Relation_Operators.v @@ -228,8 +228,11 @@ Section Lexicographic_Exponentiation. End Lexicographic_Exponentiation. +#[global] Hint Unfold transp union: sets. +#[global] Hint Resolve t_step rt_step rt_refl rst_step rst_refl: sets. +#[global] Hint Immediate rst_sym: sets. (* begin hide *) diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v index 68d200e189..430f35eecb 100644 --- a/theories/Sets/Classical_sets.v +++ b/theories/Sets/Classical_sets.v @@ -77,6 +77,7 @@ Section Ensembles_classical. Proof. unfold Subtract at 1; auto with sets. Qed. + #[local] Hint Resolve Subtract_intro : sets. Lemma Subtract_inv : @@ -123,5 +124,6 @@ Section Ensembles_classical. End Ensembles_classical. + #[global] Hint Resolve Strict_super_set_contains_new_element Subtract_intro not_SIncl_empty: sets. diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v index 5027679266..ae7cdc9a0f 100644 --- a/theories/Sets/Constructive_sets.v +++ b/theories/Sets/Constructive_sets.v @@ -140,6 +140,7 @@ Section Ensembles_facts. End Ensembles_facts. +#[global] Hint Resolve Singleton_inv Singleton_intro Add_intro1 Add_intro2 Intersection_inv Couple_inv Setminus_intro Strict_Included_intro Strict_Included_strict Noone_in_empty Inhabited_not_empty Add_not_Empty diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index face010746..581c16778d 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -92,6 +92,7 @@ Section Bounds. exists bsup : _, Lub X bsup) -> Conditionally_complete. End Bounds. +#[global] Hint Resolve Totally_ordered_definition Upper_Bound_definition Lower_Bound_definition Lub_definition Glb_definition Bottom_definition Definition_of_Complete Definition_of_Complete diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v index fb33f7834c..96fb070071 100644 --- a/theories/Sets/Ensembles.v +++ b/theories/Sets/Ensembles.v @@ -92,8 +92,10 @@ Section Ensembles. End Ensembles. +#[global] Hint Unfold In Included Same_set Strict_Included Add Setminus Subtract: sets. +#[global] Hint Resolve Union_introl Union_intror Intersection_intro In_singleton Couple_l Couple_r Triple_l Triple_m Triple_r Disjoint_intro Extensionality_Ensembles: sets. diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v index e8e2a66e98..683979be74 100644 --- a/theories/Sets/Finite_sets.v +++ b/theories/Sets/Finite_sets.v @@ -45,7 +45,9 @@ Section Ensembles_finis. End Ensembles_finis. +#[global] Hint Resolve Empty_is_finite Union_is_finite: sets. +#[global] Hint Resolve card_empty card_add: sets. Require Import Constructive_sets. diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v index 023eeaac9d..e83ff223f3 100644 --- a/theories/Sets/Image.v +++ b/theories/Sets/Image.v @@ -202,4 +202,5 @@ Section Image. End Image. +#[global] Hint Resolve Im_def image_empty finite_image: sets. diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v index b3d7ed0b7b..766f62af45 100644 --- a/theories/Sets/Infinite_sets.v +++ b/theories/Sets/Infinite_sets.v @@ -46,6 +46,7 @@ Section Approx. Defn_of_Approximant : Finite U X -> Included U X A -> Approximant A X. End Approx. +#[global] Hint Resolve Defn_of_Approximant : core. Section Infinite_sets. diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index 4d0cd1174c..3f3cade37d 100644 --- a/theories/Sets/Multiset.v +++ b/theories/Sets/Multiset.v @@ -187,7 +187,10 @@ End multiset_defs. Unset Implicit Arguments. +#[global] Hint Unfold meq multiplicity: datatypes. +#[global] Hint Resolve munion_empty_right munion_comm munion_ass meq_left meq_right munion_empty_left: datatypes. +#[global] Hint Immediate meq_sym: datatypes. diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 875afe3f44..879a7df608 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -53,7 +53,9 @@ Section Partial_orders. End Partial_orders. +#[global] Hint Unfold Carrier_of Rel_of Strict_Rel_of: sets. +#[global] Hint Resolve Definition_of_covers: sets. diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v index 96d04100b9..617836225c 100644 --- a/theories/Sets/Powerset.v +++ b/theories/Sets/Powerset.v @@ -38,12 +38,14 @@ Variable U : Type. Inductive Power_set (A:Ensemble U) : Ensemble (Ensemble U) := Definition_of_Power_set : forall X:Ensemble U, Included U X A -> In (Ensemble U) (Power_set A) X. +#[local] Hint Resolve Definition_of_Power_set : core. Theorem Empty_set_minimal : forall X:Ensemble U, Included U (Empty_set U) X. intro X; red. intros x H'; elim H'. Qed. +#[local] Hint Resolve Empty_set_minimal : core. Theorem Power_set_Inhabited : @@ -51,22 +53,26 @@ Theorem Power_set_Inhabited : intro X. apply Inhabited_intro with (Empty_set U); auto with sets. Qed. +#[local] Hint Resolve Power_set_Inhabited : core. Theorem Inclusion_is_an_order : Order (Ensemble U) (Included U). auto 6 with sets. Qed. +#[local] Hint Resolve Inclusion_is_an_order : core. Theorem Inclusion_is_transitive : Transitive (Ensemble U) (Included U). elim Inclusion_is_an_order; auto with sets. Qed. +#[local] Hint Resolve Inclusion_is_transitive : core. Definition Power_set_PO : Ensemble U -> PO (Ensemble U). intro A; try assumption. apply Definition_of_PO with (Power_set A) (Included U); auto with sets. Defined. +#[local] Hint Unfold Power_set_PO : core. Theorem Strict_Rel_is_Strict_Included : @@ -74,6 +80,7 @@ Theorem Strict_Rel_is_Strict_Included : (Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))). auto with sets. Qed. +#[local] Hint Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included : core. Lemma Strict_inclusion_is_transitive_with_inclusion : @@ -109,6 +116,7 @@ Theorem Empty_set_is_Bottom : forall A:Ensemble U, Bottom (Ensemble U) (Power_set_PO A) (Empty_set U). intro A; apply Bottom_definition; simpl; auto with sets. Qed. +#[local] Hint Resolve Empty_set_is_Bottom : core. Theorem Union_minimal : @@ -117,6 +125,7 @@ Theorem Union_minimal : intros a b X H' H'0; red. intros x H'1; elim H'1; auto with sets. Qed. +#[local] Hint Resolve Union_minimal : core. Theorem Intersection_maximal : @@ -144,6 +153,7 @@ Theorem Intersection_decreases_r : intros a b; red. intros x H'; elim H'; auto with sets. Qed. +#[local] Hint Resolve Union_increases_l Union_increases_r Intersection_decreases_l Intersection_decreases_r : core. @@ -177,14 +187,25 @@ Qed. End The_power_set_partial_order. +#[global] Hint Resolve Empty_set_minimal: sets. +#[global] Hint Resolve Power_set_Inhabited: sets. +#[global] Hint Resolve Inclusion_is_an_order: sets. +#[global] Hint Resolve Inclusion_is_transitive: sets. +#[global] Hint Resolve Union_minimal: sets. +#[global] Hint Resolve Union_increases_l: sets. +#[global] Hint Resolve Union_increases_r: sets. +#[global] Hint Resolve Intersection_decreases_l: sets. +#[global] Hint Resolve Intersection_decreases_r: sets. +#[global] Hint Resolve Empty_set_is_Bottom: sets. +#[global] Hint Resolve Strict_inclusion_is_transitive: sets. diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v index b83485bbf3..0fe63c5b66 100644 --- a/theories/Sets/Powerset_Classical_facts.v +++ b/theories/Sets/Powerset_Classical_facts.v @@ -92,6 +92,7 @@ Section Sets_as_an_algebra. apply Subtract_intro; auto with sets. red; intro H'1; apply H'; rewrite H'1; auto with sets. Qed. + #[local] Hint Resolve incl_soustr_add_r: sets. Lemma add_soustr_2 : @@ -330,9 +331,15 @@ Section Sets_as_an_algebra. End Sets_as_an_algebra. +#[global] Hint Resolve incl_soustr_in: sets. +#[global] Hint Resolve incl_soustr: sets. +#[global] Hint Resolve incl_soustr_add_l: sets. +#[global] Hint Resolve incl_soustr_add_r: sets. +#[global] Hint Resolve add_soustr_1 add_soustr_2: sets. +#[global] Hint Resolve add_soustr_xy: sets. diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v index 69b28f14e4..b21c48d305 100644 --- a/theories/Sets/Powerset_facts.v +++ b/theories/Sets/Powerset_facts.v @@ -348,6 +348,7 @@ Section Sets_as_an_algebra. End Sets_as_an_algebra. +#[global] Hint Resolve Empty_set_zero Empty_set_zero' Union_associative Union_add singlx incl_add: sets. diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v index 42755b551f..1167ad36bf 100644 --- a/theories/Sets/Relations_1.v +++ b/theories/Sets/Relations_1.v @@ -61,7 +61,9 @@ Section Relations_1. Definition_of_PER : Symmetric -> Transitive -> PER. End Relations_1. +#[global] Hint Unfold Reflexive Transitive Antisymmetric Symmetric contains same_relation: sets. +#[global] Hint Resolve Definition_of_preorder Definition_of_order Definition_of_equivalence Definition_of_PER: sets. diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v index 21fc7ceaf2..6d7b837b63 100644 --- a/theories/Sets/Relations_1_facts.v +++ b/theories/Sets/Relations_1_facts.v @@ -52,6 +52,7 @@ apply Definition_of_equivalence. split; apply H'1 with y; auto 10 with sets. - red; intros x y h; elim h; intros H'3 H'4; auto 10 with sets. Qed. +#[global] Hint Resolve Equiv_from_preorder : core. Theorem Equiv_from_order : @@ -60,6 +61,7 @@ Theorem Equiv_from_order : Proof. intros U R H'; elim H'; auto 10 with sets. Qed. +#[global] Hint Resolve Equiv_from_order : core. Theorem contains_is_preorder : @@ -67,6 +69,7 @@ Theorem contains_is_preorder : Proof. auto 10 with sets. Qed. +#[global] Hint Resolve contains_is_preorder : core. Theorem same_relation_is_equivalence : @@ -74,6 +77,7 @@ Theorem same_relation_is_equivalence : Proof. unfold same_relation at 1; auto 10 with sets. Qed. +#[global] Hint Resolve same_relation_is_equivalence : core. Theorem cong_reflexive_same_relation : diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v index 5e3206dd9b..e180798d1f 100644 --- a/theories/Sets/Relations_2.v +++ b/theories/Sets/Relations_2.v @@ -50,7 +50,11 @@ Definition Strongly_confluent : Prop := End Relations_2. +#[global] Hint Resolve Rstar_0: sets. +#[global] Hint Resolve Rstar1_0: sets. +#[global] Hint Resolve Rstar1_1: sets. +#[global] Hint Resolve Rplus_0: sets. diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v index 9ebbba485c..d5c4040033 100644 --- a/theories/Sets/Relations_3.v +++ b/theories/Sets/Relations_3.v @@ -53,10 +53,16 @@ Section Relations_3. Definition Noetherian : Prop := forall x:U, noetherian x. End Relations_3. +#[global] Hint Unfold coherent: sets. +#[global] Hint Unfold locally_confluent: sets. +#[global] Hint Unfold confluent: sets. +#[global] Hint Unfold Confluent: sets. +#[global] Hint Resolve definition_of_noetherian: sets. +#[global] Hint Unfold Noetherian: sets. diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v index db51186ef1..9f4869a625 100644 --- a/theories/Sets/Relations_3_facts.v +++ b/theories/Sets/Relations_3_facts.v @@ -38,6 +38,7 @@ Proof. intros U R x y H'; red. exists y; auto with sets. Qed. +#[global] Hint Resolve Rstar_imp_coherent : core. Theorem coherent_symmetric : diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v index 474b417e8e..d8fe7f6dbe 100644 --- a/theories/Sets/Uniset.v +++ b/theories/Sets/Uniset.v @@ -41,20 +41,24 @@ Definition Singleton (a:A) := end). Definition In (s:uniset) (a:A) : Prop := charac s a = true. +#[local] Hint Unfold In : core. (** uniset inclusion *) Definition incl (s1 s2:uniset) := forall a:A, Bool.le (charac s1 a) (charac s2 a). +#[local] Hint Unfold incl : core. (** uniset equality *) Definition seq (s1 s2:uniset) := forall a:A, charac s1 a = charac s2 a. +#[local] Hint Unfold seq : core. Lemma le_refl : forall b, Bool.le b b. Proof. destruct b; simpl; auto. Qed. +#[local] Hint Resolve le_refl : core. Lemma incl_left : forall s1 s2:uniset, seq s1 s2 -> incl s1 s2. @@ -71,6 +75,7 @@ Lemma seq_refl : forall x:uniset, seq x x. Proof. destruct x; unfold seq; auto. Qed. +#[local] Hint Resolve seq_refl : core. Lemma seq_trans : forall x y z:uniset, seq x y -> seq y z -> seq x z. @@ -94,6 +99,7 @@ Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x). Proof. unfold seq; unfold union; simpl; auto. Qed. +#[local] Hint Resolve union_empty_left : core. Lemma union_empty_right : forall x:uniset, seq x (union x Emptyset). @@ -101,6 +107,7 @@ Proof. unfold seq; unfold union; simpl. intros x a; rewrite (orb_b_false (charac x a)); auto. Qed. +#[local] Hint Resolve union_empty_right : core. Lemma union_comm : forall x y:uniset, seq (union x y) (union y x). @@ -108,6 +115,7 @@ Proof. unfold seq; unfold charac; unfold union. destruct x; destruct y; auto with bool. Qed. +#[local] Hint Resolve union_comm : core. Lemma union_ass : @@ -116,6 +124,7 @@ Proof. unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z; auto with bool. Qed. +#[local] Hint Resolve union_ass : core. Lemma seq_left : forall x y z:uniset, seq x y -> seq (union x z) (union y z). @@ -124,6 +133,7 @@ unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z. intros; elim H; auto. Qed. +#[local] Hint Resolve seq_left : core. Lemma seq_right : forall x y z:uniset, seq x y -> seq (union z x) (union z y). @@ -132,6 +142,7 @@ unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z. intros; elim H; auto. Qed. +#[local] Hint Resolve seq_right : core. diff --git a/theories/Sorting/CPermutation.v b/theories/Sorting/CPermutation.v index 31d9f7f0ed..cebb0c808c 100644 --- a/theories/Sorting/CPermutation.v +++ b/theories/Sorting/CPermutation.v @@ -96,6 +96,7 @@ Qed. End CPermutation. +#[global] Hint Resolve CPermutation_refl : core. (* These hints do not reduce the size of the problem to solve and they diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index 1130c9dd76..05a21620b7 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -36,7 +36,9 @@ Section defs. Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z. Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y. + #[local] Hint Resolve leA_refl : core. + #[local] Hint Immediate eqA_dec leA_dec leA_antisym : core. Let emptyBag := EmptyBag A. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 2f445c341a..45fb48ad5d 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -76,6 +76,7 @@ Qed. End Permutation. +#[global] Hint Resolve Permutation_refl perm_nil perm_skip : core. (* These hints do not reduce the size of the problem to solve and they diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v index 8cba461082..206eb606d2 100644 --- a/theories/Sorting/Sorted.v +++ b/theories/Sorting/Sorted.v @@ -137,7 +137,9 @@ Section defs. End defs. +#[global] Hint Constructors HdRel : core. +#[global] Hint Constructors Sorted : core. (* begin hide *) diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v index 0c3bd9393b..c923b503a7 100644 --- a/theories/Structures/DecidableType.v +++ b/theories/Structures/DecidableType.v @@ -38,7 +38,9 @@ Module KeyDecidableType(D:DecidableType). Definition eqke (p p':key*elt) := eq (fst p) (fst p') /\ (snd p) = (snd p'). + #[local] Hint Unfold eqk eqke : core. + #[local] Hint Extern 2 (eqke ?a ?b) => split : core. (* eqke is stricter than eqk *) @@ -70,7 +72,9 @@ Module KeyDecidableType(D:DecidableType). unfold eqke; intuition; [ eauto | congruence ]. Qed. + #[local] Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. + #[local] Hint Immediate eqk_sym eqke_sym : core. Global Instance eqk_equiv : Equivalence eqk. @@ -84,6 +88,7 @@ Module KeyDecidableType(D:DecidableType). Proof. unfold eqke; induction 1; intuition. Qed. + #[local] Hint Resolve InA_eqke_eqk : core. Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. @@ -94,6 +99,7 @@ Module KeyDecidableType(D:DecidableType). Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). Definition In k m := exists e:elt, MapsTo k e m. + #[local] Hint Unfold MapsTo In : core. (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) @@ -140,12 +146,19 @@ Module KeyDecidableType(D:DecidableType). End Elt. + #[global] Hint Unfold eqk eqke : core. + #[global] Hint Extern 2 (eqke ?a ?b) => split : core. + #[global] Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. + #[global] Hint Immediate eqk_sym eqke_sym : core. + #[global] Hint Resolve InA_eqke_eqk : core. + #[global] Hint Unfold MapsTo In : core. + #[global] Hint Resolve In_inv_2 In_inv_3 : core. End KeyDecidableType. diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v index 914361d718..7cd5943a3f 100644 --- a/theories/Structures/Equalities.v +++ b/theories/Structures/Equalities.v @@ -53,7 +53,9 @@ Module Type IsEqOrig (Import E:Eq'). Axiom eq_refl : forall x : t, x==x. Axiom eq_sym : forall x y : t, x==y -> y==x. Axiom eq_trans : forall x y z : t, x==y -> y==z -> x==z. + #[global] Hint Immediate eq_sym : core. + #[global] Hint Resolve eq_refl eq_trans : core. End IsEqOrig. diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v index fe9794de8a..523240065d 100644 --- a/theories/Structures/EqualitiesFacts.v +++ b/theories/Structures/EqualitiesFacts.v @@ -22,6 +22,7 @@ Module KeyDecidableType(D:DecidableType). Definition eqk {elt} : relation (key*elt) := D.eq @@1. Definition eqke {elt} : relation (key*elt) := D.eq * Logic.eq. + #[global] Hint Unfold eqk eqke : core. (** eqk, eqke are equalities *) @@ -60,6 +61,7 @@ Module KeyDecidableType(D:DecidableType). Lemma eqk_1 {elt} k k' (e e':elt) : eqk (k,e) (k',e') -> D.eq k k'. Proof. trivial. Qed. + #[global] Hint Resolve eqke_1 eqke_2 eqk_1 : core. (* Additional facts *) @@ -69,6 +71,7 @@ Module KeyDecidableType(D:DecidableType). Proof. induction 1; firstorder. Qed. + #[global] Hint Resolve InA_eqke_eqk : core. Lemma InA_eqk_eqke {elt} p (m:list (key*elt)) : @@ -86,6 +89,7 @@ Module KeyDecidableType(D:DecidableType). Definition MapsTo {elt} (k:key)(e:elt):= InA eqke (k,e). Definition In {elt} k m := exists e:elt, MapsTo k e m. + #[global] Hint Unfold MapsTo In : core. (* Alternative formulations for [In k l] *) @@ -167,8 +171,11 @@ Module KeyDecidableType(D:DecidableType). eauto with *. Qed. + #[global] Hint Extern 2 (eqke ?a ?b) => split : core. + #[global] Hint Resolve InA_eqke_eqk : core. + #[global] Hint Resolve In_inv_2 In_inv_3 : core. End KeyDecidableType. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index ecf0706a4f..dc7a48cd6b 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -44,7 +44,9 @@ Module Type MiniOrderedType. Parameter compare : forall x y : t, Compare lt eq x y. + #[global] Hint Immediate eq_sym : ordered_type. + #[global] Hint Resolve eq_refl eq_trans lt_not_eq lt_trans : ordered_type. End MiniOrderedType. @@ -144,8 +146,11 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma eq_not_gt x y : eq x y -> ~ lt y x. Proof. order. Qed. Lemma lt_not_gt x y : lt x y -> ~ lt y x. Proof. order. Qed. + #[global] Hint Resolve gt_not_eq eq_not_lt : ordered_type. + #[global] Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq : ordered_type. + #[global] Hint Resolve eq_not_gt lt_antirefl lt_not_gt : ordered_type. Lemma elim_compare_eq : @@ -248,7 +253,9 @@ Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat). Qed. End ForNotations. +#[global] Hint Resolve ListIn_In Sort_NoDup Inf_lt : ordered_type. +#[global] Hint Immediate In_eq Inf_lt : ordered_type. End OrderedTypeFacts. @@ -267,7 +274,9 @@ Module KeyOrderedType(O:OrderedType). eq (fst p) (fst p') /\ (snd p) = (snd p'). Definition ltk (p p':key*elt) := lt (fst p) (fst p'). + #[local] Hint Unfold eqk eqke ltk : ordered_type. + #[local] Hint Extern 2 (eqke ?a ?b) => split : ordered_type. (* eqke is stricter than eqk *) @@ -284,6 +293,7 @@ Module KeyOrderedType(O:OrderedType). Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. Proof. auto. Qed. + #[local] Hint Immediate ltk_right_r ltk_right_l : ordered_type. (* eqk, eqke are equalities, ltk is a strict order *) @@ -320,8 +330,11 @@ Module KeyOrderedType(O:OrderedType). exact (lt_not_eq H H1). Qed. + #[local] Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : ordered_type. + #[local] Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : ordered_type. + #[local] Hint Immediate eqk_sym eqke_sym : ordered_type. Global Instance eqk_equiv : Equivalence eqk. @@ -360,7 +373,9 @@ Module KeyOrderedType(O:OrderedType). intros (k,e) (k',e') (k'',e''). unfold ltk, eqk; simpl; eauto with ordered_type. Qed. + #[local] Hint Resolve eqk_not_ltk : ordered_type. + #[local] Hint Immediate ltk_eqk eqk_ltk : ordered_type. Lemma InA_eqke_eqk : @@ -368,6 +383,7 @@ Module KeyOrderedType(O:OrderedType). Proof. unfold eqke; induction 1; intuition. Qed. + #[local] Hint Resolve InA_eqke_eqk : ordered_type. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). @@ -375,6 +391,7 @@ Module KeyOrderedType(O:OrderedType). Notation Sort := (sort ltk). Notation Inf := (lelistA ltk). + #[local] Hint Unfold MapsTo In : ordered_type. (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) @@ -406,7 +423,9 @@ Module KeyOrderedType(O:OrderedType). Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. Proof. exact (InfA_ltA ltk_strorder). Qed. + #[local] Hint Immediate Inf_eq : ordered_type. + #[local] Hint Resolve Inf_lt : ordered_type. Lemma Sort_Inf_In : @@ -470,18 +489,31 @@ Module KeyOrderedType(O:OrderedType). End Elt. + #[global] Hint Unfold eqk eqke ltk : ordered_type. + #[global] Hint Extern 2 (eqke ?a ?b) => split : ordered_type. + #[global] Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : ordered_type. + #[global] Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : ordered_type. + #[global] Hint Immediate eqk_sym eqke_sym : ordered_type. + #[global] Hint Resolve eqk_not_ltk : ordered_type. + #[global] Hint Immediate ltk_eqk eqk_ltk : ordered_type. + #[global] Hint Resolve InA_eqke_eqk : ordered_type. + #[global] Hint Unfold MapsTo In : ordered_type. + #[global] Hint Immediate Inf_eq : ordered_type. + #[global] Hint Resolve Inf_lt : ordered_type. + #[global] Hint Resolve Sort_Inf_NotIn : ordered_type. + #[global] Hint Resolve In_inv_2 In_inv_3 : ordered_type. End KeyOrderedType. diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v index b3e3b6e853..b4ddd0b262 100644 --- a/theories/Structures/Orders.v +++ b/theories/Structures/Orders.v @@ -181,6 +181,7 @@ Module OTF_to_TotalOrder (O:OrderedTypeFull) <: TotalOrder we coerce [bool] into [Prop]. *) Local Coercion is_true : bool >-> Sortclass. +#[global] Hint Unfold is_true : core. Module Type HasLeb (Import T:Typ). diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v index 3a5dbc2f88..bace70cbee 100644 --- a/theories/Structures/OrdersLists.v +++ b/theories/Structures/OrdersLists.v @@ -50,7 +50,9 @@ Proof. exact (InfA_alt O.eq_equiv O.lt_strorder O.lt_compat). Qed. Lemma Sort_NoDup : forall l, Sort l -> NoDup l. Proof. exact (SortA_NoDupA O.eq_equiv O.lt_strorder O.lt_compat) . Qed. +#[global] Hint Resolve ListIn_In Sort_NoDup Inf_lt : core. +#[global] Hint Immediate In_eq Inf_lt : core. End OrderedTypeLists. @@ -66,6 +68,7 @@ Module KeyOrderedType(O:OrderedType). Definition ltk {elt} : relation (key*elt) := O.lt @@1. + #[global] Hint Unfold ltk : core. (* ltk is a strict order *) @@ -109,7 +112,9 @@ Module KeyOrderedType(O:OrderedType). Lemma Inf_lt l x x' : ltk x x' -> Inf x' l -> Inf x l. Proof. apply InfA_ltA; auto with *. Qed. + #[local] Hint Immediate Inf_eq : core. + #[local] Hint Resolve Inf_lt : core. Lemma Sort_Inf_In l p q : Sort l -> Inf q l -> InA eqk p l -> ltk q p. @@ -148,9 +153,13 @@ Module KeyOrderedType(O:OrderedType). End Elt. + #[global] Hint Resolve ltk_not_eqk ltk_not_eqke : core. + #[global] Hint Immediate Inf_eq : core. + #[global] Hint Resolve Inf_lt : core. + #[global] Hint Resolve Sort_Inf_NotIn : core. End KeyOrderedType. diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index a154a2b269..3799ffaca9 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -279,27 +279,32 @@ Section SCANNING. Inductive Forall {A} (P: A -> Prop): forall {n} (v: t A n), Prop := |Forall_nil: Forall P [] |Forall_cons {n} x (v: t A n): P x -> Forall P v -> Forall P (x::v). +#[local] Hint Constructors Forall : core. Inductive Exists {A} (P:A->Prop): forall {n}, t A n -> Prop := |Exists_cons_hd {m} x (v: t A m): P x -> Exists P (x::v) |Exists_cons_tl {m} x (v: t A m): Exists P v -> Exists P (x::v). +#[local] Hint Constructors Exists : core. Inductive In {A} (a:A): forall {n}, t A n -> Prop := |In_cons_hd {m} (v: t A m): In a (a::v) |In_cons_tl {m} x (v: t A m): In a v -> In a (x::v). +#[local] Hint Constructors In : core. Inductive Forall2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop := |Forall2_nil: Forall2 P [] [] |Forall2_cons {m} x1 x2 (v1:t A m) v2: P x1 x2 -> Forall2 P v1 v2 -> Forall2 P (x1::v1) (x2::v2). +#[local] Hint Constructors Forall2 : core. Inductive Exists2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop := |Exists2_cons_hd {m} x1 x2 (v1: t A m) (v2: t B m): P x1 x2 -> Exists2 P (x1::v1) (x2::v2) |Exists2_cons_tl {m} x1 x2 (v1:t A m) v2: Exists2 P v1 v2 -> Exists2 P (x1::v1) (x2::v2). +#[local] Hint Constructors Exists2 : core. End SCANNING. diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v index 474836d53d..cafa849b1b 100644 --- a/theories/Wellfounded/Inclusion.v +++ b/theories/Wellfounded/Inclusion.v @@ -22,6 +22,7 @@ Section WfInclusion. apply Acc_intro; auto with sets. Qed. + #[local] Hint Resolve Acc_incl : core. Theorem wf_incl : inclusion A R1 R2 -> well_founded R2 -> well_founded R1. diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v index 2d139504f3..49c2dd8602 100644 --- a/theories/Wellfounded/Transitive_Closure.v +++ b/theories/Wellfounded/Transitive_Closure.v @@ -31,6 +31,7 @@ Section Wf_Transitive_Closure. apply Acc_inv with y; auto with sets. Defined. + #[local] Hint Resolve Acc_clos_trans : core. Lemma Acc_inv_trans : forall x y:A, trans_clos y x -> Acc R x -> Acc R y. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 52998c8b95..47137414dc 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1754,6 +1754,7 @@ Proof. congruence. Qed. Lemma Zpos_eq_iff : forall p q, p = q <-> Z.pos p = Z.pos q. Proof (fun p q => iff_sym (Pos2Z.inj_iff p q)). +#[global] Hint Immediate Zsucc_pred: zarith. (* Not kept : diff --git a/theories/ZArith/ZArith_base.v b/theories/ZArith/ZArith_base.v index 26cd3e1e4d..cae918b4b6 100644 --- a/theories/ZArith/ZArith_base.v +++ b/theories/ZArith/ZArith_base.v @@ -30,6 +30,7 @@ Require Export Zbool. Require Export Zmisc. Require Export Wf_Z. +#[global] Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l Z.add_0_r Z.mul_1_l Z.add_opp_diag_l Z.add_opp_diag_r Z.mul_add_distr_l Z.mul_add_distr_r: zarith. diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index 2039dc0bee..13adda412d 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -75,6 +75,7 @@ Proof. + apply Pos2Z.neg_is_nonpos. Qed. +#[global] Hint Unfold Remainder : core. (** Now comes the fully general result about Euclidean division. *) @@ -203,6 +204,7 @@ Proof. intros a. zero_or_not a. apply Z.mod_1_r. Qed. Lemma Zdiv_1_r: forall a, a/1 = a. Proof. intros a. zero_or_not a. apply Z.div_1_r. Qed. +#[global] Hint Resolve Zmod_0_l Zmod_0_r Zdiv_0_l Zdiv_0_r Zdiv_1_r Zmod_1_r : zarith. diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v index 0448bcf41b..d3a9d7baac 100644 --- a/theories/ZArith/Zeven.v +++ b/theories/ZArith/Zeven.v @@ -130,6 +130,7 @@ Proof. boolify_even_odd. now rewrite Z.odd_pred. Qed. +#[global] Hint Unfold Zeven Zodd: zarith. Notation Zeven_bool_succ := Z.even_succ (only parsing). diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v index 95266186eb..80073bdbdf 100644 --- a/theories/ZArith/Zhints.v +++ b/theories/ZArith/Zhints.v @@ -40,6 +40,7 @@ Require Import Wf_Z. (** No subgoal or smaller subgoals *) +#[global] Hint Resolve (** ** Reversible simplification lemmas (no loss of information) *) (** Should clearly be declared as hints *) diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index cad9454906..861c204ab8 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -65,8 +65,11 @@ Proof. apply Z.divide_abs_l. Qed. Theorem Zdivide_Zabs_inv_l a b : (a | b) -> (Z.abs a | b). Proof. apply Z.divide_abs_l. Qed. +#[global] Hint Resolve Z.divide_refl Z.divide_1_l Z.divide_0_r: zarith. +#[global] Hint Resolve Z.mul_divide_mono_l Z.mul_divide_mono_r: zarith. +#[global] Hint Resolve Z.divide_add_r Zdivide_opp_r Zdivide_opp_r_rev Zdivide_opp_l Zdivide_opp_l_rev Z.divide_sub_r Z.divide_mul_l Z.divide_mul_r Z.divide_factor_l Z.divide_factor_r: zarith. @@ -236,6 +239,7 @@ Proof. intros; apply Zis_gcd_opp; apply Zis_gcd_0; auto. Qed. +#[global] Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith. Theorem Zis_gcd_unique: forall a b c d : Z, @@ -646,6 +650,7 @@ Proof. - absurd (p | a); intuition. Qed. +#[global] Hint Resolve prime_rel_prime: zarith. (** As a consequence, a prime number is relatively prime with smaller numbers *) @@ -866,6 +871,7 @@ Notation Zgcd_Zabs := Z.gcd_abs_l (only parsing). Notation Zgcd_0 := Z.gcd_0_r (only parsing). Notation Zgcd_1 := Z.gcd_1_r (only parsing). +#[global] Hint Resolve Z.gcd_0_r Z.gcd_1_r : zarith. Theorem Zgcd_1_rel_prime : forall a b, diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 949a01860f..4c533ac458 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -132,6 +132,7 @@ Register not_Zne as plugins.omega.not_Zne. Notation Zeq_le := Z.eq_le_incl (only parsing). +#[global] Hint Resolve Z.le_refl: zarith. (** Antisymmetry *) @@ -196,6 +197,7 @@ Proof. Z.swap_greater. Z.order. Qed. +#[global] Hint Resolve Z.le_trans: zarith. (** * Compatibility of order and operations on Z *) @@ -219,6 +221,7 @@ Proof. Z.swap_greater. apply Z.succ_lt_mono. Qed. +#[global] Hint Resolve Zsucc_le_compat: zarith. (** Simplification of successor wrt to order *) @@ -302,7 +305,9 @@ Proof. intros. now apply Z.lt_le_incl, Z.le_succ_l. Qed. +#[global] Hint Resolve Z.le_succ_diag_r: zarith. +#[global] Hint Resolve Z.le_le_succ_r: zarith. (** Relating order wrt successor and order wrt predecessor *) @@ -357,6 +362,7 @@ Proof. intros n; induction n; simpl; intros. apply Z.le_refl. easy. Qed. +#[global] Hint Immediate Z.eq_le_incl: zarith. (** Derived lemma *) diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v index c36ddad823..b69af424b1 100644 --- a/theories/ZArith/Zpow_facts.v +++ b/theories/ZArith/Zpow_facts.v @@ -57,6 +57,7 @@ Proof. apply Z.pow_gt_1. Qed. Theorem Zmult_power p q r : 0 <= r -> (p*q)^r = p^r * q^r. Proof. intros. apply Z.pow_mul_l. Qed. +#[global] Hint Resolve Z.pow_nonneg Z.pow_pos_nonneg : zarith. Theorem Zpower_le_monotone3 a b c : diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v index ae12295ca4..6f464d89bb 100644 --- a/theories/ZArith/Zpower.v +++ b/theories/ZArith/Zpower.v @@ -79,7 +79,9 @@ Proof. now apply (Z.pow_add_r z (Zpos n) (Zpos m)). Qed. +#[global] Hint Immediate Zpower_nat_is_exp Zpower_pos_is_exp : zarith. +#[global] Hint Unfold Z.pow_pos Zpower_nat: zarith. Theorem Zpower_exp x n m : @@ -226,7 +228,9 @@ Section Powers_of_2. End Powers_of_2. +#[global] Hint Resolve two_p_gt_ZERO: zarith. +#[global] Hint Immediate two_p_pred two_p_S: zarith. Section power_div_with_rest. diff --git a/theories/ZArith/Zquot.v b/theories/ZArith/Zquot.v index f95831436a..943376ecfd 100644 --- a/theories/ZArith/Zquot.v +++ b/theories/ZArith/Zquot.v @@ -57,6 +57,7 @@ Proof. now destruct a. Qed. Lemma Zquot_0_l a : 0÷a = 0. Proof. now destruct a. Qed. +#[global] Hint Resolve Zrem_0_l Zrem_0_r Zquot_0_l Zquot_0_r Z.quot_1_r Z.rem_1_r : zarith. diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v index 2ff6805c78..81d2a2d70d 100644 --- a/theories/ZArith/Zwf.v +++ b/theories/ZArith/Zwf.v @@ -57,6 +57,7 @@ Section wf_proof. End wf_proof. +#[global] Hint Resolve Zwf_well_founded: datatypes. @@ -87,4 +88,5 @@ Section wf_proof_up. End wf_proof_up. +#[global] Hint Resolve Zwf_up_well_founded: datatypes. diff --git a/theories/btauto/Algebra.v b/theories/btauto/Algebra.v index 4a603f2c52..08bb49a449 100644 --- a/theories/btauto/Algebra.v +++ b/theories/btauto/Algebra.v @@ -10,6 +10,7 @@ end. Arguments decide P /H. +#[global] Hint Extern 5 => progress bool : core. Ltac define t x H := @@ -147,6 +148,7 @@ Qed. (** * The core reflexive part. *) +#[local] Hint Constructors valid : core. Fixpoint beq_poly pl pr := @@ -315,6 +317,7 @@ Section Validity. (* Decision procedure of validity *) +#[local] Hint Constructors valid linear : core. Lemma valid_le_compat : forall k l p, valid k p -> (k <= l)%positive -> valid l p. @@ -414,6 +417,7 @@ intros pl; induction pl; intros pr var; simpl. rewrite poly_add_compat, poly_mul_mon_compat, IHpl1, IHpl2; ring. Qed. +#[local] Hint Extern 5 => match goal with | [ |- (Pos.max ?x ?y <= ?z)%positive ] => @@ -426,8 +430,10 @@ match goal with apply Pos.max_case_strong; intros; lia | _ => lia end : core. +#[local] Hint Resolve Pos.le_max_r Pos.le_max_l : core. +#[local] Hint Constructors valid linear : core. (* Compatibility of validity w.r.t algebraic operations *) diff --git a/theories/btauto/Reflect.v b/theories/btauto/Reflect.v index 867fe69550..a653b94d1c 100644 --- a/theories/btauto/Reflect.v +++ b/theories/btauto/Reflect.v @@ -77,9 +77,11 @@ intros var f; induction f; simpl poly_of_formula; simpl formula_eval; auto. end. Qed. +#[local] Hint Extern 5 => change 0 with (min 0 0) : core. Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat : core. Local Hint Constructors valid : core. +#[local] Hint Extern 5 => lia : core. (* Compatibility with validity *) diff --git a/theories/micromega/Tauto.v b/theories/micromega/Tauto.v index 99af214396..ce12b02359 100644 --- a/theories/micromega/Tauto.v +++ b/theories/micromega/Tauto.v @@ -1562,6 +1562,7 @@ Section S. auto. Qed. + #[local] Hint Resolve no_middle_eval_tt : tauto. Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') <-> eval_clause env cl \/ eval_clause env cl'. @@ -1702,6 +1703,7 @@ Section S. intros k; destruct k ; simpl; auto. Qed. + #[local] Hint Resolve hold_eTT : tauto. Lemma hold_eFF : forall k, @@ -1710,6 +1712,7 @@ Section S. intros k; destruct k ; simpl;auto. Qed. + #[local] Hint Resolve hold_eFF : tauto. Lemma hold_eAND : forall k r1 r2, diff --git a/theories/micromega/ZArith_hints.v b/theories/micromega/ZArith_hints.v index a6d3d92a99..3545e8b218 100644 --- a/theories/micromega/ZArith_hints.v +++ b/theories/micromega/ZArith_hints.v @@ -10,34 +10,56 @@ Require Import Lia. Import ZArith_base. +#[global] Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l Z.add_0_r Z.mul_1_l Z.add_opp_diag_l Z.add_opp_diag_r Z.mul_add_distr_r Z.mul_add_distr_l: zarith. Require Export Zhints. +#[global] Hint Extern 10 (_ = _ :>nat) => abstract lia: zarith. +#[global] Hint Extern 10 (_ <= _) => abstract lia: zarith. +#[global] Hint Extern 10 (_ < _) => abstract lia: zarith. +#[global] Hint Extern 10 (_ >= _) => abstract lia: zarith. +#[global] Hint Extern 10 (_ > _) => abstract lia: zarith. +#[global] Hint Extern 10 (_ <> _ :>nat) => abstract lia: zarith. +#[global] Hint Extern 10 (~ _ <= _) => abstract lia: zarith. +#[global] Hint Extern 10 (~ _ < _) => abstract lia: zarith. +#[global] Hint Extern 10 (~ _ >= _) => abstract lia: zarith. +#[global] Hint Extern 10 (~ _ > _) => abstract lia: zarith. +#[global] Hint Extern 10 (_ = _ :>Z) => abstract lia: zarith. +#[global] Hint Extern 10 (_ <= _)%Z => abstract lia: zarith. +#[global] Hint Extern 10 (_ < _)%Z => abstract lia: zarith. +#[global] Hint Extern 10 (_ >= _)%Z => abstract lia: zarith. +#[global] Hint Extern 10 (_ > _)%Z => abstract lia: zarith. +#[global] Hint Extern 10 (_ <> _ :>Z) => abstract lia: zarith. +#[global] Hint Extern 10 (~ (_ <= _)%Z) => abstract lia: zarith. +#[global] Hint Extern 10 (~ (_ < _)%Z) => abstract lia: zarith. +#[global] Hint Extern 10 (~ (_ >= _)%Z) => abstract lia: zarith. +#[global] Hint Extern 10 (~ (_ > _)%Z) => abstract lia: zarith. +#[global] Hint Extern 10 False => abstract lia: zarith. diff --git a/theories/nsatz/Nsatz.v b/theories/nsatz/Nsatz.v index b684775bb4..21f0f30140 100644 --- a/theories/nsatz/Nsatz.v +++ b/theories/nsatz/Nsatz.v @@ -60,6 +60,7 @@ exact Rplus_opp_r. Defined. Class can_compute_Z (z : Z) := dummy_can_compute_Z : True. +#[global] Hint Extern 0 (can_compute_Z ?v) => match isZcst v with true => exact I end : typeclass_instances. Instance reify_IZR z lvar {_ : can_compute_Z z} : reify (PEc z) lvar (IZR z). diff --git a/theories/ssr/ssrbool.v b/theories/ssr/ssrbool.v index e8a036bbb0..b205965ed1 100644 --- a/theories/ssr/ssrbool.v +++ b/theories/ssr/ssrbool.v @@ -487,6 +487,7 @@ Ltac prop_congr := apply: prop_congr. Lemma is_true_true : true. Proof. by []. Qed. Lemma not_false_is_true : ~ false. Proof. by []. Qed. Lemma is_true_locked_true : locked true. Proof. by unlock. Qed. +#[global] Hint Resolve is_true_true not_false_is_true is_true_locked_true : core. (** Shorter names. **) diff --git a/theories/ssr/ssreflect.v b/theories/ssr/ssreflect.v index 97a283b875..d0508bef2e 100644 --- a/theories/ssr/ssreflect.v +++ b/theories/ssr/ssreflect.v @@ -59,6 +59,15 @@ Declare ML Module "ssreflect_plugin". Canonical foo_unlockable := #[#unlockable fun foo#]#. This minimizes the comparison overhead for foo, while still allowing rewrite unlock to expose big_foo_expression. + + Additionally we provide default intro pattern ltac views: + - top of the stack actions: + => /[apply] := => hyp {}/hyp + => /[swap] := => x y; move: y x + (also swap and perserves let bindings) + => /[dup] := => x; have copy := x; move: copy x + (also copies and preserves let bindings) + More information about these definitions and their use can be found in the ssreflect manual, and in specific comments below. **) @@ -534,8 +543,10 @@ Proof. by move=> /(_ P); apply. Qed. Require Export ssrunder. +#[global] Hint Extern 0 (@Under_rel.Over_rel _ _ _ _) => solve [ apply: Under_rel.over_rel_done ] : core. +#[global] Hint Resolve Under_rel.over_rel_done : core. Register Under_rel.Under_rel as plugins.ssreflect.Under_rel. @@ -654,3 +665,50 @@ End Exports. End NonPropType. Export NonPropType.Exports. + +Module Export ipat. + +Notation "'[' 'apply' ']'" := (ltac:(let f := fresh "_top_" in move=> f {}/f)) + (at level 0, only parsing) : ssripat_scope. + +(** We try to preserve the naming by matching the names from the goal. + We do 'move' to perform a hnf before trying to match. **) +Notation "'[' 'swap' ']'" := (ltac:(move; + lazymatch goal with + | |- forall (x : _), _ => let x := fresh x in move=> x; move; + lazymatch goal with + | |- forall (y : _), _ => let y := fresh y in move=> y; move: y x + | |- let y := _ in _ => let y := fresh y in move=> y; move: @y x + | _ => let y := fresh "_top_" in move=> y; move: y x + end + | |- let x := _ in _ => let x := fresh x in move => x; move; + lazymatch goal with + | |- forall (y : _), _ => let y := fresh y in move=> y; move: y @x + | |- let y := _ in _ => let y := fresh y in move=> y; move: @y @x + | _ => let y := fresh "_top_" in move=> y; move: y x + end + | _ => let x := fresh "_top_" in let x := fresh x in move=> x; move; + lazymatch goal with + | |- forall (y : _), _ => let y := fresh y in move=> y; move: y @x + | |- let y := _ in _ => let y := fresh y in move=> y; move: @y @x + | _ => let y := fresh "_top_" in move=> y; move: y x + end + end)) + (at level 0, only parsing) : ssripat_scope. + +Notation "'[' 'dup' ']'" := (ltac:(move; + lazymatch goal with + | |- forall (x : _), _ => + let x := fresh x in move=> x; + let copy := fresh x in have copy := x; move: copy x + | |- let x := _ in _ => + let x := fresh x in move=> x; + let copy := fresh x in pose copy := x; + do [unfold x in (value of copy)]; move: @copy @x + | |- _ => + let x := fresh "_top_" in move=> x; + let copy := fresh "_top" in have copy := x; move: copy x + end)) + (at level 0, only parsing) : ssripat_scope. + +End ipat. diff --git a/theories/ssr/ssrfun.v b/theories/ssr/ssrfun.v index 053e86dc34..e1442e1da2 100644 --- a/theories/ssr/ssrfun.v +++ b/theories/ssr/ssrfun.v @@ -450,6 +450,7 @@ End ExtensionalEquality. Typeclasses Opaque eqfun. Typeclasses Opaque eqrel. +#[global] Hint Resolve frefl rrefl : core. Notation "f1 =1 f2" := (eqfun f1 f2) : fun_scope. diff --git a/theories/ssrmatching/ssrmatching.v b/theories/ssrmatching/ssrmatching.v index feca62651d..fda6b860e6 100644 --- a/theories/ssrmatching/ssrmatching.v +++ b/theories/ssrmatching/ssrmatching.v @@ -25,7 +25,7 @@ Declare Scope ssrpatternscope. Delimit Scope ssrpatternscope with pattern. (* Notation to define shortcuts for the "X in t" part of a pattern. *) -Notation "( X 'in' t )" := (_ : fun X => t) : ssrpatternscope. +Notation "( X 'in' t )" := (_ : fun X => t) (only parsing) : ssrpatternscope. (* Some shortcuts for recurrent "X in t" parts. *) Notation RHS := (X in _ = X)%pattern. diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index 5d210b2e60..e5beab5d33 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -278,8 +278,16 @@ pos_lnum = lcp.pos_lnum + n; pos_bol = lcp.pos_cnum } - let print_position chan p = - Printf.fprintf chan "%s:%d:%d" p.pos_fname p.pos_lnum (p.pos_cnum - p.pos_bol) + let print_position_p chan p = + Printf.fprintf chan "%s%d, character %d" + (if p.pos_fname = "" then "Line " else "File \"" ^ p.pos_fname ^ "\", line ") + p.pos_lnum (p.pos_cnum - p.pos_bol) + + let print_position chan {lex_start_p = p} = print_position_p chan p + + let warn msg lexbuf = + eprintf "%a, warning: %s\n" print_position lexbuf msg; + flush stderr exception MismatchPreformatted of position @@ -487,29 +495,29 @@ rule coq_bol = parse then Output.empty_line_of_code (); coq_bol lexbuf } | space* "(**" (space_nl as s) - { if is_nl s then Lexing.new_line lexbuf; + { if is_nl s then new_lines 1 lexbuf; Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then coq_bol lexbuf else coq lexbuf } | space* "Comments" (space_nl as s) - { if is_nl s then Lexing.new_line lexbuf; + { if is_nl s then new_lines 1 lexbuf; Output.end_coq (); Output.start_doc (); comments lexbuf; Output.end_doc (); Output.start_coq (); coq lexbuf } | space* begin_hide nl - { Lexing.new_line lexbuf; skip_hide lexbuf; coq_bol lexbuf } + { new_lines 1 lexbuf; skip_hide lexbuf; coq_bol lexbuf } | space* begin_show nl - { Lexing.new_line lexbuf; begin_show (); coq_bol lexbuf } + { new_lines 1 lexbuf; begin_show (); coq_bol lexbuf } | space* end_show nl - { Lexing.new_line lexbuf; end_show (); coq_bol lexbuf } + { new_lines 1 lexbuf; end_show (); coq_bol lexbuf } | space* begin_details (* At this point, the comment remains open, and will be closed by [details_body] *) { let s = details_body lexbuf in Output.end_coq (); begin_details s; Output.start_coq (); coq_bol lexbuf } | space* end_details nl - { Lexing.new_line lexbuf; + { new_lines 1 lexbuf; Output.end_coq (); end_details (); Output.start_coq (); coq_bol lexbuf } | space* (("Local"|"Global") space+)? gallina_kw_to_hide { let s = lexeme lexbuf in @@ -572,8 +580,7 @@ rule coq_bol = parse add_printing_token tok s; coq_bol lexbuf } | space* "(**" space+ "printing" space+ - { eprintf "warning: bad 'printing' command at character %d\n" - (lexeme_start lexbuf); flush stderr; + { warn "bad 'printing' command" lexbuf; comment_level := 1; ignore (comment lexbuf); coq_bol lexbuf } @@ -582,8 +589,7 @@ rule coq_bol = parse { remove_printing_token (lexeme lexbuf); coq_bol lexbuf } | space* "(**" space+ "remove" space+ "printing" space+ - { eprintf "warning: bad 'remove printing' command at character %d\n" - (lexeme_start lexbuf); flush stderr; + { warn "bad 'remove printing' command" lexbuf; comment_level := 1; ignore (comment lexbuf); coq_bol lexbuf } @@ -616,9 +622,9 @@ rule coq_bol = parse and coq = parse | nl - { Lexing.new_line lexbuf; if not (only_gallina ()) then Output.line_break(); coq_bol lexbuf } + { new_lines 1 lexbuf; if not (only_gallina ()) then Output.line_break(); coq_bol lexbuf } | "(**" (space_nl as s) - { if is_nl s then Lexing.new_line lexbuf; + { if is_nl s then new_lines 1 lexbuf; Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); @@ -719,7 +725,7 @@ and coq = parse and doc_bol = parse | space* section space+ ([^'\n' '\r' '*'] | '*'+ [^'\n' '\r' ')' '*'])* ('*'+ (nl as s))? - { if not (is_none s) then Lexing.new_line lexbuf; + { if not (is_none s) then new_lines 1 lexbuf; let eol, lex = strip_eol (lexeme lexbuf) in let lev, s = sec_title lex in if (!Cdglobals.lib_subtitles) && @@ -731,7 +737,7 @@ and doc_bol = parse | ((space_nl* nl)? as s) (space* '-'+ as line) { let nl_count = count_newlines s in match check_start_list line with - | Neither -> backtrack_past_newline lexbuf; Lexing.new_line lexbuf; doc None lexbuf + | Neither -> backtrack_past_newline lexbuf; new_lines 1 lexbuf; doc None lexbuf | List n -> new_lines nl_count lexbuf; if nl_count > 0 then Output.paragraph (); @@ -742,8 +748,10 @@ and doc_bol = parse } | (space_nl* nl) as s { new_lines (count_newlines s) lexbuf; Output.paragraph (); doc_bol lexbuf } - | "<<" space* - { Output.start_verbatim false; verbatim 0 false lexbuf; doc_bol lexbuf } + | "<<" space* nl + { new_lines 1 lexbuf; Output.start_verbatim false; verbatim_block lexbuf; doc_bol lexbuf } + | "<<" + { Output.start_verbatim true; verbatim_inline lexbuf; doc None lexbuf } | eof { true } | '_' @@ -765,27 +773,33 @@ and doc_list_bol indents = parse | InLevel (_,false) -> backtrack lexbuf; doc_bol lexbuf } - | "<<" space* - { Output.start_verbatim false; - verbatim 0 false lexbuf; + | "<<" space* nl + { new_lines 1 lexbuf; Output.start_verbatim false; + verbatim_block lexbuf; doc_list_bol indents lexbuf } + | "<<" space* + { Output.start_verbatim true; + verbatim_inline lexbuf; + doc (Some indents) lexbuf } | "[[" nl - { formatted := Some lexbuf.lex_start_p; + { new_lines 1 lexbuf; formatted := Some lexbuf.lex_start_p; Output.start_inline_coq_block (); ignore(body_bol lexbuf); Output.end_inline_coq_block (); formatted := None; doc_list_bol indents lexbuf } | "[[[" nl - { inf_rules (Some indents) lexbuf } + { new_lines 1 lexbuf; inf_rules (Some indents) lexbuf } | space* nl space* '-' { (* Like in the doc_bol production, these two productions exist only to deal properly with whitespace *) + new_lines 1 lexbuf; Output.paragraph (); backtrack_past_newline lexbuf; doc_list_bol indents lexbuf } | space* nl space* _ - { let buf' = lexeme lexbuf in + { new_lines 1 lexbuf; + let buf' = lexeme lexbuf in let buf = let bufs = Str.split_delim (Str.regexp "['\n']") buf' in match bufs with @@ -830,12 +844,14 @@ and doc_list_bol indents = parse (*s Scanning documentation elsewhere *) and doc indents = parse | nl - { Output.char '\n'; + { new_lines 1 lexbuf; + Output.char '\n'; match indents with | Some ls -> doc_list_bol ls lexbuf | None -> doc_bol lexbuf } | "[[" nl - { if !Cdglobals.plain_comments + { new_lines 1 lexbuf; + if !Cdglobals.plain_comments then (Output.char '['; Output.char '['; doc indents lexbuf) else (formatted := Some lexbuf.lex_start_p; Output.start_inline_coq_block (); @@ -847,7 +863,7 @@ and doc indents = parse | None -> doc_bol lexbuf else doc indents lexbuf)} | "[[[" nl - { inf_rules indents lexbuf } + { new_lines 1 lexbuf; inf_rules indents lexbuf } | "[]" { Output.proofbox (); doc indents lexbuf } | "{{" { url lexbuf; doc indents lexbuf } @@ -877,7 +893,7 @@ and doc indents = parse doc_bol lexbuf } | '*'* "*)" space* nl - { true } + { new_lines 1 lexbuf; Output.char '\n'; true } | '*'* "*)" { false } | "$" @@ -911,7 +927,7 @@ and doc indents = parse Output.char (lexeme_char lexbuf 1); doc indents lexbuf } | "<<" space* - { Output.start_verbatim true; verbatim 0 true lexbuf; doc_bol lexbuf } + { Output.start_verbatim true; verbatim_inline lexbuf; doc indents lexbuf } | '"' { if !Cdglobals.plain_comments then Output.char '"' @@ -951,20 +967,25 @@ and escaped_html = parse { backtrack lexbuf } | _ { Output.html_char (lexeme_char lexbuf 0); escaped_html lexbuf } -and verbatim depth inline = parse - | nl ">>" space* nl { Output.verbatim_char inline '\n'; Output.stop_verbatim inline } - | nl ">>" { Output.verbatim_char inline '\n'; Output.stop_verbatim inline } - | ">>" { Output.stop_verbatim inline } - | "(*" { Output.verbatim_char inline '('; - Output.verbatim_char inline '*'; - verbatim (depth+1) inline lexbuf } - | "*)" { if (depth == 0) - then (Output.stop_verbatim inline; backtrack lexbuf) - else (Output.verbatim_char inline '*'; - Output.verbatim_char inline ')'; - verbatim (depth-1) inline lexbuf) } - | eof { Output.stop_verbatim inline } - | _ { Output.verbatim_char inline (lexeme_char lexbuf 0); verbatim depth inline lexbuf } +and verbatim_block = parse + | nl ">>" space* nl { new_lines 2 lexbuf; Output.verbatim_char false '\n'; Output.stop_verbatim false } + | nl ">>" + { new_lines 1 lexbuf; + warn "missing newline after \">>\" block" lexbuf; + Output.verbatim_char false '\n'; + Output.stop_verbatim false } + | eof { warn "unterminated \">>\" block" lexbuf; Output.stop_verbatim false } + | nl { new_lines 1 lexbuf; Output.verbatim_char false (lexeme_char lexbuf 0); verbatim_block lexbuf } + | _ { Output.verbatim_char false (lexeme_char lexbuf 0); verbatim_block lexbuf } + +and verbatim_inline = parse + | nl { new_lines 1 lexbuf; + warn "unterminated inline \">>\"" lexbuf; + Output.char '\n'; + Output.stop_verbatim true } + | ">>" { Output.stop_verbatim true } + | eof { warn "unterminated inline \">>\"" lexbuf; Output.stop_verbatim true } + | _ { Output.verbatim_char true (lexeme_char lexbuf 0); verbatim_inline lexbuf } and url = parse | "}}" { Output.url (Buffer.contents url_buffer) None; Buffer.clear url_buffer } @@ -993,7 +1014,8 @@ and escaped_coq = parse else skipped_comment lexbuf); escaped_coq lexbuf } | "*)" - { (* likely to be a syntax error: we escape *) backtrack lexbuf } + { (* likely to be a syntax error *) + warn "unterminated \"]\"" lexbuf; backtrack lexbuf } | eof { Tokens.flush_sublexer () } | identifier @@ -1036,7 +1058,8 @@ and skipped_comment = parse { incr comment_level; skipped_comment lexbuf } | "*)" space* nl - { decr comment_level; + { new_lines 1 lexbuf; + decr comment_level; if !comment_level > 0 then skipped_comment lexbuf else true } | "*)" { decr comment_level; @@ -1050,7 +1073,8 @@ and comment = parse Output.start_comment (); comment lexbuf } | "*)" space* nl - { Output.end_comment (); + { new_lines 1 lexbuf; + Output.end_comment (); Output.line_break (); decr comment_level; if !comment_level > 0 then comment lexbuf else true } @@ -1064,7 +1088,8 @@ and comment = parse escaped_coq lexbuf; Output.end_inline_coq ()); comment lexbuf } | "[[" nl - { if !Cdglobals.plain_comments then (Output.char '['; Output.char '[') + { new_lines 1 lexbuf; + if !Cdglobals.plain_comments then (Output.char '['; Output.char '[') else (formatted := Some lexbuf.lex_start_p; Output.start_inline_coq_block (); let _ = body_bol lexbuf in @@ -1099,13 +1124,14 @@ and comment = parse { Output.indentation (fst (count_spaces (lexeme lexbuf))); comment lexbuf } | nl - { Output.line_break (); + { new_lines 1 lexbuf; + Output.line_break (); comment lexbuf } | _ { Output.char (lexeme_char lexbuf 0); comment lexbuf } and skip_to_dot = parse - | '.' space* nl { true } + | '.' space* nl { new_lines 1 lexbuf; true } | eof | '.' space+ { false } | "(*" { comment_level := 1; @@ -1114,14 +1140,14 @@ and skip_to_dot = parse | _ { skip_to_dot lexbuf } and skip_to_dot_or_brace = parse - | '.' space* nl { true } + | '.' space* nl { new_lines 1 lexbuf; true } | eof | '.' space+ { false } | "(*" { comment_level := 1; ignore (skipped_comment lexbuf); skip_to_dot_or_brace lexbuf } | "}" space* nl - { true } + { new_lines 1 lexbuf; true } | "}" { false } | space* @@ -1134,7 +1160,7 @@ and body_bol = parse | "" { Output.indentation 0; body lexbuf } and body = parse - | nl {Tokens.flush_sublexer(); Output.line_break(); Lexing.new_line lexbuf; body_bol lexbuf} + | nl { Tokens.flush_sublexer(); Output.line_break(); new_lines 1 lexbuf; body_bol lexbuf} | (nl+ as s) space* "]]" space* nl { new_lines (count_newlines s + 1) lexbuf; Tokens.flush_sublexer(); @@ -1156,7 +1182,7 @@ and body = parse end } | "]]" space* nl { Tokens.flush_sublexer(); - Lexing.new_line lexbuf; + new_lines 1 lexbuf; if is_none !formatted then begin let loc = lexeme_start lexbuf in @@ -1265,31 +1291,31 @@ and string = parse | _ { let c = lexeme_char lexbuf 0 in Output.char c; string lexbuf } and skip_hide = parse - | eof | end_hide nl { Lexing.new_line lexbuf; () } + | eof | end_hide nl { new_lines 1 lexbuf; () } | _ { skip_hide lexbuf } (*s Reading token pretty-print *) and printing_token_body = parse | "*)" (nl as s)? | eof - { if not (is_none s) then Lexing.new_line lexbuf; + { if not (is_none s) then new_lines 1 lexbuf; let s = Buffer.contents token_buffer in Buffer.clear token_buffer; s } | (nl | _) as s - { if is_nl s then Lexing.new_line lexbuf; + { if is_nl s then new_lines 1 lexbuf; Buffer.add_string token_buffer (lexeme lexbuf); printing_token_body lexbuf } and details_body = parse | "*)" space* (nl as s)? | eof - { if not (is_none s) then Lexing.new_line lexbuf; + { if not (is_none s) then new_lines 1 lexbuf; None } | ":" space* { details_body_rec lexbuf } and details_body_rec = parse | "*)" space* (nl as s)? | eof - { if not (is_none s) then Lexing.new_line lexbuf; + { if not (is_none s) then new_lines 1 lexbuf; let s = Buffer.contents token_buffer in Buffer.clear token_buffer; Some s } @@ -1300,9 +1326,10 @@ and details_body_rec = parse enclosed in [[[ ]]] brackets *) and inf_rules indents = parse | space* nl (* blank line, before or between definitions *) - { inf_rules indents lexbuf } + { new_lines 1 lexbuf; inf_rules indents lexbuf } | "]]]" nl (* end of the inference rules block *) - { match indents with + { new_lines 1 lexbuf; + match indents with | Some ls -> doc_list_bol ls lexbuf | None -> doc_bol lexbuf } | _ @@ -1315,7 +1342,8 @@ and inf_rules indents = parse *) and inf_rules_assumptions indents assumptions = parse | space* "---" '-'* [^ '\n']* nl (* hit the horizontal line *) - { let line = lexeme lexbuf in + { new_lines 1 lexbuf; + let line = lexeme lexbuf in let (spaces,_) = count_spaces line in let dashes_and_name = cut_head_tail_spaces (String.sub line 0 (String.length line - 1)) @@ -1334,7 +1362,8 @@ and inf_rules_assumptions indents assumptions = parse inf_rules_conclusion indents (List.rev assumptions) (spaces, dashes, name) [] lexbuf } | [^ '\n']* nl (* if it's not the horizontal line, it's an assumption *) - { let line = lexeme lexbuf in + { new_lines 1 lexbuf; + let line = lexeme lexbuf in let (spaces,_) = count_spaces line in let assumption = cut_head_tail_spaces (String.sub line 0 (String.length line - 1)) @@ -1348,11 +1377,12 @@ and inf_rules_assumptions indents assumptions = parse blank line or a ']]]'. *) and inf_rules_conclusion indents assumptions middle conclusions = parse | space* nl | space* "]]]" nl (* end of conclusions. *) - { backtrack lexbuf; + { new_lines 2 lexbuf; backtrack lexbuf; Output.inf_rule assumptions middle (List.rev conclusions); inf_rules indents lexbuf } | space* [^ '\n']+ nl (* this is a line in the conclusion *) - { let line = lexeme lexbuf in + { new_lines 1 lexbuf; + let line = lexeme lexbuf in let (spaces,_) = count_spaces line in let conc = cut_head_tail_spaces (String.sub line 0 (String.length line - 1)) @@ -1395,16 +1425,16 @@ and st_subtitle = parse { (* coq_bol with error handling *) let coq_bol' f lb = - Lexing.new_line lb; (* Start numbering lines from 1 *) try coq_bol lb with | MismatchPreformatted p -> - Printf.eprintf "%a: mismatched \"[[\"\n" print_position { p with pos_fname = f }; + Printf.eprintf "%a: mismatched \"[[\"\n" print_position_p p; exit 1 let coq_file f m = reset (); let c = open_in f in let lb = from_channel c in + let lb = { lb with lex_start_p = { lb.lex_start_p with pos_fname = f } } in (Index.current_library := m; Output.initialize (); Output.start_module (); diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 32cf05e1eb..a87dfb5b2e 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -313,7 +313,7 @@ module Latex = struct let start_verbatim inline = if inline then printf "\\texttt{" - else printf "\\begin{verbatim}" + else printf "\\begin{verbatim}\n" let stop_verbatim inline = if inline then printf "}" @@ -479,10 +479,6 @@ module Latex = struct let end_coq () = printf "\\end{coqdoccode}\n" - let start_code () = end_doc (); start_coq () - - let end_code () = end_coq (); start_doc () - let section_kind = function | 1 -> "\\section{" | 2 -> "\\subsection{" @@ -632,11 +628,11 @@ module Html = struct let stop_quote () = start_quote () let start_verbatim inline = - if inline then printf "<tt>" - else printf "<pre>" + if inline then printf "<code>" + else printf "<pre>\n" let stop_verbatim inline = - if inline then printf "</tt>" + if inline then printf "</code>" else printf "</pre>\n" let url addr name = @@ -738,7 +734,7 @@ module Html = struct let end_doc () = in_doc := false; stop_item (); - if not !raw_comments then printf "\n</div>\n" + if not !raw_comments then printf "</div>\n" let start_emph () = printf "<i>" @@ -754,10 +750,6 @@ module Html = struct let end_comment () = printf "*)</span>" - let start_code () = end_doc (); start_coq () - - let end_code () = end_coq (); start_doc () - let start_inline_coq () = if !inline_notmono then printf "<span class=\"inlinecodenm\">" else printf "<span class=\"inlinecode\">" @@ -1069,9 +1061,6 @@ module TeXmacs = struct let start_comment () = () let end_comment () = () - let start_code () = in_doc := true; printf "<\\code>\n" - let end_code () = in_doc := false; printf "\n</code>" - let section_kind = function | 1 -> "section" | 2 -> "subsection" @@ -1181,9 +1170,6 @@ module Raw = struct let start_coq () = () let end_coq () = () - let start_code () = end_doc (); start_coq () - let end_code () = end_coq (); start_doc () - let section_kind = function | 1 -> "* " @@ -1240,9 +1226,6 @@ let end_comment = select Latex.end_comment Html.end_comment TeXmacs.end_comment let start_coq = select Latex.start_coq Html.start_coq TeXmacs.start_coq Raw.start_coq let end_coq = select Latex.end_coq Html.end_coq TeXmacs.end_coq Raw.end_coq -let start_code = select Latex.start_code Html.start_code TeXmacs.start_code Raw.start_code -let end_code = select Latex.end_code Html.end_code TeXmacs.end_code Raw.end_code - let start_inline_coq = select Latex.start_inline_coq Html.start_inline_coq TeXmacs.start_inline_coq Raw.start_inline_coq let end_inline_coq = diff --git a/tools/coqdoc/output.mli b/tools/coqdoc/output.mli index b7a8d4d858..4088fdabf7 100644 --- a/tools/coqdoc/output.mli +++ b/tools/coqdoc/output.mli @@ -41,9 +41,6 @@ val end_comment : unit -> unit val start_coq : unit -> unit val end_coq : unit -> unit -val start_code : unit -> unit -val end_code : unit -> unit - val start_inline_coq : unit -> unit val end_inline_coq : unit -> unit diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index 524f818523..b75a4199ea 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -139,7 +139,7 @@ let compile opts copts ~echo ~f_in ~f_out = ~aux_file:(aux_file_name_for long_f_dot_out) ~v_file:long_f_dot_in); - Dumpglob.set_glob_output copts.glob_out; + Dumpglob.push_output copts.glob_out; Dumpglob.start_dump_glob ~vfile:long_f_dot_in ~vofile:long_f_dot_out; Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n"); diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index bbcfcc4826..d0d50aee70 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -149,6 +149,18 @@ let print_query opts = function heap increment and the GC pressure coefficient. *) +let set_gc_policy () = + Gc.set { (Gc.get ()) with + Gc.minor_heap_size = 32*1024*1024 (* 32Mwords x 8 bytes/word = 256Mb *) + ; Gc.space_overhead = 120 + } + +let set_gc_best_fit () = + Gc.set { (Gc.get ()) with + Gc.allocation_policy = 2 (* best-fit *) + ; Gc.space_overhead = 200 + } + let init_gc () = try (* OCAMLRUNPARAM environment variable is set. @@ -160,9 +172,8 @@ let init_gc () = (* OCAMLRUNPARAM environment variable is not set. * In this case, we put in place our preferred configuration. *) - Gc.set { (Gc.get ()) with - Gc.minor_heap_size = 32*1024*1024; (* 32Mwords x 8 bytes/word = 256Mb *) - Gc.space_overhead = 120} + set_gc_policy (); + if Coq_config.caml_version_nums >= [4;10;0] then set_gc_best_fit () else () let init_process () = (* Coq's init process, phase 1: diff --git a/vernac/classes.ml b/vernac/classes.ml index a100352145..062cc90f8f 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -502,9 +502,16 @@ let do_instance_program ~pm env env' sigma ?hook ~global ~poly cty k u ctx ctx' else declare_instance_program pm env sigma ~global ~poly id pri imps decl term termtype -let interp_instance_context ~program_mode env ctx ~generalize pl tclass = - let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in +let auto_generalize = + Goptions.declare_bool_option_and_ref + ~depr:true + ~key:["Instance";"Generalized";"Output"] + ~value:false + +let interp_instance_context ~program_mode env ctx ?(generalize=auto_generalize()) pl tclass = + let sigma, decl = interp_univ_decl_opt env pl in let tclass = + (* when we remove this code, we can remove the middle argument of CGeneralization *) if generalize then CAst.make @@ CGeneralization (Glob_term.MaxImplicit, Some AbsPi, tclass) else tclass in @@ -530,10 +537,10 @@ let interp_instance_context ~program_mode env ctx ~generalize pl tclass = let sigma = resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:true env sigma in sigma, cl, u, c', ctx', ctx, imps, args, decl -let new_instance_common ~program_mode ~generalize env instid ctx cl = +let new_instance_common ~program_mode ?generalize env instid ctx cl = let ({CAst.loc;v=instid}, pl) = instid in let sigma, k, u, cty, ctx', ctx, imps, subst, decl = - interp_instance_context ~program_mode env ~generalize ctx pl cl + interp_instance_context ~program_mode env ?generalize ctx pl cl in (* The name generator should not be here *) let id = @@ -548,20 +555,20 @@ let new_instance_common ~program_mode ~generalize env instid ctx cl = let new_instance_interactive ?(global=false) ~poly instid ctx cl - ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook + ?generalize ?(tac:unit Proofview.tactic option) ?hook pri opt_props = let env = Global.env() in let id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl = - new_instance_common ~program_mode:false ~generalize env instid ctx cl in + new_instance_common ~program_mode:false ?generalize env instid ctx cl in id, do_instance_interactive env env' sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri decl imps subst id opt_props let new_instance_program ?(global=false) ~pm ~poly instid ctx cl opt_props - ?(generalize=true) ?hook pri = + ?generalize ?hook pri = let env = Global.env() in let id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl = - new_instance_common ~program_mode:true ~generalize env instid ctx cl in + new_instance_common ~program_mode:true ?generalize env instid ctx cl in let pm = do_instance_program ~pm env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imps subst id opt_props in @@ -569,10 +576,10 @@ let new_instance_program ?(global=false) ~pm let new_instance ?(global=false) ~poly instid ctx cl props - ?(generalize=true) ?hook pri = + ?generalize ?hook pri = let env = Global.env() in let id, env', sigma, k, u, cty, ctx', ctx, imps, subst, decl = - new_instance_common ~program_mode:false ~generalize env instid ctx cl in + new_instance_common ~program_mode:false ?generalize env instid ctx cl in do_instance env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imps subst id props; id diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 12194ea20c..9e850ff1c7 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -13,7 +13,6 @@ open Util open Vars open Names open Context -open Constrexpr_ops open Constrintern open Impargs open Pretyping diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 3fc74cba5b..81154bbea9 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -114,7 +114,7 @@ let do_definition ?hook ~name ~scope ~poly ~kind ?using udecl bl red_option c ct let program_mode = false in let env = Global.env() in (* Explicitly bound universes and constraints *) - let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env udecl in + let evd, udecl = interp_univ_decl_opt env udecl in let evd, (body, types), impargs = interp_definition ~program_mode env evd empty_internalization_env bl red_option c ctypopt in @@ -134,7 +134,7 @@ let do_definition_program ?hook ~pm ~name ~scope ~poly ~kind ?using udecl bl red let program_mode = true in let env = Global.env() in (* Explicitly bound universes and constraints *) - let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env udecl in + let evd, udecl = interp_univ_decl_opt env udecl in let evd, (body, types), impargs = interp_definition ~program_mode env evd empty_internalization_env bl red_option c ctypopt in diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 29bf5fbcc2..dd6c985bf9 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -176,7 +176,7 @@ let interp_recursive ~program_mode ~cofix (fixl : 'a Vernacexpr.fix_expr_gen lis if not (CList.for_all2eq (fun x y -> Id.equal x.CAst.v y.CAst.v) lsu usu) then CErrors.user_err Pp.(str "(co)-recursive definitions should all have the same universe binders"); Some us) fixl None in - let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env all_universes in + let sigma, decl = interp_univ_decl_opt env all_universes in let sigma, (fixctxs, fiximppairs, fixannots) = on_snd List.split3 @@ List.fold_left_map (fun sigma -> interp_fix_context ~program_mode env sigma ~cofix) sigma fixl in diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index bb26ce652e..597e55a39e 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -367,7 +367,26 @@ let restrict_inductive_universes sigma ctx_params arities constructors = let uvars = List.fold_right (fun (_,ctypes) -> List.fold_right merge_universes_of_constr ctypes) constructors uvars in Evd.restrict_universe_context sigma uvars -let interp_mutual_inductive_constr ~sigma ~template ~udecl ~ctx_params ~indnames ~arities ~arityconcl ~constructors ~env_ar_params ~cumulative ~poly ~private_ind ~finite = +let check_trivial_variances variances = + Array.iter (function + | None | Some Univ.Variance.Invariant -> () + | Some _ -> + CErrors.user_err + Pp.(strbrk "Universe variance was specified but this inductive will not be cumulative.")) + variances + +let variance_of_entry ~cumulative ~variances uctx = + match uctx with + | Monomorphic_entry _ -> check_trivial_variances variances; None + | Polymorphic_entry (nas,_) -> + if not cumulative then begin check_trivial_variances variances; None end + else + let lvs = Array.length variances in + let lus = Array.length nas in + assert (lvs <= lus); + Some (Array.append variances (Array.make (lus - lvs) None)) + +let interp_mutual_inductive_constr ~sigma ~template ~udecl ~variances ~ctx_params ~indnames ~arities ~arityconcl ~constructors ~env_ar_params ~cumulative ~poly ~private_ind ~finite = (* Compute renewed arities *) let sigma = Evd.minimize_universes sigma in let nf = Evarutil.nf_evars_universes sigma in @@ -429,13 +448,13 @@ let interp_mutual_inductive_constr ~sigma ~template ~udecl ~ctx_params ~indnames mind_entry_private = if private_ind then Some false else None; mind_entry_universes = uctx; mind_entry_template = is_template; - mind_entry_cumulative = poly && cumulative; + mind_entry_variance = variance_of_entry ~cumulative ~variances uctx; } in mind_ent, Evd.universe_binders sigma let interp_params env udecl uparamsl paramsl = - let sigma, udecl = interp_univ_decl_opt env udecl in + let sigma, udecl, variances = interp_cumul_univ_decl_opt env udecl in let sigma, (uimpls, ((env_uparams, ctx_uparams), useruimpls)) = interp_context_evars ~program_mode:false env sigma uparamsl in let sigma, (impls, ((env_params, ctx_params), userimpls)) = @@ -443,7 +462,7 @@ let interp_params env udecl uparamsl paramsl = in (* Names of parameters as arguments of the inductive type (defs removed) *) sigma, env_params, (ctx_params, env_uparams, ctx_uparams, - userimpls, useruimpls, impls, udecl) + userimpls, useruimpls, impls, udecl, variances) (* When a hole remains for a param, pretend the param is uniform and do the unification. @@ -485,7 +504,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not (* In case of template polymorphism, we need to compute more constraints *) let env0 = if poly then env0 else Environ.set_universes_lbound env0 UGraph.Bound.Prop in - let sigma, env_params, (ctx_params, env_uparams, ctx_uparams, userimpls, useruimpls, impls, udecl) = + let sigma, env_params, (ctx_params, env_uparams, ctx_uparams, userimpls, useruimpls, impls, udecl, variances) = interp_params env0 udecl uparamsl paramsl in @@ -563,7 +582,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not userimpls @ impls) cimpls) indimpls cimpls in - let mie, pl = interp_mutual_inductive_constr ~template ~sigma ~ctx_params ~udecl ~arities ~arityconcl ~constructors ~env_ar_params ~poly ~finite ~cumulative ~private_ind ~indnames in + let mie, pl = interp_mutual_inductive_constr ~template ~sigma ~ctx_params ~udecl ~variances ~arities ~arityconcl ~constructors ~env_ar_params ~poly ~finite ~cumulative ~private_ind ~indnames in (mie, pl, impls) diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 91e8f609d5..8bce884ba4 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -22,7 +22,7 @@ type uniform_inductive_flag = val do_mutual_inductive : template:bool option - -> universe_decl_expr option + -> cumul_univ_decl_expr option -> (one_inductive_expr * decl_notation list) list -> cumulative:bool -> poly:bool @@ -45,6 +45,7 @@ val interp_mutual_inductive_constr : sigma:Evd.evar_map -> template:bool option -> udecl:UState.universe_decl + -> variances:Entries.variance_entry -> ctx_params:(EConstr.t, EConstr.t) Context.Rel.Declaration.pt list -> indnames:Names.Id.t list -> arities:EConstr.t list @@ -86,3 +87,13 @@ val maybe_unify_params_in : Environ.env -> Evd.evar_map -> ninds:int -> nparams: (** [nparams] is the number of parameters which aren't treated as uniform, ie the length of params (including letins) where the env is [uniform params, inductives, params, binders]. *) + +val variance_of_entry + : cumulative:bool + -> variances:Entries.variance_entry + -> Entries.universes_entry + -> Entries.variance_entry option +(** Will return None if non-cumulative, and resize if there are more + universes than originally specified. + If monomorphic, [cumulative] is treated as [false]. +*) diff --git a/vernac/comPrimitive.ml b/vernac/comPrimitive.ml index eaa5271a73..a910cc6e8b 100644 --- a/vernac/comPrimitive.ml +++ b/vernac/comPrimitive.ml @@ -30,7 +30,7 @@ let do_primitive id udecl prim typopt = declare id {Entries.prim_entry_type = None; prim_entry_content = prim} | Some typ -> let env = Global.env () in - let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env udecl in + let evd, udecl = Constrintern.interp_univ_decl_opt env udecl in let auctx = CPrimitives.op_or_type_univs prim in let evd, u = Evd.with_context_set UState.univ_flexible evd (UnivGen.fresh_instance auctx) in let expected_typ = EConstr.of_constr @@ Typeops.type_of_prim_or_type env u prim in diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 9623317ddf..31f91979d3 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -115,7 +115,7 @@ let build_wellfounded pm (recname,pl,bl,arityc,body) poly ?using r measure notat let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in Coqlib.check_required_library ["Coq";"Program";"Wf"]; let env = Global.env() in - let sigma, udecl = Constrexpr_ops.interp_univ_decl_opt env pl in + let sigma, udecl = interp_univ_decl_opt env pl in let sigma, (_, ((env', binders_rel), impls)) = interp_context_evars ~program_mode:true env sigma bl in let len = List.length binders_rel in let top_env = push_rel_context binders_rel env in diff --git a/vernac/comSearch.ml b/vernac/comSearch.ml index f3b21eb813..af51f4fafb 100644 --- a/vernac/comSearch.ml +++ b/vernac/comSearch.ml @@ -64,7 +64,8 @@ let interp_search_item env sigma = coercions, no compilation of pattern-matching) *) snd (Constrintern.intern_constr_pattern env sigma ~as_type:head pat) in GlobSearchSubPattern (where,head,pat) - | SearchString ((Anywhere,false),s,None) when Id.is_valid s -> + | SearchString ((Anywhere,false),s,None) + when Id.is_valid_ident_part s && String.equal (String.drop_simple_quotes s) s -> GlobSearchString s | SearchString ((where,head),s,sc) -> (try diff --git a/vernac/declare.ml b/vernac/declare.ml index 367d0bf944..1e8771b641 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -1291,7 +1291,7 @@ let obligation_terminator ~pm ~entry ~uctx ~oinfo:{name; num; auto} = FIXME: There is duplication of this code with obligation_terminator and Obligations.admit_obligations *) -let obligation_admitted_terminator ~pm {name; num; auto} ctx' dref = +let obligation_admitted_terminator ~pm {name; num; auto} uctx' dref = let prg = Option.get (State.find pm name) in let {obls; remaining = rem} = prg.prg_obligations in let obl = obls.(num) in @@ -1303,21 +1303,21 @@ let obligation_admitted_terminator ~pm {name; num; auto} ctx' dref = if not transparent then err_not_transp () | _ -> () in - let inst, ctx' = + let inst, uctx' = if not prg.prg_info.Info.poly (* Not polymorphic *) then (* The universe context was declared globally, we continue from the new global environment. *) - let ctx = UState.from_env (Global.env ()) in - let ctx' = UState.merge_subst ctx (UState.subst ctx') in - (Univ.Instance.empty, ctx') + let uctx = UState.from_env (Global.env ()) in + let uctx' = UState.merge_subst uctx (UState.subst uctx') in + (Univ.Instance.empty, uctx') else (* We get the right order somehow, but surely it could be enforced in a clearer way. *) - let uctx = UState.context ctx' in - (Univ.UContext.instance uctx, ctx') + let uctx = UState.context uctx' in + (Univ.UContext.instance uctx, uctx') in let obl = {obl with obl_body = Some (DefinedObl (cst, inst))} in let () = if transparent then add_hint true prg cst in - update_program_decl_on_defined ~pm prg obls num obl ~uctx:ctx' rem ~auto + update_program_decl_on_defined ~pm prg obls num obl ~uctx:uctx' rem ~auto end @@ -1627,12 +1627,12 @@ let make_univs_deferred ~poly ~initial_euctx ~uctx ~udecl let make_univs_private_poly ~poly ~uctx ~udecl (used_univs_typ, typ) (used_univs_body, body) = let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let universes = UState.restrict uctx used_univs in - let typus = UState.restrict universes used_univs_typ in - let utyp = UState.check_univ_decl ~poly typus udecl in + let uctx = UState.restrict uctx used_univs in + let uctx' = UState.restrict uctx used_univs_typ in + let utyp = UState.check_univ_decl ~poly uctx' udecl in let ubody = Univ.ContextSet.diff - (UState.context_set universes) - (UState.context_set typus) + (UState.context_set uctx) + (UState.context_set uctx') in utyp, ubody @@ -1643,8 +1643,8 @@ let make_univs ~poly ~uctx ~udecl (used_univs_typ, typ) (used_univs_body, body) for the typ. We recheck the declaration after restricting with the actually used universes. TODO: check if restrict is really necessary now. *) - let ctx = UState.restrict uctx used_univs in - let utyp = UState.check_univ_decl ~poly ctx udecl in + let uctx = UState.restrict uctx used_univs in + let utyp = UState.check_univ_decl ~poly uctx udecl in utyp, Univ.ContextSet.empty let close_proof ~opaque ~keep_body_ucst_separate ps = @@ -1712,9 +1712,9 @@ let close_proof_delayed ~feedback_id ps (fpl : closed_proof_output Future.comput (Vars.universes_of_constr types) (Vars.universes_of_constr pt) in - let univs = UState.restrict uctx used_univs in - let univs = UState.check_mono_univ_decl univs udecl in - (pt,univs),eff) + let uctx = UState.restrict uctx used_univs in + let uctx = UState.check_mono_univ_decl uctx udecl in + (pt,uctx),eff) |> delayed_definition_entry ~opaque ~feedback_id ~using ~univs ~types in let entries = Future.map2 make_entry fpl (Proofview.initial_goals entry) in diff --git a/vernac/g_proofs.mlg b/vernac/g_proofs.mlg index ebec720ce2..5b80ed6794 100644 --- a/vernac/g_proofs.mlg +++ b/vernac/g_proofs.mlg @@ -56,6 +56,8 @@ GRAMMAR EXTEND Gram [ [ IDENT "Goal"; c = lconstr -> { VernacDefinition (Decls.(NoDischarge, Definition), ((CAst.make ~loc Names.Anonymous), None), ProveBody ([], c)) } | IDENT "Proof" -> { VernacProof (None,None) } + | IDENT "Proof"; IDENT "using"; l = G_vernac.section_subset_expr -> + { VernacProof (None,Some l) } | IDENT "Proof" ; IDENT "Mode" ; mn = string -> { VernacProofMode mn } | IDENT "Proof"; c = lconstr -> { VernacExactProof c } | IDENT "Abort" -> { VernacAbort None } diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index f192d67624..1aff76114b 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -114,7 +114,8 @@ GRAMMAR EXTEND Gram ; attribute: [ [ k = ident ; v = attr_value -> { Names.Id.to_string k, v } - | "using" ; v = attr_value -> { "using", v } ] + (* Required because "ident" is declared a keyword when loading Ltac. *) + | IDENT "using" ; v = attr_value -> { "using", v } ] ] ; attr_value: @@ -193,6 +194,12 @@ let lname_of_lident : lident -> lname = let name_of_ident_decl : ident_decl -> name_decl = on_fst lname_of_lident +let test_variance_ident = + let open Pcoq.Lookahead in + to_entry "test_variance_ident" begin + lk_kws ["=";"+";"*"] >> lk_ident + end + } (* Gallina declarations *) @@ -282,7 +289,7 @@ GRAMMAR EXTEND Gram [ [ l = universe_name; ord = [ "<" -> { Univ.Lt } | "=" -> { Univ.Eq } | "<=" -> { Univ.Le } ]; r = universe_name -> { (l, ord, r) } ] ] ; - univ_decl : + univ_decl: [ [ "@{" ; l = LIST0 identref; ext = [ "+" -> { true } | -> { false } ]; cs = [ "|"; l' = LIST0 univ_constraint SEP ","; ext = [ "+" -> { true } | -> { false } ]; "}" -> { (l',ext) } @@ -295,10 +302,40 @@ GRAMMAR EXTEND Gram univdecl_extensible_constraints = snd cs } } ] ] ; + variance: + [ [ "+" -> { Univ.Variance.Covariant } + | "=" -> { Univ.Variance.Invariant } + | "*" -> { Univ.Variance.Irrelevant } + ] ] + ; + variance_identref: + [ [ id = identref -> { (id, None) } + | test_variance_ident; v = variance; id = identref -> { (id, Some v) } + (* We need this test to help the parser avoid the conflict + between "+" before ident (covariance) and trailing "+" (extra univs allowed) *) + ] ] + ; + cumul_univ_decl: + [ [ "@{" ; l = LIST0 variance_identref; ext = [ "+" -> { true } | -> { false } ]; + cs = [ "|"; l' = LIST0 univ_constraint SEP ","; + ext = [ "+" -> { true } | -> { false } ]; "}" -> { (l',ext) } + | ext = [ "}" -> { true } | bar_cbrace -> { false } ] -> { ([], ext) } ] + -> + { let open UState in + { univdecl_instance = l; + univdecl_extensible_instance = ext; + univdecl_constraints = fst cs; + univdecl_extensible_constraints = snd cs } } + ] ] + ; ident_decl: [ [ i = identref; l = OPT univ_decl -> { (i, l) } ] ] ; + cumul_ident_decl: + [ [ i = identref; l = OPT cumul_univ_decl -> { (i, l) } + ] ] + ; finite_token: [ [ IDENT "Inductive" -> { Inductive_kw } | IDENT "CoInductive" -> { CoInductive } @@ -344,7 +381,7 @@ GRAMMAR EXTEND Gram | -> { RecordDecl (None, []) } ] ] ; inductive_definition: - [ [ oc = opt_coercion; id = ident_decl; indpar = binders; + [ [ oc = opt_coercion; id = cumul_ident_decl; indpar = binders; extrapar = OPT [ "|"; p = binders -> { p } ]; c = OPT [ ":"; c = lconstr -> { c } ]; lc=opt_constructors_or_fields; ntn = decl_notations -> diff --git a/vernac/himsg.ml b/vernac/himsg.ml index bef9e29ac2..9d86ea90e6 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -744,6 +744,11 @@ let explain_bad_relevance env = let explain_bad_invert env = strbrk "Bad case inversion (maybe a bugged tactic)." +let explain_bad_variance env sigma ~lev ~expected ~actual = + str "Incorrect variance for universe " ++ Termops.pr_evd_level sigma lev ++ + str": expected " ++ Univ.Variance.pr expected ++ + str " but cannot be less restrictive than " ++ Univ.Variance.pr actual ++ str "." + let explain_type_error env sigma err = let env = make_all_name_different env sigma in match err with @@ -788,6 +793,7 @@ let explain_type_error env sigma err = | DisallowedSProp -> explain_disallowed_sprop () | BadRelevance -> explain_bad_relevance env | BadInvert -> explain_bad_invert env + | BadVariance {lev;expected;actual} -> explain_bad_variance env sigma ~lev ~expected ~actual let pr_position (cl,pos) = let clpos = match cl with diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 8477870cb4..dc2b2e889e 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -194,52 +194,6 @@ let parse_format ({CAst.loc;v=str} : lstring) = (***********************) (* Analyzing notations *) -(* Interpret notations with a recursive component *) - -let out_nt = function NonTerminal x -> x | _ -> assert false - -let msg_expected_form_of_recursive_notation = - "In the notation, the special symbol \"..\" must occur in\na configuration of the form \"x symbs .. symbs y\"." - -let rec find_pattern nt xl = function - | Break n as x :: l, Break n' :: l' when Int.equal n n' -> - find_pattern nt (x::xl) (l,l') - | Terminal s as x :: l, Terminal s' :: l' when String.equal s s' -> - find_pattern nt (x::xl) (l,l') - | [], NonTerminal x' :: l' -> - (out_nt nt,x',List.rev xl),l' - | _, Break s :: _ | Break s :: _, _ -> - user_err Pp.(str ("A break occurs on one side of \"..\" but not on the other side.")) - | _, Terminal s :: _ | Terminal s :: _, _ -> - user_err ~hdr:"Metasyntax.find_pattern" - (str "The token \"" ++ str s ++ str "\" occurs on one side of \"..\" but not on the other side.") - | _, [] -> - user_err Pp.(str msg_expected_form_of_recursive_notation) - | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) -> - anomaly (Pp.str "Only Terminal or Break expected on left, non-SProdList on right.") - -let rec interp_list_parser hd = function - | [] -> [], List.rev hd - | NonTerminal id :: tl when Id.equal id ldots_var -> - if List.is_empty hd then user_err Pp.(str msg_expected_form_of_recursive_notation); - let hd = List.rev hd in - let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in - let xyl,tl'' = interp_list_parser [] tl' in - (* We remember each pair of variable denoting a recursive part to *) - (* remove the second copy of it afterwards *) - (x,y)::xyl, SProdList (x,sl) :: tl'' - | (Terminal _ | Break _) as s :: tl -> - if List.is_empty hd then - let yl,tl' = interp_list_parser [] tl in - yl, s :: tl' - else - interp_list_parser (s::hd) tl - | NonTerminal _ as x :: tl -> - let xyl,tl' = interp_list_parser [x] tl in - xyl, List.rev_append hd tl' - | SProdList _ :: _ -> anomaly (Pp.str "Unexpected SProdList in interp_list_parser.") - - (* Find non-terminal tokens of notation *) (* To protect alphabetic tokens and quotes from being seen as variables *) @@ -256,24 +210,16 @@ let is_numeral_in_constr entry symbs = | _ -> false -let rec get_notation_vars onlyprint = function - | [] -> [] - | NonTerminal id :: sl -> - let vars = get_notation_vars onlyprint sl in - if Id.equal id ldots_var then vars else - (* don't check for nonlinearity if printing only, see Bug 5526 *) - if not onlyprint && Id.List.mem id vars then - user_err ~hdr:"Metasyntax.get_notation_vars" - (str "Variable " ++ Id.print id ++ str " occurs more than once.") - else id::vars - | (Terminal _ | Break _) :: sl -> get_notation_vars onlyprint sl - | SProdList _ :: _ -> assert false - -let analyze_notation_tokens ~onlyprint ntn = - let l = decompose_raw_notation ntn in - let vars = get_notation_vars onlyprint l in - let recvars,l = interp_list_parser [] l in - recvars, List.subtract Id.equal vars (List.map snd recvars), l +let analyze_notation_tokens ~onlyprint df = + let (recvars,mainvars,symbols as res) = decompose_raw_notation df in + (* don't check for nonlinearity if printing only, see Bug 5526 *) + (if not onlyprint then + match List.duplicates Id.equal (mainvars @ List.map snd recvars) with + | id :: _ -> + user_err ~hdr:"Metasyntax.get_notation_vars" + (str "Variable " ++ Id.print id ++ str " occurs more than once.") + | _ -> ()); + res let error_not_same_scope x y = user_err ~hdr:"Metasyntax.error_not_name_scope" diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 0e660bf20c..442269ebda 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -68,10 +68,18 @@ let pr_univ_name_list = function | Some l -> str "@{" ++ prlist_with_sep spc pr_lname l ++ str"}" +let pr_variance_lident (lid,v) = + let v = Option.cata Univ.Variance.pr (mt()) v in + v ++ pr_lident lid + let pr_univdecl_instance l extensible = prlist_with_sep spc pr_lident l ++ (if extensible then str"+" else mt ()) +let pr_cumul_univdecl_instance l extensible = + prlist_with_sep spc pr_variance_lident l ++ + (if extensible then str"+" else mt ()) + let pr_univdecl_constraints l extensible = if List.is_empty l && extensible then mt () else str"|" ++ spc () ++ prlist_with_sep (fun () -> str",") pr_uconstraint l ++ @@ -85,9 +93,20 @@ let pr_universe_decl l = str"@{" ++ pr_univdecl_instance l.univdecl_instance l.univdecl_extensible_instance ++ pr_univdecl_constraints l.univdecl_constraints l.univdecl_extensible_constraints ++ str "}" +let pr_cumul_univ_decl l = + let open UState in + match l with + | None -> mt () + | Some l -> + str"@{" ++ pr_cumul_univdecl_instance l.univdecl_instance l.univdecl_extensible_instance ++ + pr_univdecl_constraints l.univdecl_constraints l.univdecl_extensible_constraints ++ str "}" + let pr_ident_decl (lid, l) = pr_lident lid ++ pr_universe_decl l +let pr_cumul_ident_decl (lid, l) = + pr_lident lid ++ pr_cumul_univ_decl l + let string_of_fqid fqid = String.concat "." (List.map Id.to_string fqid) @@ -848,7 +867,7 @@ let pr_vernac_expr v = let pr_oneind key (((coe,iddecl),(indupar,indpar),s,lc),ntn) = hov 0 ( str key ++ spc() ++ - (if coe then str"> " else str"") ++ pr_ident_decl iddecl ++ + (if coe then str"> " else str"") ++ pr_cumul_ident_decl iddecl ++ pr_and_type_binders_arg indupar ++ pr_opt (fun p -> str "|" ++ spc() ++ pr_and_type_binders_arg p) indpar ++ pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) s ++ diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index 06f7c32cdc..840754ccc6 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -631,11 +631,11 @@ let print_constant with_values sep sp udecl = assert(ContextSet.is_empty body_uctxs); Polymorphic ctx in - let ctx = + let uctx = UState.of_binders (Printer.universe_binders_with_opt_names (Declareops.constant_polymorphic_context cb) udecl) in - let env = Global.env () and sigma = Evd.from_ctx ctx in + let env = Global.env () and sigma = Evd.from_ctx uctx in let pr_ltype = pr_ltype_env env sigma in hov 0 ( match val_0 with diff --git a/vernac/record.ml b/vernac/record.ml index acc97f61c1..583164a524 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -11,53 +11,40 @@ open Pp open CErrors open Term -open Sorts open Util open Names -open Nameops open Constr open Context -open Vars open Environ open Declarations open Entries -open Declare -open Constrintern open Type_errors open Constrexpr open Constrexpr_ops -open Goptions open Context.Rel.Declaration -open Libobject module RelDecl = Context.Rel.Declaration (********** definition d'un record (structure) **************) (** Flag governing use of primitive projections. Disabled by default. *) -let primitive_flag = ref false -let () = - declare_bool_option - { optdepr = false; - optkey = ["Primitive";"Projections"]; - optread = (fun () -> !primitive_flag) ; - optwrite = (fun b -> primitive_flag := b) } - -let typeclasses_strict = ref false -let () = - declare_bool_option - { optdepr = false; - optkey = ["Typeclasses";"Strict";"Resolution"]; - optread = (fun () -> !typeclasses_strict); - optwrite = (fun b -> typeclasses_strict := b); } - -let typeclasses_unique = ref false -let () = - declare_bool_option - { optdepr = false; - optkey = ["Typeclasses";"Unique";"Instances"]; - optread = (fun () -> !typeclasses_unique); - optwrite = (fun b -> typeclasses_unique := b); } +let primitive_flag = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Primitive";"Projections"] + ~value:false + +let typeclasses_strict = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Typeclasses";"Strict";"Resolution"] + ~value:false + +let typeclasses_unique = + Goptions.declare_bool_option_and_ref + ~depr:false + ~key:["Typeclasses";"Unique";"Instances"] + ~value:false let interp_fields_evars env sigma ~ninds ~nparams impls_env nots l = let _, sigma, impls, newfs, _ = @@ -81,7 +68,8 @@ let interp_fields_evars env sigma ~ninds ~nparams impls_env nots l = let impls_env = match i with | Anonymous -> impls_env - | Name id -> Id.Map.add id (compute_internalization_data env sigma id Constrintern.Method t impl) impls_env + | Name id -> + Id.Map.add id (Constrintern.compute_internalization_data env sigma id Constrintern.Method t impl) impls_env in let d = match b with | None -> LocalAssum (make_annot i r,t) @@ -106,7 +94,7 @@ let compute_constructor_level evars env l = let univ = if is_local_assum d then let s = Retyping.get_sort_of env evars (RelDecl.get_type d) in - Univ.sup (univ_of_sort s) univ + Univ.sup (Sorts.univ_of_sort s) univ else univ in (EConstr.push_rel d env, univ)) l (env, Univ.Universe.sprop) @@ -116,68 +104,124 @@ let check_anonymous_type ind = | { CAst.v = CSort (Glob_term.UAnonymous {rigid=true}) } -> true | _ -> false -let typecheck_params_and_fields def poly pl ps records = +let error_parameters_must_be_named bk {CAst.loc; v=name} = + match bk, name with + | Default _, Anonymous -> + CErrors.user_err ?loc ~hdr:"record" (str "Record parameters must be named") + | _ -> () + +let check_parameters_must_be_named = function + | CLocalDef (b, _, _) -> + error_parameters_must_be_named default_binder_kind b + | CLocalAssum (ls, bk, ce) -> + List.iter (error_parameters_must_be_named bk) ls + | CLocalPattern {CAst.loc} -> + Loc.raise ?loc (Stream.Error "pattern with quote not allowed in record parameters") + +(** [DataI.t] contains the information used in record interpretation, + it is a strict subset of [Ast.t] thus this should be + eventually removed or merged with [Ast.t] *) +module DataI = struct + type t = + { name : Id.t + ; arity : Constrexpr.constr_expr option + (** declared sort for the record *) + ; nots : Vernacexpr.decl_notation list list + (** notations for fields *) + ; fs : Vernacexpr.local_decl_expr list + } +end + +type projection_flags = { + pf_subclass: bool; + pf_canonical: bool; +} + +(** [DataR.t] contains record data after interpretation / + type-inference *) +module DataR = struct + type t = + { min_univ : Univ.Universe.t + ; arity : Constr.t + ; implfs : Impargs.manual_implicits list + ; fields : Constr.rel_declaration list + } +end + +module Data = struct + type t = + { id : Id.t + ; idbuild : Id.t + ; is_coercion : bool + ; coers : projection_flags list + ; rdata : DataR.t + } +end + +let build_type_telescope newps env0 (sigma, template) { DataI.arity; _ } = match arity with + | None -> + let uvarkind = Evd.univ_flexible_alg in + let sigma, s = Evd.new_sort_variable uvarkind sigma in + (sigma, template), (EConstr.mkSort s, s) + | Some t -> + let env = EConstr.push_rel_context newps env0 in + let poly = + match t with + | { CAst.v = CSort (Glob_term.UAnonymous {rigid=true}) } -> true | _ -> false in + let impls = Constrintern.empty_internalization_env in + let sigma, s = Constrintern.interp_type_evars ~program_mode:false env sigma ~impls t in + let sred = Reductionops.whd_allnolet env sigma s in + (match EConstr.kind sigma sred with + | Sort s' -> + let s' = EConstr.ESorts.kind sigma s' in + (if poly then + match Evd.is_sort_variable sigma s' with + | Some l -> + let sigma = Evd.make_flexible_variable sigma ~algebraic:true l in + (sigma, template), (s, s') + | None -> + (sigma, false), (s, s') + else (sigma, false), (s, s')) + | _ -> user_err ?loc:(constr_loc t) (str"Sort expected.")) + +type tc_result = + bool + * Impargs.manual_implicits + (* Part relative to closing the definitions *) + * UnivNames.universe_binders + * Entries.universes_entry + * Entries.variance_entry + * Constr.rel_context + * DataR.t list + +(* ps = parameter list *) +let typecheck_params_and_fields def poly udecl ps (records : DataI.t list) : tc_result = let env0 = Global.env () in (* Special case elaboration for template-polymorphic inductives, lower bound on introduced universes is Prop so that we do not miss any Set <= i constraint for universes that might actually be instantiated with Prop. *) let is_template = - List.exists (fun (_, arity, _, _) -> Option.cata check_anonymous_type true arity) records in + List.exists (fun { DataI.arity; _} -> Option.cata check_anonymous_type true arity) records in let env0 = if not poly && is_template then Environ.set_universes_lbound env0 UGraph.Bound.Prop else env0 in - let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env0 pl in - let () = - let error bk {CAst.loc; v=name} = - match bk, name with - | Default _, Anonymous -> - user_err ?loc ~hdr:"record" (str "Record parameters must be named") - | _ -> () - in - List.iter - (function CLocalDef (b, _, _) -> error default_binder_kind b - | CLocalAssum (ls, bk, ce) -> List.iter (error bk) ls - | CLocalPattern {CAst.loc} -> - Loc.raise ?loc (Stream.Error "pattern with quote not allowed in record parameters")) ps - in - let sigma, (impls_env, ((env1,newps), imps)) = interp_context_evars ~program_mode:false env0 sigma ps in - let fold (sigma, template) (_, t, _, _) = match t with - | Some t -> - let env = EConstr.push_rel_context newps env0 in - let poly = - match t with - | { CAst.v = CSort (Glob_term.UAnonymous {rigid=true}) } -> true | _ -> false in - let sigma, s = interp_type_evars ~program_mode:false env sigma ~impls:empty_internalization_env t in - let sred = Reductionops.whd_allnolet env sigma s in - (match EConstr.kind sigma sred with - | Sort s' -> - let s' = EConstr.ESorts.kind sigma s' in - (if poly then - match Evd.is_sort_variable sigma s' with - | Some l -> - let sigma = Evd.make_flexible_variable sigma ~algebraic:true l in - (sigma, template), (s, s') - | None -> - (sigma, false), (s, s') - else (sigma, false), (s, s')) - | _ -> user_err ?loc:(constr_loc t) (str"Sort expected.")) - | None -> - let uvarkind = Evd.univ_flexible_alg in - let sigma, s = Evd.new_sort_variable uvarkind sigma in - (sigma, template), (EConstr.mkSort s, s) - in - let (sigma, template), typs = List.fold_left_map fold (sigma, true) records in + let sigma, decl, variances = Constrintern.interp_cumul_univ_decl_opt env0 udecl in + let () = List.iter check_parameters_must_be_named ps in + let sigma, (impls_env, ((env1,newps), imps)) = + Constrintern.interp_context_evars ~program_mode:false env0 sigma ps in + let (sigma, template), typs = + List.fold_left_map (build_type_telescope newps env0) (sigma, true) records in let arities = List.map (fun (typ, _) -> EConstr.it_mkProd_or_LetIn typ newps) typs in let relevances = List.map (fun (_,s) -> Sorts.relevance_of_sort s) typs in - let fold accu (id, _, _, _) arity r = - EConstr.push_rel (LocalAssum (make_annot (Name id) r,arity)) accu in + let fold accu { DataI.name; _ } arity r = + EConstr.push_rel (LocalAssum (make_annot (Name name) r,arity)) accu in let env_ar = EConstr.push_rel_context newps (List.fold_left3 fold env0 records arities relevances) in let impls_env = - let ids = List.map (fun (id, _, _, _) -> id) records in + let ids = List.map (fun { DataI.name; _ } -> name) records in let imps = List.map (fun _ -> imps) arities in - compute_internalization_env env0 sigma ~impls:impls_env Inductive ids arities imps + Constrintern.compute_internalization_env env0 sigma ~impls:impls_env Constrintern.Inductive ids arities imps in let ninds = List.length arities in let nparams = List.length newps in - let fold sigma (_, _, nots, fs) arity = + let fold sigma { DataI.nots; fs; _ } arity = interp_fields_evars env_ar sigma ~ninds ~nparams impls_env nots fs in let (sigma, data) = List.fold_left2_map fold sigma records arities in @@ -198,12 +242,13 @@ let typecheck_params_and_fields def poly pl ps records = else sigma, (univ, typ) in let (sigma, typs) = List.fold_left2_map fold sigma typs data in + (* TODO: Have this use Declaredef.prepare_definition *) let sigma, (newps, ans) = Evarutil.finalize sigma (fun nf -> let newps = List.map (RelDecl.map_constr_het nf) newps in - let map (impls, newfs) (univ, typ) = - let newfs = List.map (RelDecl.map_constr_het nf) newfs in - let typ = nf typ in - (univ, typ, impls, newfs) + let map (implfs, fields) (min_univ, typ) = + let fields = List.map (RelDecl.map_constr_het nf) fields in + let arity = nf typ in + { DataR.min_univ; arity; implfs; fields } in let ans = List.map2 map data typs in newps, ans) @@ -212,7 +257,7 @@ let typecheck_params_and_fields def poly pl ps records = let ubinders = Evd.universe_binders sigma in let ce t = Pretyping.check_evars env0 sigma (EConstr.of_constr t) in let () = List.iter (iter_constr ce) (List.rev newps) in - ubinders, univs, template, newps, imps, ans + template, imps, ubinders, univs, variances, newps, ans type record_error = | MissingProj of Id.t * Id.t list @@ -293,26 +338,107 @@ let instantiate_possibly_recursive_type ind u ntypes paramdecls fields = let subst' = List.init ntypes (fun i -> mkIndU ((ind, ntypes - i - 1), u)) in Termops.substl_rel_context (subst @ subst') fields -type projection_flags = { - pf_subclass: bool; - pf_canonical: bool; -} - (* We build projections *) -let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name flags fieldimpls fields = + +(* TODO: refactor the declaration part here; this requires some + surgery as Evarutil.finalize is called too early in the path *) +(** This builds and _declares_ a named projection, the code looks + tricky due to the term manipulation. It also handles declaring the + implicits parameters, coercion status, etc... of the projection; + this could be refactored as noted above by moving to the + higher-level declare constant API *) +let build_named_proj ~primitive ~flags ~poly ~univs ~uinstance ~kind env paramdecls + paramargs decl impls fid subst sp_projs nfi ti i indsp mib lifted_fields x rp = + let ccl = subst_projection fid subst ti in + let body, p_opt = match decl with + | LocalDef (_,ci,_) -> subst_projection fid subst ci, None + | LocalAssum ({binder_relevance=rci},_) -> + (* [ccl] is defined in context [params;x:rp] *) + (* [ccl'] is defined in context [params;x:rp;x:rp] *) + if primitive then + let p = Projection.Repr.make indsp + ~proj_npars:mib.mind_nparams ~proj_arg:i (Label.of_id fid) in + mkProj (Projection.make p true, mkRel 1), Some p + else + let ccl' = liftn 1 2 ccl in + let p = mkLambda (x, lift 1 rp, ccl') in + let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in + let ci = Inductiveops.make_case_info env indsp rci LetStyle in + (* Record projections are always NoInvert because they're at + constant relevance *) + mkCase (ci, p, NoInvert, mkRel 1, [|branch|]), None + in + let proj = it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in + let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in + let entry = Declare.definition_entry ~univs ~types:projtyp proj in + let kind = Decls.IsDefinition kind in + let kn = + try Declare.declare_constant ~name:fid ~kind (Declare.DefinitionEntry entry) + with Type_errors.TypeError (ctx,te) as exn when not primitive -> + let _, info = Exninfo.capture exn in + Exninfo.iraise (NotDefinable (BadTypedProj (fid,ctx,te)),info) + in + Declare.definition_message fid; + let term = match p_opt with + | Some p -> + let _ = DeclareInd.declare_primitive_projection p kn in + mkProj (Projection.make p false,mkRel 1) + | None -> + let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in + match decl with + | LocalDef (_,ci,_) when primitive -> body + | _ -> applist (mkConstU (kn,uinstance),proj_args) + in + let refi = GlobRef.ConstRef kn in + Impargs.maybe_declare_manual_implicits false refi impls; + if flags.pf_subclass then begin + let cl = ComCoercion.class_of_global (GlobRef.IndRef indsp) in + ComCoercion.try_add_new_coercion_with_source refi ~local:false ~poly ~source:cl + end; + let i = if is_local_assum decl then i+1 else i in + (Some kn::sp_projs, i, Projection term::subst) + +(** [build_proj] will build a projection for each field, or skip if + the field is anonymous, i.e. [_ : t] *) +let build_proj env mib indsp primitive x rp lifted_fields ~poly paramdecls paramargs ~uinstance ~kind ~univs + (nfi,i,kinds,sp_projs,subst) flags decl impls = + let fi = RelDecl.get_name decl in + let ti = RelDecl.get_type decl in + let (sp_projs,i,subst) = + match fi with + | Anonymous -> + (None::sp_projs,i,NoProjection fi::subst) + | Name fid -> + try build_named_proj + ~primitive ~flags ~poly ~univs ~uinstance ~kind env paramdecls paramargs decl impls fid + subst sp_projs nfi ti i indsp mib lifted_fields x rp + with NotDefinable why as exn -> + let _, info = Exninfo.capture exn in + warning_or_error ~info flags.pf_subclass indsp why; + (None::sp_projs,i,NoProjection fi::subst) + in + (nfi - 1, i, + { Recordops.pk_name = fi + ; pk_true_proj = is_local_assum decl + ; pk_canonical = flags.pf_canonical } :: kinds + , sp_projs, subst) + +(** [declare_projections] prepares the common context for all record + projections and then calls [build_proj] for each one. *) +let declare_projections indsp univs ?(kind=Decls.StructureComponent) binder_name flags fieldimpls fields = let env = Global.env() in let (mib,mip) = Global.lookup_inductive indsp in let poly = Declareops.inductive_is_polymorphic mib in - let u = match ctx with + let uinstance = match univs with | Polymorphic_entry (_, ctx) -> Univ.UContext.instance ctx | Monomorphic_entry ctx -> Univ.Instance.empty in - let paramdecls = Inductive.inductive_paramdecls (mib, u) in - let r = mkIndU (indsp,u) in + let paramdecls = Inductive.inductive_paramdecls (mib, uinstance) in + let r = mkIndU (indsp,uinstance) in let rp = applist (r, Context.Rel.to_extended_list mkRel 0 paramdecls) in let paramargs = Context.Rel.to_extended_list mkRel 1 paramdecls in (*def in [[params;x:rp]]*) let x = make_annot (Name binder_name) mip.mind_relevance in - let fields = instantiate_possibly_recursive_type (fst indsp) u mib.mind_ntypes paramdecls fields in + let fields = instantiate_possibly_recursive_type (fst indsp) uinstance mib.mind_ntypes paramdecls fields in let lifted_fields = Termops.lift_rel_context 1 fields in let primitive = match mib.mind_record with @@ -321,74 +447,44 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f in let (_,_,kinds,sp_projs,_) = List.fold_left3 - (fun (nfi,i,kinds,sp_projs,subst) flags decl impls -> - let fi = RelDecl.get_name decl in - let ti = RelDecl.get_type decl in - let (sp_projs,i,subst) = - match fi with - | Anonymous -> - (None::sp_projs,i,NoProjection fi::subst) - | Name fid -> - try - let ccl = subst_projection fid subst ti in - let body, p_opt = match decl with - | LocalDef (_,ci,_) -> subst_projection fid subst ci, None - | LocalAssum ({binder_relevance=rci},_) -> - (* [ccl] is defined in context [params;x:rp] *) - (* [ccl'] is defined in context [params;x:rp;x:rp] *) - if primitive then - let p = Projection.Repr.make indsp - ~proj_npars:mib.mind_nparams ~proj_arg:i (Label.of_id fid) in - mkProj (Projection.make p true, mkRel 1), Some p - else - let ccl' = liftn 1 2 ccl in - let p = mkLambda (x, lift 1 rp, ccl') in - let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in - let ci = Inductiveops.make_case_info env indsp rci LetStyle in - (* Record projections are always NoInvert because - they're at constant relevance *) - mkCase (ci, p, NoInvert, mkRel 1, [|branch|]), None - in - let proj = it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in - let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in - let entry = Declare.definition_entry ~univs:ctx ~types:projtyp proj in - let kind = Decls.IsDefinition kind in - let kn = - try declare_constant ~name:fid ~kind (Declare.DefinitionEntry entry) - with Type_errors.TypeError (ctx,te) as exn when not primitive -> - let _, info = Exninfo.capture exn in - Exninfo.iraise (NotDefinable (BadTypedProj (fid,ctx,te)),info) - in - Declare.definition_message fid; - let term = match p_opt with - | Some p -> - let _ = DeclareInd.declare_primitive_projection p kn in - mkProj (Projection.make p false,mkRel 1) - | None -> - let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in - match decl with - | LocalDef (_,ci,_) when primitive -> body - | _ -> applist (mkConstU (kn,u),proj_args) - in - let refi = GlobRef.ConstRef kn in - Impargs.maybe_declare_manual_implicits false refi impls; - if flags.pf_subclass then begin - let cl = ComCoercion.class_of_global (GlobRef.IndRef indsp) in - ComCoercion.try_add_new_coercion_with_source refi ~local:false ~poly ~source:cl - end; - let i = if is_local_assum decl then i+1 else i in - (Some kn::sp_projs, i, Projection term::subst) - with NotDefinable why as exn -> - let _, info = Exninfo.capture exn in - warning_or_error ~info flags.pf_subclass indsp why; - (None::sp_projs,i,NoProjection fi::subst) - in - (nfi - 1, i, { Recordops.pk_name = fi ; pk_true_proj = is_local_assum decl ; pk_canonical = flags.pf_canonical } :: kinds, sp_projs, subst)) + (build_proj env mib indsp primitive x rp lifted_fields ~poly paramdecls paramargs ~uinstance ~kind ~univs) (List.length fields,0,[],[],[]) flags (List.rev fields) (List.rev fieldimpls) in (kinds,sp_projs) open Typeclasses +let check_template ~template ~poly ~univs ~params { Data.id; rdata = { DataR.min_univ; fields; _ }; _ } = + let template_candidate () = + (* we use some dummy values for the arities in the rel_context + as univs_of_constr doesn't care about localassums and + getting the real values is too annoying *) + let add_levels c levels = Univ.LSet.union levels (Vars.universes_of_constr c) in + let param_levels = + List.fold_left (fun levels d -> match d with + | LocalAssum _ -> levels + | LocalDef (_,b,t) -> add_levels b (add_levels t levels)) + Univ.LSet.empty params + in + let ctor_levels = List.fold_left + (fun univs d -> + let univs = + RelDecl.fold_constr (fun c univs -> add_levels c univs) d univs + in + univs) + param_levels fields + in + ComInductive.template_polymorphism_candidate ~ctor_levels univs params + (Some (Sorts.sort_of_univ min_univ)) + in + match template with + | Some template, _ -> + (* templateness explicitly requested *) + if poly && template then user_err Pp.(strbrk "template and polymorphism not compatible"); + template + | None, template -> + (* auto detect template *) + ComInductive.should_auto_template id (template && template_candidate ()) + let load_structure i (_, structure) = Recordops.register_structure structure @@ -402,7 +498,8 @@ let discharge_structure (_, x) = Some x let rebuild_structure s = Recordops.rebuild_structure (Global.env()) s -let inStruc : Recordops.struc_typ -> obj = +let inStruc : Recordops.struc_typ -> Libobject.obj = + let open Libobject in declare_object {(default_object "STRUCTURE") with cache_function = cache_structure; load_function = load_structure; @@ -414,7 +511,22 @@ let inStruc : Recordops.struc_typ -> obj = let declare_structure_entry o = Lib.add_anonymous_leaf (inStruc o) -let declare_structure ~cumulative finite ubinders univs paramimpls params template ?(kind=Decls.StructureComponent) ?name record_data = +(** Main record declaration part: + + The entry point is [definition_structure], which will match on the + declared [kind] and then either follow the regular record + declaration path to [declare_structure] or handle the record as a + class declaration with [declare_class]. + +*) + +(** [declare_structure] does two principal things: + + - prepares and declares the low-level (mutual) inductive corresponding to [record_data] + - prepares and declares the corresponding record projections, mainly taken care of by + [declare_projections] +*) +let declare_structure ~cumulative finite ~ubind ~univs ~variances paramimpls params template ?(kind=Decls.StructureComponent) ?name (record_data : Data.t list) = let nparams = List.length params in let poly, ctx = match univs with @@ -426,14 +538,14 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa let binder_name = match name with | None -> - let map (id, _, _, _, _, _, _, _) = + let map { Data.id; _ } = Id.of_string (Unicode.lowercase_first_char (Id.to_string id)) in Array.map_of_list map record_data | Some n -> n in let ntypes = List.length record_data in - let mk_block i (id, idbuild, min_univ, arity, _, fields, _, _) = + let mk_block i { Data.id; idbuild; rdata = { DataR.min_univ; arity; fields; _ }; _ } = let nfields = List.length fields in let args = Context.Rel.to_extended_list mkRel nfields params in let ind = applist (mkRel (ntypes - i + nparams + nfields), args) in @@ -444,42 +556,10 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa mind_entry_lc = [type_constructor] } in let blocks = List.mapi mk_block record_data in - let check_template (id, _, min_univ, _, _, fields, _, _) = - let template_candidate () = - (* we use some dummy values for the arities in the rel_context - as univs_of_constr doesn't care about localassums and - getting the real values is too annoying *) - let add_levels c levels = Univ.LSet.union levels (Vars.universes_of_constr c) in - let param_levels = - List.fold_left (fun levels d -> match d with - | LocalAssum _ -> levels - | LocalDef (_,b,t) -> add_levels b (add_levels t levels)) - Univ.LSet.empty params - in - let ctor_levels = List.fold_left - (fun univs d -> - let univs = - RelDecl.fold_constr (fun c univs -> add_levels c univs) d univs - in - univs) - param_levels fields - in - ComInductive.template_polymorphism_candidate ~ctor_levels univs params - (Some (Sorts.sort_of_univ min_univ)) - in - match template with - | Some template, _ -> - (* templateness explicitly requested *) - if poly && template then user_err Pp.(strbrk "template and polymorphism not compatible"); - template - | None, template -> - (* auto detect template *) - ComInductive.should_auto_template id (template && template_candidate ()) - in - let template = List.for_all check_template record_data in + let template = List.for_all (check_template ~template ~univs ~poly ~params) record_data in let primitive = - !primitive_flag && - List.for_all (fun (_,_,_,_,_,fields,_,_) -> List.exists is_local_assum fields) record_data + primitive_flag () && + List.for_all (fun { Data.rdata = { DataR.fields; _ }; _ } -> List.exists is_local_assum fields) record_data in let mie = { mind_entry_params = params; @@ -489,19 +569,19 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa mind_entry_private = None; mind_entry_universes = univs; mind_entry_template = template; - mind_entry_cumulative = poly && cumulative; + mind_entry_variance = ComInductive.variance_of_entry ~cumulative ~variances univs; } in let impls = List.map (fun _ -> paramimpls, []) record_data in - let kn = DeclareInd.declare_mutual_inductive_with_eliminations mie ubinders impls - ~primitive_expected:!primitive_flag + let kn = DeclareInd.declare_mutual_inductive_with_eliminations mie ubind impls + ~primitive_expected:(primitive_flag ()) in - let map i (_, _, _, _, fieldimpls, fields, is_coe, coers) = + let map i { Data.is_coercion; coers; rdata = { DataR.implfs; fields; _}; _ } = let rsp = (kn, i) in (* This is ind path of idstruc *) let cstr = (rsp, 1) in - let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers fieldimpls fields in + let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers implfs fields in let build = GlobRef.ConstructRef cstr in - let () = if is_coe then ComCoercion.try_add_new_coercion build ~local:false ~poly in + let () = if is_coercion then ComCoercion.try_add_new_coercion build ~local:false ~poly in let npars = Inductiveops.inductive_nparams (Global.env()) rsp in let struc = { Recordops.s_CONST = cstr; @@ -519,68 +599,105 @@ let implicits_of_context ctx = List.map (fun name -> CAst.make (Some (name,true))) (List.rev (Anonymous :: (List.map RelDecl.get_name ctx))) -let declare_class def cumulative ubinders univs id idbuild paramimpls params univ arity - template fieldimpls fields ?(kind=Decls.StructureComponent) coers = - let fieldimpls = +let build_class_constant ~univs ~rdata field implfs params paramimpls coers binder id proj_name = + let class_body = it_mkLambda_or_LetIn field params in + let class_type = it_mkProd_or_LetIn rdata.DataR.arity params in + let class_entry = + Declare.definition_entry ~types:class_type ~univs class_body in + let cst = Declare.declare_constant ~name:id + (Declare.DefinitionEntry class_entry) ~kind:Decls.(IsDefinition Definition) + in + let inst, univs = match univs with + | Polymorphic_entry (_, uctx) -> Univ.UContext.instance uctx, univs + | Monomorphic_entry _ -> Univ.Instance.empty, Monomorphic_entry Univ.ContextSet.empty + in + let cstu = (cst, inst) in + let inst_type = appvectc (mkConstU cstu) + (Termops.rel_vect 0 (List.length params)) in + let proj_type = + it_mkProd_or_LetIn (mkProd(binder, inst_type, lift 1 field)) params in + let proj_body = + it_mkLambda_or_LetIn (mkLambda (binder, inst_type, mkRel 1)) params in + let proj_entry = Declare.definition_entry ~types:proj_type ~univs proj_body in + let proj_cst = Declare.declare_constant ~name:proj_name + (Declare.DefinitionEntry proj_entry) ~kind:Decls.(IsDefinition Definition) + in + let cref = GlobRef.ConstRef cst in + Impargs.declare_manual_implicits false cref paramimpls; + Impargs.declare_manual_implicits false (GlobRef.ConstRef proj_cst) (List.hd implfs); + Classes.set_typeclass_transparency (EvalConstRef cst) false false; + let sub = List.hd coers in + let m = { + meth_name = Name proj_name; + meth_info = sub; + meth_const = Some proj_cst; + } in + [cref, [m]] + +let build_record_constant ~rdata ~ubind ~univs ~variances ~cumulative ~template + fields params paramimpls coers id idbuild binder_name = + let record_data = + { Data.id + ; idbuild + ; is_coercion = false + ; coers = List.map (fun _ -> { pf_subclass = false ; pf_canonical = true }) fields + ; rdata + } in + let inds = declare_structure ~cumulative Declarations.BiFinite ~ubind ~univs ~variances paramimpls + params template ~kind:Decls.Method ~name:[|binder_name|] [record_data] + in + let map ind = + let map decl b y = { + meth_name = RelDecl.get_name decl; + meth_info = b; + meth_const = y; + } in + let l = List.map3 map (List.rev fields) coers (Recordops.lookup_projections ind) in + GlobRef.IndRef ind, l + in + List.map map inds + +(** [declare_class] will prepare and declare a [Class]. This is done in + 2 steps: + + 1. two markely different paths are followed depending on whether the + class declaration refers to a constant "definitional classes" or to + a record, that is to say: + + Class foo := bar : T. + + which is equivalent to + + Definition foo := T. + Definition bar (x:foo) : T := x. + Existing Class foo. + + vs + + Class foo := { ... }. + + 2. declare the class, using the information from 1. in the form of [Classes.typeclass] + + *) +let declare_class def ~cumulative ~ubind ~univs ~variances id idbuild paramimpls params + rdata template ?(kind=Decls.StructureComponent) coers = + let implfs = (* Make the class implicit in the projections, and the params if applicable. *) let impls = implicits_of_context params in - List.map (fun x -> impls @ x) fieldimpls + List.map (fun x -> impls @ x) rdata.DataR.implfs in + let rdata = { rdata with DataR.implfs } in let binder_name = Namegen.next_ident_away id (Termops.vars_of_env (Global.env())) in + let fields = rdata.DataR.fields in let data = match fields with - | [LocalAssum ({binder_name=Name proj_name} as binder, field) - | LocalDef ({binder_name=Name proj_name} as binder, _, field)] when def -> + | [ LocalAssum ({binder_name=Name proj_name} as binder, field) + | LocalDef ({binder_name=Name proj_name} as binder, _, field) ] when def -> let binder = {binder with binder_name=Name binder_name} in - let class_body = it_mkLambda_or_LetIn field params in - let class_type = it_mkProd_or_LetIn arity params in - let class_entry = - Declare.definition_entry ~types:class_type ~univs class_body in - let cst = Declare.declare_constant ~name:id - (DefinitionEntry class_entry) ~kind:Decls.(IsDefinition Definition) - in - let inst, univs = match univs with - | Polymorphic_entry (_, uctx) -> Univ.UContext.instance uctx, univs - | Monomorphic_entry _ -> Univ.Instance.empty, Monomorphic_entry Univ.ContextSet.empty - in - let cstu = (cst, inst) in - let inst_type = appvectc (mkConstU cstu) - (Termops.rel_vect 0 (List.length params)) in - let proj_type = - it_mkProd_or_LetIn (mkProd(binder, inst_type, lift 1 field)) params in - let proj_body = - it_mkLambda_or_LetIn (mkLambda (binder, inst_type, mkRel 1)) params in - let proj_entry = Declare.definition_entry ~types:proj_type ~univs proj_body in - let proj_cst = Declare.declare_constant ~name:proj_name - (DefinitionEntry proj_entry) ~kind:Decls.(IsDefinition Definition) - in - let cref = GlobRef.ConstRef cst in - Impargs.declare_manual_implicits false cref paramimpls; - Impargs.declare_manual_implicits false (GlobRef.ConstRef proj_cst) (List.hd fieldimpls); - Classes.set_typeclass_transparency (EvalConstRef cst) false false; - let sub = List.hd coers in - let m = { - meth_name = Name proj_name; - meth_info = sub; - meth_const = Some proj_cst; - } in - [cref, [m]] + build_class_constant ~rdata ~univs field implfs params paramimpls coers binder id proj_name | _ -> - let record_data = [id, idbuild, univ, arity, fieldimpls, fields, false, - List.map (fun _ -> { pf_subclass = false ; pf_canonical = true }) fields] in - let inds = declare_structure ~cumulative Declarations.BiFinite ubinders univs paramimpls - params template ~kind:Decls.Method ~name:[|binder_name|] record_data - in - let map ind = - let map decl b y = { - meth_name = RelDecl.get_name decl; - meth_info = b; - meth_const = y; - } in - let l = List.map3 map (List.rev fields) coers (Recordops.lookup_projections ind) in - GlobRef.IndRef ind, l - in - List.map map inds + build_record_constant ~rdata ~ubind ~univs ~variances ~cumulative ~template + fields params paramimpls coers id idbuild binder_name in let univs, params, fields = match univs with @@ -598,8 +715,8 @@ let declare_class def cumulative ubinders univs id idbuild paramimpls params uni let k = { cl_univs = univs; cl_impl = impl; - cl_strict = !typeclasses_strict; - cl_unique = !typeclasses_unique; + cl_strict = typeclasses_strict (); + cl_unique = typeclasses_unique (); cl_context = params; cl_props = fields; cl_projs = projs } @@ -610,7 +727,6 @@ let declare_class def cumulative ubinders univs id idbuild paramimpls params uni in List.map map data - let add_constant_class env sigma cst = let ty, univs = Typeops.type_of_global_in_context env (GlobRef.ConstRef cst) in let r = (Environ.lookup_constant cst env).const_relevance in @@ -623,8 +739,8 @@ let add_constant_class env sigma cst = cl_context = ctx; cl_props = [LocalAssum (make_annot Anonymous r, t)]; cl_projs = []; - cl_strict = !typeclasses_strict; - cl_unique = !typeclasses_unique + cl_strict = typeclasses_strict (); + cl_unique = typeclasses_unique () } in Classes.add_class env sigma tc; @@ -645,8 +761,8 @@ let add_inductive_class env sigma ind = cl_context = ctx; cl_props = [LocalAssum (make_annot Anonymous r, ty)]; cl_projs = []; - cl_strict = !typeclasses_strict; - cl_unique = !typeclasses_unique } + cl_strict = typeclasses_strict (); + cl_unique = typeclasses_unique () } in Classes.add_class env sigma k @@ -667,14 +783,33 @@ let declare_existing_class g = open Vernacexpr +module Ast = struct + type t = + { name : Names.lident + ; is_coercion : coercion_flag + ; binders: local_binder_expr list + ; cfs : (local_decl_expr * record_field_attr) list + ; idbuild : Id.t + ; sort : constr_expr option + } + + let to_datai { name; is_coercion; cfs; idbuild; sort } = + let fs = List.map fst cfs in + { DataI.name = name.CAst.v + ; arity = sort + ; nots = List.map (fun (_, { rf_notation }) -> rf_notation) cfs + ; fs + } +end + let check_unique_names records = let extract_name acc (rf_decl, _) = match rf_decl with Vernacexpr.AssumExpr({CAst.v=Name id},_,_) -> id::acc | Vernacexpr.DefExpr ({CAst.v=Name id},_,_,_) -> id::acc | _ -> acc in let allnames = - List.fold_left (fun acc (_, id, _, cfs, _, _) -> - id.CAst.v :: (List.fold_left extract_name acc cfs)) [] records + List.fold_left (fun acc { Ast.name; cfs; _ } -> + name.CAst.v :: (List.fold_left extract_name acc cfs)) [] records in match List.duplicates Id.equal allnames with | [] -> () @@ -682,19 +817,15 @@ let check_unique_names records = let check_priorities kind records = let isnot_class = match kind with Class false -> false | _ -> true in - let has_priority (_, _, _, cfs, _, _) = + let has_priority { Ast.cfs; _ } = List.exists (fun (_, { rf_priority }) -> not (Option.is_empty rf_priority)) cfs in if isnot_class && List.exists has_priority records then user_err Pp.(str "Priorities only allowed for type class substructures") let extract_record_data records = - let map (is_coe, id, _, cfs, idbuild, s) = - let fs = List.map fst cfs in - id.CAst.v, s, List.map (fun (_, { rf_notation }) -> rf_notation) cfs, fs - in - let data = List.map map records in - let pss = List.map (fun (_, _, ps, _, _, _) -> ps) records in + let data = List.map Ast.to_datai records in + let pss = List.map (fun { Ast.binders; _ } -> binders) records in let ps = match pss with | [] -> CErrors.anomaly (str "Empty record block") | ps :: rem -> @@ -708,43 +839,73 @@ let extract_record_data records = in ps, data -(* [fs] corresponds to fields and [ps] to parameters; [coers] is a - list telling if the corresponding fields must me declared as coercions - or subinstances. *) -let definition_structure udecl kind ~template ~cumulative ~poly finite records = +(* declaring structures, common data to refactor *) +let class_struture ~cumulative ~template ~ubind ~impargs ~univs ~params def records data = + let { Ast.name; cfs; idbuild; _ }, rdata = match records, data with + | [r], [d] -> r, d + | _, _ -> + CErrors.user_err (str "Mutual definitional classes are not handled") + in + let coers = List.map (fun (_, { rf_subclass; rf_priority }) -> + match rf_subclass with + | Vernacexpr.BackInstance -> Some {hint_priority = rf_priority; hint_pattern = None} + | Vernacexpr.NoInstance -> None) + cfs + in + declare_class def ~cumulative ~ubind ~univs name.CAst.v idbuild + impargs params rdata template coers + +let regular_structure ~cumulative ~template ~ubind ~impargs ~univs ~variances ~params ~finite + records data = + let adjust_impls impls = impargs @ [CAst.make None] @ impls in + let data = List.map (fun ({ DataR.implfs; _ } as d) -> { d with DataR.implfs = List.map adjust_impls implfs }) data in + (* let map (min_univ, arity, fieldimpls, fields) { Ast.name; is_coercion; cfs; idbuild; _ } = *) + let map rdata { Ast.name; is_coercion; cfs; idbuild; _ } = + let coers = List.map (fun (_, { rf_subclass ; rf_canonical }) -> + { pf_subclass = + (match rf_subclass with Vernacexpr.BackInstance -> true | Vernacexpr.NoInstance -> false); + pf_canonical = rf_canonical }) + cfs + in + { Data.id = name.CAst.v; idbuild; rdata; is_coercion; coers } + in + let data = List.map2 map data records in + let inds = declare_structure ~cumulative finite ~ubind ~univs ~variances + impargs params template data + in + List.map (fun ind -> GlobRef.IndRef ind) inds + +(** [fs] corresponds to fields and [ps] to parameters; [coers] is a + list telling if the corresponding fields must me declared as coercions + or subinstances. *) +let definition_structure udecl kind ~template ~cumulative ~poly + finite (records : Ast.t list) : GlobRef.t list = let () = check_unique_names records in let () = check_priorities kind records in let ps, data = extract_record_data records in - let ubinders, univs, auto_template, params, implpars, data = + let auto_template, impargs, ubind, univs, variances, params, data = + (* In theory we should be able to use + [Notation.with_notation_protection], due to the call to + Metasyntax.set_notation_for_interpretation, however something + is messing state beyond that. + *) Vernacstate.System.protect (fun () -> - typecheck_params_and_fields (kind = Class true) poly udecl ps data) () in + typecheck_params_and_fields (kind = Class true) poly udecl ps data) () + in let template = template, auto_template in match kind with | Class def -> - let (_, id, _, cfs, idbuild, _), (univ, arity, implfs, fields) = match records, data with - | [r], [d] -> r, d - | _, _ -> CErrors.user_err (str "Mutual definitional classes are not handled") - in - let coers = List.map (fun (_, { rf_subclass=coe; rf_priority=pri }) -> - match coe with - | Vernacexpr.BackInstance -> Some {hint_priority = pri ; hint_pattern = None} - | Vernacexpr.NoInstance -> None) - cfs - in - declare_class def cumulative ubinders univs id.CAst.v idbuild - implpars params univ arity template implfs fields coers - | _ -> - let map impls = implpars @ [CAst.make None] @ impls in - let data = List.map (fun (univ, arity, implfs, fields) -> (univ, arity, List.map map implfs, fields)) data in - let map (univ, arity, implfs, fields) (is_coe, id, _, cfs, idbuild, _) = - let coe = List.map (fun (_, { rf_subclass ; rf_canonical }) -> - { pf_subclass = - (match rf_subclass with Vernacexpr.BackInstance -> true | Vernacexpr.NoInstance -> false); - pf_canonical = rf_canonical }) - cfs - in - id.CAst.v, idbuild, univ, arity, implfs, fields, is_coe, coe - in - let data = List.map2 map data records in - let inds = declare_structure ~cumulative finite ubinders univs implpars params template data in - List.map (fun ind -> GlobRef.IndRef ind) inds + class_struture ~template ~ubind ~impargs ~cumulative ~params ~univs ~variances + def records data + | Inductive_kw | CoInductive | Variant | Record | Structure -> + regular_structure ~cumulative ~template ~ubind ~impargs ~univs ~variances ~params ~finite + records data + +module Internal = struct + type nonrec projection_flags = projection_flags = { + pf_subclass: bool; + pf_canonical: bool; + } + let declare_projections = declare_projections + let declare_structure_entry = declare_structure_entry +end diff --git a/vernac/record.mli b/vernac/record.mli index 38a622977a..7a40af048c 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -12,38 +12,47 @@ open Names open Vernacexpr open Constrexpr -val primitive_flag : bool ref - -type projection_flags = { - pf_subclass: bool; - pf_canonical: bool; -} - -val declare_projections : - inductive -> - Entries.universes_entry -> - ?kind:Decls.definition_object_kind -> - Id.t -> - projection_flags list -> - Impargs.manual_implicits list -> - Constr.rel_context -> - Recordops.proj_kind list * Constant.t option list +module Ast : sig + type t = + { name : Names.lident + ; is_coercion : coercion_flag + ; binders: local_binder_expr list + ; cfs : (local_decl_expr * record_field_attr) list + ; idbuild : Id.t + ; sort : constr_expr option + } +end val definition_structure - : universe_decl_expr option + : cumul_univ_decl_expr option -> inductive_kind -> template:bool option -> cumulative:bool -> poly:bool -> Declarations.recursivity_kind - -> (coercion_flag * - Names.lident * - local_binder_expr list * - (local_decl_expr * record_field_attr) list * - Id.t * constr_expr option) list + -> Ast.t list -> GlobRef.t list val declare_existing_class : GlobRef.t -> unit -(** Used by elpi *) -val declare_structure_entry : Recordops.struc_typ -> unit +(* Implementation internals, consult Coq developers before using; + current user Elpi, see https://github.com/LPCIC/coq-elpi/pull/151 *) +module Internal : sig + type projection_flags = { + pf_subclass: bool; + pf_canonical: bool; + } + + val declare_projections + : Names.inductive + -> Entries.universes_entry + -> ?kind:Decls.definition_object_kind + -> Names.Id.t + -> projection_flags list + -> Impargs.manual_implicits list + -> Constr.rel_context + -> Recordops.proj_kind list * Names.Constant.t option list + + val declare_structure_entry : Recordops.struc_typ -> unit + +end diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index ef8631fbb6..4e52af7959 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -550,7 +550,7 @@ let start_lemma_com ~program_mode ~poly ~scope ~kind ?using ?hook thms = let env0 = Global.env () in let flags = Pretyping.{ all_no_fail_flags with program_mode } in let decl = fst (List.hd thms) in - let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env0 (snd decl) in + let evd, udecl = Constrintern.interp_univ_decl_opt env0 (snd decl) in let evd, thms = interp_lemma ~program_mode ~flags ~scope env0 evd thms in let mut_analysis = RecLemmas.look_for_possibly_mutual_statements evd thms in let evd = Evd.minimize_universes evd in @@ -715,16 +715,16 @@ let should_treat_as_uniform () = else ComInductive.NonUniformParameters let vernac_record ~template udecl ~cumulative k ~poly finite records = - let map ((coe, id), binders, sort, nameopt, cfs) = - let const = match nameopt with - | None -> Nameops.add_prefix "Build_" id.v + let map ((is_coercion, name), binders, sort, nameopt, cfs) = + let idbuild = match nameopt with + | None -> Nameops.add_prefix "Build_" name.v | Some lid -> let () = Dumpglob.dump_definition lid false "constr" in lid.v in let () = if Dumpglob.dump () then - let () = Dumpglob.dump_definition id false "rec" in + let () = Dumpglob.dump_definition name false "rec" in let iter (x, _) = match x with | Vernacexpr.(AssumExpr ({loc;v=Name id}, _, _) | DefExpr ({loc;v=Name id}, _, _, _)) -> Dumpglob.dump_definition (make ?loc id) false "proj" @@ -732,7 +732,7 @@ let vernac_record ~template udecl ~cumulative k ~poly finite records = in List.iter iter cfs in - coe, id, binders, cfs, const, sort + Record.Ast.{ name; is_coercion; binders; cfs; idbuild; sort } in let records = List.map map records in ignore(Record.definition_structure ~template udecl k ~cumulative ~poly finite records) @@ -1314,13 +1314,37 @@ let warn_implicit_core_hint_db = (fun () -> strbrk "Adding and removing hints in the core database implicitly is deprecated. " ++ strbrk"Please specify a hint database.") -let vernac_remove_hints ~module_local dbnames ids = +let warn_deprecated_hint_without_locality = + CWarnings.create ~name:"deprecated-hint-without-locality" ~category:"deprecated" + (fun () -> strbrk "The default value for hint locality is currently \ + \"local\" in a section and \"global\" otherwise, but is scheduled to change \ + in a future release. For the time being, adding hints outside of sections \ + without specifying an explicit locality is therefore deprecated. It is \ + recommended to use \"export\" whenever possible.") + +let check_hint_locality = function +| OptGlobal -> + if Global.sections_are_opened () then + CErrors.user_err Pp.(str + "This command does not support the global attribute in sections."); +| OptExport -> + if Global.sections_are_opened () then + CErrors.user_err Pp.(str + "This command does not support the export attribute in sections."); +| OptDefault -> + if not @@ Global.sections_are_opened () then + warn_deprecated_hint_without_locality () +| OptLocal -> () + +let vernac_remove_hints ~atts dbnames ids = + let locality = Attributes.(parse option_locality atts) in + let () = check_hint_locality locality in let dbnames = if List.is_empty dbnames then (warn_implicit_core_hint_db (); ["core"]) else dbnames in - Hints.remove_hints module_local dbnames (List.map Smartlocate.global_with_alias ids) + Hints.remove_hints ~locality dbnames (List.map Smartlocate.global_with_alias ids) let vernac_hints ~atts dbnames h = let dbnames = @@ -1329,17 +1353,7 @@ let vernac_hints ~atts dbnames h = else dbnames in let locality, poly = Attributes.(parse Notations.(option_locality ++ polymorphic) atts) in - let () = match locality with - | OptGlobal -> - if Global.sections_are_opened () then - CErrors.user_err Pp.(str - "This command does not support the global attribute in sections."); - | OptExport -> - if Global.sections_are_opened () then - CErrors.user_err Pp.(str - "This command does not support the export attribute in sections."); - | OptDefault | OptLocal -> () - in + let () = check_hint_locality locality in Hints.add_hints ~locality dbnames (ComHints.interp_hints ~poly h) let vernac_syntactic_definition ~atts lid x only_parsing = @@ -2184,7 +2198,7 @@ let translate_vernac ~atts v = let open Vernacextend in match v with with_module_locality ~atts vernac_create_hintdb dbname b) | VernacRemoveHints (dbnames,ids) -> VtDefault(fun () -> - with_module_locality ~atts vernac_remove_hints dbnames ids) + vernac_remove_hints ~atts dbnames ids) | VernacHints (dbnames,hints) -> VtDefault(fun () -> vernac_hints ~atts dbnames hints) diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 6a9a74144f..defb0691c0 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -189,8 +189,9 @@ type inductive_params_expr = local_binder_expr list * local_binder_expr list opt (** If the option is nonempty the "|" marker was used *) type inductive_expr = - ident_decl with_coercion * inductive_params_expr * constr_expr option * - constructor_list_or_record_decl_expr + cumul_ident_decl with_coercion + * inductive_params_expr * constr_expr option + * constructor_list_or_record_decl_expr type one_inductive_expr = lident * inductive_params_expr * constr_expr option * constructor_expr list |