diff options
686 files changed, 19047 insertions, 11842 deletions
diff --git a/.gitignore b/.gitignore index bdd692420f..aab1d1ede7 100644 --- a/.gitignore +++ b/.gitignore @@ -155,6 +155,7 @@ kernel/byterun/coq_jumptbl.h kernel/genOpcodeFiles.exe kernel/vmopcodes.ml kernel/uint63.ml +kernel/float64.ml ide/coqide/default.bindings ide/coqide/default_bindings_src.exe ide/coqide/index_urls.txt diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index b1709e1921..18ea50d77b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -461,7 +461,7 @@ pkg:nix:deploy:channel: script: - echo "$CACHIX_DEPLOYMENT_KEY" | tr -d '\r' | ssh-add - > /dev/null # Remove all pr branches because they could be missing when we run git fetch --unshallow - - git branch --list 'pr-*' | xargs -r git branch -d + - git branch --list 'pr-*' | xargs -r git branch -D - git fetch --unshallow - git branch -v - git push git@github.com:coq/coq-on-cachix "${CI_COMMIT_SHA}":"refs/heads/${CI_COMMIT_REF_NAME}" diff --git a/Makefile.common b/Makefile.common index a482b9b963..caf1821ce5 100644 --- a/Makefile.common +++ b/Makefile.common @@ -149,11 +149,9 @@ CCCMO:=plugins/cc/cc_plugin.cmo BTAUTOCMO:=plugins/btauto/btauto_plugin.cmo RTAUTOCMO:=plugins/rtauto/rtauto_plugin.cmo SYNTAXCMO:=$(addprefix plugins/syntax/, \ - r_syntax_plugin.cmo \ int63_syntax_plugin.cmo \ float_syntax_plugin.cmo \ - numeral_notation_plugin.cmo \ - string_notation_plugin.cmo) + number_string_notation_plugin.cmo) DERIVECMO:=plugins/derive/derive_plugin.cmo LTACCMO:=plugins/ltac/ltac_plugin.cmo plugins/ltac/tauto_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo diff --git a/Makefile.doc b/Makefile.doc index 473a70fb72..a5ff8e0123 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -248,8 +248,7 @@ $(DOC_GRAM): $(DOC_GRAMCMO) coqpp/coqpp_parser.mli coqpp/coqpp_parser.ml doc/too # user-contrib/*/*.mlg omitted for now (e.g. ltac2) PLUGIN_MLGS := $(wildcard plugins/*/*.mlg) -OMITTED_PLUGIN_MLGS := plugins/ssr/ssrparser.mlg plugins/ssr/ssrvernac.mlg plugins/ssrmatching/g_ssrmatching.mlg \ - plugins/ssrsearch/g_search.mlg +OMITTED_PLUGIN_MLGS := DOC_MLGS := $(wildcard */*.mlg) $(sort $(filter-out $(OMITTED_PLUGIN_MLGS), $(PLUGIN_MLGS))) \ user-contrib/Ltac2/g_ltac2.mlg DOC_EDIT_MLGS := $(wildcard doc/tools/docgram/*.edit_mlg) diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 41b5210f45..46bd4367a7 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -62,16 +62,9 @@ jobs: - script: | set -e - brew update - (cd $(brew --repository)/Library/Taps/homebrew/homebrew-core/ && git fetch --shallow-since=${HBCORE_DATE} && git checkout ${HBCORE_REF}) - brew install gnu-time opam pkg-config gtksourceview3 adwaita-icon-theme gmp || true - # || true: workaround #12657, see also #12672 and commit message for this line + brew install gnu-time opam gtksourceview3 adwaita-icon-theme pip3 install macpack displayName: 'Install system dependencies' - env: - HOMEBREW_NO_AUTO_UPDATE: "1" - HBCORE_DATE: "2019-09-03" - HBCORE_REF: "44ee64cf4b9f2d2bf000758d356db0c77425e42e" - script: | set -e @@ -107,17 +100,17 @@ jobs: make install displayName: 'Install Coq' - - script: | - set -e - eval $(opam env) - export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig - ./dev/build/osx/make-macos-dmg.sh - mv _build/*.dmg "$(Build.ArtifactStagingDirectory)/" - displayName: 'Create the dmg bundle' - env: - OUTDIR: '$(Build.BinariesDirectory)' - - - task: PublishBuildArtifacts@1 - inputs: - pathtoPublish: '$(Build.ArtifactStagingDirectory)' - artifactName: coq-macOS-installer +# - script: | +# set -e +# eval $(opam env) +# export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig +# ./dev/build/osx/make-macos-dmg.sh +# mv _build/*.dmg "$(Build.ArtifactStagingDirectory)/" +# displayName: 'Create the dmg bundle' +# env: +# OUTDIR: '$(Build.BinariesDirectory)' + +# - task: PublishBuildArtifacts@1 +# inputs: +# pathtoPublish: '$(Build.ArtifactStagingDirectory)' +# artifactName: coq-macOS-installer diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index ef606c9a75..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; } @@ -104,7 +105,7 @@ let check_kelim k1 k2 = Sorts.family_leq k1 k2 let eq_nested_types ty1 ty2 = match ty1, ty2 with | NestedInd ind1, NestedInd ind2 -> eq_ind_chk ind1 ind2 | NestedInd _, _ -> false -| NestedPrimitive c1, NestedPrimitive c2 -> Names.Constant.equal c1 c2 +| NestedPrimitive c1, NestedPrimitive c2 -> Names.Constant.CanOrd.equal c1 c2 | NestedPrimitive _, _ -> false let eq_recarg a1 a2 = match a1, a2 with 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/checker/values.ml b/checker/values.ml index 38cb243f80..4e99d087df 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -374,7 +374,7 @@ and v_modtype = let v_vodigest = Sum ("module_impl",0, [| [|String|]; [|String;String|] |]) let v_deps = Array (v_tuple "dep" [|v_dp;v_vodigest|]) let v_compiled_lib = - v_tuple "compiled" [|v_dp;v_module;v_context_set;v_deps;v_engagement;Any|] + v_tuple "compiled" [|v_dp;v_module;v_context_set;v_deps;v_engagement|] (** Library objects *) diff --git a/clib/cList.ml b/clib/cList.ml index 057200f83e..6b13fac48c 100644 --- a/clib/cList.ml +++ b/clib/cList.ml @@ -1019,20 +1019,12 @@ let rec factorize_left cmp = function module Smart = struct - let rec map_loop f p = function - | [] -> () - | x :: l' as l -> - let x' = f x in - map_loop f p l'; - if x' == x && !p == l' then p := l else p := x' :: !p - - let map f = function - | [] -> [] - | x :: l' as l -> - let p = ref [] in - let x' = f x in - map_loop f p l'; - if x' == x && !p == l' then l else x' :: !p + let rec map f l = match l with + | [] -> l + | h :: tl -> + let h' = f h in + let tl' = map f tl in + if h' == h && tl' == tl then l else h' :: tl' end diff --git a/clib/cString.ml b/clib/cString.ml index dcada4c18f..9d2c3729b2 100644 --- a/clib/cString.ml +++ b/clib/cString.ml @@ -25,6 +25,7 @@ sig val ordinal : int -> string val is_sub : string -> string -> int -> bool val is_prefix : string -> string -> bool + val is_suffix : string -> string -> bool module Set : Set.S with type elt = t module Map : CMap.ExtS with type key = t and module Set := Set module List : CList.MonoS with type elt = t @@ -105,6 +106,9 @@ let is_sub p s off = let is_prefix p s = is_sub p s 0 +let is_suffix p s = + is_sub p s (String.length s - String.length p) + let plural n s = if n<>1 then s^"s" else s let conjugate_verb_to_be n = if n<>1 then "are" else "is" diff --git a/clib/cString.mli b/clib/cString.mli index 0f78e66573..be8a202b64 100644 --- a/clib/cString.mli +++ b/clib/cString.mli @@ -54,6 +54,9 @@ sig val is_prefix : string -> string -> bool (** [is_prefix p s] tests whether [p] is a prefix of [s]. *) + val is_suffix : string -> string -> bool + (** [is_suffix suf s] tests whether [suf] is a suffix of [s]. *) + (** {6 Generic operations} **) module Set : Set.S with type elt = t 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/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 5e3199e8a6..8affe58824 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -454,7 +454,7 @@ struct let terminal s = let p = - if s <> "" && s.[0] >= '0' && s.[0] <= '9' then "CLexer.terminal_numeral" + if s <> "" && s.[0] >= '0' && s.[0] <= '9' then "CLexer.terminal_number" else "CLexer.terminal" in let c = Printf.sprintf "Pcoq.Symbol.token (%s \"%s\")" p s in SymbQuote c @@ -469,7 +469,7 @@ let rec parse_symb self = function | Uentryl (e, l) -> assert (e = "tactic"); if l = 5 then SymbEntry ("Pltac.binder_tactic", None) - else SymbEntry ("Pltac.tactic_expr", Some (string_of_int l)) + else SymbEntry ("Pltac.ltac_expr", Some (string_of_int l)) let parse_token self = function | ExtTerminal s -> (terminal s, None) diff --git a/default.nix b/default.nix index ffee77f1f7..7f9e62b28c 100644 --- a/default.nix +++ b/default.nix @@ -43,7 +43,6 @@ stdenv.mkDerivation rec { hostname python3 time # coq-makefile timing tools ] - ++ (with ocamlPackages; [ ocaml findlib ]) ++ optionals buildIde [ ocamlPackages.lablgtk3-sourceview3 glib gnome3.defaultIconTheme wrapGAppsHook @@ -69,10 +68,13 @@ stdenv.mkDerivation rec { ++ [ dune_2 ] # Maybe the next build system ); - # Since #12604, ocamlfind looks for num when building plugins + # OCaml and findlib are needed so that native_compute works + # This follows a similar change in the nixpkgs repo (cf. NixOS/nixpkgs#101058) + # ocamlfind looks for zarith when building plugins # This follows a similar change in the nixpkgs repo (cf. NixOS/nixpkgs#94230) - # Same for zarith which is needed since its introduction as a dependency of Coq - propagatedBuildInputs = with ocamlPackages; [ zarith ]; + propagatedBuildInputs = with ocamlPackages; [ ocaml findlib zarith ]; + + propagatedUserEnvPkgs = with ocamlPackages; [ ocaml findlib ]; src = if shell then null diff --git a/dev/bench/gitlab.sh b/dev/bench/gitlab.sh index 1dea97160c..d2e150be9a 100755 --- a/dev/bench/gitlab.sh +++ b/dev/bench/gitlab.sh @@ -41,18 +41,18 @@ echo $PWD #check_variable "JENKINS_URL" check_variable "CI_JOB_URL" -: "${coq_pr_number:=''}" -: "${coq_pr_comment_id:=''}" -: "${new_ocaml_switch:='ocaml-base-compiler.4.07.1'}" -: "${old_ocaml_switch:='ocaml-base-compiler.4.07.1'}" -: "${new_coq_repository:='https://gitlab.com/coq/coq.git'}" -: "${old_coq_repository:='https://gitlab.com/coq/coq.git'}" -: "${new_coq_opam_archive_git_uri:='https://github.com/coq/opam-coq-archive.git'}" -: "${old_coq_opam_archive_git_uri:='https://github.com/coq/opam-coq-archive.git'}" -: "${new_coq_opam_archive_git_branch:='master'}" -: "${old_coq_opam_archive_git_branch:='master'}" +: "${coq_pr_number:=}" +: "${coq_pr_comment_id:=}" +: "${new_ocaml_switch:=ocaml-base-compiler.4.07.1}" +: "${old_ocaml_switch:=ocaml-base-compiler.4.07.1}" +: "${new_coq_repository:=https://gitlab.com/coq/coq.git}" +: "${old_coq_repository:=https://gitlab.com/coq/coq.git}" +: "${new_coq_opam_archive_git_uri:=https://github.com/coq/opam-coq-archive.git}" +: "${old_coq_opam_archive_git_uri:=https://github.com/coq/opam-coq-archive.git}" +: "${new_coq_opam_archive_git_branch:=master}" +: "${old_coq_opam_archive_git_branch:=master}" : "${num_of_iterations:=1}" -: "${coq_opam_packages:='coq-performance-tests-lite coq-engine-bench-lite coq-hott coq-bignums coq-mathcomp-ssreflect coq-mathcomp-fingroup coq-mathcomp-algebra coq-mathcomp-solvable coq-mathcomp-field coq-mathcomp-character coq-mathcomp-odd-order coq-math-classes coq-corn coq-flocq coq-compcert coq-geocoq coq-color coq-coqprime coq-coqutil coq-bedrock2 coq-rewriter coq-fiat-core coq-fiat-parsers coq-fiat-crypto coq-unimath coq-sf-plf coq-coquelicot coq-lambda-rust coq-verdi coq-verdi-raft coq-fourcolor coq-rewriter-perf-SuperFast'}" +: "${coq_opam_packages:=coq-performance-tests-lite coq-engine-bench-lite coq-hott coq-bignums coq-mathcomp-ssreflect coq-mathcomp-fingroup coq-mathcomp-algebra coq-mathcomp-solvable coq-mathcomp-field coq-mathcomp-character coq-mathcomp-odd-order coq-math-classes coq-corn coq-flocq coq-compcert coq-geocoq coq-color coq-coqprime coq-coqutil coq-bedrock2 coq-rewriter coq-fiat-core coq-fiat-parsers coq-fiat-crypto coq-unimath coq-sf-plf coq-coquelicot coq-lambda-rust coq-verdi coq-verdi-raft coq-fourcolor coq-rewriter-perf-SuperFast}" new_coq_commit=$(git rev-parse HEAD^2) old_coq_commit=$(git merge-base HEAD^1 $new_coq_commit) diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index f9187d53a6..b85261d7fc 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -44,6 +44,18 @@ CI_BUILD_DIR="$PWD/_build_ci" ls -l "$CI_BUILD_DIR" || true +declare -A overlays + +overlay() +{ + local project=$1 + local ov_url=$2 + local ov_ref=$3 + + overlays[${project}_URL]=$ov_url + overlays[${project}_REF]=$ov_ref +} + set +x for overlay in "${ci_dir}"/user-overlays/*.sh; do # shellcheck source=/dev/null @@ -62,32 +74,44 @@ set -x # (local build), it uses git clone to perform the download. git_download() { - local PROJECT=$1 - local DEST="$CI_BUILD_DIR/$PROJECT" - local GITURL_VAR="${PROJECT}_CI_GITURL" - local GITURL="${!GITURL_VAR}" - local REF_VAR="${PROJECT}_CI_REF" - local REF="${!REF_VAR}" - - if [ -d "$DEST" ]; then - echo "Warning: download and unpacking of $PROJECT skipped because $DEST already exists." - elif [ "$FORCE_GIT" = "1" ] || [ "$CI" = "" ]; then - git clone "$GITURL" "$DEST" - cd "$DEST" - git checkout "$REF" + local project=$1 + local dest="$CI_BUILD_DIR/$project" + + local giturl_var="${project}_CI_GITURL" + local giturl="${!giturl_var}" + local ref_var="${project}_CI_REF" + local ref="${!ref_var}" + + local ov_url=${overlays[${project}_URL]} + local ov_ref=${overlays[${project}_REF]} + + if [ -d "$dest" ]; then + echo "Warning: download and unpacking of $project skipped because $dest already exists." + elif [[ $ov_url ]] || [ "$FORCE_GIT" = "1" ] || [ "$CI" = "" ]; then + git clone "$giturl" "$dest" + cd "$dest" + git checkout "$ref" + git log -n 1 + if [[ $ov_url ]]; then + git -c pull.rebase=false -c user.email=nobody@example.invalid -c user.name=Nobody \ + pull --no-ff "$ov_url" "$ov_ref" + git log -n 1 HEAD^2 + git log -n 1 + fi else # When possible, we download tarballs to reduce bandwidth and latency - local ARCHIVEURL_VAR="${PROJECT}_CI_ARCHIVEURL" - local ARCHIVEURL="${!ARCHIVEURL_VAR}" - mkdir -p "$DEST" - cd "$DEST" - local COMMIT=$(git ls-remote "$GITURL" "refs/heads/$REF" | cut -f 1) - if [[ "$COMMIT" == "" ]]; then - # $REF must have been a tag or hash, not a branch - COMMIT="$REF" + local archiveurl_var="${project}_CI_ARCHIVEURL" + local archiveurl="${!archiveurl_var}" + mkdir -p "$dest" + cd "$dest" + local commit + commit=$(git ls-remote "$giturl" "refs/heads/$ref" | cut -f 1) + if [[ "$commit" == "" ]]; then + # $ref must have been a tag or hash, not a branch + commit="$ref" fi - wget "$ARCHIVEURL/$COMMIT.tar.gz" - tar xfz "$COMMIT.tar.gz" --strip-components=1 - rm -f "$COMMIT.tar.gz" + wget "$archiveurl/$commit.tar.gz" + tar xfz "$commit.tar.gz" --strip-components=1 + rm -f "$commit.tar.gz" fi } 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/08743-ejgallego-zarith.sh b/dev/ci/user-overlays/08743-ejgallego-zarith.sh deleted file mode 100644 index da1d30c1e9..0000000000 --- a/dev/ci/user-overlays/08743-ejgallego-zarith.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11742" ] || [ "$CI_BRANCH" = "zarith+core" ]; then - - bignums_CI_REF=zarith - bignums_CI_GITURL=https://github.com/ejgallego/bignums - -fi diff --git a/dev/ci/user-overlays/10390-SkySkimmer-uip.sh b/dev/ci/user-overlays/10390-SkySkimmer-uip.sh deleted file mode 100644 index 80107ac9c5..0000000000 --- a/dev/ci/user-overlays/10390-SkySkimmer-uip.sh +++ /dev/null @@ -1,30 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10390" ] || [ "$CI_BRANCH" = "uip" ]; then - - unicoq_CI_REF=uip - unicoq_CI_GITURL=https://github.com/SkySkimmer/unicoq - - mtac2_CI_REF=uip - mtac2_CI_GITURL=https://github.com/SkySkimmer/Mtac2 - - elpi_CI_REF=uip - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - - equations_CI_REF=uip - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - paramcoq_CI_REF=uip - paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq - - relation_algebra_CI_REF=uip - relation_algebra_CI_GITURL=https://github.com/SkySkimmer/relation-algebra - - coq_dpdgraph_CI_REF=uip - coq_dpdgraph_CI_GITURL=https://github.com/SkySkimmer/coq-dpdgraph - - coqhammer_CI_REF=uip - coqhammer_CI_GITURL=https://github.com/SkySkimmer/coqhammer - - metacoq_CI_REF=uip - metacoq_CI_GITURL=https://github.com/SkySkimmer/metacoq - -fi diff --git a/dev/ci/user-overlays/11566-ejgallego-exninfo+coercion.sh b/dev/ci/user-overlays/11566-ejgallego-exninfo+coercion.sh deleted file mode 100644 index 05192facbe..0000000000 --- a/dev/ci/user-overlays/11566-ejgallego-exninfo+coercion.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11566" ] || [ "$CI_BRANCH" = "exninfo+coercion" ]; then - - mtac2_CI_REF=exninfo+coercion - mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 - -fi diff --git a/dev/ci/user-overlays/11604-persistent-arrays.sh b/dev/ci/user-overlays/11604-persistent-arrays.sh deleted file mode 100644 index aec5c4fa3d..0000000000 --- a/dev/ci/user-overlays/11604-persistent-arrays.sh +++ /dev/null @@ -1,18 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11604" ] || [ "$CI_BRANCH" = "persistent-arrays" ]; then - - unicoq_CI_REF=persistent-arrays - unicoq_CI_GITURL=https://github.com/maximedenes/unicoq - - elpi_CI_REF=persistent-arrays - elpi_CI_GITURL=https://github.com/maximedenes/coq-elpi - - #relation_algebra_CI_REF=persistent-arrays - #relation_algebra_CI_GITURL=https://github.com/maximedenes/relation-algebra - - coqhammer_CI_REF=persistent-arrays - coqhammer_CI_GITURL=https://github.com/maximedenes/coqhammer - - metacoq_CI_REF=persistent-arrays - metacoq_CI_GITURL=https://github.com/maximedenes/metacoq - -fi diff --git a/dev/ci/user-overlays/11836-ejgallego-obligations+functional.sh b/dev/ci/user-overlays/11836-ejgallego-obligations+functional.sh deleted file mode 100644 index 72ec55a37c..0000000000 --- a/dev/ci/user-overlays/11836-ejgallego-obligations+functional.sh +++ /dev/null @@ -1,18 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11836" ] || [ "$CI_BRANCH" = "obligations+functional" ]; then - - mtac2_CI_REF=obligations+functional - mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 - - paramcoq_CI_REF=obligations+functional - paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq - - equations_CI_REF=obligations+functional - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - metacoq_CI_REF=obligations+functional - metacoq_CI_GITURL=https://github.com/ejgallego/metacoq - - rewriter_CI_REF=obligations+functional - rewriter_CI_GITURL=https://github.com/ejgallego/rewriter - -fi diff --git a/dev/ci/user-overlays/11922-ppedrot-rm-local-reductionops.sh b/dev/ci/user-overlays/11922-ppedrot-rm-local-reductionops.sh deleted file mode 100644 index c9ddb3fb9f..0000000000 --- a/dev/ci/user-overlays/11922-ppedrot-rm-local-reductionops.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11922" ] || [ "$CI_BRANCH" = "rm-local-reductionops" ]; then - - equations_CI_REF="rm-local-reductionops" - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - - unicoq_CI_REF="rm-local-reductionops" - unicoq_CI_GITURL=https://github.com/ppedrot/unicoq - -fi diff --git a/dev/ci/user-overlays/11948-proux01-hexadecimal.sh b/dev/ci/user-overlays/11948-proux01-hexadecimal.sh deleted file mode 100644 index 0b3133d1f1..0000000000 --- a/dev/ci/user-overlays/11948-proux01-hexadecimal.sh +++ /dev/null @@ -1,12 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "11948" ] || [ "$CI_BRANCH" = "hexadecimal" ]; then - - stdlib2_CI_REF=hexadecimal - stdlib2_CI_GITURL=https://github.com/proux01/stdlib2 - - paramcoq_CI_REF=hexadecimal - paramcoq_CI_GITURL=https://github.com/proux01/paramcoq - - metacoq_CI_REF=hexadecimal - metacoq_CI_GITURL=https://github.com/proux01/metacoq - -fi diff --git a/dev/ci/user-overlays/12218-proux01-numeral-notations-non-inductive.sh b/dev/ci/user-overlays/12218-proux01-numeral-notations-non-inductive.sh new file mode 100644 index 0000000000..d9b49ad0d1 --- /dev/null +++ b/dev/ci/user-overlays/12218-proux01-numeral-notations-non-inductive.sh @@ -0,0 +1,18 @@ +if [ "$CI_PULL_REQUEST" = "12218" ] || [ "$CI_BRANCH" = "numeral-notations-non-inductive" ]; then + + stdlib2_CI_REF=numeral-notations-non-inductive + stdlib2_CI_GITURL=https://github.com/proux01/stdlib2 + + hott_CI_REF=numeral-notations-non-inductive + hott_CI_GITURL=https://github.com/proux01/HoTT + + paramcoq_CI_REF=numeral-notations-non-inductive + paramcoq_CI_GITURL=https://github.com/proux01/paramcoq + + quickchick_CI_REF=numeral-notations-non-inductive + quickchick_CI_GITURL=https://github.com/proux01/QuickChick + + metacoq_CI_REF=numeral-notations-non-inductive + metacoq_CI_GITURL=https://github.com/proux01/metacoq + +fi diff --git a/dev/ci/user-overlays/12267-gares-elpi-1.11.sh b/dev/ci/user-overlays/12267-gares-elpi-1.11.sh deleted file mode 100644 index ceb7afe3d1..0000000000 --- a/dev/ci/user-overlays/12267-gares-elpi-1.11.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12267" ] || [ "$CI_BRANCH" = "elpi-1.11" ]; then - - elpi_CI_REF="coq-master+elpi-1.11" - elpi_hb_CI_REF="coq-master+elpi.11" - -fi diff --git a/dev/ci/user-overlays/12372-ejgallego-proof+info.sh b/dev/ci/user-overlays/12372-ejgallego-proof+info.sh deleted file mode 100644 index b9fdc338b5..0000000000 --- a/dev/ci/user-overlays/12372-ejgallego-proof+info.sh +++ /dev/null @@ -1,24 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12372" ] || [ "$CI_BRANCH" = "proof+info" ]; then - - rewriter_CI_REF=proof+info - rewriter_CI_GITURL=https://github.com/ejgallego/rewriter - - paramcoq_CI_REF=proof+info - paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq - - mtac2_CI_REF=proof+info - mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 - - equations_CI_REF=proof+info - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - elpi_CI_REF=proof+info - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - - aac_tactics_CI_REF=proof+info - aac_tactics_CI_GITURL=https://github.com/ejgallego/aac-tactics - - metacoq_CI_REF=proof+info - metacoq_CI_GITURL=https://github.com/ejgallego/metacoq - -fi diff --git a/dev/ci/user-overlays/12505-ppedrot-factor-hint-flags.sh b/dev/ci/user-overlays/12505-ppedrot-factor-hint-flags.sh deleted file mode 100644 index ced0d95945..0000000000 --- a/dev/ci/user-overlays/12505-ppedrot-factor-hint-flags.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12505" ] || [ "$CI_BRANCH" = "factor-hint-flags" ]; then - - fiat_parsers_CI_REF="factor-hint-flags" - fiat_parsers_CI_GITURL=https://github.com/ppedrot/fiat - -fi diff --git a/dev/ci/user-overlays/12523-term-notation-custom.sh b/dev/ci/user-overlays/12523-term-notation-custom.sh deleted file mode 100644 index 6217312a2a..0000000000 --- a/dev/ci/user-overlays/12523-term-notation-custom.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12523" ] || [ "$CI_BRANCH" = "fix-11121" ]; then - - equations_CI_REF=fix-11121 - equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/12565-ppedrot-fix-tc-search-opacity.sh b/dev/ci/user-overlays/12565-ppedrot-fix-tc-search-opacity.sh deleted file mode 100644 index 7c04608403..0000000000 --- a/dev/ci/user-overlays/12565-ppedrot-fix-tc-search-opacity.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12565" ] || [ "$CI_BRANCH" = "fix-tc-search-opacity" ]; then - - coqhammer_CI_REF=fix-tc-search-opacity - coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer - -fi diff --git a/dev/ci/user-overlays/12599-ppedrot-rm-deprecated-refiner.sh b/dev/ci/user-overlays/12599-ppedrot-rm-deprecated-refiner.sh deleted file mode 100644 index c8c5b3ed5a..0000000000 --- a/dev/ci/user-overlays/12599-ppedrot-rm-deprecated-refiner.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12599" ] || [ "$CI_BRANCH" = "rm-deprecated-refiner" ]; then - - equations_CI_REF=rm-deprecated-refiner - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - -fi 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/12650-SkySkimmer-rebuild-record.sh b/dev/ci/user-overlays/12650-SkySkimmer-rebuild-record.sh deleted file mode 100644 index d4c67b03b5..0000000000 --- a/dev/ci/user-overlays/12650-SkySkimmer-rebuild-record.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12650" ] || [ "$CI_BRANCH" = "rebuild-record" ]; then - - elpi_CI_REF=rebuild-record - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - -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/12709-ppedrot-hint-pattern-out.sh b/dev/ci/user-overlays/12709-ppedrot-hint-pattern-out.sh deleted file mode 100644 index 56a69abbf7..0000000000 --- a/dev/ci/user-overlays/12709-ppedrot-hint-pattern-out.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12709" ] || [ "$CI_BRANCH" = "hint-pattern-out" ]; then - - coqhammer_CI_REF=hint-pattern-out - coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer - -fi diff --git a/dev/ci/user-overlays/12720-ppedrot-factor-class-hint-clenv.sh b/dev/ci/user-overlays/12720-ppedrot-factor-class-hint-clenv.sh deleted file mode 100644 index e57f95ef19..0000000000 --- a/dev/ci/user-overlays/12720-ppedrot-factor-class-hint-clenv.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12720" ] || [ "$CI_BRANCH" = "factor-class-hint-clenv" ]; then - - coqhammer_CI_REF=factor-class-hint-clenv - coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer - -fi diff --git a/dev/ci/user-overlays/12756-jashug-dont-refresh-argument-names.sh b/dev/ci/user-overlays/12756-jashug-dont-refresh-argument-names.sh deleted file mode 100644 index 54fdd87566..0000000000 --- a/dev/ci/user-overlays/12756-jashug-dont-refresh-argument-names.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12756" ] || [ "$CI_BRANCH" = "dont-refresh-argument-names" ]; then - - mathcomp_CI_REF=dont-refresh-argument-names-overlay - mathcomp_CI_GITURL=https://github.com/jashug/math-comp - - oddorder_CI_REF=dont-refresh-argument-names-overlay - oddorder_CI_GITURL=https://github.com/jashug/odd-order - -fi diff --git a/dev/ci/user-overlays/12801-VincentSe-CyclicSet.sh b/dev/ci/user-overlays/12801-VincentSe-CyclicSet.sh deleted file mode 100644 index 6a9cf78687..0000000000 --- a/dev/ci/user-overlays/12801-VincentSe-CyclicSet.sh +++ /dev/null @@ -1,8 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12801" ] || [ "$CI_BRANCH" = "CyclicSet" ]; then - - bignums_CI_REF=CyclicSet - bignums_CI_GITURL=https://github.com/VincentSe/bignums - - coqprime_CI_REF=CyclicSet - coqprime_CI_GITURL=https://github.com/VincentSe/coqprime -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/ci/user-overlays/12875-herbelin-master+about-print-all-arguments-names.sh b/dev/ci/user-overlays/12875-herbelin-master+about-print-all-arguments-names.sh deleted file mode 100644 index bb08c13ef3..0000000000 --- a/dev/ci/user-overlays/12875-herbelin-master+about-print-all-arguments-names.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12875" ] || [ "$CI_BRANCH" = "master+about-print-all-arguments-names" ]; then - - elpi_CI_REF=coq-master+adapt-coq12875-arguments-pass-name-impargs - elpi_CI_GITURL=https://github.com/herbelin/coq-elpi - -fi diff --git a/dev/ci/user-overlays/12892-SkySkimmer-update-s-univs.sh b/dev/ci/user-overlays/12892-SkySkimmer-update-s-univs.sh deleted file mode 100644 index f0878202d3..0000000000 --- a/dev/ci/user-overlays/12892-SkySkimmer-update-s-univs.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12892" ] || [ "$CI_BRANCH" = "update-s-univs" ]; then - - elpi_CI_REF=update-s-univs - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - - equations_CI_REF=update-s-univs - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/12968-maximedenes-delay-frozen-evarconv.sh b/dev/ci/user-overlays/12968-maximedenes-delay-frozen-evarconv.sh deleted file mode 100644 index ee75944a52..0000000000 --- a/dev/ci/user-overlays/12968-maximedenes-delay-frozen-evarconv.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12968" ] || [ "$CI_BRANCH" = "delay-frozen-evarconv" ]; then - - equations_CI_REF=delay-frozen-evarconv - equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/12977-ppedrot-static-hint-poly.sh b/dev/ci/user-overlays/12977-ppedrot-static-hint-poly.sh deleted file mode 100644 index 7bed43afe1..0000000000 --- a/dev/ci/user-overlays/12977-ppedrot-static-hint-poly.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "12977" ] || [ "$CI_BRANCH" = "static-hint-poly" ]; then - - equations_CI_REF=static-hint-poly - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - - fiat_parsers_CI_REF=static-hint-poly - fiat_parsers_CI_GITURL=https://github.com/ppedrot/fiat - -fi diff --git a/dev/ci/user-overlays/13028-herbelin-master+fix-quotations-printing.sh b/dev/ci/user-overlays/13028-herbelin-master+fix-quotations-printing.sh deleted file mode 100644 index 3407c2db39..0000000000 --- a/dev/ci/user-overlays/13028-herbelin-master+fix-quotations-printing.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13028" ] || [ "$CI_BRANCH" = "master+fix-quotations-printing" ]; then - - equations_CI_REF=master+adapt-coq-pr13028-quotation-qualifier-printing - equations_CI_GITURL=https://github.com/herbelin/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/13075-ppedrot-explicit-names-quotient.sh b/dev/ci/user-overlays/13075-ppedrot-explicit-names-quotient.sh new file mode 100644 index 0000000000..8b223719ea --- /dev/null +++ b/dev/ci/user-overlays/13075-ppedrot-explicit-names-quotient.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "13075" ] || [ "$CI_BRANCH" = "explicit-names-quotient" ]; then + + elpi_CI_REF=explicit-names-quotient + elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi + + coq_dpdgraph_CI_REF=explicit-names-quotient + coq_dpdgraph_CI_GITURL=https://github.com/ppedrot/coq-dpdgraph + +fi diff --git a/dev/ci/user-overlays/13088-gares-par-to-tactic.sh b/dev/ci/user-overlays/13088-gares-par-to-tactic.sh deleted file mode 100644 index 4108a1aed1..0000000000 --- a/dev/ci/user-overlays/13088-gares-par-to-tactic.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13088" ] || [ "$CI_BRANCH" = "par-to-tactic" ]; then - - mtac2_CI_REF=par-to-tactic - mtac2_CI_GITURL=https://github.com/gares/Mtac2 - -fi diff --git a/dev/ci/user-overlays/13128-SkySkimmer-noinstance.sh b/dev/ci/user-overlays/13128-SkySkimmer-noinstance.sh index 654d95f205..f16cf1497e 100644 --- a/dev/ci/user-overlays/13128-SkySkimmer-noinstance.sh +++ b/dev/ci/user-overlays/13128-SkySkimmer-noinstance.sh @@ -1,6 +1,5 @@ if [ "$CI_PULL_REQUEST" = "13128" ] || [ "$CI_BRANCH" = "noinstance" ]; then - elpi_CI_REF=noinstance - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + overlay elpi https://github.com/SkySkimmer/coq-elpi noinstance fi diff --git a/dev/ci/user-overlays/13139-ppedrot-clean-hint-constr.sh b/dev/ci/user-overlays/13139-ppedrot-clean-hint-constr.sh new file mode 100644 index 0000000000..2f70f43a2b --- /dev/null +++ b/dev/ci/user-overlays/13139-ppedrot-clean-hint-constr.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "13139" ] || [ "$CI_BRANCH" = "clean-hint-constr" ]; then + + equations_CI_REF=clean-hint-constr + equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations + + fiat_parsers_CI_REF=clean-hint-constr + fiat_parsers_CI_GITURL=https://github.com/ppedrot/fiat + +fi diff --git a/dev/ci/user-overlays/13143-herbelin-master+drop-misleading-arg-hbox.sh b/dev/ci/user-overlays/13143-herbelin-master+drop-misleading-arg-hbox.sh deleted file mode 100644 index 1b3121781b..0000000000 --- a/dev/ci/user-overlays/13143-herbelin-master+drop-misleading-arg-hbox.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "13143" ] || [ "$CI_BRANCH" = "master+drop-misleading-arg-hbox" ]; then - - aac_tactics_CI_REF=master+adapt-coq-pr13143-hbox-no-argument - aac_tactics_CI_GITURL=https://github.com/herbelin/aac-tactics - - equations_CI_REF=master+adapt-coq-pr13143-hbox-no-argument - equations_CI_GITURL=https://github.com/herbelin/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/8808-herbelin-master+support-binder+term-in-abbrev.sh b/dev/ci/user-overlays/8808-herbelin-master+support-binder+term-in-abbrev.sh deleted file mode 100644 index 50eaf0b109..0000000000 --- a/dev/ci/user-overlays/8808-herbelin-master+support-binder+term-in-abbrev.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8808" ] || [ "$CI_BRANCH" = "master+support-binder+term-in-abbrev" ]; then - - elpi_CI_REF=master+adapt-coq8808-syndef-same-expressiveness-notation - elpi_CI_GITURL=https://github.com/herbelin/coq-elpi - -fi diff --git a/dev/ci/user-overlays/8855-herbelin-master+more-search-options.sh b/dev/ci/user-overlays/8855-herbelin-master+more-search-options.sh deleted file mode 100644 index 3b3b20baf1..0000000000 --- a/dev/ci/user-overlays/8855-herbelin-master+more-search-options.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8855" ] || [ "$CI_BRANCH" = "master+more-search-options" ]; then - - coqhammer_CI_REF=master+adapt-pr8855-search-api - coqhammer_CI_GITURL=https://github.com/herbelin/coqhammer - - coq_dpdgraph_CI_REF=coq-master+adapt-pr8855-search-api - coq_dpdgraph_CI_GITURL=https://github.com/herbelin/coq-dpdgraph - -fi diff --git a/dev/ci/user-overlays/README.md b/dev/ci/user-overlays/README.md index 4c2f264a74..3f9ad5e878 100644 --- a/dev/ci/user-overlays/README.md +++ b/dev/ci/user-overlays/README.md @@ -4,15 +4,12 @@ When your pull request breaks an external project we test in our CI and you have prepared a branch with the fix, you can add an "overlay" to your pull request to test it with the adapted version of the external project. -An overlay is a file which defines where to look for the patched version so that -testing is possible. It redefines some variables from -[`ci-basic-overlay.sh`](../ci-basic-overlay.sh): -give the name of your branch / commit using a `_CI_REF` variable and the -location of your fork using a `_CI_GITURL` variable. -The `_CI_GITURL` variable should be the URL of the repository without a -trailing `.git`. -If the fork is not on the same platform (e.g. GitHub instead of GitLab), it is -necessary to redefine the `_CI_ARCHIVEURL` variable as well. +An overlay is a file which defines where to look for the patched +version so that testing is possible. This is done by calling the +`overlay` command for each project with the project name (as used in +the variables in [`ci-basic-overlay.sh`](../ci-basic-overlay.sh)), the +location of your fork and the branch containing the patch on your +fork. Moreover, the file contains very simple logic to test the pull request number or branch name and apply it only in this case. @@ -21,13 +18,12 @@ The name of your overlay file should start with a five-digit pull request number, followed by a dash, anything (for instance your GitHub nickname and the branch name), then a `.sh` extension (`[0-9]{5}-[a-zA-Z0-9-_]+.sh`). -Example: `10185-SkySkimmer-instance-no-bang.sh` containing +Example: `13128-SkySkimmer-noinstance.sh` containing ``` -if [ "$CI_PULL_REQUEST" = "10185" ] || [ "$CI_BRANCH" = "instance-no-bang" ]; then +if [ "$CI_PULL_REQUEST" = "13128" ] || [ "$CI_BRANCH" = "noinstance" ]; then - quickchick_CI_REF=instance-no-bang - quickchick_CI_GITURL=https://github.com/SkySkimmer/QuickChick + overlay elpi https://github.com/SkySkimmer/coq-elpi noinstance 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/dev/doc/parsing.md b/dev/doc/parsing.md index 4982e3e94d..4956b91d01 100644 --- a/dev/doc/parsing.md +++ b/dev/doc/parsing.md @@ -210,7 +210,7 @@ command. The first square bracket around a nonterminal definition is for groupi level definitions, which are separated with `|`, for example: ``` - tactic_expr: + ltac_expr: [ "5" RIGHTA [ te = binder_tactic -> { te } ] | "4" LEFTA @@ -220,8 +220,8 @@ level definitions, which are separated with `|`, for example: Grammar extensions can specify what level they are modifying, for example: ``` - tactic_expr: LEVEL "1" [ RIGHTA - [ tac = tactic_expr; intros = ssrintros_ne -> { tclintros_expr ~loc tac intros } + ltac_expr: LEVEL "1" [ RIGHTA + [ tac = ltac_expr; intros = ssrintros_ne -> { tclintros_expr ~loc tac intros } ] ]; ``` diff --git a/dev/doc/shield-icon.png b/dev/doc/shield-icon.png Binary files differindex 629e51a819..f4a5b6ff5e 100644 --- a/dev/doc/shield-icon.png +++ b/dev/doc/shield-icon.png diff --git a/dev/tools/create_overlays.sh b/dev/tools/create_overlays.sh index ad60b1115f..78ed27ba03 100755 --- a/dev/tools/create_overlays.sh +++ b/dev/tools/create_overlays.sh @@ -66,8 +66,7 @@ do make ci-$_CONTRIB_NAME || true setup_contrib_git $_CONTRIB_DIR $_CONTRIB_GITPUSHURL - echo " ${_CONTRIB_NAME}_CI_REF=$OVERLAY_BRANCH" >> $OVERLAY_FILE - echo " ${_CONTRIB_NAME}_CI_GITURL=$_CONTRIB_GITURL" >> $OVERLAY_FILE + echo " overlay ${_CONTRIB_NAME} $_CONTRIB_GITURL $OVERLAY_BRANCH" >> $OVERLAY_FILE echo "" >> $OVERLAY_FILE shift done diff --git a/doc/changelog/01-kernel/12738-fix-sr-cumul-inds.rst b/doc/changelog/01-kernel/12738-fix-sr-cumul-inds.rst deleted file mode 100644 index 1bf62de3fd..0000000000 --- a/doc/changelog/01-kernel/12738-fix-sr-cumul-inds.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** Incompleteness of conversion checking on problems - involving :ref:`eta-expansion` and :ref:`cumulative universe - polymorphic inductive types <cumulative>` (`#12738 - <https://github.com/coq/coq/pull/12738>`_, fixes `#7015 - <https://github.com/coq/coq/issues/7015>`_, by Gaëtan Gilbert). 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/12768-master+warn-non-underscore-catch-all-pattern-matching.rst b/doc/changelog/02-specification-language/12768-master+warn-non-underscore-catch-all-pattern-matching.rst new file mode 100644 index 0000000000..c9e941743c --- /dev/null +++ b/doc/changelog/02-specification-language/12768-master+warn-non-underscore-catch-all-pattern-matching.rst @@ -0,0 +1,7 @@ +- **Added:** + Warning on unused variables in pattern-matching branches of + :n:`match` serving as catch-all branches for at least two distinct + patterns. + (`#12768 <https://github.com/coq/coq/pull/12768>`_, + fixes `#12762 <https://github.com/coq/coq/issues/12762>`_, + by Hugo Herbelin). diff --git a/doc/changelog/02-specification-language/13183-using-att.rst b/doc/changelog/02-specification-language/13183-using-att.rst new file mode 100644 index 0000000000..c380d932ed --- /dev/null +++ b/doc/changelog/02-specification-language/13183-using-att.rst @@ -0,0 +1,6 @@ +- **Added:** + Definition and (Co)Fixpoint now support the :attr:`using` attribute. + It has the same effect as :cmd:`Proof using`, which is only available in + interactive mode. + (`#13183 <https://github.com/coq/coq/pull/13183>`_, + by Enrico Tassi). 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/13217-master+fix13216-typeclass-for-match-return-clause.rst b/doc/changelog/02-specification-language/13217-master+fix13216-typeclass-for-match-return-clause.rst new file mode 100644 index 0000000000..2d8230b965 --- /dev/null +++ b/doc/changelog/02-specification-language/13217-master+fix13216-typeclass-for-match-return-clause.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Allow use of type classes inference for the return predicate of a :n:`match` + (was deactivated in versions 8.10 to 8.12, `#13217 <https://github.com/coq/coq/pull/13217>`_, + fixes `#13216 <https://github.com/coq/coq/issues/13216>`_, + by Hugo Herbelin). 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/12099-master+constraining-terms-occurring-also-as-pattern-in-notations.rst b/doc/changelog/03-notations/12099-master+constraining-terms-occurring-also-as-pattern-in-notations.rst new file mode 100644 index 0000000000..e9b02aed6d --- /dev/null +++ b/doc/changelog/03-notations/12099-master+constraining-terms-occurring-also-as-pattern-in-notations.rst @@ -0,0 +1,4 @@ +- **Changed:** + Improved support for notations/abbreviations with mixed terms and patterns (such as the forcing modality) + (`#12099 <https://github.com/coq/coq/pull/12099>`_, + by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12218-numeral-notations-non-inductive.rst b/doc/changelog/03-notations/12218-numeral-notations-non-inductive.rst new file mode 100644 index 0000000000..5ea37e7494 --- /dev/null +++ b/doc/changelog/03-notations/12218-numeral-notations-non-inductive.rst @@ -0,0 +1,19 @@ +- **Deprecated** + ``Numeral.v`` is deprecated, please use ``Number.v`` instead. +- **Changed** + Rational and real constants are parsed differently. + The exponent is now encoded separately from the fractional part + using ``Z.pow_pos``. This way, parsing large exponents can no longer + blow up and constants are printed in a form closer to the one they + were parsed (i.e., ``102e-2`` is reprinted as such and not ``1.02``). +- **Removed** + OCaml parser and printer for real constants have been removed. + Real constants are now handled with proven Coq code. +- **Added:** + :ref:`Number Notation <number-notations>` and :ref:`String Notation + <string-notations>` commands now + support parameterized inductive and non inductive types + (`#12218 <https://github.com/coq/coq/pull/12218>`_, + fixes `#12035 <https://github.com/coq/coq/issues/12035>`_, + by Pierre Roux, review by Jason Gross and Jim Fehrle for the + reference manual). 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/12946-master+fix12908-part1-collision-lonely-notation-printing.rst b/doc/changelog/03-notations/12946-master+fix12908-part1-collision-lonely-notation-printing.rst deleted file mode 100644 index 95a9093272..0000000000 --- a/doc/changelog/03-notations/12946-master+fix12908-part1-collision-lonely-notation-printing.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Fixed:** - Undetected collision between a lonely notation and a notation in - scope at printing time - (`#12946 <https://github.com/coq/coq/pull/12946>`_, - fixes the first part of `#12908 <https://github.com/coq/coq/issues/12908>`_, - by Hugo Herbelin). diff --git a/doc/changelog/03-notations/13026-master+fix-printing-custom-no-level-8.2.rst b/doc/changelog/03-notations/13026-master+fix-printing-custom-no-level-8.2.rst deleted file mode 100644 index 42b62eed75..0000000000 --- a/doc/changelog/03-notations/13026-master+fix-printing-custom-no-level-8.2.rst +++ /dev/null @@ -1,7 +0,0 @@ -- **Fixed:** - Fixing printing of notations in custom entries with - variables not mentioning an explicit level - (`#13026 <https://github.com/coq/coq/pull/13026>`_, - fixes `#12775 <https://github.com/coq/coq/issues/12775>`_ - and `#13018 <https://github.com/coq/coq/issues/13018>`_, - by Hugo Herbelin). diff --git a/doc/changelog/03-notations/13067-master+fix-display-parentheses-default-coqide.rst b/doc/changelog/03-notations/13067-master+fix-display-parentheses-default-coqide.rst deleted file mode 100644 index 50aa4a9052..0000000000 --- a/doc/changelog/03-notations/13067-master+fix-display-parentheses-default-coqide.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - Repairing option :g:`Display parentheses` in CoqIDE - (`#12794 <https://github.com/coq/coq/pull/12794>`_ and `#13067 <https://github.com/coq/coq/pull/13067>`_, - fixes `#12793 <https://github.com/coq/coq/issues/12793>`_, - by Jean-Christophe Léchenet and Hugo Herbelin). diff --git a/doc/changelog/03-notations/13092-master+fix-13078-no-binder-in-pattern-notation.rst b/doc/changelog/03-notations/13092-master+fix-13078-no-binder-in-pattern-notation.rst new file mode 100644 index 0000000000..fb12c91729 --- /dev/null +++ b/doc/changelog/03-notations/13092-master+fix-13078-no-binder-in-pattern-notation.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Preventing notations for constructors to involve binders + (`#13092 <https://github.com/coq/coq/pull/13092>`_, + fixes `#13078 <https://github.com/coq/coq/issues/13078>`_, + by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/12816-master+fix12787-K-redex-injection-anomaly.rst b/doc/changelog/04-tactics/12816-master+fix12787-K-redex-injection-anomaly.rst deleted file mode 100644 index 289d17167d..0000000000 --- a/doc/changelog/04-tactics/12816-master+fix12787-K-redex-injection-anomaly.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Fixed:** - Anomaly with :tacn:`injection` involving artificial - dependencies disappearing by reduction - (`#12816 <https://github.com/coq/coq/pull/12816>`_, - fixes `#12787 <https://github.com/coq/coq/issues/12787>`_, - by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/12847-master+inversion-works-with-eq-in-type.rst b/doc/changelog/04-tactics/12847-master+inversion-works-with-eq-in-type.rst deleted file mode 100644 index b444a2f436..0000000000 --- a/doc/changelog/04-tactics/12847-master+inversion-works-with-eq-in-type.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Added:** - :tacn:`replace` and :tacn:`inversion` support registration of a - :g:`core.identity`-like equality in :g:`Type`, such as HoTT's :g:`path` - (`#12847 <https://github.com/coq/coq/pull/12847>`_, - partially fixes `#12846 <https://github.com/coq/coq/issues/12846>`_, - 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/05-tactic-language/13232-ltac2-if-then-else.rst b/doc/changelog/05-tactic-language/13232-ltac2-if-then-else.rst new file mode 100644 index 0000000000..d105561a23 --- /dev/null +++ b/doc/changelog/05-tactic-language/13232-ltac2-if-then-else.rst @@ -0,0 +1,5 @@ +- **Added:** + An if-then-else syntax to Ltac2 + (`#13232 <https://github.com/coq/coq/pull/13232>`_, + fixes `#10110 <https://github.com/coq/coq/issues/10110>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/06-ssreflect/12857-changelog-for-12857.rst b/doc/changelog/06-ssreflect/12857-changelog-for-12857.rst deleted file mode 100644 index 4350fd0238..0000000000 --- a/doc/changelog/06-ssreflect/12857-changelog-for-12857.rst +++ /dev/null @@ -1,8 +0,0 @@ -- **Fixed:** - Regression in error reporting after :tacn:`case <case (ssreflect)>`. - A generic error message "Could not fill dependent hole in apply" was - reported for any error following :tacn:`case <case (ssreflect)>` or - :tacn:`elim <elim (ssreflect)>` - (`#12857 <https://github.com/coq/coq/pull/12857>`_, - fixes `#12837 <https://github.com/coq/coq/issues/12837>`_, - by Enrico Tassi). 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/13139-clean-hint-constr.rst b/doc/changelog/07-commands-and-options/13139-clean-hint-constr.rst new file mode 100644 index 0000000000..1a6bc88c6c --- /dev/null +++ b/doc/changelog/07-commands-and-options/13139-clean-hint-constr.rst @@ -0,0 +1,6 @@ +- **Changed:** + When declaring arbitrary terms as hints, unsolved + evars are not abstracted implicitly anymore and instead + raise an error + (`#13139 <https://github.com/coq/coq/pull/13139>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/07-commands-and-options/13255-master+fix13244-use-coercions-in-search.rst b/doc/changelog/07-commands-and-options/13255-master+fix13244-use-coercions-in-search.rst new file mode 100644 index 0000000000..03be92f897 --- /dev/null +++ b/doc/changelog/07-commands-and-options/13255-master+fix13244-use-coercions-in-search.rst @@ -0,0 +1,7 @@ +- **Added:** + Added support for automatic insertion of coercions in :cmd:`Search` + patterns. Additionally, head patterns are now automatically + interpreted as types + (`#13255 <https://github.com/coq/coq/pull/13255>`_, + fixes `#13244 <https://github.com/coq/coq/issues/13244>`_, + by Hugo Herbelin). 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/08-tools/12754-master+fix-coqdoc-index-escaping.rst b/doc/changelog/08-tools/12754-master+fix-coqdoc-index-escaping.rst deleted file mode 100644 index a05829b720..0000000000 --- a/doc/changelog/08-tools/12754-master+fix-coqdoc-index-escaping.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Fixed:** - Special symbols now escaped in the index produced by coqdoc, - avoiding collision with the syntax of the output format - (`#12754 <https://github.com/coq/coq/pull/12754>`_, - fixes `#12752 <https://github.com/coq/coq/issues/12752>`_, - by Hugo Herbelin). diff --git a/doc/changelog/08-tools/12772-fix-details.rst b/doc/changelog/08-tools/12772-fix-details.rst deleted file mode 100644 index 67ee061285..0000000000 --- a/doc/changelog/08-tools/12772-fix-details.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - The `details` environment added in the 8.12 release can now be used - as advertised in the reference manual - (`#12772 <https://github.com/coq/coq/pull/12772>`_, - by Thomas Letan). diff --git a/doc/changelog/08-tools/13063-fix-no-output-sync-make-file.rst b/doc/changelog/08-tools/13063-fix-no-output-sync-make-file.rst deleted file mode 100644 index 75b1e26248..0000000000 --- a/doc/changelog/08-tools/13063-fix-no-output-sync-make-file.rst +++ /dev/null @@ -1,6 +0,0 @@ -- **Fixed:** - Targets such as ``print-pretty-timed`` in ``coq_makefile``-made - ``Makefile``\s no longer error in rare cases where ``--output-sync`` is not - passed to make and the timing output gets interleaved in just the wrong way - (`#13063 <https://github.com/coq/coq/pull/13063>`_, fixes `#13062 - <https://github.com/coq/coq/issues/13062>`_, by Jason Gross). diff --git a/doc/changelog/09-coqide/13145-master+coqide-printing-goal-names-support.rst b/doc/changelog/09-coqide/13145-master+coqide-printing-goal-names-support.rst new file mode 100644 index 0000000000..f7446cc5aa --- /dev/null +++ b/doc/changelog/09-coqide/13145-master+coqide-printing-goal-names-support.rst @@ -0,0 +1,4 @@ +- **Added:** + Support for flag :flag:`Printing Goal Names` in View menu + (`#13145 <https://github.com/coq/coq/pull/13145>`_, + by Hugo Herbelin). 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/changelog/11-infrastructure-and-dependencies/12864-fix-approve-output.rst b/doc/changelog/11-infrastructure-and-dependencies/12864-fix-approve-output.rst deleted file mode 100644 index c754826e62..0000000000 --- a/doc/changelog/11-infrastructure-and-dependencies/12864-fix-approve-output.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - ``make approve-output`` in the test-suite now correctly handles - ``output-coqtop`` and ``output-coqchk`` tests (`#12864 - <https://github.com/coq/coq/pull/12864>`_, fixes `#12863 - <https://github.com/coq/coq/issues/12863>`_, by Jason Gross). diff --git a/doc/changelog/11-infrastructure-and-dependencies/12972-ocaml+4_11.rst b/doc/changelog/11-infrastructure-and-dependencies/12972-ocaml+4_11.rst deleted file mode 100644 index 855aa360f1..0000000000 --- a/doc/changelog/11-infrastructure-and-dependencies/12972-ocaml+4_11.rst +++ /dev/null @@ -1,4 +0,0 @@ -- **Added:** - Coq is now tested against OCaml 4.11.1 - (`#12972 <https://github.com/coq/coq/pull/12972>`_, - by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/11-infrastructure-and-dependencies/13011-sphinx-3.rst b/doc/changelog/11-infrastructure-and-dependencies/13011-sphinx-3.rst deleted file mode 100644 index d17a2dff6b..0000000000 --- a/doc/changelog/11-infrastructure-and-dependencies/13011-sphinx-3.rst +++ /dev/null @@ -1,5 +0,0 @@ -- **Fixed:** - The reference manual can now build with Sphinx 3 - (`#13011 <https://github.com/coq/coq/pull/13011>`_, - fixes `#12332 <https://github.com/coq/coq/issues/12332>`_, - by Théo Zimmermann and Jim Fehrle). diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index 4461ff9240..bfdbc4c4db 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -551,7 +551,7 @@ Add either ``abort`` to the first block or ``reset`` to the second block to avoi Abbreviations and macros ------------------------ -Substitutions for specially-formatted names (like ``|Cic|``, ``|Coq|``, ``|CoqIDE|``, ``|Ltac|``, and ``|Gallina|``), along with some useful LaTeX macros, are defined in a `separate file </doc/sphinx/refman-preamble.rst>`_. This file is automatically included in all manual pages. +Substitutions for specially-formatted names (like ``|Cic|``, ``|Ltac|`` and ``|Latex|``), along with some useful LaTeX macros, are defined in a `separate file </doc/sphinx/refman-preamble.rst>`_. This file is automatically included in all manual pages. Emacs ----- diff --git a/doc/sphinx/README.template.rst b/doc/sphinx/README.template.rst index b4e21aa14a..d4e297299e 100644 --- a/doc/sphinx/README.template.rst +++ b/doc/sphinx/README.template.rst @@ -290,7 +290,7 @@ Add either ``abort`` to the first block or ``reset`` to the second block to avoi Abbreviations and macros ------------------------ -Substitutions for specially-formatted names (like ``|Cic|``, ``|Coq|``, ``|CoqIDE|``, ``|Ltac|``, and ``|Gallina|``), along with some useful LaTeX macros, are defined in a `separate file </doc/sphinx/refman-preamble.rst>`_. This file is automatically included in all manual pages. +Substitutions for specially-formatted names (like ``|Cic|``, ``|Ltac|`` and ``|Latex|``), along with some useful LaTeX macros, are defined in a `separate file </doc/sphinx/refman-preamble.rst>`_. This file is automatically included in all manual pages. Emacs ----- diff --git a/doc/sphinx/_static/coqdoc.css b/doc/sphinx/_static/coqdoc.css index 32cb0a7a15..c0b4ee4a9f 100644 --- a/doc/sphinx/_static/coqdoc.css +++ b/doc/sphinx/_static/coqdoc.css @@ -66,3 +66,7 @@ .coqdoc-tactic { font-weight: bold; } + +.smallcaps { + font-variant: small-caps; +} diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index c2249b8e57..3662822a5e 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -5,10 +5,10 @@ Program extraction :Authors: Jean-Christophe Filliâtre and Pierre Letouzey -We present here the |Coq| extraction commands, used to build certified +We present here the Coq extraction commands, used to build certified and relatively efficient functional programs, extracting them from -either |Coq| functions or |Coq| proofs of specifications. The -functional languages available as output are currently |OCaml|, Haskell +either Coq functions or Coq proofs of specifications. The +functional languages available as output are currently OCaml, Haskell and Scheme. In the following, "ML" will be used (abusively) to refer to any of the three. @@ -29,23 +29,23 @@ Generating ML Code .. note:: In the following, a qualified identifier :token:`qualid` - can be used to refer to any kind of |Coq| global "object" : constant, + can be used to refer to any kind of Coq global "object" : constant, inductive type, inductive constructor or module name. The next two commands are meant to be used for rapid preview of -extraction. They both display extracted term(s) inside |Coq|. +extraction. They both display extracted term(s) inside Coq. .. cmd:: Extraction @qualid - Extraction of the mentioned object in the |Coq| toplevel. + Extraction of the mentioned object in the Coq toplevel. .. cmd:: Recursive Extraction {+ @qualid } Recursive extraction of all the mentioned objects and - all their dependencies in the |Coq| toplevel. + all their dependencies in the Coq toplevel. All the following commands produce real ML files. User can choose to -produce one monolithic file or one file per |Coq| library. +produce one monolithic file or one file per Coq library. .. cmd:: Extraction @string {+ @qualid } @@ -57,14 +57,14 @@ produce one monolithic file or one file per |Coq| library. .. cmd:: Extraction Library @ident - Extraction of the whole |Coq| library :n:`@ident.v` to an ML module + Extraction of the whole Coq library :n:`@ident.v` to an ML module :n:`@ident.ml`. In case of name clash, identifiers are here renamed using prefixes ``coq_`` or ``Coq_`` to ensure a session-independent renaming. .. cmd:: Recursive Extraction Library @ident - Extraction of the |Coq| library :n:`@ident.v` and all other modules + Extraction of the Coq library :n:`@ident.v` and all other modules :n:`@ident.v` depends on. .. cmd:: Separate Extraction {+ @qualid } @@ -82,16 +82,16 @@ produce one monolithic file or one file per |Coq| library. The following command is meant to help automatic testing of the extraction, see for instance the ``test-suite`` directory -in the |Coq| sources. +in the Coq sources. .. cmd:: Extraction TestCompile {+ @qualid } All the mentioned objects and all their dependencies are extracted - to a temporary |OCaml| file, just as in ``Extraction "file"``. Then + to a temporary OCaml file, just as in ``Extraction "file"``. Then this temporary file and its signature are compiled with the same - |OCaml| compiler used to built |Coq|. This command succeeds only - if the extraction and the |OCaml| compilation succeed. It fails - if the current target language of the extraction is not |OCaml|. + OCaml compiler used to built Coq. This command succeeds only + if the extraction and the OCaml compilation succeed. It fails + if the current target language of the extraction is not OCaml. Extraction Options ------------------- @@ -99,10 +99,18 @@ Extraction Options Setting the target language ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Extraction Language {| OCaml | Haskell | Scheme | JSON } +.. cmd:: Extraction Language @language :name: Extraction Language - The ability to fix target language is the first and more important + .. insertprodn language language + + .. prodn:: + language ::= OCaml + | Haskell + | Scheme + | JSON + + The ability to fix target language is the first and most important of the extraction options. Default is ``OCaml``. The JSON output is mostly for development or debugging: @@ -112,17 +120,17 @@ Setting the target language Inlining and optimizations ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since |OCaml| is a strict language, the extracted code has to +Since OCaml is a strict language, the extracted code has to be optimized in order to be efficient (for instance, when using induction principles we do not want to compute all the recursive calls but only the needed ones). So the extraction mechanism provides an automatic optimization routine that will be called each time the user -wants to generate an |OCaml| program. The optimizations can be split in two +wants to generate an OCaml program. The optimizations can be split in two groups: the type-preserving ones (essentially constant inlining and reductions) and the non type-preserving ones (some function abstractions of dummy types are removed when it is deemed safe in order to have more elegant types). Therefore some constants may not appear in the -resulting monolithic |OCaml| program. In the case of modular extraction, +resulting monolithic OCaml program. In the case of modular extraction, even if some inlining is done, the inlined constants are nevertheless printed, to ensure session-independent programs. @@ -130,7 +138,7 @@ Concerning Haskell, type-preserving optimizations are less useful because of laziness. We still make some optimizations, for example in order to produce more readable code. -The type-preserving optimizations are controlled by the following |Coq| flags +The type-preserving optimizations are controlled by the following Coq flags and commands: .. flag:: Extraction Optimize @@ -191,7 +199,7 @@ The user can explicitly ask for a constant to be extracted by two means: * by mentioning it on the extraction command line - * by extracting the whole |Coq| module of this constant. + * by extracting the whole Coq module of this constant. In both cases, the declaration of this constant will be present in the produced file. But this same constant may or may not be inlined in @@ -215,14 +223,15 @@ code elimination performed during extraction, in a way which is independent but complementary to the main elimination principles of extraction (logical parts and types). -.. cmd:: Extraction Implicit @qualid [ {+ @ident } ] +.. cmd:: Extraction Implicit @qualid [ {* {| @ident | @integer } } ] - This experimental command allows declaring some arguments of - :token:`qualid` as implicit, i.e. useless in extracted code and hence to - be removed by extraction. Here :token:`qualid` can be any function or - inductive constructor, and the given :token:`ident` are the names of - the concerned arguments. In fact, an argument can also be referred - by a number indicating its position, starting from 1. + Declares some arguments of + :token:`qualid` as implicit, meaning that they are useless in extracted code. + The extracted code will omit these arguments. + Here :token:`qualid` can be + any function or inductive constructor, and the :token:`ident`\s are + the names of the useless arguments. Arguments can can also be + identified positionally by :token:`integer`\s starting from 1. When an actual extraction takes place, an error is normally raised if the :cmd:`Extraction Implicit` declarations cannot be honored, that is @@ -254,12 +263,24 @@ a closed term, and of course the system cannot guess the program which realizes an axiom. Therefore, it is possible to tell the system what ML term corresponds to a given axiom. -.. cmd:: Extract Constant @qualid => @string +.. cmd:: Extract Constant @qualid {* @string__tv } => {| @ident | @string } Give an ML extraction for the given constant. - The :token:`string` may be an identifier or a quoted string. -.. cmd:: Extract Inlined Constant @qualid => @string + :n:`@string__tv` + If the type scheme axiom is an arity (a sequence of products followed + by a sort), then some type + variables have to be given (as quoted strings). + + The number of type variables is checked by the system. For example: + + .. coqtop:: in + + Axiom Y : Set -> Set -> Set. + Extract Constant Y "'a" "'b" => " 'a * 'b ". + + +.. cmd:: Extract Inlined Constant @qualid => {| @ident | @string } Same as the previous one, except that the given ML terms will be inlined everywhere instead of being declared via a ``let``. @@ -282,20 +303,6 @@ what ML term corresponds to a given axiom. Extract Constant X => "int". Extract Constant x => "0". -Notice that in the case of type scheme axiom (i.e. whose type is an -arity, that is a sequence of product finished by a sort), then some type -variables have to be given (as quoted strings). The syntax is then: - -.. cmdv:: Extract Constant @qualid {+ @string } => @string - :undocumented: - -The number of type variables is checked by the system. For example: - -.. coqtop:: in - - Axiom Y : Set -> Set -> Set. - Extract Constant Y "'a" "'b" => " 'a * 'b ". - Realizing an axiom via :cmd:`Extract Constant` is only useful in the case of an informative axiom (of sort ``Type`` or ``Set``). A logical axiom has no computational content and hence will not appear in extracted @@ -314,38 +321,37 @@ Realizing inductive types The system also provides a mechanism to specify ML terms for inductive types and constructors. For instance, the user may want to use the ML -native boolean type instead of the |Coq| one. The syntax is the following: +native boolean type instead of the Coq one. The syntax is the following: -.. cmd:: Extract Inductive @qualid => @string__1 [ {+ @string } ] +.. cmd:: Extract Inductive @qualid => {| @ident | @string } [ {* {| @ident | @string } } ] {? @string__match } Give an ML extraction for the given inductive type. You must specify - extractions for the type itself (:n:`@string__1`) and all its - constructors (all the :n:`@string` between square brackets). In this form, + extractions for the type itself (the initial :n:`{| @ident | @string }`) and all its + constructors (the :n:`[ {* {| @ident | @string } } ]`). In this form, the ML extraction must be an ML inductive datatype, and the native pattern matching of the language will be used. - When :n:`@string__1` matches the name of the type of characters or strings + When the initial :n:`{| @ident | @string }` matches the name of the type of characters or strings (``char`` and ``string`` for OCaml, ``Prelude.Char`` and ``Prelude.String`` for Haskell), extraction of literals is handled in a specialized way, so as to generate literals in the target language. This feature requires the type designated by :n:`@qualid` to be registered as the standard char or string type, using the :cmd:`Register` command. -.. cmdv:: Extract Inductive @qualid => @string [ {+ @string } ] @string - - Same as before, with a final extra :token:`string` that indicates how to - perform pattern matching over this inductive type. In this form, - the ML extraction could be an arbitrary type. - For an inductive type with :math:`k` constructors, the function used to - emulate the pattern matching should expect :math:`k+1` arguments, first the :math:`k` - branches in functional form, and then the inductive element to - destruct. For instance, the match branch ``| S n => foo`` gives the - functional form ``(fun n -> foo)``. Note that a constructor with no - arguments is considered to have one unit argument, in order to block - early evaluation of the branch: ``| O => bar`` leads to the functional - form ``(fun () -> bar)``. For instance, when extracting :g:`nat` - into |OCaml| ``int``, the code to be provided has type: - ``(unit->'a)->(int->'a)->int->'a``. + :n:`@string__match` + Indicates how to + perform pattern matching over this inductive type. In this form, + the ML extraction could be an arbitrary type. + For an inductive type with :math:`k` constructors, the function used to + emulate the pattern matching should expect :math:`k+1` arguments, first the :math:`k` + branches in functional form, and then the inductive element to + destruct. For instance, the match branch ``| S n => foo`` gives the + functional form ``(fun n -> foo)``. Note that a constructor with no + arguments is considered to have one unit argument, in order to block + early evaluation of the branch: ``| O => bar`` leads to the functional + form ``(fun () -> bar)``. For instance, when extracting :g:`nat` + into OCaml ``int``, the code to be provided has type: + ``(unit->'a)->(int->'a)->int->'a``. .. caution:: As for :cmd:`Extract Constant`, this command should be used with care: @@ -355,15 +361,15 @@ native boolean type instead of the |Coq| one. The syntax is the following: * Extracting an inductive type to a pre-existing ML inductive type is quite sound. But extracting to a general type (by providing an ad-hoc pattern matching) will often **not** be fully rigorously - correct. For instance, when extracting ``nat`` to |OCaml| ``int``, + correct. For instance, when extracting ``nat`` to OCaml ``int``, it is theoretically possible to build ``nat`` values that are - larger than |OCaml| ``max_int``. It is the user's responsibility to + larger than OCaml ``max_int``. It is the user's responsibility to be sure that no overflow or other bad events occur in practice. * Translating an inductive type to an arbitrary ML type does **not** magically improve the asymptotic complexity of functions, even if the ML type is an efficient representation. For instance, when extracting - ``nat`` to |OCaml| ``int``, the function ``Nat.mul`` stays quadratic. + ``nat`` to OCaml ``int``, the function ``Nat.mul`` stays quadratic. It might be interesting to associate this translation with some specific :cmd:`Extract Constant` when primitive counterparts exist. @@ -377,9 +383,9 @@ Typical examples are the following: .. note:: - When extracting to |OCaml|, if an inductive constructor or type has arity 2 and + When extracting to OCaml, if an inductive constructor or type has arity 2 and the corresponding string is enclosed by parentheses, and the string meets - |OCaml|'s lexical criteria for an infix symbol, then the rest of the string is + OCaml's lexical criteria for an infix symbol, then the rest of the string is used as an infix constructor or type. .. coqtop:: in @@ -388,7 +394,7 @@ Typical examples are the following: Extract Inductive prod => "(*)" [ "(,)" ]. As an example of translation to a non-inductive datatype, let's turn -``nat`` into |OCaml| ``int`` (see caveat above): +``nat`` into OCaml ``int`` (see caveat above): .. coqtop:: in @@ -398,11 +404,11 @@ Avoiding conflicts with existing filenames ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When using :cmd:`Extraction Library`, the names of the extracted files -directly depend on the names of the |Coq| files. It may happen that +directly depend on the names of the Coq files. It may happen that these filenames are in conflict with already existing files, either in the standard library of the target language or in other code that is meant to be linked with the extracted code. -For instance the module ``List`` exists both in |Coq| and in |OCaml|. +For instance the module ``List`` exists both in Coq and in OCaml. It is possible to instruct the extraction not to use particular filenames. .. cmd:: Extraction Blacklist {+ @ident } @@ -418,7 +424,7 @@ It is possible to instruct the extraction not to use particular filenames. Allow the extraction to use any filename. -For |OCaml|, a typical use of these commands is +For OCaml, a typical use of these commands is ``Extraction Blacklist String List``. Additional settings @@ -467,12 +473,12 @@ Additional settings If set, fully expand Coq types in ML. See the Coq source code to learn more. -Differences between |Coq| and ML type systems +Differences between Coq and ML type systems ---------------------------------------------- -Due to differences between |Coq| and ML type systems, +Due to differences between Coq and ML type systems, some extracted programs are not directly typable in ML. -We now solve this problem (at least in |OCaml|) by adding +We now solve this problem (at least in OCaml) by adding when needed some unsafe casting ``Obj.magic``, which give a generic type ``'a`` to any term. @@ -486,7 +492,7 @@ function: Definition dp {A B:Type}(x:A)(y:B)(f:forall C:Type, C->C) := (f A x, f B y). -In |OCaml|, for instance, the direct extracted term would be:: +In OCaml, for instance, the direct extracted term would be:: let dp x y f = Pair((f () x),(f () y)) @@ -500,7 +506,7 @@ We now produce the following correct version:: let dp x y f = Pair ((Obj.magic f () x), (Obj.magic f () y)) -Secondly, some |Coq| definitions may have no counterpart in ML. This +Secondly, some Coq definitions may have no counterpart in ML. This happens when there is a quantification over types inside the type of a constructor; for example: @@ -509,29 +515,29 @@ of a constructor; for example: Inductive anything : Type := dummy : forall A:Set, A -> anything. which corresponds to the definition of an ML dynamic type. -In |OCaml|, we must cast any argument of the constructor dummy +In OCaml, we must cast any argument of the constructor dummy (no GADT are produced yet by the extraction). Even with those unsafe castings, you should never get error like ``segmentation fault``. In fact even if your program may seem -ill-typed to the |OCaml| type checker, it can't go wrong : it comes -from a Coq well-typed terms, so for example inductive types will always +ill-typed to the OCaml type checker, it can't go wrong : it comes +from a Coq well-typed terms, so for example inductive types will always have the correct number of arguments, etc. Of course, when launching manually some extracted function, you should apply it to arguments -of the right shape (from the |Coq| point-of-view). +of the right shape (from the Coq point-of-view). More details about the correctness of the extracted programs can be found in :cite:`Let02`. We have to say, though, that in most "realistic" programs, these problems do not -occur. For example all the programs of Coq library are accepted by the |OCaml| +occur. For example all the programs of Coq library are accepted by the OCaml type checker without any ``Obj.magic`` (see examples below). Some examples ------------- We present here two examples of extraction, taken from the -|Coq| Standard Library. We choose |OCaml| as the target language, +Coq Standard Library. We choose OCaml as the target language, but everything, with slight modifications, can also be done in the other languages supported by extraction. We then indicate where to find other examples and tests of extraction. @@ -548,7 +554,7 @@ This module contains a theorem ``eucl_dev``, whose type is:: where ``diveucl`` is a type for the pair of the quotient and the modulo, plus some logical assertions that disappear during extraction. -We can now extract this program to |OCaml|: +We can now extract this program to OCaml: .. coqtop:: none @@ -564,11 +570,11 @@ We can now extract this program to |OCaml|: The inlining of ``gt_wf_rec`` and others is not mandatory. It only enhances readability of extracted code. You can then copy-paste the output to a file ``euclid.ml`` or let -|Coq| do it for you with the following command:: +Coq do it for you with the following command:: Extraction "euclid" eucl_dev. -Let us play the resulting program (in an |OCaml| toplevel):: +Let us play the resulting program (in an OCaml toplevel):: #use "euclid.ml";; type nat = O | S of nat @@ -582,7 +588,7 @@ Let us play the resulting program (in an |OCaml| toplevel):: # eucl_dev (S (S O)) (S (S (S (S (S O)))));; - : diveucl = Divex (S (S O), S O) -It is easier to test on |OCaml| integers:: +It is easier to test on OCaml integers:: # let rec nat_of_int = function 0 -> O | n -> S (nat_of_int (n-1));; val nat_of_int : int -> nat = <fun> @@ -608,12 +614,12 @@ Extraction's horror museum ~~~~~~~~~~~~~~~~~~~~~~~~~~ Some pathological examples of extraction are grouped in the file -``test-suite/success/extraction.v`` of the sources of |Coq|. +``test-suite/success/extraction.v`` of the sources of Coq. Users' Contributions ~~~~~~~~~~~~~~~~~~~~ -Several of the |Coq| Users' Contributions use extraction to produce +Several of the Coq Users' Contributions use extraction to produce certified programs. In particular the following ones have an automatic extraction test: diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index 759f630b85..27ae7cea3a 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -170,10 +170,17 @@ compatibility constraints. Adding new relations and morphisms ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Add Parametric Relation {* @binder } : (A t1 ... tn) (Aeq t′1 ... t′m) {? reflexivity proved by @term} {? symmetry proved by @term} {? transitivity proved by @term} as @ident +.. cmd:: Add Parametric Relation {* @binder } : @one_term__A @one_term__Aeq {? reflexivity proved by @one_term } {? symmetry proved by @one_term } {? transitivity proved by @one_term } as @ident - This command declares a parametric relation :g:`Aeq: forall (y1 : β1 ... ym : βm)`, - :g:`relation (A t1 ... tn)` over :g:`(A : αi -> ... αn -> Type)`. + Declares a parametric relation of :n:`@one_term__A`, which is a `Type`, say `T`, with + :n:`@one_term__Aeq`, which is a relation on `T`, i.e. of type `(T -> T -> Prop)`. + Thus, if :n:`@one_term__A` is + :n:`A: forall α__1 … α__n, Type` then :n:`@one_term__Aeq` is + :n:`Aeq: forall α__1 … α__n, (A α__1 … α__n) -> (A α__1 … α__n) -> Prop`, + or equivalently, :n:`Aeq: forall α__1 … α__n, relation (A α__1 … α__n)`. + + :n:`@one_term__A` and :n:`@one_term__Aeq` must be typeable under the context + :token:`binder`\s. In practice, the :token:`binder`\s usually correspond to the :n:`α`\s The final :token:`ident` gives a unique name to the morphism and it is used by the command to generate fresh names for automatically provided @@ -189,16 +196,16 @@ Adding new relations and morphisms To use this command, you need to first import the module ``Setoid`` using the command ``Require Import Setoid``. -.. cmd:: Add Relation +.. cmd:: Add Relation @one_term @one_term {? reflexivity proved by @one_term } {? symmetry proved by @one_term } {? transitivity proved by @one_term } as @ident - In case the carrier and relations are not parametric, one can use this command + If the carrier and relations are not parametric, use this command instead, whose syntax is the same except there is no local context. The proofs of reflexivity, symmetry and transitivity can be omitted if the relation is not an equivalence relation. The proofs must be instances of the corresponding relation definitions: e.g. the proof of reflexivity must have a type convertible to - :g:`reflexive (A t1 ... tn) (Aeq t′ 1 …t′ n)`. + :g:`reflexive (A t1 … tn) (Aeq t′ 1 … t′ n)`. Each proof may refer to the introduced variables as well. .. example:: Parametric relation @@ -219,10 +226,10 @@ replace terms with related ones only in contexts that are syntactic compositions of parametric morphism instances declared with the following command. -.. cmd:: Add Parametric Morphism {* @binder } : (@ident {+ @term__1}) with signature @term__2 as @ident +.. cmd:: Add Parametric Morphism {* @binder } : @one_term with signature @term as @ident - This command declares a parametric morphism :n:`@ident {+ @term__1}` of - signature :n:`@term__2`. The final identifier :token:`ident` gives a unique + Declares a parametric morphism :n:`@one_term` of + signature :n:`@term`. The final identifier :token:`ident` gives a unique name to the morphism and it is used as the base name of the typeclass instance definition and as the name of the lemma that proves the well-definedness of the morphism. The parameters of the morphism as well as @@ -525,12 +532,13 @@ counterparts when the relation involved is not Leibniz equality. Notice, however, that using the prefixed tactics it is possible to pass additional arguments such as ``using relation``. -.. tacv:: setoid_reflexivity - setoid_symmetry {? in @ident} - setoid_transitivity - setoid_rewrite {? @orientation} @term {? at @occurrences} {? in @ident} - setoid_replace @term with @term {? using relation @term} {? in @ident} {? by @ltac_expr3} - :name: setoid_reflexivity; setoid_symmetry; setoid_transitivity; setoid_rewrite; setoid_replace +.. tacn:: setoid_reflexivity + setoid_symmetry {? in @ident } + setoid_transitivity @one_term + setoid_rewrite {? {| -> | <- } } @one_term {? with @bindings } {? at @occurrences } {? in @ident } + setoid_rewrite {? {| -> | <- } } @one_term {? with @bindings } in @ident at @occurrences + setoid_replace @one_term with @one_term {? using relation @one_term } {? in @ident } {? at {+ @int_or_var } } {? by @ltac_expr3 } + :name: setoid_reflexivity; setoid_symmetry; setoid_transitivity; setoid_rewrite; _; setoid_replace The ``using relation`` arguments cannot be passed to the unprefixed form. The latter argument tells the tactic what parametric relation should @@ -553,34 +561,35 @@ system up to user defined equalities. Printing relations and morphisms ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Print Instances +Use the :cmd:`Print Instances` command with the class names ``Reflexive``, ``Symmetric`` +or ``Transitive`` to print registered reflexive, symmetric or transitive relations and +with the class name ``Proper`` to print morphisms. - This command can be used to show the list of currently - registered ``Reflexive`` (using ``Print Instances Reflexive``), ``Symmetric`` - or ``Transitive`` relations, Equivalences, PreOrders, PERs, and Morphisms - (implemented as ``Proper`` instances). When the rewriting tactics refuse - to replace a term in a context because the latter is not a composition - of morphisms, the :cmd:`Print Instances` command can be useful to understand - what additional morphisms should be registered. +When rewriting tactics refuse +to replace a term in a context because the latter is not a composition +of morphisms, this command can be useful to understand +what additional morphisms should be registered. .. _deprecated_syntax_for_generalized_rewriting: Deprecated syntax and backward incompatibilities ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Add Setoid @qualid__1 @qualid__2 @qualid__3 as @ident +.. cmd:: Add Setoid @one_term__carrier @one_term__congruence @one_term__proofs as @ident This command for declaring setoids and morphisms is also accepted due to backward compatibility reasons. - Here :n:`@qualid__2` is a congruence relation without parameters, :n:`@qualid__1` is its carrier - and :n:`@qualid__3` is an object of type (:n:`Setoid_Theory @qualid__1 @qualid__2`) (i.e. a record + Here :n:`@one_term__congruence` is a congruence relation without parameters, + :n:`@one_term__carrier` is its carrier and :n:`@one_term__proofs` is an object + of type (:n:`Setoid_Theory @one_term__carrier @one_term__congruence`) (i.e. a record packing together the reflexivity, symmetry and transitivity lemmas). Notice that the syntax is not completely backward compatible since the identifier was not required. -.. cmd:: Add Morphism @ident : @ident - :name: Add Morphism +.. cmd:: Add Morphism @one_term : @ident + Add Morphism @one_term with signature @term as @ident + :name: Add Morphism; _ This command is restricted to the declaration of morphisms without parameters. It is not fully backward compatible since the @@ -590,11 +599,10 @@ Deprecated syntax and backward incompatibilities bi-implication in place of a simple implication. In practice, porting an old development to the new semantics is usually quite simple. -.. cmd:: Declare Morphism @ident : @ident +.. cmd:: Declare Morphism @one_term : @ident :name: Declare Morphism - This commands is to be used in a module type to declare a parameter that - is a morphism. + Declares a parameter in a module type that is a morphism. Notice that several limitations of the old implementation have been lifted. In particular, it is now possible to declare several relations diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index dafa510ade..0f0ccd6a20 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -8,7 +8,7 @@ Implicit Coercions General Presentation --------------------- -This section describes the inheritance mechanism of |Coq|. In |Coq| with +This section describes the inheritance mechanism of Coq. In Coq with inheritance, we are not interested in adding any expressive power to our theory, but only convenience. Given a term, possibly not typable, we are interested in the problem of determining if it can be well @@ -125,10 +125,16 @@ term consists of the successive application of its coercions. Declaring Coercions ------------------------- -.. cmd:: Coercion @qualid : @class >-> @class +.. cmd:: Coercion @reference : @class >-> @class + Coercion @ident {? @univ_decl } @def_body - Declares the construction denoted by :token:`qualid` as a coercion between - the two given classes. + :name: Coercion; _ + + The first form declares the construction denoted by :token:`reference` as a coercion between + the two given classes. The second form defines :token:`ident` + just like :cmd:`Definition` :n:`@ident {? @univ_decl } @def_body` + and then declares :token:`ident` as a coercion between it source and its target. + Both forms support the :attr:`local` attribute, which makes the coercion local to the current section. .. exn:: @qualid not declared. :undocumented: @@ -174,21 +180,6 @@ Declaring Coercions circular. When a new circular coercion path is not convertible with the identity function, it will be reported as ambiguous. - .. cmdv:: Local Coercion @qualid : @class >-> @class - - Declares the construction denoted by :token:`qualid` as a coercion local to - the current section. - - .. cmdv:: Coercion @ident := @term {? @type } - - This defines :token:`ident` just like :n:`Definition @ident := term {? @type }`, - and then declares :token:`ident` as a coercion between it source and its target. - - .. cmdv:: Local Coercion @ident := @term {? @type } - - This defines :token:`ident` just like :n:`Let @ident := @term {? @type }`, - and then declares :token:`ident` as a coercion between it source and its target. - Some objects can be declared as coercions when they are defined. This applies to :ref:`assumptions<gallina-assumptions>` and constructors of :ref:`inductive types and record fields<gallina-inductive-definitions>`. @@ -205,13 +196,11 @@ Use :n:`:>` instead of :n:`:` before the function with type :g:`forall (x₁:T₁)..(xₙ:Tₙ)(y:C x₁..xₙ),D t₁..tₘ`, and we declare it as an identity coercion between ``C`` and ``D``. + This command supports the :attr:`local` attribute, which makes the coercion local to the current section. + .. exn:: @class must be a transparent constant. :undocumented: - .. cmdv:: Local Identity Coercion @ident : @ident >-> @ident - - Same as :cmd:`Identity Coercion` but locally to the current section. - .. cmd:: SubClass @ident_decl @def_body :name: SubClass @@ -223,9 +212,7 @@ Use :n:`:>` instead of :n:`:` before the :n:`Definition @ident := @type.` :n:`Identity Coercion Id_@ident_@ident' : @ident >-> @ident'`. - .. cmdv:: Local SubClass @ident_decl @def_body - - Same as before but locally to the current section. + This command supports the :attr:`local` attribute, which makes the coercion local to the current section. Displaying Available Coercions @@ -268,24 +255,15 @@ Classes as Records .. index:: :> (coercion) -We allow the definition of *Structures with Inheritance* (or classes as records) -by extending the existing :cmd:`Record` macro. Its new syntax is: - -.. cmdv:: {| Record | Structure } {? >} @ident {* @binder } : @sort := {? @ident} { {+; @ident :{? >} @term } } - - The first identifier :token:`ident` is the name of the defined record and - :token:`sort` is its type. The optional identifier after ``:=`` is the name - of the constructor (it will be :n:`Build_@ident` if not given). - The other identifiers are the names of the fields, and :token:`term` - are their respective types. If ``:>`` is used instead of ``:`` in - the declaration of a field, then the name of this field is automatically - declared as a coercion from the record name to the class of this - field type. Note that the fields always verify the uniform - inheritance condition. If the optional ``>`` is given before the - record name, then the constructor name is automatically declared as - a coercion from the class of the last field type to the record name - (this may fail if the uniform inheritance condition is not - satisfied). +*Structures with Inheritance* may be defined using the :cmd:`Record` command. + +Use `>` before the record name to declare the constructor name as +a coercion from the class of the last field type to the record name +(this may fail if the uniform inheritance condition is not +satisfied). See :token:`record_definition`. + +Use `:>` in the field type to declare the field as a coercion from the record name +to the class of the field type. See :token:`of_type`. Coercions and Sections ---------------------- diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index b3a33ffeea..fb9965e43a 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -1,6 +1,6 @@ .. _micromega: -Micromega: tactics for solving arithmetic goals over ordered rings +Micromega: solvers for arithmetic goals over ordered rings ================================================================== :Authors: Frédéric Besson and Evgeny Makarov @@ -25,8 +25,8 @@ tactics for solving arithmetic goals over :math:`\mathbb{Q}`, ``n`` is an optional integer limiting the proof search depth, is an incomplete proof procedure for non-linear arithmetic. It is based on John Harrison’s HOL Light - driver to the external prover `csdp` [#csdp]_. Note that the `csdp` driver is - generating a *proof cache* which makes it possible to rerun scripts + driver to the external prover `csdp` [#csdp]_. Note that the `csdp` driver + generates a *proof cache* which makes it possible to rerun scripts even without `csdp`. .. flag:: Simplex @@ -250,7 +250,7 @@ proof by abstracting monomials by variables. `psatz`: a proof procedure for non-linear arithmetic ---------------------------------------------------- -.. tacn:: psatz +.. tacn:: psatz @one_term {? @int_or_var } :name: psatz This tactic explores the *Cone* by increasing degrees – hence the @@ -300,48 +300,86 @@ obtain :math:`-1`. By Theorem :ref:`Psatz <psatz_thm>`, the goal is valid. The :tacn:`zify` tactic can be extended with new types and operators by declaring and registering new typeclass instances using the following commands. The typeclass declarations can be found in the module ``ZifyClasses`` and the default instances can be found in the module ``ZifyInst``. -.. cmd:: Add Zify {| InjTyp | BinOp | UnOp |CstOp | BinRel | UnOpSpec | BinOpSpec } @qualid +.. cmd:: Add Zify @add_zify @one_term - This command registers an instance of one of the typeclasses among ``InjTyp``, ``BinOp``, ``UnOp``, ``CstOp``, ``BinRel``, - ``UnOpSpec``, ``BinOpSpec``. + .. insertprodn add_zify add_zify -.. cmd:: Show Zify {| InjTyp | BinOp | UnOp |CstOp | BinRel | UnOpSpec | BinOpSpec } + .. prodn:: + add_zify ::= {| InjTyp | BinOp | UnOp | CstOp | BinRel | UnOpSpec | BinOpSpec } + | {| PropOp | PropBinOp | PropUOp | Saturate } + + Registers an instance of the specified typeclass. + +.. cmd:: Show Zify @show_zify + + .. insertprodn show_zify show_zify + + .. prodn:: + show_zify ::= {| InjTyp | BinOp | UnOp | CstOp | BinRel | UnOpSpec | BinOpSpec | Spec } - The command prints the typeclass instances of one the typeclasses - among ``InjTyp``, ``BinOp``, ``UnOp``, ``CstOp``, ``BinRel``, - ``UnOpSpec``, ``BinOpSpec``. For instance, :cmd:`Show Zify` ``InjTyp`` + Prints instances for the specified typeclass. For instance, :cmd:`Show Zify` ``InjTyp`` prints the list of types that supported by :tacn:`zify` i.e., :g:`Z`, :g:`nat`, :g:`positive` and :g:`N`. .. cmd:: Show Zify Spec .. deprecated:: 8.13 - Use instead either :cmd:`Show Zify` ``UnOpSpec`` or :cmd:`Show Zify` ``BinOpSpec``. + Use :cmd:`Show Zify` ``UnOpSpec`` or :cmd:`Show Zify` ``BinOpSpec`` instead. + +.. cmd:: Add InjTyp @one_term + + .. deprecated:: 8.13 + Use :cmd:`Add Zify` ``InjTyp`` instead. + +.. cmd:: Add BinOp @one_term + + .. deprecated:: 8.13 + Use :cmd:`Add Zify` ``BinOp`` instead. + +.. cmd:: Add BinOpSpec @one_term + + .. deprecated:: 8.13 + Use :cmd:`Add Zify` ``BinOpSpec`` instead. + +.. cmd:: Add UnOp @one_term + + .. deprecated:: 8.13 + Use :cmd:`Add Zify` ``UnOp`` instead. + +.. cmd:: Add UnOpSpec @one_term + + .. deprecated:: 8.13 + Use :cmd:`Add Zify` ``UnOpSpec`` instead. + +.. cmd:: Add CstOp @one_term + + .. deprecated:: 8.13 + Use :cmd:`Add Zify` ``CstOp`` instead. -.. cmd:: Add InjTyp +.. cmd:: Add BinRel @one_term .. deprecated:: 8.13 - Use instead either :cmd:`Add Zify` ``InjTyp``. + Use :cmd:`Add Zify` ``BinRel`` instead. -.. cmd:: Add BinOp +.. cmd:: Add PropOp @one_term .. deprecated:: 8.13 - Use instead either :cmd:`Add Zify` ``BinOp``. + Use :cmd:`Add Zify` ``PropOp`` instead. -.. cmd:: Add UnOp +.. cmd:: Add PropBinOp @one_term .. deprecated:: 8.13 - Use instead either :cmd:`Add Zify` ``UnOp``. + Use :cmd:`Add Zify` ``PropBinOp`` instead. -.. cmd:: Add CstOp +.. cmd:: Add PropUOp @one_term .. deprecated:: 8.13 - Use instead either :cmd:`Add Zify` ``CstOp``. + Use :cmd:`Add Zify` ``PropUOp`` instead. -.. cmd:: Add BinRel +.. cmd:: Add Saturate @one_term .. deprecated:: 8.13 - Use instead either :cmd:`Add Zify` ``BinRel``. + Use :cmd:`Add Zify` ``Saturate`` instead. diff --git a/doc/sphinx/addendum/miscellaneous-extensions.rst b/doc/sphinx/addendum/miscellaneous-extensions.rst index 0e8660cb0e..7d30cae525 100644 --- a/doc/sphinx/addendum/miscellaneous-extensions.rst +++ b/doc/sphinx/addendum/miscellaneous-extensions.rst @@ -1,16 +1,16 @@ Program derivation ================== -|Coq| comes with an extension called ``Derive``, which supports program +Coq comes with an extension called ``Derive``, which supports program derivation. Typically in the style of Bird and Meertens or derivations of program refinements. To use the Derive extension it must first be required with ``Require Coq.derive.Derive``. When the extension is loaded, it provides the following command: -.. cmd:: Derive @ident__1 SuchThat @type As @ident__2 +.. cmd:: Derive @ident__1 SuchThat @one_term As @ident__2 - :n:`@ident__1` can appear in :n:`@type`. This command opens a new proof - presenting the user with a goal for :n:`@type` in which the name :n:`@ident__1` is + :n:`@ident__1` can appear in :n:`@one_term`. This command opens a new proof + presenting the user with a goal for :n:`@one_term` in which the name :n:`@ident__1` is bound to an existential variable :g:`?x` (formally, there are other goals standing for the existential variables but they are shelved, as described in :tacn:`shelve`). diff --git a/doc/sphinx/addendum/nsatz.rst b/doc/sphinx/addendum/nsatz.rst index 8a64a7ed4b..7a2be3dcef 100644 --- a/doc/sphinx/addendum/nsatz.rst +++ b/doc/sphinx/addendum/nsatz.rst @@ -1,12 +1,20 @@ .. _nsatz_chapter: -Nsatz: tactics for proving equalities in integral domains +Nsatz: a solver for equalities in integral domains =========================================================== :Author: Loïc Pottier -.. tacn:: nsatz - :name: nsatz + +To use the tactics described in this section, load the ``Nsatz`` module with the +command ``Require Import Nsatz``. Alternatively, if you prefer not to transitively depend on the +files that declare the axioms used to define the real numbers, you can +``Require Import NsatzTactic`` instead; this will still allow +:tacn:`nsatz` to solve goals defined about :math:`\mathbb{Z}`, +:math:`\mathbb{Q}` and any user-registered rings. + + +.. tacn:: nsatz {? with radicalmax := @one_term strategy := @one_term parameters := @one_term variables := @one_term } This tactic is for solving goals of the form @@ -32,13 +40,36 @@ Nsatz: tactics for proving equalities in integral domains doing automatic introductions. - You can load the ``Nsatz`` module with the command ``Require Import Nsatz``. + `radicalmax` + bound when searching for r such that + :math:`c (P−Q) r = \sum_{i=1..s} S_i (P i − Q i)`. + This argument must be of type `N` (binary natural numbers). - Alternatively, if you prefer not to transitively depend on the - files declaring the axioms used to define the real numbers, you can - ``Require Import NsatzTactic`` instead; this will still allow - :tacn:`nsatz` to solve goals defined about :math:`\mathbb{Z}`, - :math:`\mathbb{Q}` and any user-registered rings. + `strategy` + gives the order on variables :math:`X_1,\ldots,X_n` and the strategy + used in Buchberger algorithm (see :cite:`sugar` for details): + + * `strategy := 0%Z`: reverse lexicographic order and newest s-polynomial. + * `strategy := 1%Z`: reverse lexicographic order and sugar strategy. + * `strategy := 2%Z`: pure lexicographic order and newest s-polynomial. + * `strategy := 3%Z`: pure lexicographic order and sugar strategy. + + `parameters` + a list of parameters of type `R`, containing the variables :math:`X_{i_1},\ldots,X_{i_k}` among + :math:`X_1,\ldots,X_n`. Computation will be performed with + rational fractions in these parameters, i.e. polynomials have + coefficients in :math:`R(X_{i_1},\ldots,X_{i_k})`. In this case, the coefficient + :math:`c` can be a nonconstant polynomial in :math:`X_{i_1},\ldots,X_{i_k}`, and the tactic + produces a goal which states that :math:`c` is not zero. + + `variables` + a list of variables of type `R` in the decreasing order in + which they will be used in the Buchberger algorithm. If the list is empty, + then `lvar` is replaced by all the variables which are not in + `parameters`. + + See the file `Nsatz.v <https://github.com/coq/coq/blob/master/test-suite/success/Nsatz.v>`_ + for examples, especially in geometry. More about `nsatz` --------------------- @@ -63,32 +94,3 @@ Buchberger algorithm. This computation is done after a step of *reification*, which is performed using :ref:`typeclasses`. - -.. tacv:: nsatz with radicalmax:=@natural%N strategy:=@natural%Z parameters:=[{*, @ident}] variables:=[{*, @ident}] - - Most complete syntax for `nsatz`. - - * `radicalmax` is a bound when searching for r such that - :math:`c (P−Q) r = \sum_{i=1..s} S_i (P i − Q i)` - - * `strategy` gives the order on variables :math:`X_1,\ldots,X_n` and the strategy - used in Buchberger algorithm (see :cite:`sugar` for details): - - * strategy = 0: reverse lexicographic order and newest s-polynomial. - * strategy = 1: reverse lexicographic order and sugar strategy. - * strategy = 2: pure lexicographic order and newest s-polynomial. - * strategy = 3: pure lexicographic order and sugar strategy. - - * `parameters` is the list of variables :math:`X_{i_1},\ldots,X_{i_k}` among - :math:`X_1,\ldots,X_n` which are considered as parameters: computation will be performed with - rational fractions in these variables, i.e. polynomials are considered - with coefficients in :math:`R(X_{i_1},\ldots,X_{i_k})`. In this case, the coefficient - :math:`c` can be a non constant polynomial in :math:`X_{i_1},\ldots,X_{i_k}`, and the tactic - produces a goal which states that :math:`c` is not zero. - - * `variables` is the list of the variables in the decreasing order in - which they will be used in the Buchberger algorithm. If `variables` = :g:`(@nil R)`, - then `lvar` is replaced by all the variables which are not in - `parameters`. - -See the test-suite file `Nsatz.v <https://github.com/coq/coq/blob/master/test-suite/success/Nsatz.v>`_ for many examples, especially in geometry. diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst index e1b1ee8e8d..2b10f5671d 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -1,6 +1,6 @@ .. _omega_chapter: -Omega: a solver for quantifier-free problems in Presburger Arithmetic +Omega: a (deprecated) solver for arithmetic ===================================================================== :Author: Pierre Crégut diff --git a/doc/sphinx/addendum/parallel-proof-processing.rst b/doc/sphinx/addendum/parallel-proof-processing.rst index 7a50748c51..e824ae152d 100644 --- a/doc/sphinx/addendum/parallel-proof-processing.rst +++ b/doc/sphinx/addendum/parallel-proof-processing.rst @@ -6,8 +6,8 @@ Asynchronous and Parallel Proof Processing :Author: Enrico Tassi This chapter explains how proofs can be asynchronously processed by -|Coq|. This feature improves the reactivity of the system when used in -interactive mode via |CoqIDE|. In addition, it allows |Coq| to take +Coq. This feature improves the reactivity of the system when used in +interactive mode via CoqIDE. In addition, it allows Coq to take advantage of parallel hardware when used as a batch compiler by decoupling the checking of statements and definitions from the construction and checking of proofs objects. @@ -20,13 +20,13 @@ This feature has some technical limitations that may make it unsuitable for some use cases. For example, in interactive mode, some errors coming from the kernel -of |Coq| are signaled late. The type of errors belonging to this +of Coq are signaled late. The type of errors belonging to this category are universe inconsistencies. At the time of writing, only opaque proofs (ending with ``Qed`` or ``Admitted``) can be processed asynchronously. -Finally, asynchronous processing is disabled when running |CoqIDE| in +Finally, asynchronous processing is disabled when running CoqIDE in Windows. The current implementation of the feature is not stable on Windows. It can be enabled, as described below at :ref:`interactive-mode`, though doing so is not recommended. @@ -34,12 +34,12 @@ though doing so is not recommended. Proof annotations ---------------------- -To process a proof asynchronously |Coq| needs to know the precise +To process a proof asynchronously Coq needs to know the precise statement of the theorem without looking at the proof. This requires some annotations if the theorem is proved inside a Section (see Section :ref:`section-mechanism`). -When a section ends, |Coq| looks at the proof object to decide which +When a section ends, Coq looks at the proof object to decide which section variables are actually used and hence have to be quantified in the statement of the theorem. To avoid making the construction of proofs mandatory when ending a section, one can start each proof with @@ -58,7 +58,7 @@ variables used. Automatic suggestion of proof annotations ````````````````````````````````````````` -The :flag:`Suggest Proof Using` flag makes |Coq| suggest, when a ``Qed`` +The :flag:`Suggest Proof Using` flag makes Coq suggest, when a ``Qed`` command is processed, a correct proof annotation. It is up to the user to modify the proof script accordingly. @@ -66,17 +66,17 @@ to modify the proof script accordingly. Proof blocks and error resilience -------------------------------------- -|Coq| 8.6 introduced a mechanism for error resilience: in interactive -mode |Coq| is able to completely check a document containing errors +Coq 8.6 introduced a mechanism for error resilience: in interactive +mode Coq is able to completely check a document containing errors instead of bailing out at the first failure. Two kind of errors are supported: errors occurring in vernacular commands and errors occurring in proofs. -To properly recover from a failing tactic, |Coq| needs to recognize the +To properly recover from a failing tactic, Coq needs to recognize the structure of the proof in order to confine the error to a sub proof. Proof block detection is performed by looking at the syntax of the -proof script (i.e. also looking at indentation). |Coq| comes with four +proof script (i.e. also looking at indentation). Coq comes with four kind of proof blocks, and an ML API to add new ones. :curly: blocks are delimited by { and }, see Chapter :ref:`proofhandling` @@ -92,13 +92,13 @@ Caveats When a vernacular command fails the subsequent error messages may be bogus, i.e. caused by the first error. Error resilience for vernacular commands can be switched off by passing ``-async-proofs-command-error-resilience off`` -to |CoqIDE|. +to CoqIDE. An incorrect proof block detection can result into an incorrect error recovery and hence in bogus errors. Proof block detection cannot be precise for bullets or any other non well parenthesized proof structure. Error resilience can be turned off or selectively activated -for any set of block kind passing to |CoqIDE| one of the following +for any set of block kind passing to CoqIDE one of the following options: - ``-async-proofs-tactic-error-resilience off`` @@ -113,13 +113,13 @@ Interactive mode --------------------- At the time of writing the only user interface supporting asynchronous -proof processing is |CoqIDE|. +proof processing is CoqIDE. -When |CoqIDE| is started, two |Coq| processes are created. The master one +When CoqIDE is started, two Coq processes are created. The master one follows the user, giving feedback as soon as possible by skipping proofs, which are delegated to the worker process. The worker process, whose state can be seen by clicking on the button in the lower right -corner of the main |CoqIDE| window, asynchronously processes the proofs. +corner of the main CoqIDE window, asynchronously processes the proofs. If a proof contains an error, it is reported in red in the label of the very same button, that can also be used to see the list of errors and jump to the corresponding line. @@ -137,14 +137,14 @@ Only then all the universe constraints are checked. Caveats ``````` -The number of worker processes can be increased by passing |CoqIDE| +The number of worker processes can be increased by passing CoqIDE the ``-async-proofs-j n`` flag. Note that the memory consumption increases too, since each worker requires the same amount of memory as the master process. Also note that increasing the number of workers may reduce the reactivity of the master process to user commands. To disable this feature, one can pass the ``-async-proofs off`` flag to -|CoqIDE|. Conversely, on Windows, where the feature is disabled by +CoqIDE. Conversely, on Windows, where the feature is disabled by default, pass the ``-async-proofs on`` flag to enable it. Proofs that are known to take little time to process are not delegated @@ -166,9 +166,9 @@ Batch mode a ``Require``. Indeed, the loading of a nonempty ``.vos`` file is assigned higher priority than the loading of a ``.vio`` file. -When |Coq| is used as a batch compiler by running ``coqc``, it produces +When Coq is used as a batch compiler by running ``coqc``, it produces a ``.vo`` file for each ``.v`` file. A ``.vo`` file contains, among other -things, theorem statements and proofs. Hence to produce a .vo |Coq| +things, theorem statements and proofs. Hence to produce a .vo Coq need to process all the proofs of the ``.v`` file. The asynchronous processing of proofs can decouple the generation of a @@ -224,7 +224,7 @@ heavy use of the ``Type`` hierarchy. Limiting the number of parallel workers -------------------------------------------- -Many |Coq| processes may run on the same computer, and each of them may +Many Coq processes may run on the same computer, and each of them may start many additional worker processes. The ``coqworkmgr`` utility lets one limit the number of workers, globally. @@ -232,9 +232,9 @@ The utility accepts the ``-j`` argument to specify the maximum number of workers (defaults to 2). ``coqworkmgr`` automatically starts in the background and prints an environment variable assignment like ``COQWORKMGR_SOCKET=localhost:45634``. The user must set this variable -in all the shells from which |Coq| processes will be started. If one +in all the shells from which Coq processes will be started. If one uses just one terminal running the bash shell, then ``export ‘coqworkmgr -j 4‘`` will do the job. -After that, all |Coq| processes, e.g. ``coqide`` and ``coqc``, will respect the +After that, all Coq processes, e.g. ``coqide`` and ``coqc``, will respect the limit, globally. diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index c6a4b4fe1a..298ea4b4ab 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -8,34 +8,34 @@ Program :Author: Matthieu Sozeau We present here the |Program| tactic commands, used to build -certified |Coq| programs, elaborating them from their algorithmic +certified Coq programs, elaborating them from their algorithmic skeleton and a rich specification :cite:`sozeau06`. It can be thought of as a dual of :ref:`Extraction <extraction>`. The goal of |Program| is to program as in a regular functional programming language whilst using as rich a specification as desired and proving that the code meets the -specification using the whole |Coq| proof apparatus. This is done using +specification using the whole Coq proof apparatus. This is done using a technique originating from the “Predicate subtyping” mechanism of PVS :cite:`Rushby98`, which generates type checking conditions while typing a term constrained to a particular type. Here we insert existential variables in the term, which must be filled with proofs to get a -complete |Coq| term. |Program| replaces the |Program| tactic by Catherine +complete Coq term. |Program| replaces the |Program| tactic by Catherine Parent :cite:`Parent95b` which had a similar goal but is no longer maintained. -The languages available as input are currently restricted to |Coq|’s +The languages available as input are currently restricted to Coq’s term language, but may be extended to OCaml, Haskell and -others in the future. We use the same syntax as |Coq| and permit to use +others in the future. We use the same syntax as Coq and permit to use implicit arguments and the existing coercion mechanism. Input terms and types are typed in an extended system (Russell) and interpreted -into |Coq| terms. The interpretation process may produce some proof +into Coq terms. The interpretation process may produce some proof obligations which need to be resolved to create the final term. .. _elaborating-programs: Elaborating programs ---------------------- +-------------------- -The main difference from |Coq| is that an object in a type :g:`T : Set` can +The main difference from Coq is that an object in a type :g:`T : Set` can be considered as an object of type :g:`{x : T | P}` for any well-formed :g:`P : Prop`. If we go from :g:`T` to the subset of :g:`T` verifying property :g:`P`, we must prove that the object under consideration verifies it. Russell @@ -83,15 +83,15 @@ coercions. .. flag:: Program Cases - This controls the special treatment of pattern matching generating equalities + Controls the special treatment of pattern matching generating equalities and disequalities when using |Program| (it is on by default). All pattern-matches and let-patterns are handled using the standard algorithm - of |Coq| (see :ref:`extendedpatternmatching`) when this flag is + of Coq (see :ref:`extendedpatternmatching`) when this flag is deactivated. .. flag:: Program Generalized Coercion - This controls the coercion of general inductive types when using |Program| + Controls the coercion of general inductive types when using |Program| (the flag is on by default). Coercion of subset types and pairs is still active in this case. @@ -104,19 +104,19 @@ coercions. typechecking. .. attr:: program + :name: program; Program - This attribute allows to use the Program mode on a specific + Allows using the Program mode on a specific definition. An alternative syntax is to use the legacy ``Program`` - prefix (cf. :n:`@legacy_attr`) as documented in the rest of this - chapter. + prefix (cf. :n:`@legacy_attr`) as it is elsewhere in this chapter. .. _syntactic_control: Syntactic control over equalities -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To give more control over the generation of equalities, the -type checker will fall back directly to |Coq|’s usual typing of dependent +type checker will fall back directly to Coq’s usual typing of dependent pattern matching if a ``return`` or ``in`` clause is specified. Likewise, the if construct is not treated specially by |Program| so boolean tests in the code are not automatically reflected in the obligations. One can @@ -158,36 +158,20 @@ prove some goals to construct the final definitions. Program Definition ~~~~~~~~~~~~~~~~~~ -.. cmd:: Program Definition @ident := @term - - This command types the value term in Russell and generates proof - obligations. Once solved using the commands shown below, it binds the - final |Coq| term to the name :n:`@ident` in the environment. - - .. exn:: @ident already exists. - :name: @ident already exists. (Program Definition) - :undocumented: - - .. cmdv:: Program Definition @ident : @type := @term - - It interprets the type :n:`@type`, potentially generating proof - obligations to be resolved. Once done with them, we have a |Coq| - type :n:`@type__0`. It then elaborates the preterm :n:`@term` into a |Coq| - term :n:`@term__0`, checking that the type of :n:`@term__0` is coercible to - :n:`@type__0`, and registers :n:`@ident` as being of type :n:`@type__0` once the - set of obligations generated during the interpretation of :n:`@term__0` - and the aforementioned coercion derivation are solved. - - .. exn:: In environment … the term: @term does not have type @type. Actually, it has type ... - :undocumented: +A :cmd:`Definition` command with the :attr:`program` attribute types +the value term in Russell and generates proof +obligations. Once solved using the commands shown below, it binds the +final Coq term to the name :n:`@ident` in the environment. - .. cmdv:: Program Definition @ident {* @binder } : @type := @term +:n:`Program Definition @ident : @type := @term` - This is equivalent to: - - :n:`Program Definition @ident : forall {* @binder }, @type := fun {* @binder } => @term`. - - .. TODO refer to production in alias +Interprets the type :n:`@type`, potentially generating proof +obligations to be resolved. Once done with them, we have a Coq +type :n:`@type__0`. It then elaborates the preterm :n:`@term` into a Coq +term :n:`@term__0`, checking that the type of :n:`@term__0` is coercible to +:n:`@type__0`, and registers :n:`@ident` as being of type :n:`@type__0` once the +set of obligations generated during the interpretation of :n:`@term__0` +and the aforementioned coercion derivation are solved. .. seealso:: Sections :ref:`vernac-controlling-the-reduction-strategies`, :tacn:`unfold` @@ -196,20 +180,8 @@ Program Definition Program Fixpoint ~~~~~~~~~~~~~~~~ -.. cmd:: Program Fixpoint @fix_definition {* with @fix_definition } - - The optional :n:`@fixannot` annotation can be one of: - - + :g:`measure f R` where :g:`f` is a value of type :g:`X` computed on - any subset of the arguments and the optional term - :g:`R` is a relation on :g:`X`. :g:`X` defaults to :g:`nat` and :g:`R` - to :g:`lt`. - - + :g:`wf R x` which is equivalent to :g:`measure x R`. - - The structural fixpoint operator behaves just like the one of |Coq| (see - :cmd:`Fixpoint`), except it may also generate obligations. It works - with mutually recursive definitions too. +A :cmd:`Fixpoint` command with the :attr:`program` attribute may also generate obligations. It works +with mutually recursive definitions too. For example: .. coqtop:: reset in @@ -223,6 +195,17 @@ Program Fixpoint | _ => O end. +The :cmd:`Fixpoint` command may include an optional :n:`@fixannot` annotation, which can be: + ++ :g:`measure f R` where :g:`f` is a value of type :g:`X` computed on + any subset of the arguments and the optional term + :g:`R` is a relation on :g:`X`. :g:`X` defaults to :g:`nat` and :g:`R` + to :g:`lt`. + ++ :g:`wf R x` which is equivalent to :g:`measure x R`. + +.. todo see https://github.com/coq/coq/pull/12936#discussion_r492747830 + Here we have one obligation for each branch (branches for :g:`0` and ``(S 0)`` are automatically generated by the pattern matching compilation algorithm). @@ -246,8 +229,6 @@ using the syntax: | _ => O end. - - .. caution:: When defining structurally recursive functions, the generated obligations should have the prototype of the currently defined functional in their context. In this case, the obligations should be @@ -266,67 +247,70 @@ using the syntax: Program Lemma ~~~~~~~~~~~~~ -.. cmd:: Program Lemma @ident : @type - - The Russell language can also be used to type statements of logical - properties. It will generate obligations, try to solve them - automatically and fail if some unsolved obligations remain. In this - case, one can first define the lemma’s statement using :g:`Program - Definition` and use it as the goal afterwards. Otherwise the proof - will be started with the elaborated version as a goal. The - :g:`Program` prefix can similarly be used as a prefix for - :g:`Variable`, :g:`Hypothesis`, :g:`Axiom` etc. +A :cmd:`Lemma` command with the :attr:`program` attribute uses the Russell +language to type statements of logical +properties. It generates obligations, tries to solve them +automatically and fails if some unsolved obligations remain. In this +case, one can first define the lemma’s statement using :cmd:`Definition` +and use it as the goal afterwards. Otherwise the proof +will be started with the elaborated version as a goal. The +:attr:`Program` attribute can similarly be used with +:cmd:`Variable`, :cmd:`Hypothesis`, :cmd:`Axiom` etc. .. _solving_obligations: Solving obligations --------------------- +------------------- The following commands are available to manipulate obligations. The optional identifier is used when multiple functions have unsolved obligations (e.g. when defining mutually recursive blocks). The optional tactic is replaced by the default one if not specified. -.. cmd:: {? {| Local | Global } } Obligation Tactic := @ltac_expr +.. cmd:: Obligation Tactic := @ltac_expr :name: Obligation Tactic Sets the default obligation solving tactic applied to all obligations automatically, whether to solve them or when starting to prove one, - e.g. using :g:`Next`. :g:`Local` makes the setting last only for the current - module. Inside sections, local is the default. + e.g. using :cmd:`Next Obligation`. + + This command supports the :attr:`local` and :attr:`global` attributes. + :attr:`local` makes the setting last only for the current + module. :attr:`local` is the default inside sections while :attr:`global` + otherwise. .. cmd:: Show Obligation Tactic Displays the current default tactic. -.. cmd:: Obligations {? of @ident} +.. cmd:: Obligations {? of @ident } Displays all remaining obligations. -.. cmd:: Obligation @natural {? of @ident} +.. cmd:: Obligation @natural {? of @ident } {? : @type {? with @ltac_expr } } Start the proof of obligation :token:`natural`. -.. cmd:: Next Obligation {? of @ident} +.. cmd:: Next Obligation {? of @ident } {? with @ltac_expr } Start the proof of the next unsolved obligation. -.. cmd:: Solve Obligations {? {? of @ident} with @ltac_expr} +.. cmd:: Solve Obligations {? of @ident } {? with @ltac_expr } - Tries to solve each obligation of ``ident`` using the given ``tactic`` or the default one. + Tries to solve each obligation of :token:`ident` using the given :token:`ltac_expr` or the default one. -.. cmd:: Solve All Obligations {? with @ltac_expr} +.. cmd:: Solve All Obligations {? with @ltac_expr } Tries to solve each obligation of every program using the given tactic or the default one (useful for mutually recursive definitions). -.. cmd:: Admit Obligations {? of @ident} +.. cmd:: Admit Obligations {? of @ident } - Admits all obligations (of ``ident``). + Admits all obligations (of :token:`ident`). .. note:: Does not work with structurally recursive programs. -.. cmd:: Preterm {? of @ident} +.. cmd:: Preterm {? of @ident } Shows the term that will be fed to the kernel once the obligations are solved. Useful for debugging. @@ -358,7 +342,7 @@ Frequently Asked Questions .. exn:: Ill-formed recursive definition. This error can happen when one tries to define a function by structural - recursion on a subset object, which means the |Coq| function looks like: + recursion on a subset object, which means the Coq function looks like: :: diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index cda8a1b679..c93d621048 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -10,8 +10,8 @@ .. _theringandfieldtacticfamilies: -The ring and field tactic families -==================================== +ring and field: solvers for polynomial and rational equations +============================================================= :Author: Bruno Barras, Benjamin Grégoire, Assia Mahboubi, Laurent Théry [#f1]_ @@ -102,7 +102,7 @@ forget this paragraph and use the tactic according to your intuition. Concrete usage in Coq -------------------------- -.. tacn:: ring {? [ {+ @term } ] } +.. tacn:: ring {? [ {+ @one_term } ] } Solves polynomical equations of a ring (or semiring) structure. It proceeds by normalizing both sides @@ -110,14 +110,35 @@ Concrete usage in Coq distributivity, constant propagation, rewriting of monomials) and syntactically comparing the results. -.. tacn:: ring_simplify {? [ {+ @term } ] } {+ @term } {? in @ident } + :n:`[ {+ @one_term } ]` + If specified, the tactic decides the equality of two terms modulo ring operations and + the equalities defined by the :token:`one_term`\s. + Each :token:`one_term` has to be a proof of some equality :g:`m = p`, where :g:`m` + is a monomial (after “abstraction”), :g:`p` a polynomial and :g:`=` is the + corresponding equality of the ring structure. + +.. tacn:: ring_simplify {? [ {+ @one_term } ] } {+ @one_term } {? in @ident } Applies the normalization procedure described above to - the given terms. The tactic then replaces all occurrences of the terms - given in the conclusion of the goal by their normal forms. If no term + the given :token:`one_term`\s. The tactic then replaces all occurrences of the :token:`one_term`\s + given in the conclusion of the goal by their normal forms. If no :token:`one_term` is given, then the conclusion should be an equation and both sides are normalized. The tactic can also be applied in a hypothesis. + :n:`in @ident` + If specified, the tactic performs the simplification in the hypothesis named :token:`ident`. + + .. note:: + + :n:`ring_simplify @one_term__1; ring_simplify @one_term__2` is not equivalent to + :n:`ring_simplify @one_term__1 @one_term__2`. + + In the latter case the variables map is shared between the two :token:`one_term`\s, and + common subterm :g:`t` of :n:`@one_term__1` and :n:`@one_term__2` + will have the same associated variable number. So the first + alternative should be avoided for :token:`one_term`\s belonging to the same ring + theory. + The tactic must be loaded by ``Require Import Ring``. The ring structures must be declared with the ``Add Ring`` command (see below). The ring of booleans is predefined; if one wants to use the tactic on |nat| one must @@ -147,31 +168,6 @@ Concrete usage in Coq Abort. -.. tacv:: ring [{* @term }] - - This tactic decides the equality of two terms modulo ring operations and - the equalities defined by the :token:`term`\ s. - Each :token:`term` has to be a proof of some equality :g:`m = p`, where :g:`m` - is a monomial (after “abstraction”), :g:`p` a polynomial and :g:`=` the - corresponding equality of the ring structure. - -.. tacv:: ring_simplify [{* @term }] {* @term } in @ident - - This tactic performs the simplification in the hypothesis named :token:`ident`. - - -.. note:: - - :n:`ring_simplify @term__1; ring_simplify @term__2` is not equivalent to - :n:`ring_simplify @term__1 @term__2`. - - In the latter case the variables map is shared between the two terms, and - common subterm :g:`t` of :n:`@term__1` and :n:`@term__2` - will have the same associated variable number. So the first - alternative should be avoided for terms belonging to the same ring - theory. - - Error messages: @@ -386,7 +382,7 @@ The syntax for adding a new ring is that, given a term, “abstracts” it into an object of type |N| whose interpretation via ``Cp_phi`` (the evaluation function of power coefficient) is the original term, or returns ``InitialRing.NotConstant`` - if not a constant coefficient (i.e. |L_tac| is the inverse function of + if not a constant coefficient (i.e. |Ltac| is the inverse function of ``Cp_phi``). See files ``plugins/ring/ZArithRing.v`` and ``plugins/ring/RealField.v`` for examples. By default the tactic does not recognize power expressions as ring expressions. @@ -433,7 +429,7 @@ How does it work? The code of ``ring`` is a good example of a tactic written using *reflection*. What is reflection? Basically, using it means that a part of a tactic is written -in Gallina, Coq's language of terms, rather than |Ltac| or |OCaml|. From the +in Gallina, Coq's language of terms, rather than |Ltac| or OCaml. From the philosophical point of view, reflection is using the ability of the Calculus of Constructions to speak and reason about itself. For the ``ring`` tactic we used Coq as a programming language and also as a proof environment to build a tactic @@ -495,7 +491,7 @@ its correctness w.r.t interpretation, that is: So now, what is the scheme for a normalization proof? Let p be the polynomial expression that the user wants to normalize. First a little -piece of |ML| code guesses the type of `p`, the ring theory `T` to use, an +piece of ML code guesses the type of `p`, the ring theory `T` to use, an abstract polynomial `ap` and a variables map `v` such that `p` is |bdi|- equivalent to `(PEeval v ap)`. Then we replace it by `(Pphi_dev v (norm ap))`, using the main correctness theorem and we reduce it to a @@ -515,15 +511,27 @@ application of the main correctness theorem to well-chosen arguments. Dealing with fields ------------------------ -.. tacn:: field {? [ {+ @term } ] } +.. tacn:: field {? [ {+ @one_term } ] } - This tactic is an extension of the :tacn:`ring` tactic that deals with rational + An extension of the :tacn:`ring` tactic that deals with rational expressions. Given a rational expression :math:`F = 0`. It first reduces the expression `F` to a common denominator :math:`N/D = 0` where `N` and `D` are two ring expressions. For example, if we take :math:`F = (1 − 1/x) x − x + 1`, this gives :math:`N = (x − 1) x − x^2 + x` and :math:`D = x`. It then calls ring to solve :math:`N = 0`. + :n:`[ {+ @one_term } ]` + If specified, the tactic decides the equality of two terms modulo + field operations and the equalities defined + by the :token:`one_term`\s. Each :token:`one_term` has to be a proof of some equality + :g:`m = p`, where :g:`m` is a monomial (after “abstraction”), :g:`p` a polynomial + and :g:`=` the corresponding equality of the field structure. + + .. note:: + + Rewriting works with the equality :g:`m = p` only if :g:`p` is a polynomial since + rewriting is handled by the underlying ring tactic. + Note that :n:`field` also generates nonzero conditions for all the denominators it encounters in the reduction. In our example, it generates the condition :math:`x \neq 0`. These conditions appear as one subgoal @@ -559,71 +567,49 @@ Dealing with fields intros x y H H1; field [H1]; auto. Abort. -.. tacv:: field [{* @term}] - This tactic decides the equality of two terms modulo - field operations and the equalities defined - by the :token:`term`\s. Each :token:`term` has to be a proof of some equality - :g:`m = p`, where :g:`m` is a monomial (after “abstraction”), :g:`p` a polynomial - and :g:`=` the corresponding equality of the field structure. +.. example:: :tacn:`field` that generates side goals -.. note:: + .. coqtop:: reset all - Rewriting works with the equality :g:`m = p` only if :g:`p` is a polynomial since - rewriting is handled by the underlying ring tactic. + Require Import Reals. + Goal forall x y:R, + (x * y > 0)%R -> + (x * (1 / x + x / (x + y)))%R = + ((- 1 / y) * y * (- x * (x / (x + y)) - 1))%R. -.. tacn:: field_simplify {? [ {+ @term } ] } {+ @term } {? in @ident } + intros; field. + +.. tacn:: field_simplify {? [ {+ @one_term__eq } ] } {+ @one_term } {? in @ident } - performs the simplification in the conclusion of the + Performs the simplification in the conclusion of the goal, :math:`F_1 = F_2` becomes :math:`N_1 / D_1 = N_2 / D_2`. A normalization step (the same as the one for rings) is then applied to :math:`N_1`, :math:`D_1`, :math:`N_2` and :math:`D_2`. This way, polynomials remain in factorized form during fraction simplification. This yields smaller expressions when reducing to the same denominator since common factors can be canceled. -.. tacv:: field_simplify [{* @term }] - - This variant performs the simplification in the conclusion of the goal using the equalities - defined by the :token:`term`\s. - -.. tacv:: field_simplify [{* @term }] {* @term } - - This variant performs the simplification in the terms :token:`term`\s of the conclusion of the goal - using the equalities defined by :token:`term`\s inside the brackets. - -.. tacv:: field_simplify in @ident - - This variant performs the simplification in the assumption :token:`ident`. - -.. tacv:: field_simplify [{* @term }] in @ident - - This variant performs the simplification - in the assumption :token:`ident` using the equalities defined by the :token:`term`\s. - -.. tacv:: field_simplify [{* @term }] {* @term } in @ident - - This variant performs the simplification in the :token:`term`\s of the - assumption :token:`ident` using the - equalities defined by the :token:`term`\s inside the brackets. - -.. tacn:: field_simplify_eq {? [ {+ @term } ] } {? in @ident } - - performs the simplification in the conclusion of - the goal removing the denominator. :math:`F_1 = F_2` becomes :math:`N_1 D_2 = N_2 D_1`. + :n:`[ {+ @one_term__eq } ]` + Do simplification in the conclusion of the goal using the equalities + defined by these :token:`one_term`\s. -.. tacv:: field_simplify_eq [ {* @term }] + :n:`{+ @one_term }` + Terms to simplify in the conclusion. - This variant performs the simplification in - the conclusion of the goal using the equalities defined by :token:`term`\s. + :n:`in @ident` + If specified, substitute in the hypothesis :n:`@ident` instead of the conclusion. -.. tacv:: field_simplify_eq in @ident +.. tacn:: field_simplify_eq {? [ {+ @one_term } ] } {? in @ident } - This variant performs the simplification in the assumption :token:`ident`. + Performs the simplification in the conclusion of + the goal, removing the denominator. :math:`F_1 = F_2` becomes :math:`N_1 D_2 = N_2 D_1`. -.. tacv:: field_simplify_eq [{* @term}] in @ident + :n:`[ {+ @one_term } ]` + Do simplification in the conclusion of the goal using the equalities + defined by these :token:`one_term`\s. - This variant performs the simplification in the assumption :token:`ident` - using the equalities defined by :token:`term`\s and removing the denominator. + :n:`in @ident` + If specified, simplify in the hypothesis :n:`@ident` instead of the conclusion. Adding a new field structure @@ -704,9 +690,9 @@ History of ring First Samuel Boutin designed the tactic ``ACDSimpl``. This tactic did lot of rewriting. But the proofs terms generated by rewriting were too big -for |Coq|’s type checker. Let us see why: +for Coq’s type checker. Let us see why: -.. coqtop:: all +.. coqtop:: reset all Require Import ZArith. Open Scope Z_scope. @@ -724,7 +710,7 @@ was rewritten by Patrick Loiseleur: the new tactic does not any more require ``ACDSimpl`` to compile and it makes use of |bdi|-reduction not only to replace the rewriting steps, but also to achieve the interleaving of computation and reasoning (see :ref:`discussion_reflection`). He also wrote -some |ML| code for the ``Add Ring`` command that allows registering new rings dynamically. +some ML code for the ``Add Ring`` command that allows registering new rings dynamically. Proofs terms generated by ring are quite small, they are linear in the number of :math:`\oplus` and :math:`\otimes` operations in the normalized terms. Type checking @@ -767,12 +753,12 @@ tactics using reflection. Another idea suggested by Benjamin Werner: reflection could be used to couple an external tool (a rewriting program or a model checker) -with |Coq|. We define (in |Coq|) a type of terms, a type of *traces*, and +with Coq. We define (in Coq) a type of terms, a type of *traces*, and prove a correctness theorem that states that *replaying traces* is safe with respect to some interpretation. Then we let the external tool do every computation (using side-effects, backtracking, exception, or others features that are not available in pure lambda calculus) to produce -the trace. Now we can check in |Coq| that the trace has the expected +the trace. Now we can check in Coq that the trace has the expected semantics by applying the correctness theorem. diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index 6c62ff3116..2b1f343e14 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -10,13 +10,13 @@ SProp (proof irrelevant propositions) In particular, conversion checking through bytecode or native code compilation currently does not understand proof irrelevance. -This section describes the extension of |Coq| with definitionally +This section describes the extension of Coq with definitionally proof irrelevant propositions (types in the sort :math:`\SProp`, also known as strict propositions) as described in :cite:`Gilbert:POPL2019`. Use of |SProp| may be disabled by passing ``-disallow-sprop`` to the -|Coq| program or by turning the :flag:`Allow StrictProp` flag off. +Coq program or by turning the :flag:`Allow StrictProp` flag off. .. flag:: Allow StrictProp :name: Allow StrictProp diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index d533470f22..2474c784b8 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -295,10 +295,29 @@ the Existing Instance command to achieve the same effect. Summary of the commands ----------------------- -.. cmd:: Class @inductive_definition {* with @inductive_definition } +.. cmd:: Class @record_definition + Class @singleton_class_definition - The :cmd:`Class` command is used to declare a typeclass with parameters - :n:`{* @binder }` and fields the declared record fields. + .. insertprodn singleton_class_definition singleton_class_definition + + .. prodn:: + singleton_class_definition ::= {? > } @ident_decl {* @binder } {? : @sort } := @constructor + + The first form declares a record and makes the record a typeclass with parameters + :n:`{* @binder }` and the listed record fields. + + .. _singleton-class: + + The second form declares a *singleton* class with a single method. This + singleton class is a so-called definitional class, represented simply + as a definition ``ident binders := term`` and whose instances are + themselves objects of this type. Definitional classes are not wrapped + inside records, and the trivial projection of an instance of such a + class is convertible to the instance itself. This can be useful to + make instances of existing objects easily and to reduce proof size by + not inserting useless projections. The class constant itself is + declared rigid during resolution so that the class abstraction is + maintained. Like any command declaring a record, this command supports the :attr:`universes(polymorphic)`, :attr:`universes(monomorphic)`, @@ -306,22 +325,7 @@ Summary of the commands :attr:`universes(cumulative)`, :attr:`universes(noncumulative)` and :attr:`private(matching)` attributes. - .. _singleton-class: - - .. cmdv:: Class @ident {* @binder } : {? @sort} := @ident : @term - - This variant declares a *singleton* class with a single method. This - singleton class is a so-called definitional class, represented simply - as a definition ``ident binders := term`` and whose instances are - themselves objects of this type. Definitional classes are not wrapped - inside records, and the trivial projection of an instance of such a - class is convertible to the instance itself. This can be useful to - make instances of existing objects easily and to reduce proof size by - not inserting useless projections. The class constant itself is - declared rigid during resolution so that the class abstraction is - maintained. - - .. cmdv:: Existing Class @ident + .. cmd:: Existing Class @qualid This variant declares a class from a previously declared constant or inductive definition. No methods or instances are defined. @@ -330,27 +334,34 @@ Summary of the commands This command has no effect when used on a typeclass. -.. cmd:: Instance @ident {* @binder } : @term__0 {+ @term} {? | @natural} := { {*; @field_def} } +.. cmd:: Instance {? @ident_decl {* @binder } } : @type {? @hint_info } {? {| := %{ {* @field_def } %} | := @term } } + + .. insertprodn hint_info one_pattern + + .. prodn:: + hint_info ::= %| {? @natural } {? @one_pattern } + one_pattern ::= @one_term - This command is used to declare a typeclass instance named - :token:`ident` of the class :n:`@term__0` with parameters :token:`term` and + 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. - An arbitrary context of :n:`{* @binder }` can be put after the name of the - instance and before the colon to declare a parameterized instance. An - optional priority can be declared, 0 being the highest priority as for - :tacn:`auto` hints. If the priority :token:`natural` is not specified, it defaults to the number - of non-dependent binders of the instance. + 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. 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 - generalization is automatically redeclared after the section is + generalization is automatically redeclared when the section is closed. Like :cmd:`Definition`, it also supports the :attr:`program` attribute to switch the type checking to `Program` (chapter - :ref:`programs`) and use the obligation mechanism to manage missing + :ref:`programs`) and to use the obligation mechanism to manage missing fields. Finally, it supports the lighter :attr:`refine` attribute: @@ -362,67 +373,53 @@ Summary of the commands to fill them. It works exactly as if no body had been given and the :tacn:`refine` tactic has been used first. - .. cmdv:: Instance @ident {* @binder } : forall {* @binder }, @term__0 {+ @term} {? | @natural } := @term + .. cmd:: Declare Instance @ident_decl {* @binder } : @term {? @hint_info } - This syntax is used for declaration of singleton class instances or - for directly giving an explicit term of type :n:`forall {* @binder }, @term__0 - {+ @term}`. One need not even mention the unique field name for - singleton classes. - - .. cmdv:: Declare Instance - :name: Declare Instance - - In a :cmd:`Module Type`, this command states that a corresponding concrete + In a :cmd:`Module Type`, declares that a corresponding concrete instance should exist in any implementation of this :cmd:`Module Type`. This is similar to the distinction between :cmd:`Parameter` vs. :cmd:`Definition`, or between :cmd:`Declare Module` and :cmd:`Module`. -Besides the :cmd:`Class` and :cmd:`Instance` vernacular commands, there are a -few other commands related to typeclasses. + .. cmd:: Existing Instance @qualid {? @hint_info } + Existing Instances {+ @qualid } {? %| @natural } + + Adds a constant whose type ends with + an applied typeclass to the instance database with an optional + priority :token:`natural`. It can be used for redeclaring instances at the end of + sections, or declaring structure projections as instances. This is + equivalent to ``Hint Resolve ident : typeclass_instances``, except it + registers instances for :cmd:`Print Instances`. + + .. flag:: Instance Generalized Output + + .. deprecated:: 8.13 -.. cmd:: Existing Instance {+ @ident} {? | @natural} + Disabled by default, this provides compatibility with Coq + version 8.12 and earlier. - This command adds an arbitrary list of constants whose type ends with - an applied typeclass to the instance database with an optional - priority :token:`natural`. It can be used for redeclaring instances at the end of - sections, or declaring structure projections as instances. This is - equivalent to ``Hint Resolve ident : typeclass_instances``, except it - registers instances for :cmd:`Print Instances`. + When enabled, the type of the instance is implicitly generalized + over unbound and :ref:`generalizable <implicit-generalization>` variables as though surrounded by ``\`{}``. -.. tacn:: typeclasses eauto - :name: typeclasses eauto +.. cmd:: Print Instances @reference - This proof search tactic implements the resolution engine that is run + Shows the list of instances associated with the typeclass :token:`reference`. + + +.. tacn:: typeclasses eauto {? bfs } {? @int_or_var } {? with {+ @ident } } + + This proof search tactic uses the resolution engine that is run implicitly during type checking. This tactic uses a different resolution engine than :tacn:`eauto` and :tacn:`auto`. The main differences are the following: - + Contrary to :tacn:`eauto` and :tacn:`auto`, the resolution is done entirely in - the new proof engine (as of Coq 8.6), meaning that backtracking is + + Unlike :tacn:`eauto` and :tacn:`auto`, the resolution is done entirely in + the proof engine, meaning that backtracking is available among dependent subgoals, and shelving goals is supported. ``typeclasses eauto`` is a multi-goal tactic. It analyses the dependencies between subgoals to avoid backtracking on subgoals that are entirely independent. - + When called with no arguments, ``typeclasses eauto`` uses - the ``typeclass_instances`` database by default (instead of core). - Dependent subgoals are automatically shelved, and shelved goals can - remain after resolution ends (following the behavior of Coq 8.5). - - .. note:: - As of Coq 8.6, ``all:once (typeclasses eauto)`` faithfully - mimics what happens during typeclass resolution when it is called - during refinement/type inference, except that *only* declared class - subgoals are considered at the start of resolution during type - inference, while ``all`` can select non-class subgoals as well. It might - move to ``all:typeclasses eauto`` in future versions when the - refinement engine will be able to backtrack. - - + When called with specific databases (e.g. with), ``typeclasses eauto`` - allows shelved goals to remain at any point during search and treat - typeclass goals like any other. - + The transparency information of databases is used consistently for all hints declared in them. It is always used when calling the unifier. When considering local hypotheses, we use the transparent @@ -446,26 +443,44 @@ few other commands related to typeclasses. + When considering local hypotheses, we use the union of all the modes declared in the given databases. - .. tacv:: typeclasses eauto @natural + + Use the :cmd:`Typeclasses eauto` command to customize the behavior of + this tactic. - .. warning:: - The semantics for the limit :n:`@natural` - is different than for auto. By default, if no limit is given, the - search is unbounded. Contrary to :tacn:`auto`, introduction steps are - counted, which might result in larger limits being necessary when - searching with ``typeclasses eauto`` than with :tacn:`auto`. + :n:`@int_or_var` + Specifies the maximum depth of the search. - .. tacv:: typeclasses eauto with {+ @ident} + .. warning:: + The semantics for the limit :n:`@int_or_var` + are different than for :tacn:`auto`. By default, if no limit is given, the + search is unbounded. Unlike :tacn:`auto`, introduction steps count against + the limit, which might result in larger limits being necessary when + searching with :tacn:`typeclasses eauto` than with :tacn:`auto`. + + :n:`with {+ @ident }` + Runs resolution with the specified hint databases. It treats + typeclass subgoals the same as other subgoals (no shelving of + non-typeclass goals in particular), while allowing shelved goals + to remain at any point during search. + + When :n:`with` is not specified, :tacn:`typeclasses eauto` uses + the ``typeclass_instances`` database by default (instead of ``core``). + Dependent subgoals are automatically shelved, and shelved goals can + remain after resolution ends (following the behavior of Coq 8.5). - This variant runs resolution with the given hint databases. It treats - typeclass subgoals the same as other subgoals (no shelving of - non-typeclass goals in particular). + .. note:: + ``all:once (typeclasses eauto)`` faithfully + mimics what happens during typeclass resolution when it is called + during refinement/type inference, except that *only* declared class + subgoals are considered at the start of resolution during type + inference, while ``all`` can select non-class subgoals as well. It might + move to ``all:typeclasses eauto`` in future versions when the + refinement engine will be able to backtrack. -.. tacn:: autoapply @term with @ident +.. tacn:: autoapply @one_term with @ident :name: autoapply - The tactic ``autoapply`` applies a term using the transparency information - of the hint database ident, and does *no* typeclass resolution. This can + The tactic ``autoapply`` applies :token:`one_term` using the transparency information + of the hint database :token:`ident`, and does *no* typeclass resolution. This can be used in :cmd:`Hint Extern`’s for typeclass instances (in the hint database ``typeclass_instances``) to allow backtracking on the typeclass subgoals created by the lemma application, rather than doing typeclass @@ -476,16 +491,16 @@ few other commands related to typeclasses. Typeclasses Transparent, Typeclasses Opaque ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Typeclasses Transparent {+ @ident} +.. cmd:: Typeclasses Transparent {+ @qualid } - This command makes the identifiers transparent during typeclass + Makes :token:`qualid` transparent during typeclass resolution. - Shortcut for :n:`Hint Transparent {+ @ident } : typeclass_instances`. + A shortcut for :cmd:`Hint Transparent` :n:`{+ @qualid } : typeclass_instances` -.. cmd:: Typeclasses Opaque {+ @ident} +.. cmd:: Typeclasses Opaque {+ @qualid } - Make the identifiers opaque for typeclass search. - Shortcut for :n:`Hint Opaque {+ @ident } : typeclass_instances`. + Make :token:`qualid` opaque for typeclass search. + A shortcut for :cmd:`Hint Opaque` :n:`{+ @qualid } : typeclass_instances`. It is useful when some constants prevent some unifications and make resolution fail. It is also useful to declare constants which @@ -517,7 +532,7 @@ Settings .. flag:: Typeclasses Filtered Unification - This flag, available since Coq 8.6 and off by default, switches the + This flag, which is off by default, switches the hint application procedure to a filter-then-unify strategy. To apply a hint, we first check that the goal *matches* syntactically the inferred or specified pattern of the hint, and only then try to @@ -601,22 +616,25 @@ Settings of goals. Setting this option to 1 or 2 turns on the :flag:`Typeclasses Debug` flag; setting this option to 0 turns that flag off. -Typeclasses eauto `:=` -~~~~~~~~~~~~~~~~~~~~~~ +Typeclasses eauto +~~~~~~~~~~~~~~~~~ -.. cmd:: Typeclasses eauto := {? debug} {? {| (dfs) | (bfs) } } @natural +.. cmd:: Typeclasses eauto := {? debug } {? ( {| bfs | dfs } ) } {? @natural } :name: Typeclasses eauto - This command allows more global customization of the typeclass - resolution tactic. The semantics of the options are: + Allows more global customization of the :tacn:`typeclasses eauto` tactic. + The options are: - + ``debug`` This sets the debug mode. In debug mode, the trace of - successfully applied tactics is printed. The debug mode can also + ``debug`` + Sets debug mode. In debug mode, a trace of + successfully applied tactics is printed. Debug mode can also be set with :flag:`Typeclasses Debug`. - + ``(dfs)``, ``(bfs)`` This sets the search strategy to depth-first + ``dfs``, ``bfs`` + Sets the search strategy to depth-first search (the default) or breadth-first search. The search strategy can also be set with :flag:`Typeclasses Iterative Deepening`. - + :token:`natural` This sets the depth limit of the search. The depth - limit can also be set with :opt:`Typeclasses Depth`. + :token:`natural` + Sets the depth limit for the search. The limit can also be set with + :opt:`Typeclasses Depth`. diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index b0ef792bd1..064107d088 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -12,7 +12,7 @@ General Presentation The status of Universe Polymorphism is experimental. -This section describes the universe polymorphic extension of |Coq|. +This section describes the universe polymorphic extension of Coq. Universe polymorphism makes it possible to write generic definitions making use of universes and reuse them at different and sometimes incompatible universe levels. @@ -123,6 +123,7 @@ Polymorphic, Monomorphic ------------------------- .. attr:: universes(polymorphic) + :name: universes(polymorphic); Polymorphic This attribute can be used to declare universe polymorphic definitions and inductive types. There is also a legacy syntax @@ -136,6 +137,7 @@ Polymorphic, Monomorphic used. .. attr:: universes(monomorphic) + :name: universes(monomorphic); Monomorphic This attribute can be used to declare universe monomorphic definitions and inductive types (i.e. global universe constraints @@ -170,6 +172,7 @@ Cumulative, NonCumulative ------------------------- .. attr:: universes(cumulative) + :name: universes(cumulative); Cumulative Polymorphic inductive types, coinductive types, variants and records can be declared cumulative using this attribute or the @@ -200,6 +203,7 @@ Cumulative, NonCumulative effect on *monomorphic* inductive definitions. .. attr:: universes(noncumulative) + :name: universes(noncumulative); NonCumulative Declares the inductive type as non-cumulative even if the :flag:`Polymorphic Inductive Cumulativity` flag is on. There is @@ -227,7 +231,7 @@ constraints by prefixing the level names with symbols. Because inductive subtypings are only produced by comparing inductives to themselves with universes changed, they amount to variance information: each universe is either invariant, covariant or -irrelevant (there are no contravariant subtypings in |Coq|), +irrelevant (there are no contravariant subtypings in Coq), respectively represented by the symbols `=`, `+` and `*`. Here we see that :g:`list` binds an irrelevant universe, so any two @@ -242,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. @@ -250,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 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -276,7 +302,7 @@ An example of a proof using cumulativity End down. Cumulativity Weak Constraints ------------------------------ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. flag:: Cumulativity Weak Constraints @@ -379,34 +405,32 @@ 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 to universes and explicitly instantiate polymorphic definitions. -.. cmd:: Universe @ident - Polymorphic Universe @ident +.. cmd:: Universe {+ @ident } - In the monorphic case, this command declares a new global universe - named :token:`ident`, which can be referred to using its qualified name - as well. Global universe names live in a separate namespace. The - command supports the :attr:`universes(polymorphic)` attribute (or - the ``Polymorphic`` prefix) only in sections, meaning the universe - quantification will be discharged on each section definition + In the monomorphic case, declares new global universes + with the given names. Global universe names live in a separate namespace. + The command supports the :attr:`universes(polymorphic)` attribute (or + the ``Polymorphic`` legacy attribute) only in sections, meaning the universe + quantification will be discharged for each section definition independently. .. exn:: Polymorphic universes can only be declared inside sections, use Monomorphic Universe instead. :undocumented: -.. cmd:: Constraint @univ_constraint - Polymorphic Constraint @univ_constraint +.. cmd:: Constraint {+, @univ_constraint } - This command declares a new constraint between named universes. + Declares new constraints between named universes. - If consistent, the constraint is then enforced in the global + If consistent, the constraints are then enforced in the global environment. Like :cmd:`Universe`, it can be used with the :attr:`universes(polymorphic)` attribute (or the ``Polymorphic`` - prefix) in sections only to declare constraints discharged at + legacy attribute) in sections only to declare constraints discharged at section closing time. One cannot declare a global constraint on polymorphic universes. @@ -473,7 +497,7 @@ mode, introduced universe names can be referred to in terms. Note that local universe names shadow global universe names. During a proof, one can use :cmd:`Show Universes` to display the current context of universes. -It is possible to provide only some universe levels and let |Coq| infer the others +It is possible to provide only some universe levels and let Coq infer the others by adding a :g:`+` in the list of bound universe levels: .. coqtop:: all diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index af66efa95e..de5dbe79cc 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -14,7 +14,7 @@ Version 8.12 Summary of changes ~~~~~~~~~~~~~~~~~~ -|Coq| version 8.12 integrates many usability improvements, +Coq version 8.12 integrates many usability improvements, in particular with respect to notations, scopes and implicit arguments, along with many bug fixes and major improvements to the reference manual. The main changes include: @@ -59,7 +59,7 @@ Erik Martin-Dorel has maintained the `Coq Docker images <https://hub.docker.com/r/coqorg/coq>`_ that are used in many Coq projects for continuous integration. -The OPAM repository for |Coq| packages has been maintained by +The OPAM repository for Coq packages has been maintained by Guillaume Claret, Karl Palmskog, Matthieu Sozeau and Enrico Tassi with contributions from many users. A list of packages is available at https://coq.inria.fr/opam/www/. @@ -97,18 +97,18 @@ Laurent Théry, Ralf Treinen, Anton Trunov, Bernhard M. Wiedemann, Li-yao Xia, Nickolai Zeldovich and Théo Zimmermann. Many power users helped to improve the design of this new version via -the GitHub issue and pull request system, the |Coq| development mailing list +the GitHub issue and pull request system, the Coq development mailing list coqdev@inria.fr, the coq-club@inria.fr mailing list, the `Discourse forum <https://coq.discourse.group/>`_ and the new `Coq Zulip chat <http://coq.zulipchat.com>`_ (thanks to Cyril Cohen for organizing the move from Gitter). Version 8.12's development spanned 6 months from the release of -|Coq| 8.11.0. Emilio Jesus Gallego Arias and Théo Zimmermann are +Coq 8.11.0. Emilio Jesus Gallego Arias and Théo Zimmermann are the release managers of Coq 8.12. This release is the result of ~500 PRs merged, closing ~100 issues. | Nantes, June 2020, -| Matthieu Sozeau for the |Coq| development team +| Matthieu Sozeau for the Coq development team | Changes in 8.12+beta1 @@ -800,7 +800,7 @@ Tools <https://github.com/coq/coq/pull/12387>`_, by Jason Gross). CoqIDE -^^^^^^ +^^^^^^^^ - **Removed:** "Tactic" menu from CoqIDE which had been unmaintained for a number of years @@ -1141,9 +1141,6 @@ Infrastructure and dependencies Changes in 8.12.0 ~~~~~~~~~~~~~~~~~~~~~ -.. contents:: - :local: - **Notations** - **Added:** @@ -1216,13 +1213,136 @@ Changes in 8.12.0 modified in the meantime (`#12583 <https://github.com/coq/coq/pull/12583>`_, fixes `#12582 <https://github.com/coq/coq/issues/12582>`_, by Jason Gross). +Changes in 8.12.1 +~~~~~~~~~~~~~~~~~~~~~ + +**Kernel** + +- **Fixed:** Incompleteness of conversion checking on problems + involving :ref:`eta-expansion` and :ref:`cumulative universe + polymorphic inductive types <cumulative>` (`#12738 + <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:** + Undetected collision between a lonely notation and a notation in + scope at printing time + (`#12946 <https://github.com/coq/coq/pull/12946>`_, + fixes the first part of `#12908 <https://github.com/coq/coq/issues/12908>`_, + by Hugo Herbelin). +- **Fixed:** + Printing of notations in custom entries with + variables not mentioning an explicit level + (`#13026 <https://github.com/coq/coq/pull/13026>`_, + fixes `#12775 <https://github.com/coq/coq/issues/12775>`_ + and `#13018 <https://github.com/coq/coq/issues/13018>`_, + by Hugo Herbelin). + +**Tactics** + +- **Added:** + :tacn:`replace` and :tacn:`inversion` support registration of a + :g:`core.identity`\-like equality in :g:`Type`, such as HoTT's :g:`path` + (`#12847 <https://github.com/coq/coq/pull/12847>`_, + partially fixes `#12846 <https://github.com/coq/coq/issues/12846>`_, + by Hugo Herbelin). +- **Fixed:** + Anomaly with :tacn:`injection` involving artificial + dependencies disappearing by reduction + (`#12816 <https://github.com/coq/coq/pull/12816>`_, + fixes `#12787 <https://github.com/coq/coq/issues/12787>`_, + by Hugo Herbelin). + +**Tactic language** + +- **Fixed:** + Miscellaneous issues with locating tactic errors + (`#13247 <https://github.com/coq/coq/pull/13247>`_, + fixes `#12773 <https://github.com/coq/coq/issues/12773>`_ + and `#12992 <https://github.com/coq/coq/issues/12992>`_, + by Hugo Herbelin). + +**SSReflect** + +- **Fixed:** + Regression in error reporting after :tacn:`case <case (ssreflect)>`. + A generic error message "Could not fill dependent hole in apply" was + reported for any error following :tacn:`case <case (ssreflect)>` or + :tacn:`elim <elim (ssreflect)>` + (`#12857 <https://github.com/coq/coq/pull/12857>`_, + fixes `#12837 <https://github.com/coq/coq/issues/12837>`_, + by Enrico Tassi). + +**Commands and options** + +- **Fixed:** + Failures of :cmd:`Search` in the presence of primitive projections + (`#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** + +- **Fixed:** + Special symbols now escaped in the index produced by coqdoc, + avoiding collision with the syntax of the output format + (`#12754 <https://github.com/coq/coq/pull/12754>`_, + fixes `#12752 <https://github.com/coq/coq/issues/12752>`_, + by Hugo Herbelin). +- **Fixed:** + The `details` environment added in the 8.12 release can now be used + as advertised in the reference manual + (`#12772 <https://github.com/coq/coq/pull/12772>`_, + by Thomas Letan). +- **Fixed:** + Targets such as ``print-pretty-timed`` in ``coq_makefile``\-made + ``Makefile``\s no longer error in rare cases where ``--output-sync`` is not + passed to make and the timing output gets interleaved in just the wrong way + (`#13063 <https://github.com/coq/coq/pull/13063>`_, fixes `#13062 + <https://github.com/coq/coq/issues/13062>`_, by Jason Gross). + +**CoqIDE** + +- **Fixed:** + View menu "Display parentheses" + (`#12794 <https://github.com/coq/coq/pull/12794>`_ and `#13067 <https://github.com/coq/coq/pull/13067>`_, + fixes `#12793 <https://github.com/coq/coq/issues/12793>`_, + by Jean-Christophe Léchenet and Hugo Herbelin). + +**Infrastructure and dependencies** + +- **Added:** + Coq is now tested against OCaml 4.11.1 + (`#12972 <https://github.com/coq/coq/pull/12972>`_, + by Emilio Jesus Gallego Arias). +- **Fixed:** + The reference manual can now build with Sphinx 3 + (`#13011 <https://github.com/coq/coq/pull/13011>`_, + fixes `#12332 <https://github.com/coq/coq/issues/12332>`_, + by Théo Zimmermann and Jim Fehrle). + Version 8.11 ------------ Summary of changes ~~~~~~~~~~~~~~~~~~ -The main changes brought by |Coq| version 8.11 are: +The main changes brought by Coq version 8.11 are: - :ref:`Ltac2<811Ltac2>`, a new tactic language for writing more robust larger scale tactics, with built-in support for datatypes and the multi-goal tactic monad. @@ -1256,7 +1376,7 @@ also the warning message in the :ref:`corresponding chapter <omega_chapter>`). The ``dev/doc/critical-bugs`` file documents the known critical bugs -of |Coq| and affected releases. See the `Changes in 8.11+beta1`_ +of Coq and affected releases. See the `Changes in 8.11+beta1`_ section and following sections for the detailed list of changes, including potentially breaking changes marked with **Changed**. @@ -1269,7 +1389,7 @@ Maxime Dénès, Emilio Jesús Gallego Arias, Gaëtan Gilbert, Michael Soegtrop and Théo Zimmermann worked on maintaining and improving the continuous integration system and package building infrastructure. -The OPAM repository for |Coq| packages has been maintained by +The OPAM repository for Coq packages has been maintained by Guillaume Claret, Karl Palmskog, Matthieu Sozeau and Enrico Tassi with contributions from many users. A list of packages is available at https://coq.inria.fr/opam/www/. @@ -1292,20 +1412,20 @@ Matthieu Sozeau, spanjel, Claude Stolze, Enrico Tassi, Laurent Théry, James R. Wilcox, Xia Li-yao, Théo Zimmermann Many power users helped to improve the design of the new features via -the issue and pull request system, the |Coq| development mailing list, +the issue and pull request system, the Coq development mailing list, the coq-club@inria.fr mailing list or the `Discourse forum <https://coq.discourse.group/>`_. It would be impossible to mention exhaustively the names of everybody who to some extent influenced the development. -Version 8.11 is the sixth release of |Coq| developed on a time-based +Version 8.11 is the sixth release of Coq developed on a time-based development cycle. Its development spanned 3 months from the release of -|Coq| 8.10. Pierre-Marie Pédrot is the release manager and maintainer of this +Coq 8.10. Pierre-Marie Pédrot is the release manager and maintainer of this release, assisted by Matthieu Sozeau. This release is the result of 2000+ commits and 300+ PRs merged, closing 75+ issues. | Paris, November 2019, -| Matthieu Sozeau for the |Coq| development team +| Matthieu Sozeau for the Coq development team | @@ -1463,8 +1583,8 @@ Changes in 8.11+beta1 A simplification of parsing rules could cause a slight change of parsing precedences for the very rare users who defined notations with `constr` at level strictly between 100 and 200 and used these - notations on the right-hand side of a cast operator (`:`, `:>`, - `:>>`) (`#10963 <https://github.com/coq/coq/pull/10963>`_, by Théo + notations on the right-hand side of a cast operator (`:`, `<:`, + `<<:`) (`#10963 <https://github.com/coq/coq/pull/10963>`_, by Théo Zimmermann, simplification initially noticed by Jim Fehrle). **Tactics** @@ -1957,7 +2077,7 @@ Version 8.10 Summary of changes ~~~~~~~~~~~~~~~~~~ -|Coq| version 8.10 contains two major new features: support for a native +Coq version 8.10 contains two major new features: support for a native fixed-precision integer type and a new sort :math:`\SProp` of strict propositions. It is also the result of refinements and stabilization of previous features, deprecations or removals of deprecated features, @@ -2121,7 +2241,7 @@ the numerous changes to the implementation and improvements of interfaces. The file provides guidelines on porting a plugin to the new version and a plugin development tutorial originally made by Yves Bertot is now in `doc/plugin_tutorial`. The ``dev/doc/critical-bugs`` file -documents the known critical bugs of |Coq| and affected releases. +documents the known critical bugs of Coq and affected releases. The efficiency of the whole system has seen improvements thanks to contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, and Maxime Dénès. @@ -2129,7 +2249,7 @@ contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, and Maxime Dénès. Maxime Dénès, Emilio Jesús Gallego Arias, Gaëtan Gilbert, Michael Soegtrop, Théo Zimmermann worked on maintaining and improving the continuous integration system and package building infrastructure. -Coq is now continuously tested against OCaml trunk, in addition to the +Coq is now continuously tested against the OCaml trunk, in addition to the oldest supported and latest OCaml releases. Coq's documentation for the development branch is now deployed @@ -2138,7 +2258,7 @@ the ML API), https://coq.github.io/doc/master/refman (reference manual), and https://coq.github.io/doc/master/stdlib (documentation of the standard library). Similar links exist for the `v8.10` branch. -The OPAM repository for |Coq| packages has been maintained by Guillaume +The OPAM repository for Coq packages has been maintained by Guillaume Melquiond, Matthieu Sozeau, Enrico Tassi (who migrated it to opam 2) with contributions from many users. A list of packages is available at https://coq.inria.fr/opam/www/. @@ -2160,19 +2280,19 @@ Tassi, Laurent Théry, Kamil Trzciński, whitequark, Théo Winterhalter, Xia Li-yao, Beta Ziliani and Théo Zimmermann. Many power users helped to improve the design of the new features via -the issue and pull request system, the |Coq| development mailing list, +the issue and pull request system, the Coq development mailing list, the coq-club@inria.fr mailing list or the new Discourse forum. It would be impossible to mention exhaustively the names of everybody who to some extent influenced the development. -Version 8.10 is the fifth release of |Coq| developed on a time-based +Version 8.10 is the fifth release of Coq developed on a time-based development cycle. Its development spanned 6 months from the release of -|Coq| 8.9. Vincent Laporte is the release manager and maintainer of this +Coq 8.9. Vincent Laporte is the release manager and maintainer of this release. This release is the result of ~2500 commits and ~650 PRs merged, closing 150+ issues. | Santiago de Chile, April 2019, -| Matthieu Sozeau for the |Coq| development team +| Matthieu Sozeau for the Coq development team | Other changes in 8.10+beta1 @@ -2761,7 +2881,7 @@ Version 8.9 Summary of changes ~~~~~~~~~~~~~~~~~~ -|Coq| version 8.9 contains the result of refinements and stabilization +Coq version 8.9 contains the result of refinements and stabilization of features and deprecations or removals of deprecated features, cleanups of the internals of the system and API along with a few new features. This release includes many user-visible changes, including @@ -2779,7 +2899,7 @@ changes: manual). - Deprecated notations of the standard library will be removed in the - next version of |Coq|, see the next subsection for a script to + next version of Coq, see the next subsection for a script to ease porting, by Jason Gross and Jean-Christophe Léchenet. - Added the :cmd:`Number Notation` command for registering decimal @@ -2842,7 +2962,7 @@ changes: - Tools: removed the ``gallina`` utility and the homebrewed ``Emacs`` mode. -- Packaging: as in |Coq| 8.8.2, the Windows installer now includes many +- Packaging: as in Coq 8.8.2, the Windows installer now includes many more external packages that can be individually selected for installation, by Michael Soegtrop. @@ -2856,7 +2976,7 @@ interfaces. The file provides guidelines on porting a plugin to the new version and a plugin development tutorial kept in sync with Coq was introduced by Yves Bertot http://github.com/ybertot/plugin_tutorials. The new ``dev/doc/critical-bugs`` file documents the known critical bugs -of |Coq| and affected releases. +of Coq and affected releases. The efficiency of the whole system has seen improvements thanks to contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, and Maxime Dénès. @@ -2865,7 +2985,7 @@ Maxime Dénès, Emilio Jesús Gallego Arias, Gaëtan Gilbert, Michael Soegtrop, Théo Zimmermann worked on maintaining and improving the continuous integration system. -The OPAM repository for |Coq| packages has been maintained by Guillaume +The OPAM repository for Coq packages has been maintained by Guillaume Melquiond, Matthieu Sozeau, Enrico Tassi with contributions from many users. A list of packages is available at https://coq.inria.fr/opam/www/. @@ -2885,23 +3005,23 @@ Tassi, Laurent Théry, Anton Trunov, whitequark, Théo Winterhalter, Zeimer, Beta Ziliani, Théo Zimmermann. Many power users helped to improve the design of the new features via -the issue and pull request system, the |Coq| development mailing list or +the issue and pull request system, the Coq development mailing list or the coq-club@inria.fr mailing list. It would be impossible to mention exhaustively the names of everybody who to some extent influenced the development. -Version 8.9 is the fourth release of |Coq| developed on a time-based +Version 8.9 is the fourth release of Coq developed on a time-based development cycle. Its development spanned 7 months from the release of -|Coq| 8.8. The development moved to a decentralized merging process +Coq 8.8. The development moved to a decentralized merging process during this cycle. Guillaume Melquiond was in charge of the release process and is the maintainer of this release. This release is the result of ~2,000 commits and ~500 PRs merged, closing 75+ issues. -The |Coq| development team welcomed Vincent Laporte, a new |Coq| -engineer working with Maxime Dénès in the |Coq| consortium. +The Coq development team welcomed Vincent Laporte, a new Coq +engineer working with Maxime Dénès in the Coq consortium. | Paris, November 2018, -| Matthieu Sozeau for the |Coq| development team +| Matthieu Sozeau for the Coq development team | Details of changes in 8.9+beta1 @@ -3134,7 +3254,7 @@ Version 8.8 Summary of changes ~~~~~~~~~~~~~~~~~~ -|Coq| version 8.8 contains the result of refinements and stabilization of +Coq version 8.8 contains the result of refinements and stabilization of features and deprecations, cleanups of the internals of the system along with a few new features. The main user visible changes are: @@ -3196,12 +3316,12 @@ contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, Maxime Dénès and Matthieu Sozeau and performance issue tracking by Jason Gross and Paul Steckler. -The official wiki and the bugtracker of |Coq| migrated to the GitHub +The official wiki and the bugtracker of Coq migrated to the GitHub platform, thanks to the work of Pierre Letouzey and Théo Zimmermann. Gaëtan Gilbert, Emilio Jesús Gallego Arias worked on maintaining and improving the continuous integration system. -The OPAM repository for |Coq| packages has been maintained by Guillaume +The OPAM repository for Coq packages has been maintained by Guillaume Melquiond, Matthieu Sozeau, Enrico Tassi with contributions from many users. A list of packages is available at https://coq.inria.fr/opam/www/. @@ -3216,26 +3336,26 @@ Clément Pit-Claudel, Matthew Ryan, Matt Quinn, Sigurd Schneider, Bernhard Schommer, Michael Soegtrop, Matthieu Sozeau, Arnaud Spiwack, Paul Steckler, Enrico Tassi, Anton Trunov, Martin Vassor, Vadim Zaliva and Théo Zimmermann. -Version 8.8 is the third release of |Coq| developed on a time-based +Version 8.8 is the third release of Coq developed on a time-based development cycle. Its development spanned 6 months from the release of -|Coq| 8.7 and was based on a public roadmap. The development process +Coq 8.7 and was based on a public roadmap. The development process was coordinated by Matthieu Sozeau. Maxime Dénès was in charge of the release process. Théo Zimmermann is the maintainer of this release. Many power users helped to improve the design of the new features via -the bug tracker, the pull request system, the |Coq| development mailing +the bug tracker, the pull request system, the Coq development mailing list or the coq-club@inria.fr mailing list. Special thanks to the users who contributed patches and intensive brain-storming and code reviews, starting with Jason Gross, Ralf Jung, Robbert Krebbers and Amin Timany. It would however be impossible to mention exhaustively the names of everybody who to some extent influenced the development. -The |Coq| consortium, an organization directed towards users and +The Coq consortium, an organization directed towards users and supporters of the system, is now running and employs Maxime Dénès. The contacts of the Coq Consortium are Yves Bertot and Maxime Dénès. | Santiago de Chile, March 2018, -| Matthieu Sozeau for the |Coq| development team +| Matthieu Sozeau for the Coq development team | Details of changes in 8.8+beta1 @@ -3501,7 +3621,7 @@ Version 8.7 Summary of changes ~~~~~~~~~~~~~~~~~~ -|Coq| version 8.7 contains the result of refinements, stabilization of features +Coq version 8.7 contains the result of refinements, stabilization of features and cleanups of the internals of the system along with a few new features. The main user visible changes are: @@ -3520,7 +3640,7 @@ main user visible changes are: and the extensibility of generated Makefiles, and to make ``_CoqProject`` files more palatable to IDEs by Enrico Tassi. -|Coq| 8.7 involved a large amount of work on cleaning and speeding up the code +Coq 8.7 involved a large amount of work on cleaning and speeding up the code base, notably the work of Pierre-Marie Pédrot on making the tactic-level system insensitive to existential variable expansion, providing a safer API to plugin writers and making the code more robust. The ``dev/doc/changes.txt`` file @@ -3540,7 +3660,7 @@ Thomas Sibut-Pinote and Hugo Herbelin added support for side effect hooks in cbv, cbn and simpl. The side effects are provided via a plugin available at https://github.com/herbelin/reduction-effects/. -The BigN, BigZ, BigQ libraries are no longer part of the |Coq| standard library, +The BigN, BigZ, BigQ libraries are no longer part of the Coq standard library, they are now provided by a separate repository https://github.com/coq/bignums, maintained by Pierre Letouzey. @@ -3554,7 +3674,7 @@ others, documented in the next subsection file. The mathematical proof language/declarative mode plugin was removed from the archive. -The OPAM repository for |Coq| packages has been maintained by Guillaume Melquiond, +The OPAM repository for Coq packages has been maintained by Guillaume Melquiond, Matthieu Sozeau, Enrico Tassi with contributions from many users. A list of packages is available at https://coq.inria.fr/opam/www/. @@ -3579,29 +3699,29 @@ Maxime Dénès, who was also in charge of the release process. Théo Zimmermann the maintainer of this release. Many power users helped to improve the design of the new features via the bug -tracker, the pull request system, the |Coq| development mailing list or the +tracker, the pull request system, the Coq development mailing list or the Coq-Club mailing list. Special thanks to the users who contributed patches and intensive brain-storming and code reviews, starting with Jason Gross, Ralf Jung, Robbert Krebbers, Xavier Leroy, Clément Pit–Claudel and Gabriel Scherer. It would however be impossible to mention exhaustively the names of everybody who to some extent influenced the development. -Version 8.7 is the second release of |Coq| developed on a time-based development -cycle. Its development spanned 9 months from the release of |Coq| 8.6 and was +Version 8.7 is the second release of Coq developed on a time-based development +cycle. Its development spanned 9 months from the release of Coq 8.6 and was based on a public road-map. It attracted many external contributions. Code reviews and continuous integration testing were systematically used before integration of new features, with an important focus given to compatibility and -performance issues, resulting in a hopefully more robust release than |Coq| 8.6 +performance issues, resulting in a hopefully more robust release than Coq 8.6 while maintaining compatibility. -|Coq| Enhancement Proposals (CEPs for short) and open pull request discussions +Coq Enhancement Proposals (CEPs for short) and open pull request discussions were used to discuss publicly the new features. -The |Coq| consortium, an organization directed towards users and supporters of the +The Coq consortium, an organization directed towards users and supporters of the system, is now upcoming and will rely on Inria’s newly created Foundation. | Paris, August 2017, -| Matthieu Sozeau and the |Coq| development team +| Matthieu Sozeau and the Coq development team | Potential compatibility issues @@ -3871,9 +3991,9 @@ over 100 contributions integrated. The main user visible changes are: - A new, faster state-of-the-art universe constraint checker, by Jacques-Henri Jourdan. -- In |CoqIDE| and other asynchronous interfaces, more fine-grained +- In CoqIDE and other asynchronous interfaces, more fine-grained asynchronous processing and error reporting by Enrico Tassi, making - |Coq| capable of recovering from errors and continue processing the + Coq capable of recovering from errors and continue processing the document. - More access to the proof engine features from Ltac: goal management @@ -3920,7 +4040,7 @@ Matthieu Sozeau. The minimization algorithm has been improved by Matthieu Sozeau. The unifier has been improved by Hugo Herbelin and Matthieu Sozeau, -fixing some incompatibilities introduced in |Coq| 8.5. Unification +fixing some incompatibilities introduced in Coq 8.5. Unification constraints can now be left floating around and be seen by the user thanks to a new option. The Keyed Unification mode has been improved by Matthieu Sozeau. @@ -3943,19 +4063,19 @@ the pretty-printing and user interface communication components. Frédéric Besson maintained the micromega tactic. -The OPAM repository for |Coq| packages has been maintained by Guillaume +The OPAM repository for Coq packages has been maintained by Guillaume Claret, Guillaume Melquiond, Matthieu Sozeau, Enrico Tassi and others. A list of packages is now available at https://coq.inria.fr/opam/www/. Packaging tools and software development kits were prepared by Michael Soegtrop with the help of Maxime Dénès and Enrico Tassi for Windows, and Maxime Dénès and Matthieu Sozeau for MacOS X. Packages are now regularly -built on the continuous integration server. |Coq| now comes with a META +built on the continuous integration server. Coq now comes with a META file usable with ocamlfind, contributed by Emilio Jesús Gallego Arias, Gregory Malecha, and Matthieu Sozeau. Matej Košík maintained and greatly improved the continuous integration -setup and the testing of |Coq| contributions. He also contributed many API +setup and the testing of Coq contributions. He also contributed many API improvements and code cleanups throughout the system. The contributors for this version are Bruno Barras, C.J. Bell, Yves @@ -3972,7 +4092,7 @@ coordinated by Hugo Herbelin and Matthieu Sozeau with the help of Maxime Dénès, who was also in charge of the release process. Many power users helped to improve the design of the new features via -the bug tracker, the pull request system, the |Coq| development mailing +the bug tracker, the pull request system, the Coq development mailing list or the Coq-Club mailing list. Special thanks to the users who contributed patches and intensive brain-storming and code reviews, starting with Cyril Cohen, Jason Gross, Robbert Krebbers, Jonathan @@ -3981,23 +4101,23 @@ Scherer and Beta Ziliani. It would however be impossible to mention exhaustively the names of everybody who to some extent influenced the development. -Version 8.6 is the first release of |Coq| developed on a time-based +Version 8.6 is the first release of Coq developed on a time-based development cycle. Its development spanned 10 months from the release of Coq 8.5 and was based on a public roadmap. To date, it contains more -external contributions than any previous |Coq| system. Code reviews were +external contributions than any previous Coq system. Code reviews were systematically done before integration of new features, with an important focus given to compatibility and performance issues, resulting -in a hopefully more robust release than |Coq| 8.5. +in a hopefully more robust release than Coq 8.5. Coq Enhancement Proposals (CEPs for short) were introduced by Enrico Tassi to provide more visibility and a discussion period on new features, they are publicly available https://github.com/coq/ceps. Started during this period, an effort is led by Yves Bertot and Maxime -Dénès to put together a |Coq| consortium. +Dénès to put together a Coq consortium. | Paris, November 2016, -| Matthieu Sozeau and the |Coq| development team +| Matthieu Sozeau and the Coq development team | Potential sources of incompatibilities @@ -4252,7 +4372,7 @@ the backtracking behavior of tactics. Multiple goal handling paves the way for smarter automation tactics. It is currently used for simple goal manipulation such as goal reordering. -The way |Coq| processes a document in batch and interactive mode has been +The way Coq processes a document in batch and interactive mode has been redesigned by Enrico Tassi with help from Bruno Barras. Opaque proofs, the text between Proof and Qed, can be processed asynchronously, decoupling the checking of definitions and statements from the checking @@ -4265,12 +4385,12 @@ already Required. All .vio files can be turned into complete .vo files in parallel. The same infrastructure also allows terminating tactics to be run in parallel on a set of goals via the ``par:`` goal selector. -|CoqIDE| was modified to cope with asynchronous checking of the document. -Its source code was also made separate from that of |Coq|, so that |CoqIDE| +CoqIDE was modified to cope with asynchronous checking of the document. +Its source code was also made separate from that of Coq, so that CoqIDE no longer has a special status among user interfaces, paving the way for -decoupling its release cycle from that of |Coq| in the future. +decoupling its release cycle from that of Coq in the future. -Carst Tankink developed a |Coq| back-end for user interfaces built on +Carst Tankink developed a Coq back-end for user interfaces built on Makarius Wenzel’s Prover IDE framework (PIDE), like PIDE/jEdit (with help from Makarius Wenzel) or PIDE/Coqoon (with help from Alexander Faithfull and Jesper Bengtson). The development of such features was @@ -4304,7 +4424,7 @@ principles such as propositional extensionality and univalence, thanks to Maxime Dénès and Bruno Barras. To ensure compatibility with the univalence axiom, a new flag ``-indices-matter`` has been implemented, taking into account the universe levels of indices when computing the -levels of inductive types. This supports using |Coq| as a tool to explore +levels of inductive types. This supports using Coq as a tool to explore the relations between homotopy theory and type theory. Maxime Dénès and Benjamin Grégoire developed an implementation of @@ -4334,13 +4454,13 @@ Matthieu Sozeau. Error messages for unification and type inference failures have been improved by Hugo Herbelin, Pierre-Marie Pédrot and Arnaud Spiwack. -Pierre Courtieu contributed new features for using |Coq| through Proof +Pierre Courtieu contributed new features for using Coq through Proof General and for better interactive experience (bullets, Search, etc). The efficiency of the whole system has been significantly improved thanks to contributions from Pierre-Marie Pédrot. -A distribution channel for |Coq| packages using the OPAM tool has been +A distribution channel for Coq packages using the OPAM tool has been initiated by Thomas Braibant and developed by Guillaume Claret, with contributions by Enrico Tassi and feedback from Hugo Herbelin. @@ -4357,7 +4477,7 @@ Jonathan Leivent, Greg Malecha, Clément Pit-Claudel, Marc Lasson, Lionel Rieg. It would however be impossible to mention with precision all names of people who to some extent influenced the development. -Version 8.5 is one of the most important releases of |Coq|. Its development +Version 8.5 is one of the most important releases of Coq. Its development spanned over about 3 years and a half with about one year of beta-testing. General maintenance during part or whole of this period has been done by Pierre Boutillier, Pierre Courtieu, Maxime Dénès, Hugo @@ -4369,7 +4489,7 @@ Mahboubi, Jean-Marc Notin, Yann Régis-Gianas, François Ripault, Carst Tankink. Maxime Dénès coordinated the release process. | Paris, January 2015, revised December 2015, -| Hugo Herbelin, Matthieu Sozeau and the |Coq| development team +| Hugo Herbelin, Matthieu Sozeau and the Coq development team | Potential sources of incompatibilities @@ -5158,7 +5278,7 @@ Other bugfixes - #4503: mixing universe polymorphic and monomorphic variables and definitions in sections is unsupported. - #4519: oops, global shadowed local universe level bindings. - #4506: Anomaly: File "pretyping/indrec.ml", line 169, characters 14-20: Assertion failed. -- #4548: Coqide crashes when going back one command +- #4548: CoqIDE crashes when going back one command Details of changes in 8.5pl2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -5273,7 +5393,7 @@ Summary of changes Coq version 8.4 contains the result of three long-term projects: a new modular library of arithmetic by Pierre Letouzey, a new proof engine by -Arnaud Spiwack and a new communication protocol for |CoqIDE| by Vincent +Arnaud Spiwack and a new communication protocol for CoqIDE by Vincent Gross. The new modular library of arithmetic extends, generalizes and unifies @@ -5295,14 +5415,14 @@ goals simultaneously, for reordering goals, all features which are planned for the next release. The new proof engine forced Pierre Letouzey to reimplement info and Show Script differently. -Before version 8.4, |CoqIDE| was linked to |Coq| with the graphical -interface living in a separate thread. From version 8.4, |CoqIDE| is a -separate process communicating with |Coq| through a textual channel. This -allows for a more robust interfacing, the ability to interrupt |Coq| +Before version 8.4, CoqIDE was linked to Coq with the graphical +interface living in a separate thread. From version 8.4, CoqIDE is a +separate process communicating with Coq through a textual channel. This +allows for a more robust interfacing, the ability to interrupt Coq without interrupting the interface, and the ability to manage several sessions in parallel. Relying on the infrastructure work made by Vincent Gross, Pierre Letouzey, Pierre Boutillier and Pierre-Marie Pédrot -contributed many various refinements of |CoqIDE|. +contributed many various refinements of CoqIDE. Coq 8.4 also comes with a bunch of various smaller-scale changes and improvements regarding the different components of the system. @@ -5313,7 +5433,7 @@ addition of :math:`\eta`-conversion is justified by the confidence that the formulation of the Calculus of Inductive Constructions based on typed equality (such as the one considered in Lee and Werner to build a set-theoretic model of CIC :cite:`LeeWerner11`) is -applicable to the concrete implementation of |Coq|. +applicable to the concrete implementation of Coq. The underlying logic benefited also from a refinement of the guard condition for fixpoints by Pierre Boutillier, the point being that it is @@ -5394,7 +5514,7 @@ Coq through Proof General. The Dp plugin has been removed. Use the plugin provided with Why 3 instead (http://why3.lri.fr/). -Under the hood, the |Coq| architecture benefited from improvements in +Under the hood, the Coq architecture benefited from improvements in terms of efficiency and robustness, especially regarding universes management and existential variables management, thanks to Pierre Letouzey and Yann Régis-Gianas with contributions from Stéphane Glondu @@ -5703,19 +5823,19 @@ Extraction CoqIDE -- Coqide now runs coqtop as separated process, making it more robust: +- CoqIDE now runs coqtop as separated process, making it more robust: coqtop subprocess can be interrupted, or even killed and relaunched (cf button "Restart Coq", ex-"Go to Start"). For allowing such interrupts, the Windows version of coqide now requires Windows >= XP SP1. -- The communication between CoqIDE and Coqtop is now done via a dialect +- The communication between CoqIDE and coqtop is now done via a dialect of XML (DOC TODO). - The backtrack engine of CoqIDE has been reworked, it now uses the "Backtrack" command similarly to Proof General. -- The Coqide parsing of sentences has be reworked and now supports +- The CoqIDE parsing of sentences has be reworked and now supports tactic delimitation via { }. -- Coqide now accepts the Abort command (wish #2357). -- Coqide can read coq_makefile files as "project file" and use it to +- CoqIDE now accepts the Abort command (wish #2357). +- CoqIDE can read coq_makefile files as "project file" and use it to set automatically options to send to coqtop. - Preference files have moved to $XDG_CONFIG_HOME/coq and accelerators are not stored as a list anymore. @@ -5785,7 +5905,7 @@ Module System CoqIDE -- Coqide now supports the "Restart" command, and "Undo" (with a warning). +- CoqIDE now supports the "Restart" command, and "Undo" (with a warning). Better support for "Abort". Details of changes in 8.4 @@ -5887,8 +6007,8 @@ more robust basis. Though invisible from outside, Arnaud Spiwack improved the general process of management of existential variables. Pierre Letouzey and -Stéphane Glondu improved the compilation scheme of the |Coq| archive. -Vincent Gross provided support to |CoqIDE|. Jean-Marc Notin provided +Stéphane Glondu improved the compilation scheme of the Coq archive. +Vincent Gross provided support to CoqIDE. Jean-Marc Notin provided support for benchmarking and archiving. Many users helped by reporting problems, providing patches, suggesting @@ -6258,16 +6378,16 @@ Summary of changes Coq version 8.2 adds new features, new libraries and improves on many various aspects. -Regarding the language of |Coq|, the main novelty is the introduction by +Regarding the language of Coq, the main novelty is the introduction by Matthieu Sozeau of a package of commands providing Haskell-style typeclasses. Typeclasses, which come with a few convenient features such as type-based resolution of implicit arguments, play a new landmark role -in the architecture of |Coq| with respect to automation. For +in the architecture of Coq with respect to automation. For instance, thanks to typeclass support, Matthieu Sozeau could implement a new resolution-based version of the tactics dedicated to rewriting on arbitrary transitive relations. -Another major improvement of |Coq| 8.2 is the evolution of the arithmetic +Another major improvement of Coq 8.2 is the evolution of the arithmetic libraries and of the tools associated to them. Benjamin Grégoire and Laurent Théry contributed a modular library for building arbitrarily large integers from bounded integers while Evgeny Makarov contributed a @@ -6291,7 +6411,7 @@ Arnaud Spiwack developed a library of 31-bits machine integers and, relying on Benjamin Grégoire and Laurent Théry’s library, delivered a library of unbounded integers in base :math:`2^{31}`. As importantly, he developed a notion of “retro-knowledge” so as to safely extend the -kernel-located bytecode-based efficient evaluation algorithm of |Coq| +kernel-located bytecode-based efficient evaluation algorithm of Coq version 8.1 to use 31-bits machine arithmetic for efficiently computing with the library of integers he developed. @@ -6323,16 +6443,16 @@ the Scheme command and of injection. Bruno Barras implemented the ``coqchk`` tool: this is a stand-alone type checker that can be used to certify .vo files. Especially, as this verifier runs in a separate process, it is granted not to be “hijacked” -by virtually malicious extensions added to |Coq|. +by virtually malicious extensions added to Coq. Yves Bertot, Jean-Christophe Filliâtre, Pierre Courtieu and Julien Forest acted as maintainers of features they implemented in previous -versions of |Coq|. +versions of Coq. -Julien Narboux contributed to |CoqIDE|. Nicolas Tabareau made the +Julien Narboux contributed to CoqIDE. Nicolas Tabareau made the adaptation of the interface of the old “setoid rewrite” tactic to the -new version. Lionel Mamane worked on the interaction between |Coq| and its -external interfaces. With Samuel Mimram, he also helped making |Coq| +new version. Lionel Mamane worked on the interaction between Coq and its +external interfaces. With Samuel Mimram, he also helped making Coq compatible with recent software tools. Russell O’Connor, Cezary Kaliszyk, Milad Niqui contributed to improve the libraries of integers, rational, and real numbers. We also thank many users and partners for @@ -6823,7 +6943,7 @@ Extraction not happen anymore. - The command Extract Inductive has now a syntax for infix notations. This - allows in particular to map Coq lists and pairs onto Caml ones: + allows in particular to map Coq lists and pairs onto OCaml ones: + Extract Inductive list => list [ "[]" "(::)" ]. + Extract Inductive prod => "(*)" [ "(,)" ]. @@ -6886,7 +7006,7 @@ Summary of changes Coq version 8.1 adds various new functionalities. Benjamin Grégoire implemented an alternative algorithm to check the -convertibility of terms in the |Coq| type checker. This alternative +convertibility of terms in the Coq type checker. This alternative algorithm works by compilation to an efficient bytecode that is interpreted in an abstract machine similar to Xavier Leroy’s ZINC machine. Convertibility is performed by comparing the normal forms. This @@ -6916,7 +7036,7 @@ Claudio Sacerdoti Coen added new tactic features. Hugo Herbelin implemented matching on disjunctive patterns. -New mechanisms made easier the communication between |Coq| and external +New mechanisms made easier the communication between Coq and external provers. Nicolas Ayache and Jean-Christophe Filliâtre implemented connections with the provers cvcl, Simplify and zenon. Hugo Herbelin implemented an experimental protocol for calling external tools from the @@ -6930,7 +7050,7 @@ unresolved implicit has been implemented by Hugo Herbelin. Laurent Théry’s contribution on strings and Pierre Letouzey and Jean-Christophe Filliâtre’s contribution on finite maps have been -integrated to the |Coq| standard library. Pierre Letouzey developed a +integrated to the Coq standard library. Pierre Letouzey developed a library about finite sets “à la Objective Caml”. With Jean-Marc Notin, he extended the library on lists. Pierre Letouzey’s contribution on rational numbers has been integrated and extended. @@ -7180,7 +7300,7 @@ Tools - Tool coq_makefile now removes custom targets that are file names in "make clean" - New environment variable COQREMOTEBROWSER to set the command invoked - to start the remote browser both in Coq and coqide. Standard syntax: + to start the remote browser both in Coq and CoqIDE. Standard syntax: "%s" is the placeholder for the URL. Details of changes in 8.1gamma @@ -7256,7 +7376,7 @@ Version 8.0 Summary of changes ~~~~~~~~~~~~~~~~~~ -Coq version 8 is a major revision of the |Coq| proof assistant. First, the +Coq version 8 is a major revision of the Coq proof assistant. First, the underlying logic is slightly different. The so-called *impredicativity* of the sort Set has been dropped. The main reason is that it is inconsistent with the principle of description which is quite a useful @@ -7285,7 +7405,7 @@ main motivations were Together with the revision of the concrete syntax, a new mechanism of *notation scopes* permits to reuse the same symbols (typically +, -, \*, /, <, <=) in various mathematical theories without any -ambiguities for |Coq|, leading to a largely improved readability of |Coq| +ambiguities for Coq, leading to a largely improved readability of Coq scripts. New commands to easily add new symbols are also provided. Coming with the new syntax of terms, a slight reform of the tactic @@ -7295,29 +7415,29 @@ easier to use and to remember. Thirdly, a restructuring and uniformization of the standard library of Coq has been performed. There is now just one Leibniz equality usable -for all the different kinds of |Coq| objects. Also, the set of real +for all the different kinds of Coq objects. Also, the set of real numbers now lies at the same level as the sets of natural and integer numbers. Finally, the names of the standard properties of numbers now follow a standard pattern and the symbolic notations for the standard definitions as well. -The fourth point is the release of |CoqIDE|, a new graphical gtk2-based -interface fully integrated with |Coq|. Close in style to the Proof General -Emacs interface, it is faster and its integration with |Coq| makes +The fourth point is the release of CoqIDE, a new graphical gtk2-based +interface fully integrated with Coq. Close in style to the Proof General +Emacs interface, it is faster and its integration with Coq makes interactive developments more friendly. All mathematical Unicode symbols -are usable within |CoqIDE|. +are usable within CoqIDE. -Finally, the module system of |Coq| completes the picture of |Coq| version +Finally, the module system of Coq completes the picture of Coq version 8.0. Though released with an experimental status in the previous version 7.4, it should be considered as a salient feature of the new version. -Besides, |Coq| comes with its load of novelties and improvements: new or +Besides, Coq comes with its load of novelties and improvements: new or improved tactics (including a new tactic for solving first-order statements), new management commands, extended libraries. Bruno Barras and Hugo Herbelin have been the main contributors of the reflection and the implementation of the new syntax. The smart automatic -translator from old to new syntax released with |Coq| is also their work +translator from old to new syntax released with Coq is also their work with contributions by Olivier Desmettre. Hugo Herbelin is the main designer and implementer of the notion of @@ -7330,21 +7450,21 @@ Pierre Corbineau is the main designer and implementer of the new tactic for solving first-order statements in presence of inductive types. He is also the maintainer of the non-domain specific automation tactics. -Benjamin Monate is the developer of the |CoqIDE| graphical interface with +Benjamin Monate is the developer of the CoqIDE graphical interface with contributions by Jean-Christophe Filliâtre, Pierre Letouzey, Claude Marché and Bruno Barras. -Claude Marché coordinated the edition of the Reference Manual for |Coq| +Claude Marché coordinated the edition of the Reference Manual for Coq V8.0. Pierre Letouzey and Jacek Chrząszcz respectively maintained the -extraction tool and module system of |Coq|. +extraction tool and module system of Coq. Jean-Christophe Filliâtre, Pierre Letouzey, Hugo Herbelin and other contributors from Sophia-Antipolis and Nijmegen participated in extending the library. -Julien Narboux built a NSIS-based automatic |Coq| installation tool for +Julien Narboux built a NSIS-based automatic Coq installation tool for the Windows platform. Hugo Herbelin and Christine Paulin coordinated the development which was diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index a8a574c861..75ac2a76cd 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -183,9 +183,7 @@ todo_include_todos = False nitpicky = True nitpick_ignore = [ ('token', token) for token in [ - 'collection', 'tactic', - 'bindings', 'induction_clause', 'conversion', 'where', diff --git a/doc/sphinx/history.rst b/doc/sphinx/history.rst index 02821613cc..c5ef92a1bf 100644 --- a/doc/sphinx/history.rst +++ b/doc/sphinx/history.rst @@ -1,8 +1,8 @@ .. _history: --------------------- +---------------------- Early history of Coq --------------------- +---------------------- Historical roots ---------------- @@ -17,7 +17,7 @@ verified mathematical proofs, and the *program extractor* which synthesizes computer programs obeying their formal specifications, written as logical assertions in the language. -The logical language used by |Coq| is a variety of type theory, called the +The logical language used by Coq is a variety of type theory, called the *Calculus of Inductive Constructions*. Without going back to Leibniz and Boole, we can date the creation of what is now called mathematical logic to the work of Frege and Peano at the turn of the century. The discovery @@ -108,7 +108,7 @@ modules, automatically generated from a consistency proof of their formal specifications. We are however still far from being able to use this methodology in a smooth interaction with the standard tools from software engineering, i.e. compilers, linkers, run-time systems taking -advantage of special hardware, debuggers, and the like. We hope that |Coq| +advantage of special hardware, debuggers, and the like. We hope that Coq can be of use to researchers interested in experimenting with this new methodology. @@ -154,7 +154,7 @@ manipulation of windows, menus, mouse-sensitive buttons, and other widgets. This system (Version 5.6) was released in 1991. Coq was ported to the new implementation Caml-light of X. Leroy and D. -Doligez by D. de Rauglaudre (Version 5.7) in 1992. A new version of |Coq| +Doligez by D. de Rauglaudre (Version 5.7) in 1992. A new version of Coq was then coordinated by C. Murthy, with new tools designed by C. Parent to prove properties of ML programs (this methodology is dual to program extraction) and a new user-interaction loop. This system (Version 5.8) @@ -163,9 +163,9 @@ by Y. Bertot from the Croap project from INRIA-Sophia-Antipolis. In parallel, G. Dowek and H. Herbelin developed a new proof engine, allowing the general manipulation of existential variables consistently -with dependent types in an experimental version of |Coq| (V5.9). +with dependent types in an experimental version of Coq (V5.9). -The version V5.10 of |Coq| is based on a generic system for manipulating +The version V5.10 of Coq is based on a generic system for manipulating terms with binding operators due to Chet Murthy. A new proof engine allows the parallel development of partial proofs for independent subgoals. The structure of these proof trees is a mixed representation @@ -519,14 +519,14 @@ Versions 6 Version 6.1 ~~~~~~~~~~~ -The present version 6.1 of |Coq| is based on the V5.10 architecture. It +The present version 6.1 of Coq is based on the V5.10 architecture. It was ported to the new language Objective Caml by Bruno Barras. The underlying framework has slightly changed and allows more conversions between sorts. The new version provides powerful tools for easier developments. -Cristina Cornes designed an extension of the |Coq| syntax to allow +Cristina Cornes designed an extension of the Coq syntax to allow definition of terms using a powerful pattern matching analysis in the style of ML programs. @@ -539,13 +539,13 @@ written. Yann Coscoy designed a command which explains a proof term using natural language. Pierre Crégut built a new tactic which solves problems in quantifier-free Presburger Arithmetic. Both functionalities have been -integrated to the |Coq| system by Hugo Herbelin. +integrated to the Coq system by Hugo Herbelin. Samuel Boutin designed a tactic for simplification of commutative rings using a canonical set of rewriting rules and equality modulo associativity and commutativity. -Finally the organisation of the |Coq| distribution has been supervised by +Finally the organisation of the Coq distribution has been supervised by Jean-Christophe Filliâtre with the help of Judicaël Courant and Bruno Barras. @@ -556,21 +556,21 @@ Barras. Version 6.2 ~~~~~~~~~~~ -In version 6.2 of |Coq|, the parsing is done using camlp4, a preprocessor +In version 6.2 of Coq, the parsing is done using camlp4, a preprocessor and pretty-printer for CAML designed by Daniel de Rauglaudre at INRIA. -Daniel de Rauglaudre made the first adaptation of |Coq| for camlp4, this -work was continued by Bruno Barras who also changed the structure of |Coq| +Daniel de Rauglaudre made the first adaptation of Coq for camlp4, this +work was continued by Bruno Barras who also changed the structure of Coq abstract syntax trees and the primitives to manipulate them. The result of these changes is a faster parsing procedure with greatly improved syntax-error messages. The user-interface to introduce grammar or pretty-printing rules has also changed. Eduardo Giménez redesigned the internal tactic libraries, giving uniform -names to Caml functions corresponding to |Coq| tactic names. +names to Caml functions corresponding to Coq tactic names. Bruno Barras wrote new, more efficient reduction functions. -Hugo Herbelin introduced more uniform notations in the |Coq| specification +Hugo Herbelin introduced more uniform notations in the Coq specification language: the definitions by fixpoints and pattern matching have a more readable syntax. Patrick Loiseleur introduced user-friendly notations for arithmetic expressions. @@ -586,10 +586,10 @@ a proof term with holes as a proof scheme. David Delahaye designed the tool to search an object in the library given its type (up to isomorphism). -Henri Laulhère produced the |Coq| distribution for the Windows +Henri Laulhère produced the Coq distribution for the Windows environment. -Finally, Hugo Herbelin was the main coordinator of the |Coq| documentation +Finally, Hugo Herbelin was the main coordinator of the Coq documentation with principal contributions by Bruno Barras, David Delahaye, Jean-Christophe Filliâtre, Eduardo Giménez, Hugo Herbelin and Patrick Loiseleur. @@ -639,7 +639,7 @@ Summary of changes The version V7 is a new implementation started in September 1999 by Jean-Christophe Filliâtre. This is a major revision with respect to the -internal architecture of the system. The |Coq| version 7.0 was distributed +internal architecture of the system. The Coq version 7.0 was distributed in March 2001, version 7.1 in September 2001, version 7.2 in January 2002, version 7.3 in May 2002 and version 7.4 in February 2003. @@ -653,13 +653,13 @@ Hugo Herbelin introduced a new structure of terms with local definitions. He introduced “qualified” names, wrote a new pattern matching compilation algorithm and designed a more compact algorithm for checking the logical consistency of universes. He -contributed to the simplification of |Coq| internal structures and the +contributed to the simplification of Coq internal structures and the optimisation of the system. He added basic tactics for forward reasoning and coercions in patterns. David Delahaye introduced a new language for tactics. General tactics using pattern matching on goals and context can directly be written from -the |Coq| toplevel. He also provided primitives for the design of +the Coq toplevel. He also provided primitives for the design of user-defined tactics in Caml. Micaela Mayero contributed the library on real numbers. Olivier @@ -668,16 +668,16 @@ square, square roots, finite sums, Chasles property and basic plane geometry. Jean-Christophe Filliâtre and Pierre Letouzey redesigned a new -extraction procedure from |Coq| terms to Caml or Haskell programs. This +extraction procedure from Coq terms to Caml or Haskell programs. This new extraction procedure, unlike the one implemented in previous version -of |Coq| is able to handle all terms in the Calculus of Inductive +of Coq is able to handle all terms in the Calculus of Inductive Constructions, even involving universes and strong elimination. P. Letouzey adapted user contributions to extract ML programs when it was sensible. Jean-Christophe Filliâtre wrote ``coqdoc``, a documentation -tool for |Coq| libraries usable from version 7.2. +tool for Coq libraries usable from version 7.2. Bruno Barras improved the efficiency of the reduction algorithm and the -confidence level in the correctness of |Coq| critical type checking +confidence level in the correctness of Coq critical type checking algorithm. Yves Bertot designed the ``SearchPattern`` and ``SearchRewrite`` tools @@ -696,7 +696,7 @@ real numbers. Pierre Crégut developed a new, reflection-based version of the Omega decision procedure. -Claudio Sacerdoti Coen designed an XML output for the |Coq| modules to be +Claudio Sacerdoti Coen designed an XML output for the Coq modules to be used in the Hypertextual Electronic Library of Mathematics (HELM cf http://www.cs.unibo.it/helm). @@ -706,13 +706,13 @@ contributed by Jean Goubault was integrated in the basic theories. Pierre Courtieu developed a command and a tactic to reason on the inductive structure of recursively defined functions. -Jacek Chrząszcz designed and implemented the module system of |Coq| whose +Jacek Chrząszcz designed and implemented the module system of Coq whose foundations are in Judicaël Courant’s PhD thesis. The development was coordinated by C. Paulin. Many discussions within the Démons team and the LogiCal project -influenced significantly the design of |Coq| especially with J. Courant, +influenced significantly the design of Coq especially with J. Courant, J. Duprat, J. Goubault, A. Miquel, C. Marché, B. Monate and B. Werner. Intensive users suggested improvements of the system : Y. Bertot, L. @@ -1171,7 +1171,7 @@ Incompatibilities - New naming strategy for NewInduction/NewDestruct may affect 7.1 compatibility - Extra parentheses may exceptionally be needed in tactic definitions. -- Coq extensions written in Ocaml need to be updated (see dev/changements.txt +- Coq extensions written in OCaml need to be updated (see dev/changements.txt for a description of the main changes in the interface files of V7.2) - New behaviour of Intuition/Tauto may exceptionally lead to incompatibilities diff --git a/doc/sphinx/introduction.rst b/doc/sphinx/introduction.rst index b059fb4069..06a677d837 100644 --- a/doc/sphinx/introduction.rst +++ b/doc/sphinx/introduction.rst @@ -1,4 +1,4 @@ -This is the reference manual of |Coq|. Coq is an interactive theorem +This is the reference manual of Coq. Coq is an interactive theorem prover. It lets you formalize mathematical concepts and then helps you interactively generate machine-checked proofs of theorems. Machine checking gives users much more confidence that the proofs are diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index f1ed64e52a..85b04f6df0 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -1,7 +1,7 @@ Typing rules ==================================== -The underlying formal language of |Coq| is a *Calculus of Inductive +The underlying formal language of Coq is a *Calculus of Inductive Constructions* (|Cic|) whose inference rules are presented in this chapter. The history of this formalism as well as pointers to related work are provided in a separate chapter; see *Credits*. @@ -33,7 +33,7 @@ the following rules. #. variables, hereafter ranged over by letters :math:`x`, :math:`y`, etc., are terms #. constants, hereafter ranged over by letters :math:`c`, :math:`d`, etc., are terms. #. if :math:`x` is a variable and :math:`T`, :math:`U` are terms then - :math:`∀ x:T,~U` (:g:`forall x:T, U` in |Coq| concrete syntax) is a term. + :math:`∀ x:T,~U` (:g:`forall x:T, U` in Coq concrete syntax) is a term. If :math:`x` occurs in :math:`U`, :math:`∀ x:T,~U` reads as “for all :math:`x` of type :math:`T`, :math:`U`”. As :math:`U` depends on :math:`x`, one says that :math:`∀ x:T,~U` is @@ -43,11 +43,11 @@ the following rules. written: :math:`T \rightarrow U`. #. if :math:`x` is a variable and :math:`T`, :math:`u` are terms then :math:`λ x:T .~u` (:g:`fun x:T => u` - in |Coq| concrete syntax) is a term. This is a notation for the + in Coq concrete syntax) is a term. This is a notation for the λ-abstraction of λ-calculus :cite:`Bar81`. The term :math:`λ x:T .~u` is a function which maps elements of :math:`T` to the expression :math:`u`. #. if :math:`t` and :math:`u` are terms then :math:`(t~u)` is a term - (:g:`t u` in |Coq| concrete + (:g:`t u` in Coq concrete syntax). The term :math:`(t~u)` reads as “:math:`t` applied to :math:`u`”. #. if :math:`x` is a variable, and :math:`t`, :math:`T` and :math:`u` are terms then :math:`\letin{x}{t:T}{u}` is @@ -91,10 +91,10 @@ Let us assume that ``mult`` is a function of type :math:`\nat→\nat→\nat` and predicate of type :math:`\nat→\nat→ \Prop`. The λ-abstraction can serve to build “ordinary” functions as in :math:`λ x:\nat.~(\kw{mult}~x~x)` (i.e. :g:`fun x:nat => mult x x` -in |Coq| notation) but may build also predicates over the natural +in Coq notation) but may build also predicates over the natural numbers. For instance :math:`λ x:\nat.~(\kw{eqnat}~x~0)` (i.e. :g:`fun x:nat => eqnat x 0` -in |Coq| notation) will represent the predicate of one variable :math:`x` which +in Coq notation) will represent the predicate of one variable :math:`x` which asserts the equality of :math:`x` with :math:`0`. This predicate has type :math:`\nat → \Prop` and it can be applied to any expression of type :math:`\nat`, say :math:`t`, to give an @@ -524,7 +524,7 @@ One can consequently derive the following property. The Calculus of Inductive Constructions with impredicative Set ----------------------------------------------------------------- -|Coq| can be used as a type checker for the Calculus of Inductive +Coq can be used as a type checker for the Calculus of Inductive Constructions with an impredicative sort :math:`\Set` by using the compiler option ``-impredicative-set``. For example, using the ordinary `coqtop` command, the following is rejected, diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index 485dfd964d..d061ed41f1 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -1,28 +1,28 @@ .. _thecoqlibrary: -The |Coq| library +The Coq library ================= .. index:: single: Theories -The |Coq| library has two parts: +The Coq library has two parts: * The :gdef:`prelude`: definitions and theorems for the most commonly used elementary logical notions and - data types. |Coq| normally loads these files automatically when it starts. + data types. Coq normally loads these files automatically when it starts. * The :gdef:`standard library`: general-purpose libraries with definitions and theorems for sets, lists, sorting, arithmetic, etc. To use these files, users must load them explicitly with the ``Require`` command (see :ref:`compiled-files`) -There are also many libraries provided by |Coq| users' community. +There are also many libraries provided by Coq users' community. These libraries and developments are available for download at http://coq.inria.fr (see :ref:`userscontributions`). -This chapter briefly reviews the |Coq| libraries whose contents can +This chapter briefly reviews the Coq libraries whose contents can also be browsed at http://coq.inria.fr/stdlib/. @@ -32,9 +32,9 @@ The prelude ----------- This section lists the basic notions and results which are directly -available in the standard |Coq| system. Most of these constructions +available in the standard Coq system. Most of these constructions are defined in the ``Prelude`` module in directory ``theories/Init`` -in the |Coq| root directory; this includes the modules +in the Coq root directory; this includes the modules ``Notations``, ``Logic``, ``Datatypes``, @@ -92,7 +92,7 @@ Notation Precedence Associativity Logic ~~~~~ -The basic library of |Coq| comes with the definitions of standard +The basic library of Coq comes with the definitions of standard (intuitionistic) logical connectives (they are defined as inductive constructions). They are equipped with an appealing syntax enriching the subclass :token:`form` of the syntactic class :token:`term`. The constructs @@ -767,7 +767,7 @@ the modules they provide are compiled at installation time. So they are directly accessible with the command ``Require`` (see Section :ref:`compiled-files`). -The different modules of the |Coq| standard library are documented +The different modules of the Coq standard library are documented online at https://coq.inria.fr/stdlib. Peano’s arithmetic (nat) diff --git a/doc/sphinx/language/core/assumptions.rst b/doc/sphinx/language/core/assumptions.rst index 41e1c30f0d..e029068630 100644 --- a/doc/sphinx/language/core/assumptions.rst +++ b/doc/sphinx/language/core/assumptions.rst @@ -141,8 +141,8 @@ has type :n:`@type`. of_type ::= {| : | :> } @type These commands bind one or more :n:`@ident`\(s) to specified :n:`@type`\(s) as their specifications in - the global context. The fact asserted by the :n:`@type` (or, equivalently, the existence - of an object of this type) is accepted as a postulate. + the global context. The fact asserted by :n:`@type` (or, equivalently, the existence + of an object of this type) is accepted as a postulate. They accept the :attr:`program` attribute. :cmd:`Axiom`, :cmd:`Conjecture`, :cmd:`Parameter` and their plural forms are equivalent. They can take the :attr:`local` :term:`attribute`, @@ -155,6 +155,10 @@ has type :n:`@type`. is closed, the :n:`@ident`\(s) become undefined and every object depending on them will be explicitly parameterized (i.e., the variables are *discharged*). See Section :ref:`section-mechanism`. + :n:`:>` + If specified, :token:`ident_decl` is automatically + declared as a coercion to the class of its type. See :ref:`coercions`. + The :n:`Inline` clause is only relevant inside functors. See :cmd:`Module`. .. example:: Simple assumptions diff --git a/doc/sphinx/language/core/basic.rst b/doc/sphinx/language/core/basic.rst index 45bdc019ac..5406da38a1 100644 --- a/doc/sphinx/language/core/basic.rst +++ b/doc/sphinx/language/core/basic.rst @@ -10,7 +10,7 @@ manual. Then, we present the essential vocabulary necessary to read the rest of the manual. Other terms are defined throughout the manual. The reader may refer to the :ref:`glossary index <glossary_index>` for a complete list of defined terms. Finally, we describe the various types of -settings that |Coq| provides. +settings that Coq provides. Syntax and lexical conventions ------------------------------ @@ -21,7 +21,7 @@ Syntax conventions ~~~~~~~~~~~~~~~~~~ The syntax described in this documentation is equivalent to that -accepted by the |Coq| parser, but the grammar has been edited +accepted by the Coq parser, but the grammar has been edited to improve readability and presentation. In the grammar presented in this manual, the terminal symbols are @@ -49,13 +49,13 @@ graphically using the following kinds of blocks: `Precedence levels <https://en.wikipedia.org/wiki/Order_of_operations>`_ that are -implemented in the |Coq| parser are shown in the documentation by +implemented in the Coq parser are shown in the documentation by appending the level to the nonterminal name (as in :n:`@term100` or :n:`@ltac_expr3`). .. note:: - |Coq| uses an extensible parser. Plugins and the :ref:`notation + Coq uses an extensible parser. Plugins and the :ref:`notation system <syntax-extensions-and-notation-scopes>` can extend the syntax at run time. Some notations are defined in the :term:`prelude`, which is loaded by default. The documented grammar doesn't include @@ -71,8 +71,8 @@ appending the level to the nonterminal name (as in :n:`@term100` or Given the complexity of these parsing rules, it would be extremely difficult to create an external program that can properly parse a - |Coq| document. Therefore, tool writers are advised to delegate - parsing to |Coq|, by communicating with it, for instance through + Coq document. Therefore, tool writers are advised to delegate + parsing to Coq, by communicating with it, for instance through `SerAPI <https://github.com/ejgallego/coq-serapi>`_. .. seealso:: :cmd:`Print Grammar` @@ -113,7 +113,7 @@ Identifiers Numbers Numbers are sequences of digits with an optional fractional part - and exponent, optionally preceded by a minus sign. Hexadecimal numerals + and exponent, optionally preceded by a minus sign. Hexadecimal numbers start with ``0x`` or ``0X``. :n:`@bigint` are integers; numbers without fractional nor exponent parts. :n:`@bignat` are non-negative integers. Underscores embedded in the digits are ignored, for example @@ -172,7 +172,7 @@ Other tokens (even when starting Coq with the `-noinit` command-line flag):: ! #[ % & ' ( () ) * + , - -> - . .( .. ... / : ::= := :> :>> ; < <+ <- <: + . .( .. ... / : ::= := :> ; < <+ <- <: <<: <= = => > >-> >= ? @ @{ [ ] _ `( `{ { {| | } @@ -195,7 +195,7 @@ Essential vocabulary -------------------- This section presents the most essential notions to understand the -rest of the |Coq| manual: :term:`terms <term>` and :term:`types +rest of the Coq manual: :term:`terms <term>` and :term:`types <type>` on the one hand, :term:`commands <command>` and :term:`tactics <tactic>` on the other hand. @@ -203,14 +203,14 @@ rest of the |Coq| manual: :term:`terms <term>` and :term:`types term - Terms are the basic expressions of |Coq|. Terms can represent + Terms are the basic expressions of Coq. Terms can represent mathematical expressions, propositions and proofs, but also executable programs and program types. Here is the top-level syntax of terms. Each of the listed constructs is presented in a dedicated section. Some of these constructs (like :n:`@term_forall_or_fun`) are part of the core - language that the kernel of |Coq| understands and are therefore + language that the kernel of Coq understands and are therefore described in :ref:`this chapter <core-language>`, while others (like :n:`@term_if`) are language extensions that are presented in :ref:`the next chapter <extensions>`. @@ -256,18 +256,18 @@ rest of the |Coq| manual: :term:`terms <term>` and :term:`types type - To be valid and accepted by the |Coq| kernel, a term needs an + To be valid and accepted by the Coq kernel, a term needs an associated type. We express this relationship by “:math:`x` *of type* :math:`T`”, which we write as “:math:`x:T`”. Informally, “:math:`x:T`” can be thought as “:math:`x` *belongs to* :math:`T`”. - The |Coq| kernel is a type checker: it verifies that a term has + The Coq kernel is a type checker: it verifies that a term has the expected type by applying a set of typing rules (see :ref:`Typing-rules`). If that's indeed the case, we say that the term is :gdef:`well-typed`. - A special feature of the |Coq| language is that types can depend + A special feature of the Coq language is that types can depend on terms (we say that the language is `dependently-typed <https://en.wikipedia.org/wiki/Dependent_type>`_). Because of this, types and terms share a common syntax. All types are terms, @@ -289,13 +289,13 @@ rest of the |Coq| manual: :term:`terms <term>` and :term:`types mathematics alternative to the standard `"set theory" <https://en.wikipedia.org/wiki/Set_theory>`_: we call such logical foundations `"type theories" - <https://en.wikipedia.org/wiki/Type_theory>`_. |Coq| is based on + <https://en.wikipedia.org/wiki/Type_theory>`_. Coq is based on the Calculus of Inductive Constructions, which is a particular instance of type theory. sentence - |Coq| documents are made of a series of sentences that contain + Coq documents are made of a series of sentences that contain :term:`commands <command>` or :term:`tactics <tactic>`, generally terminated with a period and optionally decorated with :term:`attributes <attribute>`. @@ -315,7 +315,7 @@ rest of the |Coq| manual: :term:`terms <term>` and :term:`types command - A :production:`command` can be used to modify the state of a |Coq| + A :production:`command` can be used to modify the state of a Coq document, for instance by declaring a new object, or to get information about the current state. @@ -325,16 +325,16 @@ rest of the |Coq| manual: :term:`terms <term>` and :term:`types boldface label "Command:". Commands are listed in the :ref:`command_index`. Example: - .. cmd:: Comments {* @string } + .. cmd:: Comments {* {| @one_term | @string | @natural } } - This command prints "Comments ok" and does not change anything - to the state of the document. + Prints "Comments ok" and does not change + the state of the document. tactic Tactics specify how to transform the current proof state as a step in creating a proof. They are syntactically valid only when - |Coq| is in proof mode, such as after a :cmd:`Theorem` command + Coq is in proof mode, such as after a :cmd:`Theorem` command and before any subsequent proof-terminating command such as :cmd:`Qed`. See :ref:`proofhandling` for more on proof mode. @@ -346,10 +346,10 @@ rest of the |Coq| manual: :term:`terms <term>` and :term:`types Settings -------- -There are several mechanisms for changing the behavior of |Coq|. The +There are several mechanisms for changing the behavior of Coq. The :term:`attribute` mechanism is used to modify the behavior of a single :term:`sentence`. The :term:`flag`, :term:`option` and :term:`table` -mechanisms are used to modify the behavior of |Coq| more globally in a +mechanisms are used to modify the behavior of Coq more globally in a document or project. .. _attributes: @@ -420,7 +420,7 @@ boldface label "Attribute:". Attributes are listed in the Flags, Options and Tables ~~~~~~~~~~~~~~~~~~~~~~~~~ -The following types of settings can be used to change the behavior of |Coq| in +The following types of settings can be used to change the behavior of Coq in subsequent commands and tactics (see :ref:`set_unset_scope_qualifiers` for a more precise description of the scope of these settings): @@ -463,10 +463,10 @@ they appear after a boldface label. They are listed in the This warning message can be raised by :cmd:`Set` and :cmd:`Unset` when :n:`@setting_name` is unknown. It is a warning rather than an error because this helps library authors - produce |Coq| code that is compatible with several |Coq| versions. + produce Coq code that is compatible with several Coq versions. To preserve the same behavior, they may need to set some compatibility flags or options that did not exist in previous - |Coq| versions. + Coq versions. .. cmd:: Unset @setting_name :name: Unset diff --git a/doc/sphinx/language/core/coinductive.rst b/doc/sphinx/language/core/coinductive.rst index c034b7f302..3e2ecdc0f0 100644 --- a/doc/sphinx/language/core/coinductive.rst +++ b/doc/sphinx/language/core/coinductive.rst @@ -28,8 +28,8 @@ More information on co-inductive definitions can be found in This command supports the :attr:`universes(polymorphic)`, :attr:`universes(monomorphic)`, :attr:`universes(template)`, :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, - :attr:`universes(noncumulative)` and :attr:`private(matching)` - attributes. + :attr:`universes(noncumulative)`, :attr:`private(matching)` + and :attr:`using` attributes. .. example:: diff --git a/doc/sphinx/language/core/conversion.rst b/doc/sphinx/language/core/conversion.rst index 6b031cfea3..7395b12339 100644 --- a/doc/sphinx/language/core/conversion.rst +++ b/doc/sphinx/language/core/conversion.rst @@ -85,7 +85,7 @@ reduction is called δ-reduction and shows as follows. ζ-reduction ~~~~~~~~~~~ -|Coq| allows also to remove local definitions occurring in terms by +Coq allows also to remove local definitions occurring in terms by replacing the defined variable by its value. The declaration being destroyed, this reduction differs from δ-reduction. It is called ζ-reduction and shows as follows. diff --git a/doc/sphinx/language/core/definitions.rst b/doc/sphinx/language/core/definitions.rst index 42203d9d65..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 + | @destructuring_let -: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’`. +: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) @@ -87,8 +90,8 @@ Section :ref:`typing-rules`. computation on :n:`@term`. These commands also support the :attr:`universes(polymorphic)`, - :attr:`universes(monomorphic)`, :attr:`program` and - :attr:`canonical` attributes. + :attr:`universes(monomorphic)`, :attr:`program` (see :ref:`program_definition`), + :attr:`canonical` and :attr:`using` attributes. If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. @@ -140,6 +143,8 @@ Chapter :ref:`Tactics`. The basic assertion command is: validated, the proof is generalized into a proof of :n:`forall {* @binder }, @type` and the theorem is bound to the name :n:`@ident` in the environment. + These commands accept the :attr:`program` attribute. See :ref:`program_lemma`. + Forms using the :n:`with` clause are useful for theorems that are proved by simultaneous induction over a mutually inductive assumption, or that assert mutually dependent statements in some mutual co-inductive type. It is equivalent to @@ -157,6 +162,8 @@ Chapter :ref:`Tactics`. The basic assertion command is: correct at some time of the interactive development of a proof, use the command :cmd:`Guarded`. + This command accepts the :attr:`using` attribute. + .. exn:: The term @term has type @type which should be Set, Prop or Type. :undocumented: diff --git a/doc/sphinx/language/core/inductive.rst b/doc/sphinx/language/core/inductive.rst index 39b154de8d..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 @@ -342,9 +343,9 @@ Recursive functions: fix .. insertprodn term_fix fixannot .. prodn:: - term_fix ::= let fix @fix_body in @term - | fix @fix_body {? {+ with @fix_body } for @ident } - fix_body ::= @ident {* @binder } {? @fixannot } {? : @type } := @term + term_fix ::= let fix @fix_decl in @term + | fix @fix_decl {? {+ with @fix_decl } for @ident } + fix_decl ::= @ident {* @binder } {? @fixannot } {? : @type } := @term fixannot ::= %{ struct @ident %} | %{ wf @one_term @ident %} | %{ measure @one_term {? @ident } {? @one_term } %} @@ -361,7 +362,11 @@ syntax: :n:`let fix @ident {* @binder } := @term in` stands for Some options of :n:`@fixannot` are only supported in specific constructs. :n:`fix` and :n:`let fix` only support the :n:`struct` option, while :n:`wf` and :n:`measure` are only supported in -commands such as :cmd:`Function` and :cmd:`Program Fixpoint`. +commands such as :cmd:`Fixpoint` (with the :attr:`program` attribute) and :cmd:`Function`. + +.. todo explanation of struct: see text above at the Fixpoint command, also + see https://github.com/coq/coq/pull/12936#discussion_r510716268 and above. + Consider whether to move the grammar for fixannot elsewhere .. _Fixpoint: @@ -379,7 +384,7 @@ constructions. .. prodn:: fix_definition ::= @ident_decl {* @binder } {? @fixannot } {? : @type } {? := @term } {? @decl_notations } - This command allows defining functions by pattern matching over inductive + Allows defining functions by pattern matching over inductive objects using a fixed point construction. The meaning of this declaration is to define :n:`@ident` as a recursive function with arguments specified by the :n:`@binder`\s such that :n:`@ident` applied to arguments @@ -388,6 +393,8 @@ constructions. consequently :n:`forall {* @binder }, @type` and its value is equivalent to :n:`fun {* @binder } => @term`. + This command accepts the :attr:`program` attribute. + To be accepted, a :cmd:`Fixpoint` definition has to satisfy syntactical constraints on a special argument called the decreasing argument. They are needed to ensure that the :cmd:`Fixpoint` definition always terminates. @@ -399,7 +406,7 @@ constructions. that satisfies the decreasing condition. :cmd:`Fixpoint` without the :attr:`program` attribute does not support the - :n:`wf` or :n:`measure` clauses of :n:`@fixannot`. + :n:`wf` or :n:`measure` clauses of :n:`@fixannot`. See :ref:`program_fixpoint`. The :n:`with` clause allows simultaneously defining several mutual fixpoints. It is especially useful when defining functions over mutually defined @@ -410,6 +417,8 @@ constructions. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. + This command accepts the :attr:`using` attribute. + .. note:: + Some fixpoints may have several arguments that fit as decreasing @@ -544,7 +553,7 @@ the sort of the inductive type :math:`t` (not to be confused with :math:`\Sort` \end{array} \right]} - which corresponds to the result of the |Coq| declaration: + which corresponds to the result of the Coq declaration: .. coqtop:: in reset @@ -565,7 +574,7 @@ the sort of the inductive type :math:`t` (not to be confused with :math:`\Sort` \consf &:& \tree → \forest → \forest\\ \end{array}\right]} - which corresponds to the result of the |Coq| declaration: + which corresponds to the result of the Coq declaration: .. coqtop:: in @@ -588,7 +597,7 @@ the sort of the inductive type :math:`t` (not to be confused with :math:`\Sort` \oddS &:& ∀ n,~\even~n → \odd~(\nS~n) \end{array}\right]} - which corresponds to the result of the |Coq| declaration: + which corresponds to the result of the Coq declaration: .. coqtop:: in @@ -1091,7 +1100,7 @@ Conversion is preserved as any (partial) instance :math:`I_j~q_1 … q_r` or template polymorphic, even if the :flag:`Auto Template Polymorphism` flag is on. -In practice, the rule **Ind-Family** is used by |Coq| only when all the +In practice, the rule **Ind-Family** is used by Coq only when all the inductive types of the inductive definition are declared with an arity whose sort is in the Type hierarchy. Then, the polymorphism is over the parameters whose type is an arity of sort in the Type hierarchy. @@ -1229,7 +1238,7 @@ at the computational level it implements a generic operator for doing primitive recursion over the structure. But this operator is rather tedious to implement and use. We choose in -this version of |Coq| to factorize the operator for primitive recursion +this version of Coq to factorize the operator for primitive recursion into two more primitive operations as was first suggested by Th. Coquand in :cite:`Coq92`. One is the definition by pattern matching. The second one is a definition by guarded fixpoints. @@ -1244,7 +1253,7 @@ The basic idea of this operator is that we have an object :math:`m` in an inductive type :math:`I` and we want to prove a property which possibly depends on :math:`m`. For this, it is enough to prove the property for :math:`m = (c_i~u_1 … u_{p_i} )` for each constructor of :math:`I`. -The |Coq| term for this proof +The Coq term for this proof will be written: .. math:: @@ -1259,7 +1268,7 @@ Actually, for type checking a :math:`\Match…\with…\kwend` expression we also to know the predicate :math:`P` to be proved by case analysis. In the general case where :math:`I` is an inductively defined :math:`n`-ary relation, :math:`P` is a predicate over :math:`n+1` arguments: the :math:`n` first ones correspond to the arguments of :math:`I` -(parameters excluded), and the last one corresponds to object :math:`m`. |Coq| +(parameters excluded), and the last one corresponds to object :math:`m`. Coq can sometimes infer this predicate but sometimes not. The concrete syntax for describing this predicate uses the :math:`\as…\In…\return` construction. For instance, let us assume that :math:`I` is an unary predicate diff --git a/doc/sphinx/language/core/modules.rst b/doc/sphinx/language/core/modules.rst index 866104d5d1..54252689e1 100644 --- a/doc/sphinx/language/core/modules.rst +++ b/doc/sphinx/language/core/modules.rst @@ -864,17 +864,17 @@ Libraries and qualified names Names of libraries ~~~~~~~~~~~~~~~~~~ -The theories developed in |Coq| are stored in *library files* which are +The theories developed in Coq are stored in *library files* which are hierarchically classified into *libraries* and *sublibraries*. To express this hierarchy, library names are represented by qualified identifiers qualid, i.e. as list of identifiers separated by dots (see :ref:`qualified-names`). For instance, the library file ``Mult`` of the standard -|Coq| library ``Arith`` is named ``Coq.Arith.Mult``. The identifier that starts +Coq library ``Arith`` is named ``Coq.Arith.Mult``. The identifier that starts the name of a library is called a *library root*. All library files of -the standard library of |Coq| have the reserved root |Coq| but library -filenames based on other roots can be obtained by using |Coq| commands +the standard library of Coq have the reserved root Coq but library +filenames based on other roots can be obtained by using Coq commands (coqc, coqtop, coqdep, …) options ``-Q`` or ``-R`` (see :ref:`command-line-options`). -Also, when an interactive |Coq| session starts, a library of root ``Top`` is +Also, when an interactive Coq session starts, a library of root ``Top`` is started, unless option ``-top`` or ``-notop`` is set (see :ref:`command-line-options`). .. _qualified-names: @@ -897,7 +897,7 @@ followed by the sequence of submodules names encapsulating the construction and ended by the proper name of the construction. Typically, the absolute name ``Coq.Init.Logic.eq`` denotes Leibniz’ equality defined in the module Logic in the sublibrary ``Init`` of the -standard library of |Coq|. +standard library of Coq. The proper name that ends the name of a construction is the short name (or sometimes base name) of the construction (for instance, the short @@ -906,7 +906,7 @@ name is a *partially qualified name* (e.g. ``Logic.eq`` is a partially qualified name for ``Coq.Init.Logic.eq``). Especially, the short name of a construction is its shortest partially qualified name. -|Coq| does not accept two constructions (definition, theorem, …) with +Coq does not accept two constructions (definition, theorem, …) with the same absolute name but different constructions can have the same short name (or even same partially qualified names as soon as the full names are different). @@ -916,14 +916,14 @@ names also applies to library filenames. **Visibility** -|Coq| maintains a table called the name table which maps partially qualified +Coq maintains a table called the name table which maps partially qualified names of constructions to absolute names. This table is updated by the commands :cmd:`Require`, :cmd:`Import` and :cmd:`Export` and also each time a new declaration is added to the context. An absolute name is called visible from a given short or partially qualified name when this latter name is enough to denote it. This means that the short or partially qualified name is mapped to the absolute name in -|Coq| name table. Definitions with the :attr:`local` attribute are only accessible with +Coq name table. Definitions with the :attr:`local` attribute are only accessible with their fully qualified name (see :ref:`gallina-definitions`). It may happen that a visible name is hidden by the short name or a @@ -953,13 +953,13 @@ accessible, absolute names can never be hidden. Libraries and filesystem ~~~~~~~~~~~~~~~~~~~~~~~~ -.. note:: The questions described here have been subject to redesign in |Coq| 8.5. - Former versions of |Coq| use the same terminology to describe slightly different things. +.. note:: The questions described here have been subject to redesign in Coq 8.5. + Former versions of Coq use the same terminology to describe slightly different things. Compiled files (``.vo`` and ``.vio``) store sub-libraries. In order to refer -to them inside |Coq|, a translation from file-system names to |Coq| names +to them inside Coq, a translation from file-system names to Coq names is needed. In this translation, names in the file system are called -*physical* paths while |Coq| names are contrastingly called *logical* +*physical* paths while Coq names are contrastingly called *logical* names. A logical prefix Lib can be associated with a physical path using @@ -967,7 +967,7 @@ the command line option ``-Q`` `path` ``Lib``. All subfolders of path are recursively associated to the logical path ``Lib`` extended with the corresponding suffix coming from the physical path. For instance, the folder ``path/fOO/Bar`` maps to ``Lib.fOO.Bar``. Subdirectories corresponding -to invalid |Coq| identifiers are skipped, and, by convention, +to invalid Coq identifiers are skipped, and, by convention, subdirectories named ``CVS`` or ``_darcs`` are skipped too. Thanks to this mechanism, ``.vo`` files are made available through the @@ -979,7 +979,7 @@ its logical name, so that an error is issued if it is loaded with the wrong loadpath afterwards. Some folders have a special status and are automatically put in the -path. |Coq| commands associate automatically a logical path to files in +path. Coq commands associate automatically a logical path to files in the repository trees rooted at the directory from where the command is launched, ``coqlib/user-contrib/``, the directories listed in the ``$COQPATH``, ``${XDG_DATA_HOME}/coq/`` and ``${XDG_DATA_DIRS}/coq/`` @@ -1001,12 +1001,12 @@ of the ``Require`` command can be used to bypass the implicit shortening by providing an absolute root to the required file (see :ref:`compiled-files`). There also exists another independent loadpath mechanism attached to -OCaml object files (``.cmo`` or ``.cmxs``) rather than |Coq| object +OCaml object files (``.cmo`` or ``.cmxs``) rather than Coq object files as described above. The OCaml loadpath is managed using the option ``-I`` `path` (in the OCaml world, there is neither a notion of logical name prefix nor a way to access files in subdirectories of path). See the command :cmd:`Declare ML Module` in :ref:`compiled-files` to understand the need of the OCaml loadpath. -See :ref:`command-line-options` for a more general view over the |Coq| command +See :ref:`command-line-options` for a more general view over the Coq command line options. diff --git a/doc/sphinx/language/core/primitive.rst b/doc/sphinx/language/core/primitive.rst index 48647deeff..4505fc4b4d 100644 --- a/doc/sphinx/language/core/primitive.rst +++ b/doc/sphinx/language/core/primitive.rst @@ -46,7 +46,7 @@ applications of these primitive operations. The extraction of these primitives can be customized similarly to the extraction of regular axioms (see :ref:`extraction`). Nonetheless, the :g:`ExtrOCamlInt63` module can be used when extracting to OCaml: it maps the Coq primitives to types -and functions of a :g:`Uint63` module. Said OCaml module is not produced by +and functions of a :g:`Uint63` module. That OCaml module is not produced by extraction. Instead, it has to be provided by the user (if they want to compile or execute the extracted code). For instance, an implementation of this module can be taken from the kernel of Coq. diff --git a/doc/sphinx/language/core/records.rst b/doc/sphinx/language/core/records.rst index b2099b8636..e6df3ee9f5 100644 --- a/doc/sphinx/language/core/records.rst +++ b/doc/sphinx/language/core/records.rst @@ -18,7 +18,7 @@ expressions. In this sense, the :cmd:`Record` construction allows defining .. insertprodn record_definition field_def .. prodn:: - record_definition ::= {? > } @ident_decl {* @binder } {? : @type } {? @ident } %{ {*; @record_field } {? ; } %} {? @decl_notations } + record_definition ::= {? > } @ident_decl {* @binder } {? : @sort } {? := {? @ident } %{ {*; @record_field } {? ; } %} } record_field ::= {* #[ {*, @attribute } ] } @name {? @field_body } {? %| @natural } {? @decl_notations } field_body ::= {* @binder } @of_type | {* @binder } @of_type := @term @@ -26,19 +26,28 @@ expressions. In this sense, the :cmd:`Record` construction allows defining term_record ::= %{%| {*; @field_def } {? ; } %|%} field_def ::= @qualid {* @binder } := @term - Each :n:`@record_definition` defines a record named by :n:`@ident_decl`. The constructor name is given by :n:`@ident`. If the constructor name is not specified, then the default name :n:`Build_@ident` is used, where :n:`@ident` is the record name. - If :n:`@type` is - omitted, the default type is :math:`\Type`. The identifiers inside the brackets are the field names. - The type of each field :n:`@ident` is :n:`forall {* @binder }, @type`. + If :token:`sort` is omitted, the default sort is Type. Notice that the type of an identifier can depend on a previously-given identifier. Thus the order of the fields is important. :n:`@binder` parameters may be applied to the record as a whole or to individual fields. + .. todo + "Record foo2:Prop := { a }." gives the error "Cannot infer this placeholder of type "Type", + while "Record foo2:Prop := { a:Type }." gives the output "foo2 is defined. + a cannot be defined because it is informative and foo2 is not." + Your thoughts? + + :n:`{? > }` + If provided, the constructor name is automatically declared as + a coercion from the class of the last field type to the record name + (this may fail if the uniform inheritance condition is not + satisfied). See :ref:`coercions`. + Notations can be attached to fields using the :n:`@decl_notations` annotation. :cmd:`Record` and :cmd:`Structure` are synonyms. @@ -76,7 +85,7 @@ Let us now see the work done by the ``Record`` macro. First the macro generates a variant type definition with just one constructor: :n:`Variant @ident {* @binder } : @sort := @ident__0 {* @binder }`. -To build an object of type :token:`ident`, one should provide the constructor +To build an object of type :token:`ident`, provide the constructor :n:`@ident__0` with the appropriate number of terms filling the fields of the record. .. example:: diff --git a/doc/sphinx/language/core/variants.rst b/doc/sphinx/language/core/variants.rst index 2904250e41..645986be9c 100644 --- a/doc/sphinx/language/core/variants.rst +++ b/doc/sphinx/language/core/variants.rst @@ -29,6 +29,7 @@ Private (matching) inductive types ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. attr:: private(matching) + :name: private(matching); Private This attribute can be used to forbid the use of the :g:`match` construct on objects of this inductive type outside of the module diff --git a/doc/sphinx/language/extensions/arguments-command.rst b/doc/sphinx/language/extensions/arguments-command.rst index 0ae9fab7ab..2460461ede 100644 --- a/doc/sphinx/language/extensions/arguments-command.rst +++ b/doc/sphinx/language/extensions/arguments-command.rst @@ -86,6 +86,7 @@ Setting properties of a function's arguments the parameter name used in the function definition). Unless `rename` is specified, the list of :n:`@name`\s must be a prefix of the formal parameters, including all implicit arguments. `_` can be used to skip over a formal parameter. + The construct :n:`@name {? % @scope }` declares :n:`@name` as non-implicit if `clear implicits` is specified or at least one other name is declared implicit in the same list of :n:`@name`\s. :token:`scope` can be either a scope name or its delimiting key. See :ref:`binding_to_scope`. `clear implicits` @@ -181,7 +182,7 @@ Manual declaration of implicit arguments Automatic declaration of implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The ":n:`default implicits`" :token:`args_modifier` clause tells |Coq| to automatically determine the + The ":n:`default implicits`" :token:`args_modifier` clause tells Coq to automatically determine the implicit arguments of the object. Auto-detection is governed by flags specifying whether strict, diff --git a/doc/sphinx/language/extensions/canonical.rst b/doc/sphinx/language/extensions/canonical.rst index bfda8befff..48120503af 100644 --- a/doc/sphinx/language/extensions/canonical.rst +++ b/doc/sphinx/language/extensions/canonical.rst @@ -196,7 +196,7 @@ We amend that by equipping ``nat`` with a comparison relation. Check 3 == 3. Eval compute in 3 == 4. -This last test shows that |Coq| is now not only able to type check ``3 == 3``, +This last test shows that Coq is now not only able to type check ``3 == 3``, but also that the infix relation was bound to the ``nat_eq`` relation. This relation is selected whenever ``==`` is used on terms of type nat. This can be read in the line declaring the canonical structure @@ -223,7 +223,7 @@ example work: Fail Check forall (e : EQ.type) (a b : EQ.obj e), (a, b) == (a, b). -The error message is telling that |Coq| has no idea on how to compare +The error message is telling that Coq has no idea on how to compare pairs of objects. The following construction is telling Coq exactly how to do that. @@ -241,7 +241,7 @@ how to do that. Check forall n m : nat, (3, 4) == (n, m). -Thanks to the ``pair_EQty`` declaration, |Coq| is able to build a comparison +Thanks to the ``pair_EQty`` declaration, Coq is able to build a comparison relation for pairs whenever it is able to build a comparison relation for each component of the pair. The declaration associates to the key ``*`` (the type constructor of pairs) the canonical comparison @@ -290,7 +290,7 @@ As before we register a canonical ``LE`` class for ``nat``. Canonical Structure nat_LEty : LE.type := LE.Pack nat nat_LEcl. -And we enable |Coq| to relate pair of terms with ``<=``. +And we enable Coq to relate pair of terms with ``<=``. .. coqtop:: all @@ -355,10 +355,10 @@ theory of this new class. The problem is that the two classes ``LE`` and ``LEQ`` are not yet related by -a subclass relation. In other words |Coq| does not see that an object of +a subclass relation. In other words Coq does not see that an object of the ``LEQ`` class is also an object of the ``LE`` class. -The following two constructions tell |Coq| how to canonically build the +The following two constructions tell Coq how to canonically build the ``LE.type`` and ``EQ.type`` structure given an ``LEQ.type`` structure on the same type. @@ -413,7 +413,7 @@ setting to any concrete instate of the algebraic structure. Abort. -Again one has to tell |Coq| that the type ``nat`` is in the ``LEQ`` class, and +Again one has to tell Coq that the type ``nat`` is in the ``LEQ`` class, and how the type constructor ``*`` interacts with the ``LEQ`` class. In the following proofs are omitted for brevity. @@ -468,7 +468,7 @@ Note that no direct proof of ``n <= m -> m <= n -> n == m`` is provided by the user for ``n`` and m of type ``nat * nat``. What the user provides is a proof of this statement for ``n`` and ``m`` of type ``nat`` and a proof that the pair constructor preserves this property. The combination of these two -facts is a simple form of proof search that |Coq| performs automatically +facts is a simple form of proof search that Coq performs automatically while inferring canonical structures. Compact declaration of Canonical Structures @@ -507,7 +507,7 @@ instances: ``[find e | EQ.obj e ~ T | "is not an EQ.type" ]``. It should be read as: “find a class e such that its objects have type T or fail with message "T is not an EQ.type"”. -The other utilities are used to ask |Coq| to solve a specific unification +The other utilities are used to ask Coq to solve a specific unification problem, that will in turn require the inference of some canonical structures. They are explained in more details in :cite:`CSwcu`. @@ -532,7 +532,7 @@ The object ``Pack`` takes a type ``T`` (the key) and a mixin ``m``. It infers al the other pieces of the class ``LEQ`` and declares them as canonical values associated to the ``T`` key. All in all, the only new piece of information we add in the ``LEQ`` class is the mixin, all the rest is -already canonical for ``T`` and hence can be inferred by |Coq|. +already canonical for ``T`` and hence can be inferred by Coq. ``Pack`` is a notation, hence it is not type checked at the time of its declaration. It will be type checked when it is used, an in that case ``T`` is diff --git a/doc/sphinx/language/extensions/evars.rst b/doc/sphinx/language/extensions/evars.rst index 20f4310d13..fd9695e270 100644 --- a/doc/sphinx/language/extensions/evars.rst +++ b/doc/sphinx/language/extensions/evars.rst @@ -13,7 +13,7 @@ Existential variables | ?[ ?@ident ] | ?@ident {? @%{ {+; @ident := @term } %} } -|Coq| terms can include existential variables that represent unknown +Coq terms can include existential variables that represent unknown subterms that are eventually replaced with actual subterms. Existential variables are generated in place of unsolved implicit diff --git a/doc/sphinx/language/extensions/implicit-arguments.rst b/doc/sphinx/language/extensions/implicit-arguments.rst index f8375e93ce..23ba5f703a 100644 --- a/doc/sphinx/language/extensions/implicit-arguments.rst +++ b/doc/sphinx/language/extensions/implicit-arguments.rst @@ -146,7 +146,7 @@ by replacing it with `_`. .. exn:: Cannot infer a term for this placeholder. :name: Cannot infer a term for this placeholder. (Casual use of implicit arguments) - |Coq| was not able to deduce an instantiation of a “_”. + Coq was not able to deduce an instantiation of a “_”. .. _declare-implicit-args: @@ -290,8 +290,8 @@ Controlling contextual implicit arguments .. flag:: Contextual Implicit - By default, |Coq| does not automatically set implicit the contextual - implicit arguments. You can turn this flag on to tell |Coq| to also + By default, Coq does not automatically set implicit the contextual + implicit arguments. You can turn this flag on to tell Coq to also infer contextual implicit argument. .. _controlling-rev-pattern-implicit-args: @@ -301,8 +301,8 @@ Controlling reversible-pattern implicit arguments .. flag:: Reversible Pattern Implicit - By default, |Coq| does not automatically set implicit the reversible-pattern - implicit arguments. You can turn this flag on to tell |Coq| to also infer + By default, Coq does not automatically set implicit the reversible-pattern + implicit arguments. You can turn this flag on to tell Coq to also infer reversible-pattern implicit argument. .. _controlling-insertion-implicit-args: diff --git a/doc/sphinx/language/extensions/match.rst b/doc/sphinx/language/extensions/match.rst index c36b9deef3..8e62c2af13 100644 --- a/doc/sphinx/language/extensions/match.rst +++ b/doc/sphinx/language/extensions/match.rst @@ -5,7 +5,7 @@ Extended pattern matching :Authors: Cristina Cornes and Hugo Herbelin -This section describes the full form of pattern matching in |Coq| terms. +This section describes the full form of pattern matching in Coq terms. .. |rhs| replace:: right hand sides @@ -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 ++++++++++++++++++++++++++++++ @@ -187,10 +194,10 @@ Printing nested patterns pattern matching into a single pattern matching over a nested pattern. - When this flag is on (default), |Coq|’s printer tries to do such + When this flag is on (default), Coq’s printer tries to do such limited re-factorization. - Turning it off tells |Coq| to print only simple pattern matching problems - in the same way as the |Coq| kernel handles them. + Turning it off tells Coq to print only simple pattern matching problems + in the same way as the Coq kernel handles them. Factorization of clauses with same right-hand side @@ -200,7 +207,7 @@ Factorization of clauses with same right-hand side When several patterns share the same right-hand side, it is additionally possible to share the clauses using disjunctive patterns. Assuming that the - printing matching mode is on, this flag (on by default) tells |Coq|'s + printing matching mode is on, this flag (on by default) tells Coq's printer to try to do this kind of factorization. Use of a default clause @@ -212,7 +219,7 @@ Use of a default clause arguments of the patterns, yet an extra factorization is possible: the disjunction of patterns can be replaced with a `_` default clause. Assuming that the printing matching mode and the factorization mode are on, this flag (on by - default) tells |Coq|'s printer to use a default clause when relevant. + default) tells Coq's printer to use a default clause when relevant. Printing of wildcard patterns ++++++++++++++++++++++++++++++ @@ -234,7 +241,7 @@ Printing of the elimination predicate In most of the cases, the type of the result of a matched term is mechanically synthesizable. Especially, if the result type does not depend of the matched term. When this flag is on (default), - the result type is not printed when |Coq| knows that it can re- + the result type is not printed when Coq knows that it can re- synthesize it. @@ -290,6 +297,43 @@ This example emphasizes what the printing settings offer. Print snd. +Conventions about unused pattern-matching variables +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Pattern-matching variables that are not used on the right-hand side of ``=>`` are +considered the sign of a potential error. For instance, it could +result from an undetected mispelled constant constructor. By default, +a warning is issued in such situations. + +.. warn:: Unused variable @ident catches more than one case. + + This indicates that an unused pattern variable :token:`ident` + occurs in a pattern-matching clause used to complete at least two + cases of the pattern-matching problem. + + The warning can be deactivated by using a variable name starting + with ``_`` or by setting ``Set Warnings + "-unused-pattern-matching-variable"``. + + Here is an example where the warning is activated. + + .. example:: + + .. coqtop:: none + + Set Warnings "-unused-pattern-matching-variable". + + .. coqtop:: all + + Definition is_zero (o : option nat) := match o with + | Some 0 => true + | x => false + end. + + .. coqtop:: none + + Set Warnings "+unused-pattern-matching-variable". + Patterns -------- diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index ec182ce08f..d20a82e6c0 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -1,13 +1,13 @@ .. _thecoqcommands: -The |Coq| commands +The Coq commands ==================== -There are three |Coq| commands: +There are three Coq commands: -+ ``coqtop``: the |Coq| toplevel (interactive mode); -+ ``coqc``: the |Coq| compiler (batch compilation); -+ ``coqchk``: the |Coq| checker (validation of compiled libraries). ++ ``coqtop``: the Coq toplevel (interactive mode); ++ ``coqc``: the Coq compiler (batch compilation); ++ ``coqchk``: the Coq checker (validation of compiled libraries). The options are (basically) the same for the first two commands, and @@ -19,11 +19,11 @@ roughly described below. You can also look at the ``man`` pages of Interactive use (coqtop) ------------------------ -In the interactive mode, also known as the |Coq| toplevel, the user can -develop his theories and proofs step by step. The |Coq| toplevel is run +In the interactive mode, also known as the Coq toplevel, the user can +develop his theories and proofs step by step. The Coq toplevel is run by the command ``coqtop``. -There are two different binary images of |Coq|: the byte-code one and the +There are two different binary images of Coq: the byte-code one and the native-code one (if OCaml provides a native-code compiler for your platform, which is supposed in the following). By default, ``coqtop`` executes the native-code version; run ``coqtop.byte`` to get @@ -31,7 +31,7 @@ the byte-code version. The byte-code toplevel is based on an OCaml toplevel (to allow dynamic linking of tactics). You can switch to the OCaml toplevel -with the command ``Drop.``, and come back to the |Coq| +with the command ``Drop.``, and come back to the Coq toplevel with the command ``Coqloop.loop();;``. .. flag:: Coqtop Exit On Error @@ -48,7 +48,7 @@ vernacular file named *file*.v, and tries to compile it into a .. caution:: - The name *file* should be a regular |Coq| identifier as defined in Section :ref:`lexical-conventions`. + The name *file* should be a regular Coq identifier as defined in Section :ref:`lexical-conventions`. It should contain only letters, digits or underscores (_). For example ``/bar/foo/toto.v`` is valid, but ``/bar/foo/to-to.v`` is not. @@ -59,7 +59,7 @@ Customization at launch time By resource file ~~~~~~~~~~~~~~~~~~~~~~~ -When |Coq| is launched, with either ``coqtop`` or ``coqc``, the +When Coq is launched, with either ``coqtop`` or ``coqc``, the resource file ``$XDG_CONFIG_HOME/coq/coqrc.xxx``, if it exists, will be implicitly prepended to any document read by Coq, whether it is an interactive session or a file to compile. Here, ``$XDG_CONFIG_HOME`` @@ -73,7 +73,7 @@ You can also specify an arbitrary name for the resource file (see option ``-init-file`` below). The resource file may contain, for instance, ``Add LoadPath`` commands to add -directories to the load path of |Coq|. It is possible to skip the +directories to the load path of Coq. It is possible to skip the loading of the resource file with the option ``-q``. .. _customization-by-environment-variables: @@ -82,10 +82,10 @@ By environment variables ~~~~~~~~~~~~~~~~~~~~~~~~~ ``$COQPATH`` can be used to specify the load path. It is a list of directories separated by -``:`` (``;`` on Windows). |Coq| will also honor ``$XDG_DATA_HOME`` and +``:`` (``;`` on Windows). Coq will also honor ``$XDG_DATA_HOME`` and ``$XDG_DATA_DIRS`` (see Section :ref:`libraries-and-filesystem`). -Some |Coq| commands call other |Coq| commands. In this case, they look for +Some Coq commands call other Coq commands. In this case, they look for the commands in directory specified by ``$COQBIN``. If this variable is not set, they look for the commands in the executable path. @@ -115,7 +115,7 @@ can be used to specify certain runtime and memory usage parameters. In most cas experimenting with these settings will likely not cause a significant performance difference and should be harmless. -If the variable is not set, |Coq| uses the +If the variable is not set, Coq uses the `default values <https://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#TYPEcontrol>`_, except that ``space_overhead`` is set to 120 and ``minor_heap_size`` is set to 32Mwords (256MB with 64-bit executables or 128MB with 32-bit executables). @@ -140,14 +140,14 @@ and ``coqtop``, unless stated otherwise: :ref:`names-of-libraries` and the command Declare ML Module Section :ref:`compiled-files`. :-Q *directory* *dirpath*: Add physical path *directory* to the list of - directories where |Coq| looks for a file and bind it to the logical + directories where Coq looks for a file and bind it to the logical directory *dirpath*. The subdirectory structure of *directory* is - recursively available from |Coq| using absolute names (extending the + recursively available from Coq using absolute names (extending the :n:`@dirpath` prefix) (see Section :ref:`qualified-names`). Note that only those subdirectories and files which obey the lexical conventions of what is an :n:`@ident` are taken into account. Conversely, the underlying file systems or operating systems may be more restrictive - than |Coq|. While Linux’s ext4 file system supports any |Coq| recursive + than Coq. While Linux’s ext4 file system supports any Coq recursive layout (within the limit of 255 bytes per filename), the default on NTFS (Windows) or HFS+ (MacOS X) file systems is on the contrary to disallow two files differing only in the case in the same directory. @@ -155,7 +155,7 @@ and ``coqtop``, unless stated otherwise: .. seealso:: Section :ref:`names-of-libraries`. :-R *directory* *dirpath*: Do as ``-Q`` *directory* *dirpath* but make the subdirectory structure of *directory* recursively visible so that the - recursive contents of physical *directory* is available from |Coq| using + recursive contents of physical *directory* is available from Coq using short or partially qualified names. .. seealso:: Section :ref:`names-of-libraries`. @@ -172,12 +172,12 @@ and ``coqtop``, unless stated otherwise: loading the default resource file from the standard configuration directories. :-q: Do not to load the default resource file. -:-l *file*, -load-vernac-source *file*: Load and execute the |Coq| +:-l *file*, -load-vernac-source *file*: Load and execute the Coq script from *file.v*. :-lv *file*, -load-vernac-source-verbose *file*: Load and execute the - |Coq| script from *file.v*. Write its contents to the standard output as + Coq script from *file.v*. Write its contents to the standard output as it is executed. -:-load-vernac-object *qualid*: Load |Coq| compiled library :n:`@qualid`. This +:-load-vernac-object *qualid*: Load Coq compiled library :n:`@qualid`. This is equivalent to running :cmd:`Require` :n:`@qualid`. .. _interleave-command-line: @@ -191,27 +191,27 @@ and ``coqtop``, unless stated otherwise: :cmd:`Unset` commands will be executed in the order specified on the command-line. -:-rfrom *dirpath* *qualid*: Load |Coq| compiled library :n:`@qualid`. +:-rfrom *dirpath* *qualid*: Load Coq compiled library :n:`@qualid`. This is equivalent to running :cmd:`From <From … Require>` :n:`@dirpath` :cmd:`Require <From … Require>` :n:`@qualid`. See the :ref:`note above <interleave-command-line>` regarding the order of command-line options. -:-ri *qualid*, -require-import *qualid*: Load |Coq| compiled library :n:`@qualid` and import it. +:-ri *qualid*, -require-import *qualid*: Load Coq compiled library :n:`@qualid` and import it. This is equivalent to running :cmd:`Require Import` :n:`@qualid`. See the :ref:`note above <interleave-command-line>` regarding the order of command-line options. -:-re *qualid*, -require-export *qualid*: Load |Coq| compiled library :n:`@qualid` and transitively import it. +:-re *qualid*, -require-export *qualid*: Load Coq compiled library :n:`@qualid` and transitively import it. This is equivalent to running :cmd:`Require Export` :n:`@qualid`. See the :ref:`note above <interleave-command-line>` regarding the order of command-line options. :-rifrom *dirpath* *qualid*, -require-import-from *dirpath* *qualid*: - Load |Coq| compiled library :n:`@qualid` and import it. This is + Load Coq compiled library :n:`@qualid` and import it. This is equivalent to running :cmd:`From <From … Require>` :n:`@dirpath` :cmd:`Require Import <From … Require>` :n:`@qualid`. See the :ref:`note above <interleave-command-line>` regarding the order of command-line options. :-refrom *dirpath* *qualid*, -require-export-from *dirpath* *qualid*: - Load |Coq| compiled library :n:`@qualid` and transitively import it. + Load Coq compiled library :n:`@qualid` and transitively import it. This is equivalent to running :cmd:`From <From … Require>` :n:`@dirpath` :cmd:`Require Export <From … Require>` :n:`@qualid`. See the :ref:`note above <interleave-command-line>` regarding the @@ -219,11 +219,11 @@ and ``coqtop``, unless stated otherwise: :-batch: Exit just after argument parsing. Available for ``coqtop`` only. :-verbose: Output the content of the input file as it is compiled. This option is available for ``coqc`` only. -:-vos: Indicate |Coq| to skip the processing of opaque proofs +:-vos: Indicate Coq to skip the processing of opaque proofs (i.e., proofs ending with :cmd:`Qed` or :cmd:`Admitted`), output a ``.vos`` files instead of a ``.vo`` file, and to load ``.vos`` files instead of ``.vo`` files when interpreting :cmd:`Require` commands. -:-vok: Indicate |Coq| to check a file completely, to load ``.vos`` files instead +:-vok: Indicate Coq to check a file completely, to load ``.vos`` files instead of ``.vo`` files when interpreting :cmd:`Require` commands, and to output an empty ``.vok`` files upon success instead of writing a ``.vo`` file. :-w (all|none|w₁,…,wₙ): Configure the display of warnings. This @@ -241,7 +241,7 @@ and ``coqtop``, unless stated otherwise: syntax/definitions/notations. :-emacs, -ide-slave: Start a special toplevel to communicate with a specific IDE. -:-impredicative-set: Change the logical theory of |Coq| by declaring the +:-impredicative-set: Change the logical theory of Coq by declaring the sort :g:`Set` impredicative. .. warning:: @@ -249,7 +249,7 @@ and ``coqtop``, unless stated otherwise: This is known to be inconsistent with some standard axioms of classical mathematics such as the functional axiom of choice or the principle of description. -:-type-in-type: Collapse the universe hierarchy of |Coq|. +:-type-in-type: Collapse the universe hierarchy of Coq. .. warning:: This makes the logic inconsistent. :-mangle-names *ident*: *Experimental.* Do not depend on this option. Replace @@ -285,16 +285,16 @@ and ``coqtop``, unless stated otherwise: :-no-glob: Disable the dumping of references for global names. :-image *file*: Set the binary image to be used by ``coqc`` to be *file* instead of the standard one. Not of general use. -:-bindir *directory*: Set the directory containing |Coq| binaries to be +:-bindir *directory*: Set the directory containing Coq binaries to be used by ``coqc``. It is equivalent to doing export COQBIN= *directory* before launching ``coqc``. -:-where: Print the location of |Coq|’s standard library and exit. -:-config: Print the locations of |Coq|’s binaries, dependencies, and +:-where: Print the location of Coq’s standard library and exit. +:-config: Print the locations of Coq’s binaries, dependencies, and libraries, then exit. :-filteropts: Print the list of command line arguments that `coqtop` has recognized as options and exit. -:-v: Print |Coq|’s version and exit. -:-list-tags: Print the highlight tags known by |Coq| as well as their +:-v: Print Coq’s version and exit. +:-list-tags: Print the highlight tags known by Coq as well as their currently associated color and exit. :-h, --help: Print a short usage and exit. @@ -401,7 +401,7 @@ within a section. .. warn:: You should use the “Proof using [...].” syntax instead of “Proof.” to enable skipping this proof which is located inside a section. Give as argument to “Proof using” the list of section variables that are not needed to typecheck the statement but that are required by the proof. - If |Coq| is invoked using the ``-vos`` option, whenever it finds the + If Coq is invoked using the ``-vos`` option, whenever it finds the command ``Proof.`` inside a section, it will compile the proof, that is, refuse to skip it, and it will raise a warning. To disable the warning, one may pass the flag ``-w -proof-without-using-in-section``. @@ -412,7 +412,7 @@ When compiling a file ``foo.v`` using ``coqc`` in the standard way (i.e., withou ``-vos`` nor ``-vok``), an empty file ``foo.vos`` and an empty file ``foo.vok`` are created in addition to the regular output file ``foo.vo``. If ``coqc`` is subsequently invoked on some other file ``bar.v`` using option -``-vos`` or ``-vok``, and that ``bar.v`` requires ``foo.v``, if |Coq| finds an +``-vos`` or ``-vok``, and that ``bar.v`` requires ``foo.v``, if Coq finds an empty file ``foo.vos``, then it will load ``foo.vo`` instead of ``foo.vos``. The purpose of this feature is to allow users to benefit from the ``-vos`` diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index 42e752841d..c239797cc2 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -2,7 +2,7 @@ .. _coqintegrateddevelopmentenvironment: -|Coq| Integrated Development Environment +Coq Integrated Development Environment ======================================== The Coq Integrated Development Environment is a graphical tool, to be @@ -10,19 +10,19 @@ used as a user-friendly replacement to `coqtop`. Its main purpose is to allow the user to navigate forward and backward into a Coq vernacular file, executing corresponding commands or undoing them respectively. -|CoqIDE| is run by typing the command `coqide` on the command line. +CoqIDE is run by typing the command `coqide` on the command line. Without argument, the main screen is displayed with an “unnamed buffer”, and with a filename as argument, another buffer displaying the contents of that file. Additionally, `coqide` accepts the same options as `coqtop`, given in :ref:`thecoqcommands`, the ones having obviously -no meaning for |CoqIDE| being ignored. +no meaning for CoqIDE being ignored. .. _coqide_mainscreen: .. image:: ../_static/coqide.png - :alt: |CoqIDE| main screen + :alt: CoqIDE main screen -A sample |CoqIDE| main screen, while navigating into a file `Fermat.v`, +A sample CoqIDE main screen, while navigating into a file `Fermat.v`, is shown in the figure :ref:`CoqIDE main screen <coqide_mainscreen>`. At the top is a menu bar, and a tool bar below it. The large window on the left is displaying the various @@ -43,7 +43,7 @@ is the one where Coq commands are currently executed. Buffers may be edited as in any text editor, and classical basic editing commands (Copy/Paste, …) are available in the *Edit* menu. -|CoqIDE| offers only basic editing commands, so if you need more complex +CoqIDE offers only basic editing commands, so if you need more complex editing commands, you may launch your favorite text editor on the current buffer, using the *Edit/External Editor* menu. @@ -74,7 +74,7 @@ and use the goto button. Unlike with `coqtop`, you should never use There are two additional buttons for navigation within the running buffer. The "down" button with a line goes directly to the end; the "up" button with a line goes back to the beginning. The handling of errors when using the go-to-the-end -button depends on whether |Coq| is running in asynchronous mode or not (see +button depends on whether Coq is running in asynchronous mode or not (see Chapter :ref:`asynchronousandparallelproofprocessing`). If it is not running in that mode, execution stops as soon as an error is found. Otherwise, execution continues, and the error is marked with an underline in the error foreground color, with a @@ -86,12 +86,12 @@ If you ever try to execute a command that runs for a long time and would like to abort it before it terminates, you may use the interrupt button (the white cross on a red circle). -There are other buttons on the |CoqIDE| toolbar: a button to save the running +There are other buttons on the CoqIDE toolbar: a button to save the running buffer; a button to close the current buffer (an "X"); buttons to switch among buffers (left and right arrows); an "information" button; and a "gears" button. -The "gears" button submits proof terms to the |Coq| kernel for type checking. -When |Coq| uses asynchronous processing (see Chapter :ref:`asynchronousandparallelproofprocessing`), +The "gears" button submits proof terms to the Coq kernel for type checking. +When Coq uses asynchronous processing (see Chapter :ref:`asynchronousandparallelproofprocessing`), proofs may have been completed without kernel-checking of generated proof terms. The presence of unchecked proof terms is indicated by ``Qed`` statements that have a subdued *being-processed* color (light blue by default), rather than the @@ -114,11 +114,11 @@ Queries ------------ .. image:: ../_static/coqide-queries.png - :alt: |CoqIDE| queries + :alt: CoqIDE queries We call *query* any vernacular command that does not change the current state, such as ``Check``, ``Search``, etc. To run such commands interactively, without -writing them in scripts, |CoqIDE| offers a *query pane*. The query pane can be +writing them in scripts, CoqIDE offers a *query pane*. The query pane can be displayed on demand by using the ``View`` menu, or using the shortcut ``F1``. Queries can also be performed by selecting a particular phrase, then choosing an item from the ``Queries`` menu. The response then appears in the message window. @@ -148,12 +148,12 @@ The first section is for selecting the text font used for scripts, goal and message windows. The second and third sections are for controlling colors and style of -the three main buffers. A predefined |Coq| highlighting style as well +the three main buffers. A predefined Coq highlighting style as well as standard |GtkSourceView| styles are available. Other styles can be added e.g. in ``$HOME/.local/share/gtksourceview-3.0/styles/`` (see the general documentation about |GtkSourceView| for the various possibilities). Note that the style of the rest of graphical part of -Coqide is not under the control of |GtkSourceView| but of GTK+ and +CoqIDE is not under the control of |GtkSourceView| but of GTK+ and governed by files such as ``settings.ini`` and ``gtk.css`` in ``$XDG_CONFIG_HOME/gtk-3.0`` or files in ``$HOME/.themes/NameOfTheme/gtk-3.0``, as well as the environment @@ -169,7 +169,7 @@ The next section is devoted to file management: you may configure automatic saving of files, by periodically saving the contents into files named `#f#` for each opened file `f`. You may also activate the *revert* feature: in case a opened file is modified on the disk by a -third party, |CoqIDE| may read it again for you. Note that in the case +third party, CoqIDE may read it again for you. Note that in the case you edited that same file, you will be prompted to choose to either discard your changes or not. The File charset encoding choice is described below in :ref:`character-encoding-saved-files`. @@ -196,9 +196,9 @@ still edit this configuration file by hand, but this is more involved. Using Unicode symbols -------------------------- -|CoqIDE| is based on GTK+ and inherits from it support for Unicode in +CoqIDE is based on GTK+ and inherits from it support for Unicode in its text windows. Consequently a large set of symbols is available for -notations. Furthermore, |CoqIDE| conveniently provides a simple way to +notations. Furthermore, CoqIDE conveniently provides a simple way to input Unicode characters. @@ -220,8 +220,8 @@ mathematical symbols ∀ and ∃, you may define: There exists a small set of such notations already defined, in the file `utf8.v` of Coq library, so you may enable them just by -``Require Import Unicode.Utf8`` inside |CoqIDE|, or equivalently, -by starting |CoqIDE| with ``coqide -l utf8``. +``Require Import Unicode.Utf8`` inside CoqIDE, or equivalently, +by starting CoqIDE with ``coqide -l utf8``. However, there are some issues when using such Unicode symbols: you of course need to use a character font which supports them. In the Fonts @@ -255,7 +255,7 @@ Custom bindings may be added, as explained further on. .. note:: It remains possible to input non-ASCII symbols using system-wide - approaches independent of |CoqIDE|. + approaches independent of CoqIDE. Adding custom bindings @@ -286,7 +286,7 @@ Similarly, the above settings ensure than ``\l`` resolves to ``\le``, and that ``\la`` resolves to ``\lambda``. It can be useful to work with per-project binding files. For this purpose -|CoqIDE| accepts a command line argument of the form +CoqIDE accepts a command line argument of the form ``-unicode-bindings file1,file2,...,fileN``. Each of the file tokens provided may consists of one of: @@ -320,7 +320,7 @@ related to the way files are saved. If you have no need to exchange files with non UTF-8 aware applications, it is better to choose the UTF-8 encoding, since it guarantees that your files will be read again without problems. (This -is because when |CoqIDE| reads a file, it tries to automatically detect +is because when CoqIDE reads a file, it tries to automatically detect its character encoding.) If you choose something else than UTF-8, then missing characters will diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index daae46ad11..ec3689bbbe 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -9,7 +9,7 @@ beside proof development, tactics writing or documentation. Using Coq as a library ----------------------- +------------------------ In previous versions, ``coqmktop`` was used to build custom toplevels - for example for better debugging or custom static @@ -34,7 +34,7 @@ For example, to statically link |Ltac|, you can just do: and similarly for other plugins. -Building a |Coq| project +Building a Coq project ------------------------ As of today it is possible to build Coq projects using two tools: @@ -44,11 +44,11 @@ As of today it is possible to build Coq projects using two tools: .. _coq_makefile: -Building a |Coq| project with coq_makefile +Building a Coq project with coq_makefile ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The majority of |Coq| projects are very similar: a collection of ``.v`` -files and eventually some ``.ml`` ones (a |Coq| plugin). The main piece of +The majority of Coq projects are very similar: a collection of ``.v`` +files and eventually some ``.ml`` ones (a Coq plugin). The main piece of metadata needed in order to build the project are the command line options to ``coqc`` (e.g. ``-R``, ``Q``, ``-I``, see :ref:`command line options <command-line-options>`). Collecting the list of files @@ -74,11 +74,11 @@ to literally pass an argument ``foo`` to ``coqc``: in the example, this allows to pass the two-word option ``-w all`` (see :ref:`command line options <command-line-options>`). -|CoqIDE|, Proof-General and VSCoq all -understand ``_CoqProject`` files and can be used to invoke |Coq| with the desired options. +CoqIDE, Proof-General and VSCoq all +understand ``_CoqProject`` files and can be used to invoke Coq with the desired options. The ``coq_makefile`` utility can be used to set up a build infrastructure -for the |Coq| project based on makefiles. The recommended way of +for the Coq project based on makefiles. The recommended way of invoking ``coq_makefile`` is the following one: :: @@ -91,14 +91,14 @@ Such command generates the following files: CoqMakefile is a makefile for ``GNU Make`` with targets to build the project (e.g. generate .vo or .html files from .v or compile .ml* files) - and install it in the ``user-contrib`` directory where the |Coq| + and install it in the ``user-contrib`` directory where the Coq library is installed. Run ``make`` with the ``-f CoqMakefile`` option to use ``CoqMakefile``. CoqMakefile.conf contains make variables assignments that reflect the contents of the ``_CoqProject`` file as well as the path relevant to - |Coq|. + Coq. An optional file ``CoqMakefile.local`` can be provided by the user in order to @@ -111,11 +111,11 @@ The extensions of the files listed in ``_CoqProject`` is used in order to decide how to build them. In particular: -+ |Coq| files must use the ``.v`` extension -+ |OCaml| files must use the ``.ml`` or ``.mli`` extension -+ |OCaml| files that require pre processing for syntax ++ Coq files must use the ``.v`` extension ++ OCaml files must use the ``.ml`` or ``.mli`` extension ++ OCaml files that require pre processing for syntax extensions (like ``VERNAC EXTEND``) must use the ``.mlg`` extension -+ In order to generate a plugin one has to list all |OCaml| ++ In order to generate a plugin one has to list all OCaml modules (i.e. ``Baz`` for ``baz.ml``) in a ``.mlpack`` file (or ``.mllib`` file). @@ -145,7 +145,7 @@ Here we describe only few of them. passed to the OCaml compiler on building or linking of modules. Eg: ``-package yojson``. :CAMLFLAGS: - can be used to specify additional flags to the |OCaml| + can be used to specify additional flags to the OCaml compiler, like ``-bin-annot`` or ``-w``.... :OCAMLWARN: it contains a default of ``-warn-error +a-3``, useful to modify @@ -524,7 +524,7 @@ Precompiling for ``native_compute`` +++++++++++++++++++++++++++++++++++ To compile files for ``native_compute``, one can use the -``-native-compiler yes`` option of |Coq|, for instance by putting the +``-native-compiler yes`` option of Coq, for instance by putting the following in a :ref:`coqmakefilelocal` file: :: @@ -555,7 +555,7 @@ of installing the extra ``.coq-native`` directories. This requires all dependencies to be themselves compiled with ``-native-compiler yes``. -Building a |Coq| project with Dune +Building a Coq project with Dune ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. note:: @@ -575,7 +575,7 @@ for your files. This involves adding a ``dune-project`` and ``pkg.opam`` file to the root (``pkg.opam`` can be empty or generated by Dune itself), and then providing ``dune`` files in the directories your ``.v`` files are placed. For the experimental version "0.1" of -the Coq Dune language, |Coq| library stanzas look like: +the Coq Dune language, Coq library stanzas look like: .. code:: scheme @@ -642,14 +642,14 @@ Computing Module dependencies ----------------------------- In order to compute module dependencies (to be used by ``make`` or -``dune``), |Coq| provides the ``coqdep`` tool. +``dune``), Coq provides the ``coqdep`` tool. -``coqdep`` computes inter-module dependencies for |Coq| +``coqdep`` computes inter-module dependencies for Coq programs, and prints the dependencies on the standard output in a format readable by make. When a directory is given as argument, it is recursively looked at. -Dependencies of |Coq| modules are computed by looking at ``Require`` +Dependencies of Coq modules are computed by looking at ``Require`` commands (``Require``, ``Require Export``, ``Require Import``), but also at the command ``Declare ML Module``. @@ -659,20 +659,20 @@ Both Dune and ``coq_makefile`` use ``coqdep`` to compute the dependencies among the files part of a Coq project. Embedded Coq phrases inside |Latex| documents ---------------------------------------------- +----------------------------------------------- When writing documentation about a proof development, one may want -to insert |Coq| phrases inside a |Latex| document, possibly together +to insert Coq phrases inside a |Latex| document, possibly together with the corresponding answers of the system. We provide a mechanical -way to process such |Coq| phrases embedded in |Latex| files: the ``coq-tex`` -filter. This filter extracts |Coq| phrases embedded in |Latex| files, +way to process such Coq phrases embedded in |Latex| files: the ``coq-tex`` +filter. This filter extracts Coq phrases embedded in |Latex| files, evaluates them, and insert the outcome of the evaluation after each phrase. -Starting with a file ``file.tex`` containing |Coq| phrases, the ``coq-tex`` +Starting with a file ``file.tex`` containing Coq phrases, the ``coq-tex`` filter produces a file named ``file.v.tex`` with the Coq outcome. -There are options to produce the |Coq| parts in smaller font, italic, +There are options to produce the Coq parts in smaller font, italic, between horizontal rules, etc. See the man page of ``coq-tex`` for more details. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index f18569c7fd..6464f085b8 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -60,7 +60,7 @@ The constructs in :token:`ltac_expr` are :term:`left associative`. ltac_expr3 ::= @l3_tactic | @ltac_expr2 ltac_expr2 ::= @ltac_expr1 + {| @ltac_expr2 | @binder_tactic } - | @ltac_expr1 || {| @ltac_expr2 | @binder_tactic } + | @ltac_expr1 %|| {| @ltac_expr2 | @binder_tactic } | @l2_tactic | @ltac_expr1 ltac_expr1 ::= @tactic_value @@ -161,7 +161,7 @@ Syntactic values Provides a way to use the syntax and semantics of a grammar nonterminal as a value in an :token:`ltac_expr`. The table below describes the most useful of these. You can see the others by running ":cmd:`Print Grammar` `tactic`" and -examining the part at the end under "Entry tactic:tactic_arg". +examining the part at the end under "Entry tactic:tactic_value". :token:`ident` name of a grammar nonterminal listed in the table @@ -729,7 +729,7 @@ First tactic to make progress: || Yet another way of branching without backtracking is the following structure: -.. tacn:: @ltac_expr1 || {| @ltac_expr2 | @binder_tactic } +.. tacn:: @ltac_expr1 %|| {| @ltac_expr2 | @binder_tactic } :name: || (first tactic making progress) :n:`@ltac_expr1 || @ltac_expr2` is @@ -879,7 +879,8 @@ Print/identity tactic: idtac .. tacn:: idtac {* {| @ident | @string | @natural } } :name: idtac - Leaves the proof unchanged and prints the given tokens. Strings and integers are printed + Leaves the proof unchanged and prints the given tokens. :token:`String<string>`\s + and :token:`natural`\s are printed literally. If :token:`ident` is an |Ltac| variable, its contents are printed; if not, it is an error. @@ -888,7 +889,7 @@ Print/identity tactic: idtac Failing ~~~~~~~ -.. tacn:: {| fail | gfail } {? @int_or_var } {* {| @ident | @string | @integer } } +.. tacn:: {| fail | gfail } {? @int_or_var } {* {| @ident | @string | @natural } } :name: fail; gfail :tacn:`fail` is the always-failing tactic: it does not solve any @@ -919,7 +920,7 @@ Failing the call to :tacn:`fail` :n:`@natural` is not enclosed in a :n:`+` construct, respecting the algebraic identity. - :n:`{* {| @ident | @string | @integer } }` + :n:`{* {| @ident | @string | @natural } }` The given tokens are used for printing the failure message. If :token:`ident` is an |Ltac| variable, its contents are printed; if not, it is an error. @@ -937,7 +938,7 @@ Failing .. todo the example is too long; could show the Goal True. Proof. once and hide the Aborts to shorten it. And add a line of text before each subexample. Perhaps add some very short - explanations/generalizations (eg gfail always fails; "tac; fail" succeeds but "fail." alone + explanations/generalizations (e.g. gfail always fails; "tac; fail" succeeds but "fail." alone fails. .. coqtop:: reset all fail @@ -1352,8 +1353,8 @@ Pattern matching on goals and hypotheses: match goal .. insertprodn goal_pattern match_hyp .. prodn:: - goal_pattern ::= {*, @match_hyp } |- @match_pattern - | [ {*, @match_hyp } |- @match_pattern ] + goal_pattern ::= {*, @match_hyp } %|- @match_pattern + | [ {*, @match_hyp } %|- @match_pattern ] | _ match_hyp ::= @name : @match_pattern | @name := @match_pattern @@ -1488,7 +1489,7 @@ Examples: match_context_rule ::= [ {*, @match_hyp } |- @match_pattern ] => @ltac_expr match_hyp ::= | @name := {? [ @match_pattern ] : } @match_pattern -.. todo PR The following items (up to numgoals) are part of "value_tactic". I'd like to make +.. todo The following items (up to numgoals) are part of "value_tactic". I'd like to make this a subsection and explain that they all return values. How do I get a 5th-level section title? Filling a term context @@ -1522,7 +1523,7 @@ produce subgoals but generates a term to be used in tactic expressions: Generating fresh hypothesis names ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tactics sometimes need to generate new names for hypothesis. Letting |Coq| +Tactics sometimes need to generate new names for hypothesis. Letting Coq choose a name with the intro tactic is not so good since it is very awkward to retrieve that name. The following expression returns an identifier: @@ -1729,6 +1730,8 @@ Defining |Ltac| symbols |Ltac| toplevel definitions are made as follows: +.. index:: ::= + .. cmd:: Ltac @tacdef_body {* with @tacdef_body } :name: Ltac @@ -1753,10 +1756,15 @@ Defining |Ltac| symbols Defines a user-defined symbol, but gives an error if the symbol has already been defined. -.. todo apparent inconsistency: "Ltac intros := idtac" seems like it redefines/hides an existing tactic, - but in fact it creates a tactic which can only be called by it's qualified name. This is true in general - of tactic notations. The only way to overwrite most primitive tactics, and any user-defined tactic - notation, is with another tactic notation. + .. todo apparent inconsistency: + + "Ltac intros := idtac" seems like it redefines/hides an + existing tactic, but in fact it creates a tactic which can + only be called by its qualified name. This is true in + general of tactic notations. The only way to overwrite most + primitive tactics, and any user-defined tactic notation, is + with another tactic notation. + .. exn:: There is already an Ltac named @qualid :undocumented: @@ -1766,7 +1774,8 @@ Defining |Ltac| symbols do not count as user-defined tactics for `::=`. If :attr:`local` is not specified, the redefinition applies across module boundaries. - .. exn: There is no Ltac named @qualid + .. exn:: There is no Ltac named @qualid + :undocumented: :n:`{* with @tacdef_body }` Permits definition of mutually recursive tactics. diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 773e393eb6..a46f4fb894 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -3,8 +3,8 @@ Ltac2 ===== -The Ltac tactic language is probably one of the ingredients of the success of -Coq, yet it is at the same time its Achilles' heel. Indeed, Ltac: +The |Ltac| tactic language is probably one of the ingredients of the success of +Coq, yet it is at the same time its Achilles' heel. Indeed, |Ltac|: - has often unclear semantics - is very non-uniform due to organic growth @@ -38,7 +38,6 @@ Current limitations include: - Printing functions are limited and awkward to use. Only a few data types are printable. - Deep pattern matching and matching on tuples don't work. - - If statements on Ltac2 boolean values - A convenient way to build terms with casts through the low-level API. Because the cast type is opaque, building terms with casts currently requires an awkward construction like the following, which also incurs extra overhead to repeat typechecking for each @@ -228,7 +227,7 @@ One can define new types with the following commands. :name: Ltac2 external Declares abstract terms. Frequently, these declare OCaml functions - defined in |Coq| and give their type information. They can also declare + defined in Coq and give their type information. They can also declare data structures from OCaml. This command has no use for the end user. APIs @@ -345,12 +344,10 @@ Ltac2 Definitions .. coqtop:: all - Ltac2 mutable rec f b := match b with true => 0 | _ => f true end. - Ltac2 Set f := fun b => - match b with true => 1 | _ => f true end. + Ltac2 mutable rec f b := if b then 0 else f true. + Ltac2 Set f := fun b => if b then 1 else f true. Ltac2 Eval (f false). - Ltac2 Set f as oldf := fun b => - match b with true => 2 | _ => oldf false end. + Ltac2 Set f as oldf := fun b => if b then 2 else oldf false. Ltac2 Eval (f false). In the definition, the `f` in the body is resolved statically @@ -537,7 +534,7 @@ aware of bound variables and must use heuristics to decide whether a variable is a proper one or referring to something in the Ltac context. Likewise, in Ltac1, constr parsing is implicit, so that ``foo 0`` is -not ``foo`` applied to the Ltac integer expression ``0`` (Ltac does have a +not ``foo`` applied to the Ltac integer expression ``0`` (|Ltac| does have a notion of integers, though it is not first-class), but rather the Coq term :g:`Datatypes.O`. @@ -565,7 +562,7 @@ Built-in quotations | ltac1 : ( @ltac1_expr_in_env ) | ltac1val : ( @ltac1_expr_in_env ) ltac1_expr_in_env ::= @ltac_expr - | {* @ident } |- @ltac_expr + | {* @ident } %|- @ltac_expr The current implementation recognizes the following built-in quotations: @@ -981,7 +978,7 @@ Match over goals .. prodn:: goal_match_list ::= {? %| } {+| @gmatch_rule } gmatch_rule ::= @gmatch_pattern => @ltac2_expr - gmatch_pattern ::= [ {*, @gmatch_hyp_pattern } |- @ltac2_match_pattern ] + gmatch_pattern ::= [ {*, @gmatch_hyp_pattern } %|- @ltac2_match_pattern ] gmatch_hyp_pattern ::= @name : @ltac2_match_pattern Matches over goals, similar to Ltac1 :tacn:`match goal`. @@ -1149,6 +1146,13 @@ Match on values | @tac2pat1 , {*, @tac2pat1 } | @tac2pat1 +.. tacn:: if @ltac2_expr5__test then @ltac2_expr5__then else @ltac2_expr5__else + :name: if-then-else (Ltac2) + + Equivalent to a :tacn:`match <match (Ltac2)>` on a boolean value. If the + :n:`@ltac2_expr5__test` evaluates to true, :n:`@ltac2_expr5__then` + is evaluated. Otherwise :n:`@ltac2_expr5__else` is evaluated. + .. note:: For now, deep pattern matching is not implemented. @@ -1182,7 +1186,7 @@ Notations into the right-hand side. The right-hand side is typechecked when the notation is used, not when it is defined. In the following example, `x` is the formal parameter name and `constr` is its :ref:`syntactic class<syntactic_classes>`. `print` and `of_constr` are - functions provided by |Coq| through `Message.v`. + functions provided by Coq through `Message.v`. .. todo "print" doesn't seem to pay attention to "Set Printing All" @@ -1281,7 +1285,7 @@ Abbreviations Defining tactics ~~~~~~~~~~~~~~~~ -Built-in tactics (those defined in OCaml code in the |Coq| executable) and Ltac1 tactics, +Built-in tactics (those defined in OCaml code in the Coq executable) and Ltac1 tactics, which are defined in `.v` files, must be defined through notations. (Ltac2 tactics can be defined with :cmd:`Ltac2`. @@ -1289,7 +1293,7 @@ Notations for many but not all built-in tactics are defined in `Notations.v`, wh loaded with Ltac2. The Ltac2 syntax for these tactics is often identical or very similar to the tactic syntax described in other chapters of this documentation. These notations rely on tactic functions declared in `Std.v`. Functions corresponding to some built-in tactics may not yet be defined in the -|Coq| executable or declared in `Std.v`. Adding them may require code changes to |Coq| or defining +Coq executable or declared in `Std.v`. Adding them may require code changes to Coq or defining workarounds through Ltac1 (described below). Two examples of syntax differences: @@ -1321,7 +1325,7 @@ Syntactic classes ~~~~~~~~~~~~~~~~~ The simplest syntactic classes in Ltac2 notations represent individual nonterminals -from the |Coq| grammar. Only a few selected nonterminals are available as syntactic classes. +from the Coq grammar. Only a few selected nonterminals are available as syntactic classes. In addition, there are metasyntactic operations for describing more complex syntax, such as making an item optional or representing a list of items. When parsing, each syntactic class expression returns a value that's bound to a name in the @@ -1598,8 +1602,8 @@ Here is the syntax for the :n:`q_*` nonterminals: ltac2_clause ::= in @ltac2_in_clause | at @ltac2_occs_nums ltac2_in_clause ::= * {? @ltac2_occs } - | * |- {? @ltac2_concl_occ } - | {*, @ltac2_hypident_occ } {? |- {? @ltac2_concl_occ } } + | * %|- {? @ltac2_concl_occ } + | {*, @ltac2_hypident_occ } {? %|- {? @ltac2_concl_occ } } .. insertprodn q_occurrences ltac2_hypident @@ -1629,7 +1633,7 @@ Here is the syntax for the :n:`q_*` nonterminals: .. insertprodn ltac2_oriented_rewriter ltac2_rewriter .. prodn:: - ltac2_oriented_rewriter ::= {| -> | <- } @ltac2_rewriter + ltac2_oriented_rewriter ::= {? {| -> | <- } } @ltac2_rewriter ltac2_rewriter ::= {? @natural } {? {| ? | ! } } @ltac2_constr_with_bindings .. insertprodn ltac2_for_each_goal ltac2_goal_tactics diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index edd93f2266..7f5aacbfdb 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -1,914 +1,5 @@ -.. _proofhandling: +:orphan: -------------------- - Proof handling -------------------- +.. raw:: html -In |Coq|’s proof editing mode all top-level commands documented in -Chapter :ref:`vernacularcommands` remain available and the user has access to specialized -commands dealing with proof development pragmas documented in this -section. They can also use some other specialized commands called -*tactics*. They are the very tools allowing the user to deal with -logical reasoning. They are documented in Chapter :ref:`tactics`. - -Coq user interfaces usually have a way of marking whether the user has -switched to proof editing mode. For instance, in coqtop the prompt ``Coq <`` is changed into -:n:`@ident <` where :token:`ident` is the declared name of the theorem currently edited. - -At each stage of a proof development, one has a list of goals to -prove. Initially, the list consists only in the theorem itself. After -having applied some tactics, the list of goals contains the subgoals -generated by the tactics. - -To each subgoal is associated a number of hypotheses called the *local context* -of the goal. Initially, the local context contains the local variables and -hypotheses of the current section (see Section :ref:`gallina-assumptions`) and -the local variables and hypotheses of the theorem statement. It is enriched by -the use of certain tactics (see e.g. :tacn:`intro`). - -When a proof is completed, the message ``Proof completed`` is displayed. -One can then register this proof as a defined constant in the -environment. Because there exists a correspondence between proofs and -terms of λ-calculus, known as the *Curry-Howard isomorphism* -:cite:`How80,Bar81,Gir89,H89`, |Coq| stores proofs as terms of |Cic|. Those -terms are called *proof terms*. - - -.. exn:: No focused proof. - - Coq raises this error message when one attempts to use a proof editing command - out of the proof editing mode. - -.. _proof-editing-mode: - -Entering and leaving proof editing mode ---------------------------------------- - -The proof editing mode is entered by asserting a statement, which typically is -the assertion of a theorem using an assertion command like :cmd:`Theorem`. The -list of assertion commands is given in :ref:`Assertions`. The command -:cmd:`Goal` can also be used. - -.. cmd:: Goal @form - - This is intended for quick assertion of statements, without knowing in - advance which name to give to the assertion, typically for quick - testing of the provability of a statement. If the proof of the - statement is eventually completed and validated, the statement is then - bound to the name ``Unnamed_thm`` (or a variant of this name not already - used for another statement). - -.. cmd:: Qed - - This command is available in interactive editing proof mode when the - proof is completed. Then :cmd:`Qed` extracts a proof term from the proof - script, switches back to Coq top-level and attaches the extracted - proof term to the declared name of the original goal. This name is - added to the environment as an opaque constant. - - .. exn:: Attempt to save an incomplete proof. - :undocumented: - - .. note:: - - Sometimes an error occurs when building the proof term, because - tactics do not enforce completely the term construction - constraints. - - The user should also be aware of the fact that since the - proof term is completely rechecked at this point, one may have to wait - a while when the proof is large. In some exceptional cases one may - even incur a memory overflow. - -.. cmd:: Defined - - Same as :cmd:`Qed`, except the proof is made *transparent*, which means - that its content can be explicitly used for type checking and that it can be - unfolded in conversion tactics (see :ref:`performingcomputations`, - :cmd:`Opaque`, :cmd:`Transparent`). - -.. cmd:: Save @ident - :name: Save - - Saves a completed proof with the name :token:`ident`. - -.. cmd:: Admitted - - This command is available in interactive editing mode to give up - the current proof and declare the initial goal as an axiom. - -.. cmd:: Abort - - This command cancels the current proof development, switching back to - the previous proof development, or to the |Coq| toplevel if no other - proof was edited. - - .. exn:: No focused proof (No proof-editing in progress). - :undocumented: - - .. cmdv:: Abort @ident - - Aborts the editing of the proof named :token:`ident` (in case you have - nested proofs). - - .. seealso:: :flag:`Nested Proofs Allowed` - - .. cmdv:: Abort All - - Aborts all current goals. - -.. cmd:: Proof @term - :name: Proof `term` - - This command applies in proof editing mode. It is equivalent to - :n:`exact @term. Qed.` - That is, you have to give the full proof in one gulp, as a - proof term (see Section :ref:`applyingtheorems`). - - .. warning:: - - Use of this command is discouraged. In particular, it - doesn't work in Proof General because it must - immediately follow the command that opened proof mode, but - Proof General inserts :cmd:`Unset` :flag:`Silent` before it (see - `Proof General issue #498 - <https://github.com/ProofGeneral/PG/issues/498>`_). - -.. cmd:: Proof - - Is a no-op which is useful to delimit the sequence of tactic commands - which start a proof, after a :cmd:`Theorem` command. It is a good practice to - use :cmd:`Proof` as an opening parenthesis, closed in the script with a - closing :cmd:`Qed`. - - .. seealso:: :cmd:`Proof with` - -.. cmd:: Proof using {+ @ident } - - This command applies in proof editing mode. It declares the set of - section variables (see :ref:`gallina-assumptions`) used by the proof. - At :cmd:`Qed` time, the - system will assert that the set of section variables actually used in - the proof is a subset of the declared one. - - The set of declared variables is closed under type dependency. For - example, if ``T`` is a variable and ``a`` is a variable of type - ``T``, then the commands ``Proof using a`` and ``Proof using T a`` - are equivalent. - - The set of declared variables always includes the variables used by - the statement. In other words ``Proof using e`` is equivalent to - ``Proof using Type + e`` for any declaration expression ``e``. - - .. cmdv:: Proof using {+ @ident } with @tactic - - Combines in a single line :cmd:`Proof with` and :cmd:`Proof using`. - - .. seealso:: :ref:`tactics-implicit-automation` - - .. cmdv:: Proof using All - - Use all section variables. - - .. cmdv:: Proof using {? Type } - - Use only section variables occurring in the statement. - - .. cmdv:: Proof using Type* - - The ``*`` operator computes the forward transitive closure. E.g. if the - variable ``H`` has type ``p < 5`` then ``H`` is in ``p*`` since ``p`` occurs in the type - of ``H``. ``Type*`` is the forward transitive closure of the entire set of - section variables occurring in the statement. - - .. cmdv:: Proof using -({+ @ident }) - - Use all section variables except the list of :token:`ident`. - - .. cmdv:: Proof using @collection__1 + @collection__2 - - Use section variables from the union of both collections. - See :ref:`nameaset` to know how to form a named collection. - - .. cmdv:: Proof using @collection__1 - @collection__2 - - Use section variables which are in the first collection but not in the - second one. - - .. cmdv:: Proof using @collection - ({+ @ident }) - - Use section variables which are in the first collection but not in the - list of :token:`ident`. - - .. cmdv:: Proof using @collection * - - Use section variables in the forward transitive closure of the collection. - The ``*`` operator binds stronger than ``+`` and ``-``. - - -Proof using options -``````````````````` - -The following options modify the behavior of ``Proof using``. - - -.. opt:: Default Proof Using "@collection" - :name: Default Proof Using - - Use :n:`@collection` as the default ``Proof using`` value. E.g. ``Set Default - Proof Using "a b"`` will complete all ``Proof`` commands not followed by a - ``using`` part with ``using a b``. - - -.. flag:: Suggest Proof Using - - When :cmd:`Qed` is performed, suggest a ``using`` annotation if the user did not - provide one. - -.. _`nameaset`: - -Name a set of section hypotheses for ``Proof using`` -```````````````````````````````````````````````````` - -.. cmd:: Collection @ident := @collection - - This can be used to name a set of section - hypotheses, with the purpose of making ``Proof using`` annotations more - compact. - - .. example:: - - Define the collection named ``Some`` containing ``x``, ``y`` and ``z``:: - - Collection Some := x y z. - - Define the collection named ``Fewer`` containing only ``x`` and ``y``:: - - Collection Fewer := Some - z - - Define the collection named ``Many`` containing the set union or set - difference of ``Fewer`` and ``Some``:: - - Collection Many := Fewer + Some - Collection Many := Fewer - Some - - Define the collection named ``Many`` containing the set difference of - ``Fewer`` and the unnamed collection ``x y``:: - - Collection Many := Fewer - (x y) - - - -.. cmd:: Existential @natural := @term - - This command instantiates an existential variable. :token:`natural` is an index in - the list of uninstantiated existential variables displayed by :cmd:`Show Existentials`. - - This command is intended to be used to instantiate existential - variables when the proof is completed but some uninstantiated - existential variables remain. To instantiate existential variables - during proof edition, you should use the tactic :tacn:`instantiate`. - -.. 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. - -Proof modes -``````````` - -When entering proof mode through commands such as :cmd:`Goal` and :cmd:`Proof`, -|Coq| picks by default the |Ltac| mode. Nonetheless, there exist other proof modes -shipped in the standard |Coq| installation, and furthermore some plugins define -their own proof modes. The default proof mode used when opening a proof can -be changed using the following option. - -.. opt:: Default Proof Mode @string - :name: Default Proof Mode - - Select the proof mode to use when starting a proof. Depending on the proof - mode, various syntactic constructs are allowed when writing an interactive - proof. The possible option values are listed below. - - - "Classic": this is the default. It activates the |Ltac| language to interact - with the proof, and also allows vernacular commands. - - - "Noedit": this proof mode only allows vernacular commands. No tactic - language is activated at all. This is the default when the prelude is not - loaded, e.g. through the `-noinit` option for `coqc`. - - - "Ltac2": this proof mode is made available when requiring the Ltac2 - library, and is set to be the default when it is imported. It allows - to use the Ltac2 language, as well as vernacular commands. - - - Some external plugins also define their own proof mode, which can be - activated via this command. - -Navigation in the proof tree --------------------------------- - -.. cmd:: Undo - - This command cancels the effect of the last command. Thus, it - backtracks one step. - -.. cmdv:: Undo @natural - - Repeats Undo :token:`natural` times. - -.. cmdv:: Restart - :name: Restart - - This command restores the proof editing process to the original goal. - - .. exn:: No focused proof to restart. - :undocumented: - -.. cmd:: Focus - - This focuses the attention on the first subgoal to prove and the - printing of the other subgoals is suspended until the focused subgoal - is solved or unfocused. This is useful when there are many current - subgoals which clutter your screen. - - .. deprecated:: 8.8 - - Prefer the use of bullets or focusing brackets (see below). - -.. cmdv:: Focus @natural - - This focuses the attention on the :token:`natural` th subgoal to prove. - - .. deprecated:: 8.8 - - Prefer the use of focusing brackets with a goal selector (see below). - -.. cmd:: Unfocus - - This command restores to focus the goal that were suspended by the - last :cmd:`Focus` command. - - .. deprecated:: 8.8 - -.. cmd:: Unfocused - - Succeeds if the proof is fully unfocused, fails if there are some - goals out of focus. - -.. _curly-braces: - -.. index:: { - } - -.. cmd:: {| %{ | %} } - - The command ``{`` (without a terminating period) focuses on the first - goal, much like :cmd:`Focus` does, however, the subproof can only be - unfocused when it has been fully solved ( *i.e.* when there is no - focused goal left). Unfocusing is then handled by ``}`` (again, without a - terminating period). See also an example in the next section. - - Note that when a focused goal is proved a message is displayed - together with a suggestion about the right bullet or ``}`` to unfocus it - or focus the next one. - - .. cmdv:: @natural: %{ - - This focuses on the :token:`natural`\-th subgoal to prove. - - .. cmdv:: [@ident]: %{ - - This focuses on the named goal :token:`ident`. - - .. note:: - - Goals are just existential variables and existential variables do not - get a name by default. You can give a name to a goal by using :n:`refine ?[@ident]`. - You may also wrap this in an Ltac-definition like: - - .. coqtop:: in - - Ltac name_goal name := refine ?[name]. - - .. seealso:: :ref:`existential-variables` - - .. example:: - - This first example uses the Ltac definition above, and the named goals - only serve for documentation. - - .. coqtop:: all - - Goal forall n, n + 0 = n. - Proof. - induction n; [ name_goal base | name_goal step ]. - [base]: { - - .. coqtop:: all - - reflexivity. - - .. coqtop:: in - - } - - .. coqtop:: all - - [step]: { - - .. coqtop:: all - - simpl. - f_equal. - assumption. - } - Qed. - - This can also be a way of focusing on a shelved goal, for instance: - - .. coqtop:: all - - Goal exists n : nat, n = n. - eexists ?[x]. - reflexivity. - [x]: exact 0. - Qed. - - .. exn:: This proof is focused, but cannot be unfocused this way. - - You are trying to use ``}`` but the current subproof has not been fully solved. - - .. exn:: No such goal (@natural). - :undocumented: - - .. exn:: No such goal (@ident). - :undocumented: - - .. exn:: Brackets do not support multi-goal selectors. - - Brackets are used to focus on a single goal given either by its position - or by its name if it has one. - - .. seealso:: The error messages about bullets below. - -.. _bullets: - -Bullets -``````` - -Alternatively to ``{`` and ``}``, proofs can be structured with bullets. The -use of a bullet ``b`` for the first time focuses on the first goal ``g``, the -same bullet cannot be used again until the proof of ``g`` is completed, -then it is mandatory to focus the next goal with ``b``. The consequence is -that ``g`` and all goals present when ``g`` was focused are focused with the -same bullet ``b``. See the example below. - -Different bullets can be used to nest levels. The scope of bullet does -not go beyond enclosing ``{`` and ``}``, so bullets can be reused as further -nesting levels provided they are delimited by these. Bullets are made of -repeated ``-``, ``+`` or ``*`` symbols: - -.. prodn:: bullet ::= {| {+ - } | {+ + } | {+ * } } - -Note again that when a focused goal is proved a message is displayed -together with a suggestion about the right bullet or ``}`` to unfocus it -or focus the next one. - -.. note:: - - In Proof General (``Emacs`` interface to |Coq|), you must use - bullets with the priority ordering shown above to have a correct - indentation. For example ``-`` must be the outer bullet and ``**`` the inner - one in the example below. - -The following example script illustrates all these features: - -.. example:: - - .. coqtop:: all - - Goal (((True /\ True) /\ True) /\ True) /\ True. - Proof. - split. - - split. - + split. - ** { split. - - trivial. - - trivial. - } - ** trivial. - + trivial. - - assert True. - { trivial. } - assumption. - Qed. - -.. exn:: Wrong bullet @bullet__1: Current bullet @bullet__2 is not finished. - - Before using bullet :n:`@bullet__1` again, you should first finish proving - the current focused goal. - Note that :n:`@bullet__1` and :n:`@bullet__2` may be the same. - -.. exn:: Wrong bullet @bullet__1: Bullet @bullet__2 is mandatory here. - - You must put :n:`@bullet__2` to focus on the next goal. No other bullet is - allowed here. - -.. exn:: No such goal. Focus next goal with bullet @bullet. - - You tried to apply a tactic but no goals were under focus. - Using :n:`@bullet` is mandatory here. - -.. FIXME: the :noindex: below works around a Sphinx issue. - (https://github.com/sphinx-doc/sphinx/issues/4979) - It should be removed once that issue is fixed. - -.. exn:: No such goal. Try unfocusing with %}. - :noindex: - - You just finished a goal focused by ``{``, you must unfocus it with ``}``. - -Mandatory Bullets -````````````````` - -Using :opt:`Default Goal Selector` with the ``!`` selector forces -tactic scripts to keep focus to exactly one goal (e.g. using bullets) -or use explicit goal selectors. - -Set Bullet Behavior -``````````````````` -.. opt:: Bullet Behavior {| "None" | "Strict Subproofs" } - :name: Bullet Behavior - - This option controls the bullet behavior and can take two possible values: - - - "None": this makes bullets inactive. - - "Strict Subproofs": this makes bullets active (this is the default behavior). - -.. _requestinginformation: - -Requesting information ----------------------- - - -.. cmd:: Show - - This command displays the current goals. - - .. exn:: No focused proof. - :undocumented: - - .. cmdv:: Show @natural - - Displays only the :token:`natural`\-th subgoal. - - .. exn:: No such goal. - :undocumented: - - .. cmdv:: Show @ident - - Displays the named goal :token:`ident`. This is useful in - particular to display a shelved goal but only works if the - corresponding existential variable has been named by the user - (see :ref:`existential-variables`) as in the following example. - - .. example:: - - .. coqtop:: all abort - - Goal exists n, n = 0. - eexists ?[n]. - Show n. - - .. cmdv:: Show Proof {? Diffs {? removed } } - :name: Show Proof - - Displays the proof term generated by the tactics - that have been applied so far. If the proof is incomplete, the term - will contain holes, which correspond to subterms which are still to be - constructed. Each hole is an existential variable, which appears as a - question mark followed by an identifier. - - Specifying “Diffs” highlights the difference between the - current and previous proof step. By default, the command shows the - output once with additions highlighted. Including “removed” shows - the output twice: once showing removals and once showing additions. - It does not examine the :opt:`Diffs` option. See :ref:`showing_proof_diffs`. - - .. cmdv:: Show Conjectures - :name: Show Conjectures - - It prints the list of the names of all the - theorems that are currently being proved. As it is possible to start - proving a previous lemma during the proof of a theorem, this list may - contain several names. - - .. cmdv:: Show Intro - :name: Show Intro - - If the current goal begins by at least one product, - this command prints the name of the first product, as it would be - generated by an anonymous :tacn:`intro`. The aim of this command is to ease - the writing of more robust scripts. For example, with an appropriate - Proof General macro, it is possible to transform any anonymous :tacn:`intro` - into a qualified one such as ``intro y13``. In the case of a non-product - goal, it prints nothing. - - .. cmdv:: Show Intros - :name: Show Intros - - This command is similar to the previous one, it - simulates the naming process of an :tacn:`intros`. - - .. cmdv:: Show Existentials - :name: Show Existentials - - Displays all open goals / existential variables in the current proof - along with the type and the context of each variable. - - .. cmdv:: Show Match @ident - - This variant displays a template of the Gallina - ``match`` construct with a branch for each constructor of the type - :token:`ident` - - .. example:: - - .. coqtop:: all - - Show Match nat. - - .. exn:: Unknown inductive type. - :undocumented: - - .. cmdv:: Show Universes - :name: Show Universes - - It displays the set of all universe constraints and - its normalized form at the current stage of the proof, useful for - debugging universe inconsistencies. - - .. cmdv:: Show Goal @natural at @natural - :name: Show Goal - - This command is only available in coqtop. Displays a goal at a - proof state using the goal ID number and the proof state ID number. - It is primarily for use by tools such as Prooftree that need to fetch - goal history in this way. Prooftree is a tool for visualizing a proof - as a tree that runs in Proof General. - -.. cmd:: Guarded - - Some tactics (e.g. :tacn:`refine`) allow to build proofs using - fixpoint or co-fixpoint constructions. Due to the incremental nature - of interactive proof construction, the check of the termination (or - guardedness) of the recursive calls in the fixpoint or cofixpoint - constructions is postponed to the time of the completion of the proof. - - The command :cmd:`Guarded` allows checking if the guard condition for - fixpoint and cofixpoint is violated at some time of the construction - of the proof without having to wait the completion of the proof. - -.. _showing_diffs: - -Showing differences between proof steps ---------------------------------------- - -Coq can automatically highlight the differences between successive proof steps -and between values in some error messages. Coq can also highlight differences -in the proof term. -For example, the following screenshots of CoqIDE and coqtop show the application -of the same :tacn:`intros` tactic. The tactic creates two new hypotheses, highlighted in green. -The conclusion is entirely in pale green because although it’s changed, no tokens were added -to it. The second screenshot uses the "removed" option, so it shows the conclusion a -second time with the old text, with deletions marked in red. Also, since the hypotheses are -new, no line of old text is shown for them. - -.. comment screenshot produced with: - Inductive ev : nat -> Prop := - | ev_0 : ev 0 - | ev_SS : forall n : nat, ev n -> ev (S (S n)). - - Fixpoint double (n:nat) := - match n with - | O => O - | S n' => S (S (double n')) - end. - - Goal forall n, ev n -> exists k, n = double k. - intros n E. - -.. - - .. image:: ../_static/diffs-coqide-on.png - :alt: |CoqIDE| with Set Diffs on - -.. - - .. image:: ../_static/diffs-coqide-removed.png - :alt: |CoqIDE| with Set Diffs removed - -.. - - .. image:: ../_static/diffs-coqtop-on3.png - :alt: coqtop with Set Diffs on - -This image shows an error message with diff highlighting in CoqIDE: - -.. - - .. image:: ../_static/diffs-error-message.png - :alt: |CoqIDE| error message with diffs - -How to enable diffs -``````````````````` - -.. opt:: Diffs {| "on" | "off" | "removed" } - :name: Diffs - - The “on” setting highlights added tokens in green, while the “removed” setting - additionally reprints items with removed tokens in red. Unchanged tokens in - modified items are shown with pale green or red. Diffs in error messages - use red and green for the compared values; they appear regardless of the setting. - (Colors are user-configurable.) - -For coqtop, showing diffs can be enabled when starting coqtop with the -``-diffs on|off|removed`` command-line option or by setting the :opt:`Diffs` option -within Coq. You will need to provide the ``-color on|auto`` command-line option when -you start coqtop in either case. - -Colors for coqtop can be configured by setting the ``COQ_COLORS`` environment -variable. See section :ref:`customization-by-environment-variables`. Diffs -use the tags ``diff.added``, ``diff.added.bg``, ``diff.removed`` and ``diff.removed.bg``. - -In CoqIDE, diffs should be enabled from the ``View`` menu. Don’t use the ``Set Diffs`` -command in CoqIDE. You can change the background colors shown for diffs from the -``Edit | Preferences | Tags`` panel by changing the settings for the ``diff.added``, -``diff.added.bg``, ``diff.removed`` and ``diff.removed.bg`` tags. This panel also -lets you control other attributes of the highlights, such as the foreground -color, bold, italic, underline and strikeout. - -As of June 2019, Proof General can also display Coq-generated proof diffs automatically. -Please see the PG documentation section -"`Showing Proof Diffs" <https://proofgeneral.github.io/doc/master/userman/Coq-Proof-General#Showing-Proof-Diffs>`_) -for details. - -How diffs are calculated -```````````````````````` - -Diffs are calculated as follows: - -1. Select the old proof state to compare to, which is the proof state before - the last tactic that changed the proof. Changes that only affect the view - of the proof, such as ``all: swap 1 2``, are ignored. - -2. For each goal in the new proof state, determine what old goal to compare - it to—the one it is derived from or is the same as. Match the hypotheses by - name (order is ignored), handling compacted items specially. - -3. For each hypothesis and conclusion (the “items”) in each goal, pass - them as strings to the lexer to break them into tokens. Then apply the - Myers diff algorithm :cite:`Myers` on the tokens and add appropriate highlighting. - -Notes: - -* Aside from the highlights, output for the "on" option should be identical - to the undiffed output. -* Goals completed in the last proof step will not be shown even with the - "removed" setting. - -.. comment The following screenshots show diffs working with multiple goals and with compacted - hypotheses. In the first one, notice that the goal ``P 1`` is not highlighted at - all after the split because it has not changed. - - .. todo: Use this script and remove the screenshots when COQ_COLORS - works for coqtop in sphinx - .. coqtop:: none - - Set Diffs "on". - Parameter P : nat -> Prop. - Goal P 1 /\ P 2 /\ P 3. - - .. coqtop:: out - - split. - - .. coqtop:: all abort - - 2: split. - - .. - - .. coqtop:: none - - Set Diffs "on". - Goal forall n m : nat, n + m = m + n. - Set Diffs "on". - - .. coqtop:: out - - intros n. - - .. coqtop:: all abort - - intros m. - -This screen shot shows the result of applying a :tacn:`split` tactic that replaces one goal -with 2 goals. Notice that the goal ``P 1`` is not highlighted at all after -the split because it has not changed. - -.. - - .. image:: ../_static/diffs-coqide-multigoal.png - :alt: coqide with Set Diffs on with multiple goals - -Diffs may appear like this after applying a :tacn:`intro` tactic that results -in a compacted hypotheses: - -.. - - .. image:: ../_static/diffs-coqide-compacted.png - :alt: coqide with Set Diffs on with compacted hypotheses - -.. _showing_proof_diffs: - -"Show Proof" differences -```````````````````````` - -To show differences in the proof term: - -- In coqtop and Proof General, use the :cmd:`Show Proof` `Diffs` command. - -- In CoqIDE, position the cursor on or just after a tactic to compare the proof term - after the tactic with the proof term before the tactic, then select - `View / Show Proof` from the menu or enter the associated key binding. - Differences will be shown applying the current `Show Diffs` setting - from the `View` menu. If the current setting is `Don't show diffs`, diffs - will not be shown. - - Output with the "added and removed" option looks like this: - - .. - - .. image:: ../_static/diffs-show-proof.png - :alt: coqide with Set Diffs on with compacted hypotheses - -Controlling the effect of proof editing commands ------------------------------------------------- - - -.. opt:: Hyps Limit @natural - :name: Hyps Limit - - This option controls the maximum number of hypotheses displayed in goals - after the application of a tactic. All the hypotheses remain usable - in the proof development. - When unset, it goes back to the default mode which is to print all - available hypotheses. - - -.. flag:: Nested Proofs Allowed - - When turned on (it is off by default), this flag enables support for nested - proofs: a new assertion command can be inserted before the current proof is - finished, in which case Coq will temporarily switch to the proof of this - *nested lemma*. When the proof of the nested lemma is finished (with :cmd:`Qed` - or :cmd:`Defined`), its statement will be made available (as if it had been - proved before starting the previous proof) and Coq will switch back to the - proof of the previous assertion. - -.. flag:: Printing Goal Names - - When turned on, the name of the goal is printed in interactive - proof mode, which can be useful in cases of cross references - between goals. - -Controlling memory usage ------------------------- - -.. cmd:: Print Debug GC - - Prints heap usage statistics, which are values from the `stat` type of the `Gc` module - described - `here <https://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#TYPEstat>`_ - in the OCaml documentation. - The `live_words`, `heap_words` and `top_heap_words` values give the basic information. - Words are 8 bytes or 4 bytes, respectively, for 64- and 32-bit executables. - -When experiencing high memory usage the following commands can be used -to force |Coq| to optimize some of its internal data structures. - -.. cmd:: Optimize Proof - - Shrink the data structure used to represent the current proof. - - -.. cmd:: Optimize Heap - - Perform a heap compaction. This is generally an expensive operation. - See: `OCaml Gc.compact <http://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#VALcompact>`_ - There is also an analogous tactic :tacn:`optimize_heap`. - -Memory usage parameters can be set through the :ref:`OCAMLRUNPARAM <OCAMLRUNPARAM>` -environment variable. + <meta http-equiv="refresh" content="0;URL=../proofs/writing-proofs/proof-mode.html"> diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index ca50a02562..07c2d268c6 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -13,12 +13,12 @@ Introduction This chapter describes a set of tactics known as |SSR| originally designed to provide support for the so-called *small scale reflection* proof methodology. Despite the original purpose this set of tactic is -of general interest and is available in |Coq| starting from version 8.7. +of general interest and is available in Coq starting from version 8.7. |SSR| was developed independently of the tactics described in Chapter :ref:`tactics`. Indeed the scope of the tactics part of |SSR| largely overlaps with the standard set of tactics. Eventually the overlap will -be reduced in future releases of |Coq|. +be reduced in future releases of Coq. Proofs written in |SSR| typically look quite different from the ones written using only tactics as per Chapter :ref:`tactics`. We try to @@ -112,7 +112,7 @@ Compatibility issues ~~~~~~~~~~~~~~~~~~~~ Requiring the above modules creates an environment which is mostly -compatible with the rest of |Coq|, up to a few discrepancies: +compatible with the rest of Coq, up to a few discrepancies: + New keywords (``is``) might clash with variable, constant, tactic or @@ -124,11 +124,11 @@ compatible with the rest of |Coq|, up to a few discrepancies: + Identifiers with both leading and trailing ``_``, such as ``_x_``, are reserved by |SSR| and cannot appear in scripts. + The extensions to the :tacn:`rewrite` tactic are partly incompatible with those - available in current versions of |Coq|; in particular: ``rewrite .. in + available in current versions of Coq; in particular: ``rewrite .. in (type of k)`` or ``rewrite .. in *`` or any other variant of :tacn:`rewrite` will not work, and the |SSR| syntax and semantics for occurrence selection and rule chaining is different. Use an explicit rewrite direction - (``rewrite <- …`` or ``rewrite -> …``) to access the |Coq| rewrite tactic. + (``rewrite <- …`` or ``rewrite -> …``) to access the Coq rewrite tactic. + New symbols (``//``, ``/=``, ``//=``) might clash with adjacent existing symbols. This can be avoided by inserting white spaces. @@ -176,16 +176,16 @@ compatible with the rest of |Coq|, up to a few discrepancies: create such identifiers. Disabling the flag generates a warning instead, increasing compatibility with other parts of Coq. -|Gallina| extensions +Gallina extensions -------------------- Small-scale reflection makes an extensive use of the programming -subset of |Gallina|, |Coq|’s logical specification language. This subset +subset of Gallina, Coq’s logical specification language. This subset is quite suited to the description of functions on representations, because it closely follows the well-established design of the ML programming language. The |SSR| extension provides three additions -to |Gallina|, for pattern assignment, pattern testing, and polymorphism; -these mitigate minor but annoying discrepancies between |Gallina| and +to Gallina, for pattern assignment, pattern testing, and polymorphism; +these mitigate minor but annoying discrepancies between Gallina and ML. @@ -199,7 +199,7 @@ irrefutable pattern matching, that is, destructuring assignment: term += let: @pattern := @term in @term Note the colon ``:`` after the ``let`` keyword, which avoids any ambiguity -with a function definition or |Coq|’s basic destructuring let. The let: +with a function definition or Coq’s basic destructuring let. The let: construct differs from the latter in that @@ -237,7 +237,7 @@ construct differs from the latter in that The ``let:`` construct is just (more legible) notation for the primitive -|Gallina| expression :n:`match @term with @pattern => @term end`. +Gallina expression :n:`match @term with @pattern => @term end`. The |SSR| destructuring assignment supports all the dependent match annotations; the full syntax is @@ -294,10 +294,10 @@ example, the null and all list function(al)s can be defined as follows: The pattern conditional also provides a notation for destructuring assignment with a refutable pattern, adapted to the pure functional -setting of |Gallina|, which lacks a ``Match_Failure`` exception. +setting of Gallina, which lacks a ``Match_Failure`` exception. Like ``let:`` above, the ``if…is`` construct is just (more legible) notation -for the primitive |Gallina| expression +for the primitive Gallina expression :n:`match @term with @pattern => @term | _ => @term end`. Similarly, it will always be displayed as the expansion of this form @@ -355,15 +355,15 @@ Note that :token:`pattern` eventually binds variables in the third Parametric polymorphism ~~~~~~~~~~~~~~~~~~~~~~~ -Unlike ML, polymorphism in core |Gallina| is explicit: the type +Unlike ML, polymorphism in core Gallina is explicit: the type parameters of polymorphic functions must be declared explicitly, and -supplied at each point of use. However, |Coq| provides two features to +supplied at each point of use. However, Coq provides two features to suppress redundant parameters: + Sections are used to provide (possibly implicit) parameters for a set of definitions. -+ Implicit arguments declarations are used to tell |Coq| to use type ++ Implicit arguments declarations are used to tell Coq to use type inference to deduce some parameters from the context at each point of call. @@ -392,11 +392,11 @@ expressions such as Definition all_null (s : list T) := all (@null T) s. Unfortunately, such higher-order expressions are quite frequent in -representation functions, especially those which use |Coq|'s +representation functions, especially those which use Coq's ``Structures`` to emulate Haskell typeclasses. -Therefore, |SSR| provides a variant of |Coq|’s implicit argument -declaration, which causes |Coq| to fill in some implicit parameters at +Therefore, |SSR| provides a variant of Coq’s implicit argument +declaration, which causes Coq to fill in some implicit parameters at each point of use, e.g., the above definition can be written: .. example:: @@ -432,7 +432,7 @@ The syntax of the new declaration is As these prenex implicit arguments are ubiquitous and have often large display strings, it is strongly recommended to change the default - display settings of |Coq| so that they are not printed (except after + display settings of Coq so that they are not printed (except after a ``Set Printing All`` command). All |SSR| library files thus start with the incantation @@ -957,7 +957,7 @@ context. This is essential in the context of an interactive development environment (IDE), because it facilitates navigating the proof, allowing to instantly "jump back" to the point at which a questionable assumption was added, and to find relevant assumptions by -browsing the pruned context. While novice or casual |Coq| users may find +browsing the pruned context. While novice or casual Coq users may find the automatic name selection feature convenient, the usage of such a feature severely undermines the readability and maintainability of proof scripts, much like automatic variable declaration in programming @@ -973,7 +973,7 @@ the foundation of the |SSR| proof language. Bookkeeping ~~~~~~~~~~~ -During the course of a proof |Coq| always present the user with a +During the course of a proof Coq always present the user with a *sequent* whose general form is:: ci : Ti @@ -1015,7 +1015,7 @@ are *ordered*, but *unnamed*: the display names of variables may change at any time because of α-conversion. Similarly, basic deductive steps such as apply can only operate on the -goal because the |Gallina| terms that control their action (e.g., the +goal because the Gallina terms that control their action (e.g., the type of the lemma used by ``apply``) only provide unnamed bound variables. [#2]_ Since the proof script can only refer directly to the context, it must constantly shift declarations from the goal to the context and @@ -1083,7 +1083,7 @@ simultaneously renames ``m`` and ``le_m_n`` into ``p`` and ``le_n_p``, respectively, by first turning them into unnamed variables, then turning these variables back into constants and facts. -Furthermore, |SSR| redefines the basic |Coq| tactics ``case``, ``elim``, +Furthermore, |SSR| redefines the basic Coq tactics ``case``, ``elim``, and ``apply`` so that they can take better advantage of ``:`` and ``=>``. In there |SSR| variants, these tactic operate on the first variable or @@ -1421,7 +1421,7 @@ Therefore this tactic changes any goal ``G`` into forall n n0 : nat, n = n0 -> G. -where the name ``n0`` is picked by the |Coq| display function, and assuming +where the name ``n0`` is picked by the Coq display function, and assuming ``n`` appeared only in ``G``. Finally, note that a discharge operation generalizes defined constants @@ -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 `````````````` @@ -1927,7 +1930,7 @@ When the top assumption of a goal has an inductive type, two specific operations are possible: the case analysis performed by the :tacn:`case` tactic, and the application of an induction principle, performed by the :tacn:`elim` tactic. When this top assumption has an inductive type, which -is moreover an instance of a type family, |Coq| may need help from the +is moreover an instance of a type family, Coq may need help from the user to specify which occurrences of the parameters of the type should be substituted. @@ -2055,7 +2058,7 @@ Control flow Indentation and bullets ~~~~~~~~~~~~~~~~~~~~~~~ -A linear development of |Coq| scripts gives little information on the +A linear development of Coq scripts gives little information on the structure of the proof. In addition, replaying a proof after some changes in the statement to be proved will usually not display information to distinguish between the various branches of case @@ -3391,7 +3394,7 @@ rewrite operations prescribed by the rules on the current goal. Indeed rule ``eqab`` is the first to apply among the ones gathered in the tuple passed to the rewrite tactic. This multirule - ``(eqab, eqac)`` is actually a |Coq| term and we can name it with a + ``(eqab, eqac)`` is actually a Coq term and we can name it with a definition: .. coqtop:: all @@ -3529,11 +3532,11 @@ Anyway this tactic is *not* equivalent to lemma that was used, while the latter requires you prove the quantified form. -When |SSR| rewrite fails on standard |Coq| licit rewrite +When |SSR| rewrite fails on standard Coq licit rewrite ```````````````````````````````````````````````````````` In a few cases, the |SSR| rewrite tactic fails rewriting some -redexes which standard |Coq| successfully rewrites. There are two main +redexes which standard Coq successfully rewrites. There are two main cases: @@ -3550,7 +3553,7 @@ cases: Lemma fubar (x : unit) : (let u := x in u) = tt. -+ The standard rewrite tactic provided by |Coq| uses a different algorithm ++ The standard rewrite tactic provided by Coq uses a different algorithm to find instances of the rewrite rule. .. example:: @@ -3953,7 +3956,7 @@ together with “term tagging” operations. The first one uses auxiliary definitions to introduce a provably equal copy of any term t. However this copy is (on purpose) *not -convertible* to t in the |Coq| system [#8]_. The job is done by the +convertible* to t in the Coq system [#8]_. The job is done by the following construction: .. coqdoc:: @@ -4542,7 +4545,7 @@ is a synonym for: elim x using V; clear x; intro y. where ``x`` is a variable in the context, ``y`` a fresh name and ``V`` -any second order lemma; |SSR| relaxes the syntactic restrictions of the |Coq| +any second order lemma; |SSR| relaxes the syntactic restrictions of the Coq ``elim``. The first pattern following ``:`` can be a ``_`` wildcard if the conclusion of the view ``V`` specifies a pattern for its last argument (e.g., if ``V`` is a functional induction lemma generated by the @@ -4590,7 +4593,7 @@ generation (see section :ref:`generation_of_equations_ssr`). elim/last_ind_list E : l=> [| u v]; last first. -User-provided eliminators (potentially generated with |Coq|’s ``Function`` +User-provided eliminators (potentially generated with Coq’s ``Function`` command) can be combined with the type family switches described in section :ref:`type_families_ssr`. Consider an eliminator ``foo_ind`` of type: @@ -4982,8 +4985,8 @@ distinction between logical propositions and boolean values. On the one hand, logical propositions are objects of *sort* ``Prop`` which is the carrier of intuitionistic reasoning. Logical connectives in ``Prop`` are *types*, which give precise information on the structure -of their proofs; this information is automatically exploited by |Coq| -tactics. For example, |Coq| knows that a proof of ``A \/ B`` is +of their proofs; this information is automatically exploited by Coq +tactics. For example, Coq knows that a proof of ``A \/ B`` is either a proof of ``A`` or a proof of ``B``. The tactics ``left`` and ``right`` change the goal ``A \/ B`` to ``A`` and ``B``, respectively; dually, the tactic ``case`` reduces the goal ``A \/ B => G`` to two @@ -5042,7 +5045,7 @@ mechanism: Coercion is_true (b : bool) := b = true. -This allows any boolean formula ``b`` to be used in a context where |Coq| +This allows any boolean formula ``b`` to be used in a context where Coq would expect a proposition, e.g., after ``Lemma … :``. It is then interpreted as ``(is_true b)``, i.e., the proposition ``b = true``. Coercions are elided by the pretty-printer, so they are essentially transparent @@ -5077,9 +5080,9 @@ proposition ``b1 /\ b2`` hides two coercions. The conjunction of Expressing logical equivalences through this family of inductive types makes possible to take benefit from *rewritable equations* associated -to the case analysis of |Coq|’s inductive types. +to the case analysis of Coq’s inductive types. -Since the equivalence predicate is defined in |Coq| as: +Since the equivalence predicate is defined in Coq as: .. coqdoc:: @@ -5573,7 +5576,7 @@ Natural number .. prodn:: nat_or_ident ::= {| @natural | @ident } -where :token:`ident` is an Ltac variable denoting a standard |Coq| number +where :token:`ident` is an Ltac variable denoting a standard Coq number (should not be the name of a tactic which can be followed by a bracket ``[``, like ``do``, ``have``,…) @@ -5724,11 +5727,11 @@ respectively. local function definition -.. tacv:: pose fix @fix_body +.. tacv:: pose fix @fix_decl local fix definition -.. tacv:: pose cofix @fix_body +.. tacv:: pose cofix @fix_decl local cofix definition @@ -5823,6 +5826,6 @@ Settings .. [#8] This is an implementation feature: there is no such obstruction in the metatheory .. [#9] The current state of the proof shall be displayed by the Show - Proof command of |Coq| proof mode. + Proof command of Coq proof mode. .. [#10] A simple proof context entry is a naked identifier (i.e. not between parentheses) designating a context entry that is not a section variable. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 4b1f312105..26a56005c1 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -86,42 +86,36 @@ specified, the default selector is used. Although other selectors are available, only ``all``, ``!`` or a single natural number are valid default goal selectors. -.. _bindingslist: +.. _bindings: -Bindings list -~~~~~~~~~~~~~ +Bindings +~~~~~~~~ -Tactics that take a term as an argument may also support a bindings list +Tactics that take a term as an argument may also accept :token:`bindings` to instantiate some parameters of the term by name or position. -The general form of a term with a bindings list is -:n:`@term with @bindings_list` where :token:`bindings_list` can take two different forms: +The general form of a term with :token:`bindings` is +:n:`@term__tac with @bindings` where :token:`bindings` can take two different forms: -.. _bindings_list_grammar: + .. insertprodn bindings bindings .. prodn:: - ref ::= @ident - | @natural - bindings_list ::= {+ (@ref := @term) } - | {+ @term } - -+ In a bindings list of the form :n:`{+ (@ref:= @term)}`, :n:`@ref` is either an - :n:`@ident` or a :n:`@natural`. The references are determined according to the type of - :n:`@term`. If :n:`@ref` is an identifier, this identifier has to be bound in the - type of :n:`@term` and the binding provides the tactic with an instance for the - parameter of this name. If :n:`@ref` is a number ``n``, it refers to - the ``n``-th non dependent premise of the :n:`@term`, as determined by the type - of :n:`@term`. + bindings ::= {+ ( {| @ident | @natural } := @term ) } + | {+ @one_term } + ++ In the first form, if an :token:`ident` is specified, it must be bound in the + type of :n:`@term` and provides the tactic with an instance for the + parameter of this name. If a :token:`natural` is specified, it refers to + the ``n``-th non dependent premise of :n:`@term__tac`. .. exn:: No such binder. :undocumented: -+ A bindings list can also be a simple list of terms :n:`{* @term}`. - In that case the references to which these terms correspond are - determined by the tactic. In case of :tacn:`induction`, :tacn:`destruct`, :tacn:`elim` - and :tacn:`case`, the terms have to - provide instances for all the dependent products in the type of term while in ++ In the second form, the interpretation of the :token:`one_term`\s depend on which + tactic they appear in. For :tacn:`induction`, :tacn:`destruct`, :tacn:`elim` + and :tacn:`case`, the :token:`one_term`\s + provide instances for all the dependent products in the type of :n:`@term__tac` while in the case of :tacn:`apply`, or of :tacn:`constructor` and its variants, only instances - for the dependent products that are not bound in the conclusion of the type + for the dependent products that are not bound in the conclusion of :n:`@term__tac` are required. .. exn:: Not the right number of missing arguments. @@ -274,7 +268,7 @@ These patterns can be used when the hypothesis is an equality: For :n:`intros @intropattern_list`, controls how to handle a conjunctive pattern that doesn't give enough simple patterns to match - all the arguments in the constructor. If set (the default), |Coq| generates + all the arguments in the constructor. If set (the default), Coq generates additional names to match the number of arguments. Unsetting the flag will put the additional hypotheses in the goal instead, behavior that is more similar to |SSR|'s intro patterns. @@ -682,11 +676,11 @@ Applying theorems .. exn:: Not the right number of missing arguments. :undocumented: - .. tacv:: apply @term with @bindings_list + .. tacv:: apply @term with @bindings This also provides apply with values for instantiating premises. Here, variables are referred by names and non-dependent products by increasing numbers (see - :ref:`bindings list <bindingslist>`). + :ref:`bindings`). .. tacv:: apply {+, @term} @@ -747,8 +741,8 @@ Applying theorems tactics that backtrack often. Moreover, it does not traverse tuples as :tacn:`apply` does. - .. tacv:: {? simple} apply {+, @term {? with @bindings_list}} - {? simple} eapply {+, @term {? with @bindings_list}} + .. tacv:: {? simple} apply {+, @term {? with @bindings}} + {? simple} eapply {+, @term {? with @bindings}} :name: simple apply; simple eapply This summarizes the different syntaxes for :tacn:`apply` and :tacn:`eapply`. @@ -888,18 +882,18 @@ Applying theorems This applies each :token:`term` in sequence in :token:`ident`. - .. tacv:: apply {+, @term with @bindings_list} in @ident + .. tacv:: apply {+, @term with @bindings} in @ident This does the same but uses the bindings in each :n:`(@ident := @term)` to instantiate the parameters of the corresponding type of :token:`term` - (see :ref:`bindings list <bindingslist>`). + (see :ref:`bindings`). - .. tacv:: eapply {+, @term {? with @bindings_list } } in @ident + .. tacv:: eapply {+, @term {? with @bindings } } in @ident This works as :tacn:`apply … in` but turns unresolved bindings into existential variables, if any, instead of failing. - .. tacv:: apply {+, @term {? with @bindings_list } } in @ident as @simple_intropattern + .. tacv:: apply {+, @term {? with @bindings } } in @ident as @simple_intropattern :name: apply … in … as This works as :tacn:`apply … in` then applies the :token:`simple_intropattern` @@ -911,8 +905,8 @@ Applying theorems only on subterms that contain no variables to instantiate and does not traverse tuples. See :ref:`the corresponding example <simple_apply_ex>`. - .. tacv:: {? simple} apply {+, @term {? with @bindings_list}} in @ident {? as @simple_intropattern} - {? simple} eapply {+, @term {? with @bindings_list}} in @ident {? as @simple_intropattern} + .. tacv:: {? simple} apply {+, @term {? with @bindings}} in @ident {? as @simple_intropattern} + {? simple} eapply {+, @term {? with @bindings}} in @ident {? as @simple_intropattern} This summarizes the different syntactic variants of :n:`apply @term in @ident` and :n:`eapply @term in @ident`. @@ -938,48 +932,48 @@ Applying theorems :g:`constructor n` where ``n`` is the number of constructors of the head of the goal. - .. tacv:: constructor @natural with @bindings_list + .. tacv:: constructor @natural with @bindings Let ``c`` be the i-th constructor of :g:`I`, then - :n:`constructor i with @bindings_list` is equivalent to - :n:`intros; apply c with @bindings_list`. + :n:`constructor i with @bindings` is equivalent to + :n:`intros; apply c with @bindings`. .. warning:: - The terms in the :token:`bindings_list` are checked in the context + The terms in :token:`bindings` are checked in the context where constructor is executed and not in the context where :tacn:`apply` is executed (the introductions are not taken into account). - .. tacv:: split {? with @bindings_list } + .. tacv:: split {? with @bindings } :name: split This applies only if :g:`I` has a single constructor. It is then - equivalent to :n:`constructor 1 {? with @bindings_list }`. It is + equivalent to :n:`constructor 1 {? with @bindings }`. It is typically used in the case of a conjunction :math:`A \wedge B`. - .. tacv:: exists @bindings_list + .. tacv:: exists @bindings :name: exists This applies only if :g:`I` has a single constructor. It is then equivalent - to :n:`intros; constructor 1 with @bindings_list.` It is typically used in + to :n:`intros; constructor 1 with @bindings.` It is typically used in the case of an existential quantification :math:`\exists x, P(x).` - .. tacv:: exists {+, @bindings_list } + .. tacv:: exists {+, @bindings } - This iteratively applies :n:`exists @bindings_list`. + This iteratively applies :n:`exists @bindings`. .. exn:: Not an inductive goal with 1 constructor. :undocumented: - .. tacv:: left {? with @bindings_list } - right {? with @bindings_list } + .. tacv:: left {? with @bindings } + right {? with @bindings } :name: left; right These tactics apply only if :g:`I` has two constructors, for instance in the case of a disjunction :math:`A \vee B`. Then, they are respectively equivalent to - :n:`constructor 1 {? with @bindings_list }` and - :n:`constructor 2 {? with @bindings_list }`. + :n:`constructor 1 {? with @bindings }` and + :n:`constructor 2 {? with @bindings }`. .. exn:: Not an inductive goal with 2 constructors. :undocumented: @@ -1518,13 +1512,13 @@ Controlling the proof flow list of remaining subgoal to prove. .. tacv:: specialize (@ident {* @term}) {? as @simple_intropattern} - specialize @ident with @bindings_list {? as @simple_intropattern} + specialize @ident with @bindings {? as @simple_intropattern} :name: specialize; _ This tactic works on local hypothesis :n:`@ident`. The premises of this hypothesis (either universal quantifications or non-dependent implications) are instantiated by concrete terms coming either - from arguments :n:`{* @term}` or from a :ref:`bindings list <bindingslist>`. + from arguments :n:`{* @term}` or from :ref:`bindings`. In the first form the application to :n:`{* @term}` can be partial. The first form is equivalent to :n:`assert (@ident := @ident {* @term})`. In the second form, instantiation elements can also be partial. In this case the @@ -1767,7 +1761,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) by :token:`naming_intropattern` (see :tacn:`intros`), in particular ``?`` can be used to let Coq generate a fresh name. - .. tacv:: destruct @term with @bindings_list + .. tacv:: destruct @term with @bindings This behaves like :n:`destruct @term` providing explicit instances for the dependent premises of the type of :token:`term`. @@ -1781,9 +1775,9 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) are left as existential variables to be inferred later, in the same way as :tacn:`eapply` does. - .. tacv:: destruct @term using @term {? with @bindings_list } + .. tacv:: destruct @term using @term {? with @bindings } - This is synonym of :n:`induction @term using @term {? with @bindings_list }`. + This is synonym of :n:`induction @term using @term {? with @bindings }`. .. tacv:: destruct @term in @goal_occurrences @@ -1792,8 +1786,8 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) clause is an occurrence clause whose syntax and behavior is described in :ref:`occurrences sets <occurrencessets>`. - .. tacv:: destruct @term {? with @bindings_list } {? as @or_and_intropattern_loc } {? eqn:@naming_intropattern } {? using @term {? with @bindings_list } } {? in @goal_occurrences } - edestruct @term {? with @bindings_list } {? as @or_and_intropattern_loc } {? eqn:@naming_intropattern } {? using @term {? with @bindings_list } } {? in @goal_occurrences } + .. tacv:: destruct @term {? with @bindings } {? as @or_and_intropattern_loc } {? eqn:@naming_intropattern } {? using @term {? with @bindings } } {? in @goal_occurrences } + edestruct @term {? with @bindings } {? as @or_and_intropattern_loc } {? eqn:@naming_intropattern } {? using @term {? with @bindings } } {? in @goal_occurrences } These are the general forms of :tacn:`destruct` and :tacn:`edestruct`. They combine the effects of the ``with``, ``as``, ``eqn:``, ``using``, @@ -1806,15 +1800,15 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) recursion. It behaves as :n:`elim @term` but using a case-analysis elimination principle and not a recursive one. -.. tacv:: case @term with @bindings_list +.. tacv:: case @term with @bindings - Analogous to :n:`elim @term with @bindings_list` above. + Analogous to :n:`elim @term with @bindings` above. -.. tacv:: ecase @term {? with @bindings_list } +.. tacv:: ecase @term {? with @bindings } :name: ecase In case the type of :n:`@term` has dependent premises, or dependent premises - whose values are not inferable from the :n:`with @bindings_list` clause, + whose values are not inferable from the :n:`with @bindings` clause, :n:`ecase` turns them into existential variables to be resolved later on. .. tacv:: simple destruct @ident @@ -1906,10 +1900,10 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) :n:`(p`:sub:`1` :n:`, ... , p`:sub:`n` :n:`)` can be used instead of :n:`[ p`:sub:`1` :n:`... p`:sub:`n` :n:`]`. -.. tacv:: induction @term with @bindings_list +.. tacv:: induction @term with @bindings This behaves like :tacn:`induction` providing explicit instances for the - premises of the type of :n:`term` (see :ref:`bindings list <bindingslist>`). + premises of the type of :n:`term` (see :ref:`bindings`). .. tacv:: einduction @term :name: einduction @@ -1926,7 +1920,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) It does not expect the conclusion of the type of the first :n:`@term` to be inductive. -.. tacv:: induction @term using @term with @bindings_list +.. tacv:: induction @term using @term with @bindings This behaves as :tacn:`induction … using …` but also providing instances for the premises of the type of the second :n:`@term`. @@ -1954,8 +1948,8 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) induction y in x |- *. Show 2. -.. tacv:: induction @term with @bindings_list as @or_and_intropattern_loc using @term with @bindings_list in @goal_occurrences - einduction @term with @bindings_list as @or_and_intropattern_loc using @term with @bindings_list in @goal_occurrences +.. tacv:: induction @term with @bindings as @or_and_intropattern_loc using @term with @bindings in @goal_occurrences + einduction @term with @bindings as @or_and_intropattern_loc using @term with @bindings in @goal_occurrences These are the most general forms of :tacn:`induction` and :tacn:`einduction`. It combines the effects of the with, as, using, and in clauses. @@ -1978,11 +1972,11 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) products, the tactic tries to find an instance for which the elimination lemma applies and fails otherwise. -.. tacv:: elim @term with @bindings_list +.. tacv:: elim @term with @bindings :name: elim … with Allows to give explicit instances to the premises of the type of :n:`@term` - (see :ref:`bindings list <bindingslist>`). + (see :ref:`bindings`). .. tacv:: eelim @term :name: eelim @@ -1991,15 +1985,15 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) existential variables to be resolved later on. .. tacv:: elim @term using @term - elim @term using @term with @bindings_list + elim @term using @term with @bindings Allows the user to give explicitly an induction principle :n:`@term` that is not the standard one for the underlying inductive type of :n:`@term`. The - :n:`@bindings_list` clause allows instantiating premises of the type of + :n:`@bindings` clause allows instantiating premises of the type of :n:`@term`. -.. tacv:: elim @term with @bindings_list using @term with @bindings_list - eelim @term with @bindings_list using @term with @bindings_list +.. tacv:: elim @term with @bindings using @term with @bindings + eelim @term with @bindings using @term with @bindings These are the most general forms of :tacn:`elim` and :tacn:`eelim`. It combines the effects of the ``using`` clause and of the two uses of the ``with`` clause. @@ -2148,13 +2142,13 @@ and an explanation of the underlying technique. :n:`discriminate @ident` where :n:`@ident` is the identifier for the last introduced hypothesis. -.. tacv:: discriminate @term with @bindings_list +.. tacv:: discriminate @term with @bindings This does the same thing as :n:`discriminate @term` but using the given bindings to instantiate parameters or hypotheses of :n:`@term`. .. tacv:: ediscriminate @natural - ediscriminate @term {? with @bindings_list} + ediscriminate @term {? with @bindings} :name: ediscriminate; _ This works the same as :tacn:`discriminate` but if the type of :token:`term`, or the @@ -2212,7 +2206,7 @@ and an explanation of the underlying technique. different types :g:`(P t`:sub:`1` :g:`... t`:sub:`n` :g:`)` and :g:`(P u`:sub:`1` :g:`... u`:sub:`n` :sub:`)`. If :g:`t`:sub:`1` and :g:`u`:sub:`1` are the same and have for type an inductive type for which a decidable - equality has been declared using the command :cmd:`Scheme Equality` + equality has been declared using :cmd:`Scheme` :n:`Equality ...` (see :ref:`proofschemes-induction-principles`), the use of a sigma type is avoided. @@ -2237,13 +2231,13 @@ and an explanation of the underlying technique. :n:`injection @ident` where :n:`@ident` is the identifier for the last introduced hypothesis. - .. tacv:: injection @term with @bindings_list + .. tacv:: injection @term with @bindings This does the same as :n:`injection @term` but using the given bindings to instantiate parameters or hypotheses of :n:`@term`. .. tacv:: einjection @natural - einjection @term {? with @bindings_list} + einjection @term {? with @bindings} :name: einjection; _ This works the same as :n:`injection` but if the type of :n:`@term`, or the @@ -2258,10 +2252,10 @@ and an explanation of the underlying technique. .. exn:: goal does not satisfy the expected preconditions. :undocumented: - .. tacv:: injection @term {? with @bindings_list} as {+ @simple_intropattern} + .. tacv:: injection @term {? with @bindings} as {+ @simple_intropattern} injection @natural as {+ @simple_intropattern} injection as {+ @simple_intropattern} - einjection @term {? with @bindings_list} as {+ @simple_intropattern} + einjection @term {? with @bindings} as {+ @simple_intropattern} einjection @natural as {+ @simple_intropattern} einjection as {+ @simple_intropattern} @@ -2273,10 +2267,10 @@ and an explanation of the underlying technique. to the number of new equalities. The original equality is erased if it corresponds to a hypothesis. - .. tacv:: injection @term {? with @bindings_list} as @injection_intropattern + .. tacv:: injection @term {? with @bindings} as @injection_intropattern injection @natural as @injection_intropattern injection as @injection_intropattern - einjection @term {? with @bindings_list} as @injection_intropattern + einjection @term {? with @bindings} as @injection_intropattern einjection @natural as @injection_intropattern einjection as @injection_intropattern @@ -2669,1760 +2663,6 @@ and an explanation of the underlying technique. simultaneously proved are respectively :g:`forall binder ... binder, type` The identifiers :n:`@ident` are the names of the coinduction hypotheses. -.. _rewritingexpressions: - -Rewriting expressions ---------------------- - -These tactics use the equality :g:`eq:forall A:Type, A->A->Prop` defined in -file ``Logic.v`` (see :ref:`coq-library-logic`). The notation for :g:`eq T t u` is -simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. - -.. tacn:: rewrite @term - :name: rewrite - - This tactic applies to any goal. The type of :token:`term` must have the form - - ``forall (x``:sub:`1` ``:A``:sub:`1` ``) ... (x``:sub:`n` ``:A``:sub:`n` ``), eq term``:sub:`1` ``term``:sub:`2` ``.`` - - where :g:`eq` is the Leibniz equality or a registered setoid equality. - - Then :n:`rewrite @term` finds the first subterm matching `term`\ :sub:`1` in the goal, - resulting in instances `term`:sub:`1`' and `term`:sub:`2`' and then - replaces every occurrence of `term`:subscript:`1`' by `term`:subscript:`2`'. - Hence, some of the variables :g:`x`\ :sub:`i` are solved by unification, - and some of the types :g:`A`\ :sub:`1`:g:`, ..., A`\ :sub:`n` become new - subgoals. - - .. exn:: The @term provided does not end with an equation. - :undocumented: - - .. exn:: Tactic generated a subgoal identical to the original goal. This happens if @term does not occur in the goal. - :undocumented: - - .. tacv:: rewrite -> @term - - Is equivalent to :n:`rewrite @term` - - .. tacv:: rewrite <- @term - - Uses the equality :n:`@term`:sub:`1` :n:`= @term` :sub:`2` from right to left - - .. tacv:: rewrite @term in @goal_occurrences - - Analogous to :n:`rewrite @term` but rewriting is done following - the clause :token:`goal_occurrences`. For instance: - - + :n:`rewrite H in H'` will rewrite `H` in the hypothesis - ``H'`` instead of the current goal. - + :n:`rewrite H in H' at 1, H'' at - 2 |- *` means - :n:`rewrite H; rewrite H in H' at 1; rewrite H in H'' at - 2.` - In particular a failure will happen if any of these three simpler tactics - fails. - + :n:`rewrite H in * |-` will do :n:`rewrite H in H'` for all hypotheses - :g:`H'` different from :g:`H`. - A success will happen as soon as at least one of these simpler tactics succeeds. - + :n:`rewrite H in *` is a combination of :n:`rewrite H` and :n:`rewrite H in * |-` - that succeeds if at least one of these two tactics succeeds. - - Orientation :g:`->` or :g:`<-` can be inserted before the :token:`term` to rewrite. - - .. tacv:: rewrite @term at @occurrences - - Rewrite only the given :token:`occurrences` of :token:`term`. Occurrences are - specified from left to right as for pattern (:tacn:`pattern`). The rewrite is - always performed using setoid rewriting, even for Leibniz’s equality, so one - has to ``Import Setoid`` to use this variant. - - .. tacv:: rewrite @term by @tactic - - Use tactic to completely solve the side-conditions arising from the - :tacn:`rewrite`. - - .. tacv:: rewrite {+, @orientation @term} {? in @ident } - - Is equivalent to the `n` successive tactics :n:`{+; rewrite @term}`, each one - working on the first subgoal generated by the previous one. An :production:`orientation` - ``->`` or ``<-`` can be inserted before each :token:`term` to rewrite. One - unique clause can be added at the end after the keyword in; it will then - affect all rewrite operations. - - In all forms of rewrite described above, a :token:`term` to rewrite can be - immediately prefixed by one of the following modifiers: - - + `?` : the tactic :n:`rewrite ?@term` performs the rewrite of :token:`term` as many - times as possible (perhaps zero time). This form never fails. - + :n:`@natural?` : works similarly, except that it will do at most :token:`natural` rewrites. - + `!` : works as `?`, except that at least one rewrite should succeed, otherwise - the tactic fails. - + :n:`@natural!` (or simply :n:`@natural`) : precisely :token:`natural` rewrites of :token:`term` will be done, - leading to failure if these :token:`natural` rewrites are not possible. - - .. tacv:: erewrite @term - :name: erewrite - - This tactic works as :n:`rewrite @term` but turning - unresolved bindings into existential variables, if any, instead of - failing. It has the same variants as :tacn:`rewrite` has. - - .. flag:: Keyed Unification - - Makes higher-order unification used by :tacn:`rewrite` rely on a set of keys to drive - unification. The subterms, considered as rewriting candidates, must start with - the same key as the left- or right-hand side of the lemma given to rewrite, and the arguments - are then unified up to full reduction. - -.. tacn:: replace @term with @term’ - :name: replace - - This tactic applies to any goal. It replaces all free occurrences of :n:`@term` - in the current goal with :n:`@term’` and generates an equality :n:`@term = @term’` - as a subgoal. This equality is automatically solved if it occurs among - the assumptions, or if its symmetric form occurs. It is equivalent to - :n:`cut @term = @term’; [intro H`:sub:`n` :n:`; rewrite <- H`:sub:`n` :n:`; clear H`:sub:`n`:n:`|| assumption || symmetry; try assumption]`. - - .. exn:: Terms do not have convertible types. - :undocumented: - - .. tacv:: replace @term with @term’ by @tactic - - This acts as :n:`replace @term with @term’` but applies :token:`tactic` to solve the generated - subgoal :n:`@term = @term’`. - - .. tacv:: replace @term - - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term = @term’` or :n:`@term’ = @term`. - - .. tacv:: replace -> @term - - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term = @term’` - - .. tacv:: replace <- @term - - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term’ = @term` - - .. tacv:: replace @term {? with @term} in @goal_occurrences {? by @tactic} - replace -> @term in @goal_occurrences - replace <- @term in @goal_occurrences - - Acts as before but the replacements take place in the specified clauses - (:token:`goal_occurrences`) (see :ref:`performingcomputations`) and not - only in the conclusion of the goal. The clause argument must not contain - any ``type of`` nor ``value of``. - -.. tacn:: subst @ident - :name: subst - - This tactic applies to a goal that has :n:`@ident` in its context and (at - least) one hypothesis, say :g:`H`, of type :n:`@ident = t` or :n:`t = @ident` - with :n:`@ident` not occurring in :g:`t`. Then it replaces :n:`@ident` by - :g:`t` everywhere in the goal (in the hypotheses and in the conclusion) and - clears :n:`@ident` and :g:`H` from the context. - - If :n:`@ident` is a local definition of the form :n:`@ident := t`, it is also - unfolded and cleared. - - If :n:`@ident` is a section variable it is expected to have no - indirect occurrences in the goal, i.e. that no global declarations - implicitly depending on the section variable must be present in the - goal. - - .. note:: - + When several hypotheses have the form :n:`@ident = t` or :n:`t = @ident`, the - first one is used. - - + If :g:`H` is itself dependent in the goal, it is replaced by the proof of - reflexivity of equality. - - .. tacv:: subst {+ @ident} - - This is equivalent to :n:`subst @ident`:sub:`1`:n:`; ...; subst @ident`:sub:`n`. - - .. tacv:: subst - - This applies :tacn:`subst` repeatedly from top to bottom to all hypotheses of the - context for which an equality of the form :n:`@ident = t` or :n:`t = @ident` - or :n:`@ident := t` exists, with :n:`@ident` not occurring in - ``t`` and :n:`@ident` not a section variable with indirect - dependencies in the goal. - - .. flag:: Regular Subst Tactic - - This flag controls the behavior of :tacn:`subst`. When it is - activated (it is by default), :tacn:`subst` also deals with the following corner cases: - - + A context with ordered hypotheses :n:`@ident`:sub:`1` :n:`= @ident`:sub:`2` - and :n:`@ident`:sub:`1` :n:`= t`, or :n:`t′ = @ident`:sub:`1`` with `t′` not - a variable, and no other hypotheses of the form :n:`@ident`:sub:`2` :n:`= u` - or :n:`u = @ident`:sub:`2`; without the flag, a second call to - subst would be necessary to replace :n:`@ident`:sub:`2` by `t` or - `t′` respectively. - + The presence of a recursive equation which without the flag would - be a cause of failure of :tacn:`subst`. - + A context with cyclic dependencies as with hypotheses :n:`@ident`:sub:`1` :n:`= f @ident`:sub:`2` - and :n:`@ident`:sub:`2` :n:`= g @ident`:sub:`1` which without the - flag would be a cause of failure of :tacn:`subst`. - - Additionally, it prevents a local definition such as :n:`@ident := t` to be - unfolded which otherwise it would exceptionally unfold in configurations - containing hypotheses of the form :n:`@ident = u`, or :n:`u′ = @ident` - with `u′` not a variable. Finally, it preserves the initial order of - hypotheses, which without the flag it may break. - default. - - .. exn:: Cannot find any non-recursive equality over :n:`@ident`. - :undocumented: - - .. exn:: Section variable :n:`@ident` occurs implicitly in global declaration :n:`@qualid` present in hypothesis :n:`@ident`. - Section variable :n:`@ident` occurs implicitly in global declaration :n:`@qualid` present in the conclusion. - - Raised when the variable is a section variable with indirect - dependencies in the goal. - - -.. tacn:: stepl @term - :name: stepl - - This tactic is for chaining rewriting steps. It assumes a goal of the - form :n:`R @term @term` where ``R`` is a binary relation and relies on a - database of lemmas of the form :g:`forall x y z, R x y -> eq x z -> R z y` - where `eq` is typically a setoid equality. The application of :n:`stepl @term` - then replaces the goal by :n:`R @term @term` and adds a new goal stating - :n:`eq @term @term`. - - .. cmd:: Declare Left Step @term - - Adds :n:`@term` to the database used by :tacn:`stepl`. - - This tactic is especially useful for parametric setoids which are not accepted - as regular setoids for :tacn:`rewrite` and :tacn:`setoid_replace` (see - :ref:`Generalizedrewriting`). - - .. tacv:: stepl @term by @tactic - - This applies :n:`stepl @term` then applies :token:`tactic` to the second goal. - - .. tacv:: stepr @term by @tactic - :name: stepr - - This behaves as :tacn:`stepl` but on the right-hand-side of the binary - relation. Lemmas are expected to be of the form - :g:`forall x y z, R x y -> eq y z -> R x z`. - - .. cmd:: Declare Right Step @term - - Adds :n:`@term` to the database used by :tacn:`stepr`. - - -.. tacn:: change @term - :name: change - - This tactic applies to any goal. It implements the rule ``Conv`` given in - :ref:`subtyping-rules`. :g:`change U` replaces the current goal `T` - with `U` providing that `U` is well-formed and that `T` and `U` are - convertible. - - .. exn:: Not convertible. - :undocumented: - - .. tacv:: change @term with @term’ - - This replaces the occurrences of :n:`@term` by :n:`@term’` in the current goal. - The term :n:`@term` and :n:`@term’` must be convertible. - - .. tacv:: change @term at {+ @natural} with @term’ - - This replaces the occurrences numbered :n:`{+ @natural}` of :n:`@term` by :n:`@term’` - in the current goal. The terms :n:`@term` and :n:`@term’` must be convertible. - - .. exn:: Too few occurrences. - :undocumented: - - .. tacv:: change @term {? {? at {+ @natural}} with @term} in @ident - - This applies the :tacn:`change` tactic not to the goal but to the hypothesis :n:`@ident`. - - .. tacv:: now_show @term - - This is a synonym of :n:`change @term`. It can be used to - make some proof steps explicit when refactoring a proof script - to make it readable. - - .. seealso:: :ref:`Performing computations <performingcomputations>` - -.. _performingcomputations: - -Performing computations ---------------------------- - -.. insertprodn red_expr pattern_occ - -.. prodn:: - red_expr ::= red - | hnf - | simpl {? @delta_flag } {? @ref_or_pattern_occ } - | cbv {? @strategy_flag } - | cbn {? @strategy_flag } - | lazy {? @strategy_flag } - | compute {? @delta_flag } - | vm_compute {? @ref_or_pattern_occ } - | native_compute {? @ref_or_pattern_occ } - | unfold {+, @unfold_occ } - | fold {+ @one_term } - | pattern {+, @pattern_occ } - | @ident - delta_flag ::= {? - } [ {+ @reference } ] - strategy_flag ::= {+ @red_flag } - | @delta_flag - red_flag ::= beta - | iota - | match - | fix - | cofix - | zeta - | delta {? @delta_flag } - ref_or_pattern_occ ::= @reference {? at @occs_nums } - | @one_term {? at @occs_nums } - occs_nums ::= {+ {| @natural | @ident } } - | - {| @natural | @ident } {* @int_or_var } - int_or_var ::= @integer - | @ident - unfold_occ ::= @reference {? at @occs_nums } - pattern_occ ::= @one_term {? at @occs_nums } - -This set of tactics implements different specialized usages of the -tactic :tacn:`change`. - -All conversion tactics (including :tacn:`change`) can be parameterized by the -parts of the goal where the conversion can occur. This is done using -*goal clauses* which consists in a list of hypotheses and, optionally, -of a reference to the conclusion of the goal. For defined hypothesis -it is possible to specify if the conversion should occur on the type -part, the body part or both (default). - -Goal clauses are written after a conversion tactic (tactics :tacn:`set`, -:tacn:`rewrite`, :tacn:`replace` and :tacn:`autorewrite` also use goal -clauses) and are introduced by the keyword `in`. If no goal clause is -provided, the default is to perform the conversion only in the -conclusion. - -The syntax and description of the various goal clauses is the -following: - -+ :n:`in {+ @ident} |-` only in hypotheses :n:`{+ @ident}` -+ :n:`in {+ @ident} |- *` in hypotheses :n:`{+ @ident}` and in the - conclusion -+ :n:`in * |-` in every hypothesis -+ :n:`in *` (equivalent to in :n:`* |- *`) everywhere -+ :n:`in (type of @ident) (value of @ident) ... |-` in type part of - :n:`@ident`, in the value part of :n:`@ident`, etc. - -For backward compatibility, the notation :n:`in {+ @ident}` performs -the conversion in hypotheses :n:`{+ @ident}`. - -.. tacn:: cbv {? @strategy_flag } - lazy {? @strategy_flag } - :name: cbv; lazy - - These parameterized reduction tactics apply to any goal and perform - the normalization of the goal according to the specified flags. In - correspondence with the kinds of reduction considered in Coq namely - :math:`\beta` (reduction of functional application), :math:`\delta` - (unfolding of transparent constants, see :ref:`vernac-controlling-the-reduction-strategies`), - :math:`\iota` (reduction of - pattern matching over a constructed term, and unfolding of :g:`fix` and - :g:`cofix` expressions) and :math:`\zeta` (contraction of local definitions), the - flags are either ``beta``, ``delta``, ``match``, ``fix``, ``cofix``, - ``iota`` or ``zeta``. The ``iota`` flag is a shorthand for ``match``, ``fix`` - and ``cofix``. The ``delta`` flag itself can be refined into - :n:`delta [ {+ @qualid} ]` or :n:`delta - [ {+ @qualid} ]`, restricting in the first - case the constants to unfold to the constants listed, and restricting in the - second case the constant to unfold to all but the ones explicitly mentioned. - Notice that the ``delta`` flag does not apply to variables bound by a let-in - construction inside the :n:`@term` itself (use here the ``zeta`` flag). In - any cases, opaque constants are not unfolded (see :ref:`vernac-controlling-the-reduction-strategies`). - - Normalization according to the flags is done by first evaluating the - head of the expression into a *weak-head* normal form, i.e. until the - evaluation is blocked by a variable (or an opaque constant, or an - axiom), as e.g. in :g:`x u1 ... un` , or :g:`match x with ... end`, or - :g:`(fix f x {struct x} := ...) x`, or is a constructed form (a - :math:`\lambda`-expression, a constructor, a cofixpoint, an inductive type, a - product type, a sort), or is a redex that the flags prevent to reduce. Once a - weak-head normal form is obtained, subterms are recursively reduced using the - same strategy. - - Reduction to weak-head normal form can be done using two strategies: - *lazy* (``lazy`` tactic), or *call-by-value* (``cbv`` tactic). The lazy - strategy is a call-by-need strategy, with sharing of reductions: the - arguments of a function call are weakly evaluated only when necessary, - and if an argument is used several times then it is weakly computed - only once. This reduction is efficient for reducing expressions with - dead code. For instance, the proofs of a proposition :g:`exists x. P(x)` - reduce to a pair of a witness :g:`t`, and a proof that :g:`t` satisfies the - predicate :g:`P`. Most of the time, :g:`t` may be computed without computing - the proof of :g:`P(t)`, thanks to the lazy strategy. - - The call-by-value strategy is the one used in ML languages: the - arguments of a function call are systematically weakly evaluated - first. Despite the lazy strategy always performs fewer reductions than - the call-by-value strategy, the latter is generally more efficient for - evaluating purely computational expressions (i.e. with little dead code). - -.. tacv:: compute - cbv - :name: compute; _ - - These are synonyms for ``cbv beta delta iota zeta``. - -.. tacv:: lazy - - This is a synonym for ``lazy beta delta iota zeta``. - -.. tacv:: compute [ {+ @qualid} ] - cbv [ {+ @qualid} ] - - These are synonyms of :n:`cbv beta delta {+ @qualid} iota zeta`. - -.. tacv:: compute - [ {+ @qualid} ] - cbv - [ {+ @qualid} ] - - These are synonyms of :n:`cbv beta delta -{+ @qualid} iota zeta`. - -.. tacv:: lazy [ {+ @qualid} ] - lazy - [ {+ @qualid} ] - - These are respectively synonyms of :n:`lazy beta delta {+ @qualid} iota zeta` - and :n:`lazy beta delta -{+ @qualid} iota zeta`. - -.. tacv:: vm_compute - :name: vm_compute - - This tactic evaluates the goal using the optimized call-by-value evaluation - bytecode-based virtual machine described in :cite:`CompiledStrongReduction`. - This algorithm is dramatically more efficient than the algorithm used for the - :tacn:`cbv` tactic, but it cannot be fine-tuned. It is especially interesting for - full evaluation of algebraic objects. This includes the case of - reflection-based tactics. - -.. tacv:: native_compute - :name: native_compute - - This tactic evaluates the goal by compilation to OCaml as described - in :cite:`FullReduction`. If Coq is running in native code, it can be - typically two to five times faster than :tacn:`vm_compute`. Note however that the - compilation cost is higher, so it is worth using only for intensive - computations. - - .. flag:: NativeCompute Timing - - This flag causes all calls to the native compiler to print - timing information for the conversion to native code, - compilation, execution, and reification phases of native - compilation. Timing is printed in units of seconds of - wall-clock time. - - .. flag:: NativeCompute Profiling - - On Linux, if you have the ``perf`` profiler installed, this flag makes - it possible to profile :tacn:`native_compute` evaluations. - - .. opt:: NativeCompute Profile Filename @string - :name: NativeCompute Profile Filename - - This option specifies the profile output; the default is - ``native_compute_profile.data``. The actual filename used - will contain extra characters to avoid overwriting an existing file; that - filename is reported to the user. - That means you can individually profile multiple uses of - :tacn:`native_compute` in a script. From the Linux command line, run ``perf report`` - on the profile file to see the results. Consult the ``perf`` documentation - for more details. - -.. flag:: Debug Cbv - - This flag makes :tacn:`cbv` (and its derivative :tacn:`compute`) print - information about the constants it encounters and the unfolding decisions it - makes. - -.. tacn:: red - :name: red - - This tactic applies to a goal that has the form:: - - forall (x:T1) ... (xk:Tk), T - - with :g:`T` :math:`\beta`:math:`\iota`:math:`\zeta`-reducing to :g:`c t`:sub:`1` :g:`... t`:sub:`n` and :g:`c` a - constant. If :g:`c` is transparent then it replaces :g:`c` with its - definition (say :g:`t`) and then reduces - :g:`(t t`:sub:`1` :g:`... t`:sub:`n` :g:`)` according to :math:`\beta`:math:`\iota`:math:`\zeta`-reduction rules. - -.. exn:: Not reducible. - :undocumented: - -.. exn:: No head constant to reduce. - :undocumented: - -.. tacn:: hnf - :name: hnf - - This tactic applies to any goal. It replaces the current goal with its - head normal form according to the :math:`\beta`:math:`\delta`:math:`\iota`:math:`\zeta`-reduction rules, i.e. it - reduces the head of the goal until it becomes a product or an - irreducible term. All inner :math:`\beta`:math:`\iota`-redexes are also reduced. - The behavior of both :tacn:`hnf` can be tuned using the :cmd:`Arguments` command. - - Example: The term :g:`fun n : nat => S n + S n` is not reduced by :n:`hnf`. - -.. note:: - The :math:`\delta` rule only applies to transparent constants (see :ref:`vernac-controlling-the-reduction-strategies` - on transparency and opacity). - -.. tacn:: cbn - simpl - :name: cbn; simpl - - These tactics apply to any goal. They try to reduce a term to - something still readable instead of fully normalizing it. They perform - a sort of strong normalization with two key differences: - - + They unfold a constant if and only if it leads to a :math:`\iota`-reduction, - i.e. reducing a match or unfolding a fixpoint. - + While reducing a constant unfolding to (co)fixpoints, the tactics - use the name of the constant the (co)fixpoint comes from instead of - the (co)fixpoint definition in recursive calls. - - The :tacn:`cbn` tactic is claimed to be a more principled, faster and more - predictable replacement for :tacn:`simpl`. - - The :tacn:`cbn` tactic accepts the same flags as :tacn:`cbv` and - :tacn:`lazy`. The behavior of both :tacn:`simpl` and :tacn:`cbn` - can be tuned using the :cmd:`Arguments` command. - - .. todo add "See <subsection about controlling the behavior of reduction strategies>" - to TBA section - - Notice that only transparent constants whose name can be reused in the - recursive calls are possibly unfolded by :tacn:`simpl`. For instance a - constant defined by :g:`plus' := plus` is possibly unfolded and reused in - the recursive calls, but a constant such as :g:`succ := plus (S O)` is - never unfolded. This is the main difference between :tacn:`simpl` and :tacn:`cbn`. - The tactic :tacn:`cbn` reduces whenever it will be able to reuse it or not: - :g:`succ t` is reduced to :g:`S t`. - -.. tacv:: cbn [ {+ @qualid} ] - cbn - [ {+ @qualid} ] - - These are respectively synonyms of :n:`cbn beta delta [ {+ @qualid} ] iota zeta` - and :n:`cbn beta delta - [ {+ @qualid} ] iota zeta` (see :tacn:`cbn`). - -.. tacv:: simpl @pattern - - This applies :tacn:`simpl` only to the subterms matching - :n:`@pattern` in the current goal. - -.. tacv:: simpl @pattern at {+ @natural} - - This applies :tacn:`simpl` only to the :n:`{+ @natural}` occurrences of the subterms - matching :n:`@pattern` in the current goal. - - .. exn:: Too few occurrences. - :undocumented: - -.. tacv:: simpl @qualid - simpl @string - - This applies :tacn:`simpl` only to the applicative subterms whose head occurrence - is the unfoldable constant :n:`@qualid` (the constant can be referred to by - its notation using :n:`@string` if such a notation exists). - -.. tacv:: simpl @qualid at {+ @natural} - simpl @string at {+ @natural} - - This applies :tacn:`simpl` only to the :n:`{+ @natural}` applicative subterms whose - head occurrence is :n:`@qualid` (or :n:`@string`). - -.. flag:: Debug RAKAM - - This flag makes :tacn:`cbn` print various debugging information. - ``RAKAM`` is the Refolding Algebraic Krivine Abstract Machine. - -.. tacn:: unfold @qualid - :name: unfold - - This tactic applies to any goal. The argument qualid must denote a - defined transparent constant or local definition (see - :ref:`gallina-definitions` and - :ref:`vernac-controlling-the-reduction-strategies`). The tactic - :tacn:`unfold` applies the :math:`\delta` rule to each occurrence - of the constant to which :n:`@qualid` refers in the current goal - and then replaces it with its :math:`\beta\iota\zeta`-normal form. - Use the general reduction tactics if you want to avoid this final - reduction, for instance :n:`cbv delta [@qualid]`. - - .. exn:: Cannot coerce @qualid to an evaluable reference. - - This error is frequent when trying to unfold something that has - defined as an inductive type (or constructor) and not as a - definition. - - .. example:: - - .. coqtop:: abort all fail - - Goal 0 <= 1. - unfold le. - - This error can also be raised if you are trying to unfold - something that has been marked as opaque. - - .. example:: - - .. coqtop:: abort all fail - - Opaque Nat.add. - Goal 1 + 0 = 1. - unfold Nat.add. - - .. tacv:: unfold @qualid in @goal_occurrences - - Replaces :n:`@qualid` in hypothesis (or hypotheses) designated - by :token:`goal_occurrences` with its definition and replaces - the hypothesis with its :math:`\beta`:math:`\iota` normal form. - - .. tacv:: unfold {+, @qualid} - - Replaces :n:`{+, @qualid}` with their definitions and replaces - the current goal with its :math:`\beta`:math:`\iota` normal - form. - - .. tacv:: unfold {+, @qualid at @occurrences } - - The list :token:`occurrences` specify the occurrences of - :n:`@qualid` to be unfolded. Occurrences are located from left - to right. - - .. exn:: Bad occurrence number of @qualid. - :undocumented: - - .. exn:: @qualid does not occur. - :undocumented: - - .. tacv:: unfold @string - - If :n:`@string` denotes the discriminating symbol of a notation - (e.g. "+") or an expression defining a notation (e.g. `"_ + - _"`), and this notation denotes an application whose head symbol - is an unfoldable constant, then the tactic unfolds it. - - .. tacv:: unfold @string%@ident - - This is variant of :n:`unfold @string` where :n:`@string` gets - its interpretation from the scope bound to the delimiting key - :token:`ident` instead of its default interpretation (see - :ref:`Localinterpretationrulesfornotations`). - - .. tacv:: unfold {+, {| @qualid | @string{? %@ident } } {? at @occurrences } } {? in @goal_occurrences } - - This is the most general form. - -.. tacn:: fold @term - :name: fold - - This tactic applies to any goal. The term :n:`@term` is reduced using the - :tacn:`red` tactic. Every occurrence of the resulting :n:`@term` in the goal is - then replaced by :n:`@term`. This tactic is particularly useful when a fixpoint - definition has been wrongfully unfolded, making the goal very hard to read. - On the other hand, when an unfolded function applied to its argument has been - reduced, the :tacn:`fold` tactic won't do anything. - - .. example:: - - .. coqtop:: all abort - - Goal ~0=0. - unfold not. - Fail progress fold not. - pattern (0 = 0). - fold not. - - .. tacv:: fold {+ @term} - - Equivalent to :n:`fold @term ; ... ; fold @term`. - -.. tacn:: pattern @term - :name: pattern - - This command applies to any goal. The argument :n:`@term` must be a free - subterm of the current goal. The command pattern performs :math:`\beta`-expansion - (the inverse of :math:`\beta`-reduction) of the current goal (say :g:`T`) by - - + replacing all occurrences of :n:`@term` in :g:`T` with a fresh variable - + abstracting this variable - + applying the abstracted goal to :n:`@term` - - For instance, if the current goal :g:`T` is expressible as - :math:`\varphi`:g:`(t)` where the notation captures all the instances of :g:`t` - in :math:`\varphi`:g:`(t)`, then :n:`pattern t` transforms it into - :g:`(fun x:A =>` :math:`\varphi`:g:`(x)) t`. This tactic can be used, for - instance, when the tactic ``apply`` fails on matching. - -.. tacv:: pattern @term at {+ @natural} - - Only the occurrences :n:`{+ @natural}` of :n:`@term` are considered for - :math:`\beta`-expansion. Occurrences are located from left to right. - -.. tacv:: pattern @term at - {+ @natural} - - All occurrences except the occurrences of indexes :n:`{+ @natural }` - of :n:`@term` are considered for :math:`\beta`-expansion. Occurrences are located from - left to right. - -.. tacv:: pattern {+, @term} - - Starting from a goal :math:`\varphi`:g:`(t`:sub:`1` :g:`... t`:sub:`m`:g:`)`, - the tactic :n:`pattern t`:sub:`1`:n:`, ..., t`:sub:`m` generates the - equivalent goal - :g:`(fun (x`:sub:`1`:g:`:A`:sub:`1`:g:`) ... (x`:sub:`m` :g:`:A`:sub:`m` :g:`) =>`:math:`\varphi`:g:`(x`:sub:`1` :g:`... x`:sub:`m` :g:`)) t`:sub:`1` :g:`... t`:sub:`m`. - If :g:`t`:sub:`i` occurs in one of the generated types :g:`A`:sub:`j` these - occurrences will also be considered and possibly abstracted. - -.. tacv:: pattern {+, @term at {+ @natural}} - - This behaves as above but processing only the occurrences :n:`{+ @natural}` of - :n:`@term` starting from :n:`@term`. - -.. tacv:: pattern {+, @term {? at {? -} {+, @natural}}} - - This is the most general syntax that combines the different variants. - -.. tacn:: with_strategy @strategy_level_or_var [ {+ @reference } ] @ltac_expr3 - :name: with_strategy - - Executes :token:`ltac_expr3`, applying the alternate unfolding - behavior that the :cmd:`Strategy` command controls, but only for - :token:`ltac_expr3`. This can be useful for guarding calls to - reduction in tactic automation to ensure that certain constants are - never unfolded by tactics like :tacn:`simpl` and :tacn:`cbn` or to - ensure that unfolding does not fail. - - .. example:: - - .. coqtop:: all reset abort - - Opaque id. - Goal id 10 = 10. - Fail unfold id. - with_strategy transparent [id] unfold id. - - .. warning:: - - Use this tactic with care, as effects do not persist past the - end of the proof script. Notably, this fine-tuning of the - conversion strategy is not in effect during :cmd:`Qed` nor - :cmd:`Defined`, so this tactic is most useful either in - combination with :tacn:`abstract`, which will check the proof - early while the fine-tuning is still in effect, or to guard - calls to conversion in tactic automation to ensure that, e.g., - :tacn:`unfold` does not fail just because the user made a - constant :cmd:`Opaque`. - - This can be illustrated with the following example involving the - factorial function. - - .. coqtop:: in reset - - Fixpoint fact (n : nat) : nat := - match n with - | 0 => 1 - | S n' => n * fact n' - end. - - Suppose now that, for whatever reason, we want in general to - unfold the :g:`id` function very late during conversion: - - .. coqtop:: in - - Strategy 1000 [id]. - - If we try to prove :g:`id (fact n) = fact n` by - :tacn:`reflexivity`, it will now take time proportional to - :math:`n!`, because |Coq| will keep unfolding :g:`fact` and - :g:`*` and :g:`+` before it unfolds :g:`id`, resulting in a full - computation of :g:`fact n` (in unary, because we are using - :g:`nat`), which takes time :math:`n!`. We can see this cross - the relevant threshold at around :math:`n = 9`: - - .. coqtop:: all abort - - Goal True. - Time assert (id (fact 8) = fact 8) by reflexivity. - Time assert (id (fact 9) = fact 9) by reflexivity. - - Note that behavior will be the same if you mark :g:`id` as - :g:`Opaque` because while most reduction tactics refuse to - unfold :g:`Opaque` constants, conversion treats :g:`Opaque` as - merely a hint to unfold this constant last. - - We can get around this issue by using :tacn:`with_strategy`: - - .. coqtop:: all - - Goal True. - Fail Timeout 1 assert (id (fact 100) = fact 100) by reflexivity. - Time assert (id (fact 100) = fact 100) by with_strategy -1 [id] reflexivity. - - However, when we go to close the proof, we will run into - trouble, because the reduction strategy changes are local to the - tactic passed to :tacn:`with_strategy`. - - .. coqtop:: all abort fail - - exact I. - Timeout 1 Defined. - - We can fix this issue by using :tacn:`abstract`: - - .. coqtop:: all - - Goal True. - Time assert (id (fact 100) = fact 100) by with_strategy -1 [id] abstract reflexivity. - exact I. - Time Defined. - - On small examples this sort of behavior doesn't matter, but - because |Coq| is a super-linear performance domain in so many - places, unless great care is taken, tactic automation using - :tacn:`with_strategy` may not be robustly performant when - scaling the size of the input. - - .. warning:: - - In much the same way this tactic does not play well with - :cmd:`Qed` and :cmd:`Defined` without using :tacn:`abstract` as - an intermediary, this tactic does not play well with ``coqchk``, - even when used with :tacn:`abstract`, due to the inability of - tactics to persist information about conversion hints in the - proof term. See `#12200 - <https://github.com/coq/coq/issues/12200>`_ for more details. - -Conversion tactics applied to hypotheses -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -.. tacn:: @tactic in {+, @ident} - - Applies :token:`tactic` (any of the conversion tactics listed in this - section) to the hypotheses :n:`{+ @ident}`. - - If :token:`ident` is a local definition, then :token:`ident` can be replaced by - :n:`type of @ident` to address not the body but the type of the local - definition. - - Example: :n:`unfold not in (type of H1) (type of H3)`. - -.. exn:: No such hypothesis: @ident. - :undocumented: - - -.. _automation: - -Automation ----------- - -.. tacn:: auto - :name: auto - - This tactic implements a Prolog-like resolution procedure to solve the - current goal. It first tries to solve the goal using the :tacn:`assumption` - tactic, then it reduces the goal to an atomic one using :tacn:`intros` and - introduces the newly generated hypotheses as hints. Then it looks at - the list of tactics associated to the head symbol of the goal and - tries to apply one of them (starting from the tactics with lower - cost). This process is recursively applied to the generated subgoals. - - By default, :tacn:`auto` only uses the hypotheses of the current goal and - the hints of the database named ``core``. - - .. warning:: - - :tacn:`auto` uses a weaker version of :tacn:`apply` that is closer to - :tacn:`simple apply` so it is expected that sometimes :tacn:`auto` will - fail even if applying manually one of the hints would succeed. - - .. tacv:: auto @natural - - Forces the search depth to be :token:`natural`. The maximal search depth - is 5 by default. - - .. tacv:: auto with {+ @ident} - - Uses the hint databases :n:`{+ @ident}` in addition to the database ``core``. - - .. note:: - - Use the fake database `nocore` if you want to *not* use the `core` - database. - - .. tacv:: auto with * - - Uses all existing hint databases. Using this variant is highly discouraged - in finished scripts since it is both slower and less robust than the variant - where the required databases are explicitly listed. - - .. seealso:: - :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` for the list of - pre-defined databases and the way to create or extend a database. - - .. tacv:: auto using {+ @qualid__i} {? with {+ @ident } } - - Uses lemmas :n:`@qualid__i` in addition to hints. If :n:`@qualid` is an - inductive type, it is the collection of its constructors which are added - as hints. - - .. note:: - - The hints passed through the `using` clause are used in the same - way as if they were passed through a hint database. Consequently, - they use a weaker version of :tacn:`apply` and :n:`auto using @qualid` - may fail where :n:`apply @qualid` succeeds. - - Given that this can be seen as counter-intuitive, it could be useful - to have an option to use full-blown :tacn:`apply` for lemmas passed - through the `using` clause. Contributions welcome! - - .. tacv:: info_auto - - Behaves like :tacn:`auto` but shows the tactics it uses to solve the goal. This - variant is very useful for getting a better understanding of automation, or - to know what lemmas/assumptions were used. - - .. tacv:: debug auto - :name: debug auto - - Behaves like :tacn:`auto` but shows the tactics it tries to solve the goal, - including failing paths. - - .. tacv:: {? info_}auto {? @natural} {? using {+ @qualid}} {? with {+ @ident}} - - This is the most general form, combining the various options. - -.. tacv:: trivial - :name: trivial - - This tactic is a restriction of :tacn:`auto` that is not recursive - and tries only hints that cost `0`. Typically it solves trivial - equalities like :g:`X=X`. - - .. tacv:: trivial with {+ @ident} - trivial with * - trivial using {+ @qualid} - debug trivial - info_trivial - {? info_}trivial {? using {+ @qualid}} {? with {+ @ident}} - :name: _; _; _; debug trivial; info_trivial; _ - :undocumented: - -.. note:: - :tacn:`auto` and :tacn:`trivial` either solve completely the goal or - else succeed without changing the goal. Use :g:`solve [ auto ]` and - :g:`solve [ trivial ]` if you would prefer these tactics to fail when - they do not manage to solve the goal. - -.. flag:: Info Auto - Debug Auto - Info Trivial - Debug Trivial - - These flags enable printing of informative or debug information for - the :tacn:`auto` and :tacn:`trivial` tactics. - -.. tacn:: eauto - :name: eauto - - This tactic generalizes :tacn:`auto`. While :tacn:`auto` does not try - resolution hints which would leave existential variables in the goal, - :tacn:`eauto` does try them (informally speaking, it internally uses a tactic - close to :tacn:`simple eapply` instead of a tactic close to :tacn:`simple apply` - in the case of :tacn:`auto`). As a consequence, :tacn:`eauto` - can solve such a goal: - - .. example:: - - .. coqtop:: all - - Hint Resolve ex_intro : core. - Goal forall P:nat -> Prop, P 0 -> exists n, P n. - eauto. - - Note that ``ex_intro`` should be declared as a hint. - - - .. tacv:: {? info_}eauto {? @natural} {? using {+ @qualid}} {? with {+ @ident}} - - The various options for :tacn:`eauto` are the same as for :tacn:`auto`. - - :tacn:`eauto` also obeys the following flags: - - .. flag:: Info Eauto - Debug Eauto - :undocumented: - - .. seealso:: :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` - - -.. tacn:: autounfold with {+ @ident} - :name: autounfold - - This tactic unfolds constants that were declared through a :cmd:`Hint Unfold` - in the given databases. - -.. tacv:: autounfold with {+ @ident} in @goal_occurrences - - Performs the unfolding in the given clause (:token:`goal_occurrences`). - -.. tacv:: autounfold with * - - Uses the unfold hints declared in all the hint databases. - -.. tacn:: autorewrite with {+ @ident} - :name: autorewrite - - This tactic carries out rewritings according to the rewriting rule - bases :n:`{+ @ident}`. - - Each rewriting rule from the base :n:`@ident` is applied to the main subgoal until - it fails. Once all the rules have been processed, if the main subgoal has - progressed (e.g., if it is distinct from the initial main goal) then the rules - of this base are processed again. If the main subgoal has not progressed then - the next base is processed. For the bases, the behavior is exactly similar to - the processing of the rewriting rules. - - The rewriting rule bases are built with the :cmd:`Hint Rewrite` - command. - -.. warning:: - - This tactic may loop if you build non terminating rewriting systems. - -.. tacv:: autorewrite with {+ @ident} using @tactic - - Performs, in the same way, all the rewritings of the bases :n:`{+ @ident}` - applying tactic to the main subgoal after each rewriting step. - -.. tacv:: autorewrite with {+ @ident} in @qualid - - Performs all the rewritings in hypothesis :n:`@qualid`. - -.. tacv:: autorewrite with {+ @ident} in @qualid using @tactic - - Performs all the rewritings in hypothesis :n:`@qualid` applying :n:`@tactic` - to the main subgoal after each rewriting step. - -.. tacv:: autorewrite with {+ @ident} in @goal_occurrences - - Performs all the rewriting in the clause :n:`@goal_occurrences`. - -.. seealso:: - - :ref:`Hint-Rewrite <hintrewrite>` for feeding the database of lemmas used by - :tacn:`autorewrite` and :tacn:`autorewrite` for examples showing the use of this tactic. - -.. tacn:: easy - :name: easy - - This tactic tries to solve the current goal by a number of standard closing steps. - In particular, it tries to close the current goal using the closing tactics - :tacn:`trivial`, :tacn:`reflexivity`, :tacn:`symmetry`, :tacn:`contradiction` - and :tacn:`inversion` of hypothesis. - If this fails, it tries introducing variables and splitting and-hypotheses, - using the closing tactics afterwards, and splitting the goal using - :tacn:`split` and recursing. - - This tactic solves goals that belong to many common classes; in particular, many cases of - unsatisfiable hypotheses, and simple equality goals are usually solved by this tactic. - -.. tacv:: now @tactic - :name: now - - Run :n:`@tactic` followed by :tacn:`easy`. This is a notation for :n:`@tactic; easy`. - -Controlling automation --------------------------- - -.. _thehintsdatabasesforautoandeauto: - -The hints databases for auto and eauto -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The hints for :tacn:`auto` and :tacn:`eauto` are stored in databases. Each database -maps head symbols to a list of hints. - -.. cmd:: Print Hint @ident - - Use this command - to display the hints associated to the head symbol :n:`@ident` - (see :ref:`Print Hint <printhint>`). Each hint has a cost that is a nonnegative - integer, and an optional pattern. The hints with lower cost are tried first. A - hint is tried by :tacn:`auto` when the conclusion of the current goal matches its - pattern or when it has no pattern. - -Creating Hint databases -``````````````````````` - -One can optionally declare a hint database using the command -:cmd:`Create HintDb`. If a hint is added to an unknown database, it will be -automatically created. - -.. cmd:: Create HintDb @ident {? discriminated} - - This command creates a new database named :n:`@ident`. The database is - implemented by a Discrimination Tree (DT) that serves as an index of - all the lemmas. The DT can use transparency information to decide if a - constant should be indexed or not - (c.f. :ref:`The hints databases for auto and eauto <thehintsdatabasesforautoandeauto>`), - making the retrieval more efficient. The legacy implementation (the default one - for new databases) uses the DT only on goals without existentials (i.e., :tacn:`auto` - goals), for non-Immediate hints and does not make use of transparency - hints, putting more work on the unification that is run after - retrieval (it keeps a list of the lemmas in case the DT is not used). - The new implementation enabled by the discriminated option makes use - of DTs in all cases and takes transparency information into account. - However, the order in which hints are retrieved from the DT may differ - from the order in which they were inserted, making this implementation - observationally different from the legacy one. - -.. cmd:: Hint @hint_definition : {+ @ident} - - The general command to add a hint to some databases :n:`{+ @ident}`. - - This command supports the :attr:`local`, :attr:`global` and :attr:`export` - locality attributes. When no locality is explictly given, the - command is :attr:`local` inside a section and :attr:`global` otherwise. - - + :attr:`local` hints are never visible from other modules, even if they - require or import the current module. Inside a section, the :attr:`local` - attribute is useless since hints do not survive anyway to the closure of - 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. - - + :attr:`global` hints are made available by merely requiring the current - module. - - The various possible :production:`hint_definition`\s are given below. - - .. cmdv:: Hint @hint_definition - - No database name is given: the hint is registered in the ``core`` database. - - .. deprecated:: 8.10 - - .. cmdv:: Hint Resolve @qualid {? | {? @natural} {? @pattern}} : @ident - :name: Hint Resolve - - This command adds :n:`simple apply @qualid` to the hint list with the head - symbol of the type of :n:`@qualid`. The cost of that hint is the number of - subgoals generated by :n:`simple apply @qualid` or :n:`@natural` if specified. The - associated :n:`@pattern` is inferred from the conclusion of the type of - :n:`@qualid` or the given :n:`@pattern` if specified. In case the inferred type - of :n:`@qualid` does not start with a product the tactic added in the hint list - is :n:`exact @qualid`. In case this type can however be reduced to a type - starting with a product, the tactic :n:`simple apply @qualid` is also stored in - the hints list. If the inferred type of :n:`@qualid` contains a dependent - quantification on a variable which occurs only in the premisses of the type - and not in its conclusion, no instance could be inferred for the variable by - unification with the goal. In this case, the hint is added to the hint list - of :tacn:`eauto` instead of the hint list of auto and a warning is printed. A - typical example of a hint that is used only by :tacn:`eauto` is a transitivity - lemma. - - .. exn:: @qualid cannot be used as a hint - - The head symbol of the type of :n:`@qualid` is a bound variable - such that this tactic cannot be associated to a constant. - - .. cmdv:: Hint Resolve {+ @qualid} : @ident - - Adds each :n:`Hint Resolve @qualid`. - - .. cmdv:: Hint Resolve -> @qualid : @ident - - Adds the left-to-right implication of an equivalence as a hint (informally - the hint will be used as :n:`apply <- @qualid`, although as mentioned - before, the tactic actually used is a restricted version of - :tacn:`apply`). - - .. cmdv:: Hint Resolve <- @qualid - - Adds the right-to-left implication of an equivalence as a hint. - - .. cmdv:: Hint Immediate @qualid : @ident - :name: Hint Immediate - - This command adds :n:`simple apply @qualid; trivial` to the hint list associated - with the head symbol of the type of :n:`@ident` in the given database. This - tactic will fail if all the subgoals generated by :n:`simple apply @qualid` are - not solved immediately by the :tacn:`trivial` tactic (which only tries tactics - with cost 0).This command is useful for theorems such as the symmetry of - equality or :g:`n+1=m+1 -> n=m` that we may like to introduce with a limited - use in order to avoid useless proof-search. The cost of this tactic (which - never generates subgoals) is always 1, so that it is not used by :tacn:`trivial` - itself. - - .. exn:: @qualid cannot be used as a hint - :undocumented: - - .. cmdv:: Hint Immediate {+ @qualid} : @ident - - Adds each :n:`Hint Immediate @qualid`. - - .. cmdv:: Hint Constructors @qualid : @ident - :name: Hint Constructors - - If :token:`qualid` is an inductive type, this command adds all its constructors as - hints of type ``Resolve``. Then, when the conclusion of current goal has the form - :n:`(@qualid ...)`, :tacn:`auto` will try to apply each constructor. - - .. exn:: @qualid is not an inductive type - :undocumented: - - .. cmdv:: Hint Constructors {+ @qualid} : @ident - - Extends the previous command for several inductive types. - - .. cmdv:: Hint Unfold @qualid : @ident - :name: Hint Unfold - - This adds the tactic :n:`unfold @qualid` to the hint list that will only be - used when the head constant of the goal is :token:`qualid`. - Its cost is 4. - - .. cmdv:: Hint Unfold {+ @qualid} - - Extends the previous command for several defined constants. - - .. cmdv:: Hint Transparent {+ @qualid} : @ident - Hint Opaque {+ @qualid} : @ident - :name: Hint Transparent; Hint Opaque - - This adds transparency hints to the database, making :n:`@qualid` - transparent or opaque constants during resolution. This information is used - during unification of the goal with any lemma in the database and inside the - discrimination network to relax or constrain it in the case of discriminated - databases. - - .. cmdv:: Hint Variables {| Transparent | Opaque } : @ident - Hint Constants {| Transparent | Opaque } : @ident - :name: Hint Variables; Hint Constants - - This sets the transparency flag used during unification of - hints in the database for all constants or all variables, - overwriting the existing settings of opacity. It is advised - to use this just after a :cmd:`Create HintDb` command. - - .. cmdv:: Hint Extern @natural {? @pattern} => @tactic : @ident - :name: Hint Extern - - This hint type is to extend :tacn:`auto` with tactics other than :tacn:`apply` and - :tacn:`unfold`. For that, we must specify a cost, an optional :n:`@pattern` and a - :n:`@tactic` to execute. - - .. example:: - - .. coqtop:: in - - Hint Extern 4 (~(_ = _)) => discriminate : core. - - Now, when the head of the goal is a disequality, ``auto`` will try - discriminate if it does not manage to solve the goal with hints with a - cost less than 4. - - One can even use some sub-patterns of the pattern in - the tactic script. A sub-pattern is a question mark followed by an - identifier, like ``?X1`` or ``?X2``. Here is an example: - - .. example:: - - .. coqtop:: reset all - - Require Import List. - Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => generalize X1, X2; decide equality : eqdec. - Goal forall a b:list (nat * nat), {a = b} + {a <> b}. - Info 1 auto with eqdec. - - .. cmdv:: Hint Cut @regexp : @ident - :name: Hint Cut - - .. warning:: - - These hints currently only apply to typeclass proof search and the - :tacn:`typeclasses eauto` tactic. - - This command can be used to cut the proof-search tree according to a regular - expression matching paths to be cut. The grammar for regular expressions is - the following. Beware, there is no operator precedence during parsing, one can - check with :cmd:`Print HintDb` to verify the current cut expression: - - .. prodn:: - regexp ::= @ident (hint or instance identifier) - | _ (any hint) - | @regexp | @regexp (disjunction) - | @regexp @regexp (sequence) - | @regexp * (Kleene star) - | emp (empty) - | eps (epsilon) - | ( @regexp ) - - The `emp` regexp does not match any search path while `eps` - matches the empty path. During proof search, the path of - successive successful hints on a search branch is recorded, as a - list of identifiers for the hints (note that :cmd:`Hint Extern`\’s do not have - an associated identifier). - Before applying any hint :n:`@ident` the current path `p` extended with - :n:`@ident` is matched against the current cut expression `c` associated to - the hint database. If matching succeeds, the hint is *not* applied. The - semantics of :n:`Hint Cut @regexp` is to set the cut expression - to :n:`c | regexp`, the initial cut expression being `emp`. - - .. cmdv:: Hint Mode @qualid {* {| + | ! | - } } : @ident - :name: Hint Mode - - This sets an optional mode of use of the identifier :n:`@qualid`. When - proof-search faces a goal that ends in an application of :n:`@qualid` to - arguments :n:`@term ... @term`, the mode tells if the hints associated to - :n:`@qualid` can be applied or not. A mode specification is a list of n ``+``, - ``!`` or ``-`` items that specify if an argument of the identifier is to be - treated as an input (``+``), if its head only is an input (``!``) or an output - (``-``) of the identifier. For a mode to match a list of arguments, input - terms and input heads *must not* contain existential variables or be - existential variables respectively, while outputs can be any term. Multiple - modes can be declared for a single identifier, in that case only one mode - needs to match the arguments for the hints to be applied. The head of a term - is understood here as the applicative head, or the match or projection - scrutinee’s head, recursively, casts being ignored. :cmd:`Hint Mode` is - especially useful for typeclasses, when one does not want to support default - instances and avoid ambiguity in general. Setting a parameter of a class as an - input forces proof-search to be driven by that index of the class, with ``!`` - giving more flexibility by allowing existentials to still appear deeper in the - index but not at its head. - - .. note:: - - + One can use a :cmd:`Hint Extern` with no pattern to do - pattern matching on hypotheses using ``match goal with`` - inside the tactic. - - + If you want to add hints such as :cmd:`Hint Transparent`, - :cmd:`Hint Cut`, or :cmd:`Hint Mode`, for typeclass - resolution, do not forget to put them in the - ``typeclass_instances`` hint database. - - -Hint databases defined in the Coq standard library -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Several hint databases are defined in the Coq standard library. The -actual content of a database is the collection of hints declared -to belong to this database in each of the various modules currently -loaded. Especially, requiring new modules may extend the database. -At Coq startup, only the core database is nonempty and can be used. - -:core: This special database is automatically used by ``auto``, except when - pseudo-database ``nocore`` is given to ``auto``. The core database - contains only basic lemmas about negation, conjunction, and so on. - Most of the hints in this database come from the Init and Logic directories. - -:arith: This database contains all lemmas about Peano’s arithmetic proved in the - directories Init and Arith. - -:zarith: contains lemmas about binary signed integers from the - directories theories/ZArith. The database also contains - high-cost hints that call :tacn:`lia` on equations and - inequalities in ``nat`` or ``Z``. - -:bool: contains lemmas about booleans, mostly from directory theories/Bool. - -:datatypes: is for lemmas about lists, streams and so on that are mainly proved - in the Lists subdirectory. - -:sets: contains lemmas about sets and relations from the directories Sets and - Relations. - -:typeclass_instances: contains all the typeclass instances declared in the - environment, including those used for ``setoid_rewrite``, - from the Classes directory. - -:fset: internal database for the implementation of the ``FSets`` library. - -:ordered_type: lemmas about ordered types (as defined in the legacy ``OrderedType`` module), - mainly used in the ``FSets`` and ``FMaps`` libraries. - -You are advised not to put your own hints in the core database, but -use one or several databases specific to your development. - -.. _removehints: - -.. cmd:: Remove Hints {+ @term} : {+ @ident} - - This command removes the hints associated to terms :n:`{+ @term}` in databases - :n:`{+ @ident}`. - -.. _printhint: - -.. cmd:: Print Hint - - This command displays all hints that apply to the current goal. It - fails if no proof is being edited, while the two variants can be used - at every moment. - -**Variants:** - - -.. cmd:: Print Hint @ident - - This command displays only tactics associated with :n:`@ident` in the hints - list. This is independent of the goal being edited, so this command will not - fail if no goal is being edited. - -.. cmd:: Print Hint * - - This command displays all declared hints. - -.. cmd:: Print HintDb @ident - - This command displays all hints from database :n:`@ident`. - -.. _hintrewrite: - -.. cmd:: Hint Rewrite {+ @term} : {+ @ident} - - This vernacular command adds the terms :n:`{+ @term}` (their types must be - equalities) in the rewriting bases :n:`{+ @ident}` with the default orientation - (left to right). Notice that the rewriting bases are distinct from the :tacn:`auto` - hint bases and that :tacn:`auto` does not take them into account. - - This command is synchronous with the section mechanism (see :ref:`section-mechanism`): - when closing a section, all aliases created by ``Hint Rewrite`` in that - section are lost. Conversely, when loading a module, all ``Hint Rewrite`` - declarations at the global level of that module are loaded. - -**Variants:** - -.. cmd:: Hint Rewrite -> {+ @term} : {+ @ident} - - This is strictly equivalent to the command above (we only make explicit the - orientation which otherwise defaults to ->). - -.. cmd:: Hint Rewrite <- {+ @term} : {+ @ident} - - Adds the rewriting rules :n:`{+ @term}` with a right-to-left orientation in - the bases :n:`{+ @ident}`. - -.. cmd:: Hint Rewrite {+ @term} using @tactic : {+ @ident} - - When the rewriting rules :n:`{+ @term}` in :n:`{+ @ident}` will be used, the - tactic ``tactic`` will be applied to the generated subgoals, the main subgoal - excluded. - -.. cmd:: Print Rewrite HintDb @ident - - This command displays all rewrite hints contained in :n:`@ident`. - -Hint locality -~~~~~~~~~~~~~ - -Hints provided by the ``Hint`` commands are erased when closing a section. -Conversely, all hints of a module ``A`` that are not defined inside a -section (and not defined with option ``Local``) become available when the -module ``A`` is required (using e.g. ``Require A.``). - -As of today, hints only have a binary behavior regarding locality, as -described above: either they disappear at the end of a section scope, -or they remain global forever. This causes a scalability issue, -because hints coming from an unrelated part of the code may badly -influence another development. It can be mitigated to some extent -thanks to the :cmd:`Remove Hints` command, -but this is a mere workaround and has some limitations (for instance, external -hints cannot be removed). - -A proper way to fix this issue is to bind the hints to their module scope, as -for most of the other objects Coq uses. Hints should only be made available when -the module they are defined in is imported, not just required. It is very -difficult to change the historical behavior, as it would break a lot of scripts. -We propose a smooth transitional path by providing the :opt:`Loose Hint Behavior` -option which accepts three flags allowing for a fine-grained handling of -non-imported hints. - -.. opt:: Loose Hint Behavior {| "Lax" | "Warn" | "Strict" } - :name: Loose Hint Behavior - - This option accepts three values, which control the behavior of hints w.r.t. - :cmd:`Import`: - - - "Lax": this is the default, and corresponds to the historical behavior, - that is, hints defined outside of a section have a global scope. - - - "Warn": outputs a warning when a non-imported hint is used. Note that this - is an over-approximation, because a hint may be triggered by a run that - will eventually fail and backtrack, resulting in the hint not being - actually useful for the proof. - - - "Strict": changes the behavior of an unloaded hint to a immediate fail - tactic, allowing to emulate an import-scoped hint mechanism. - -.. _tactics-implicit-automation: - -Setting implicit automation tactics -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -.. cmd:: Proof with @tactic - - This command may be used to start a proof. It defines a default tactic - to be used each time a tactic command ``tactic``:sub:`1` is ended by ``...``. - In this case the tactic command typed by the user is equivalent to - ``tactic``:sub:`1` ``;tactic``. - - .. seealso:: :cmd:`Proof` in :ref:`proof-editing-mode`. - - - .. cmdv:: Proof with @tactic using {+ @ident} - - Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`proof-editing-mode` - - .. cmdv:: Proof using {+ @ident} with @tactic - - Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`proof-editing-mode` - -.. _decisionprocedures: - -Decision procedures -------------------- - -.. tacn:: tauto - :name: tauto - - This tactic implements a decision procedure for intuitionistic propositional - calculus based on the contraction-free sequent calculi LJT* of Roy Dyckhoff - :cite:`Dyc92`. Note that :tacn:`tauto` succeeds on any instance of an - intuitionistic tautological proposition. :tacn:`tauto` unfolds negations and - logical equivalence but does not unfold any other definition. - -.. example:: - - The following goal can be proved by :tacn:`tauto` whereas :tacn:`auto` would - fail: - - .. coqtop:: reset all - - Goal forall (x:nat) (P:nat -> Prop), x = 0 \/ P x -> x <> 0 -> P x. - intros. - tauto. - -Moreover, if it has nothing else to do, :tacn:`tauto` performs introductions. -Therefore, the use of :tacn:`intros` in the previous proof is unnecessary. -:tacn:`tauto` can for instance for: - -.. example:: - - .. coqtop:: reset all - - Goal forall (A:Prop) (P:nat -> Prop), A \/ (forall x:nat, ~ A -> P x) -> forall x:nat, ~ A -> P x. - tauto. - -.. note:: - In contrast, :tacn:`tauto` cannot solve the following goal - :g:`Goal forall (A:Prop) (P:nat -> Prop), A \/ (forall x:nat, ~ A -> P x) ->` - :g:`forall x:nat, ~ ~ (A \/ P x).` - because :g:`(forall x:nat, ~ A -> P x)` cannot be treated as atomic and - an instantiation of `x` is necessary. - -.. tacv:: dtauto - :name: dtauto - - While :tacn:`tauto` recognizes inductively defined connectives isomorphic to - the standard connectives ``and``, ``prod``, ``or``, ``sum``, ``False``, - ``Empty_set``, ``unit``, ``True``, :tacn:`dtauto` also recognizes all inductive - types with one constructor and no indices, i.e. record-style connectives. - -.. tacn:: intuition @tactic - :name: intuition - - The tactic :tacn:`intuition` takes advantage of the search-tree built by the - decision procedure involved in the tactic :tacn:`tauto`. It uses this - information to generate a set of subgoals equivalent to the original one (but - simpler than it) and applies the tactic :n:`@tactic` to them :cite:`Mun94`. If - this tactic fails on some goals then :tacn:`intuition` fails. In fact, - :tacn:`tauto` is simply :g:`intuition fail`. - - .. example:: - - For instance, the tactic :g:`intuition auto` applied to the goal:: - - (forall (x:nat), P x) /\ B -> (forall (y:nat), P y) /\ P O \/ B /\ P O - - internally replaces it by the equivalent one:: - - (forall (x:nat), P x), B |- P O - - and then uses :tacn:`auto` which completes the proof. - -Originally due to César Muñoz, these tactics (:tacn:`tauto` and -:tacn:`intuition`) have been completely re-engineered by David Delahaye using -mainly the tactic language (see :ref:`ltac`). The code is -now much shorter and a significant increase in performance has been noticed. -The general behavior with respect to dependent types, unfolding and -introductions has slightly changed to get clearer semantics. This may lead to -some incompatibilities. - -.. tacv:: intuition - - Is equivalent to :g:`intuition auto with *`. - -.. tacv:: dintuition - :name: dintuition - - While :tacn:`intuition` recognizes inductively defined connectives - isomorphic to the standard connectives ``and``, ``prod``, ``or``, ``sum``, ``False``, - ``Empty_set``, ``unit``, ``True``, :tacn:`dintuition` also recognizes all inductive - types with one constructor and no indices, i.e. record-style connectives. - -.. flag:: Intuition Negation Unfolding - - Controls whether :tacn:`intuition` unfolds inner negations which do not need - to be unfolded. This flag is on by default. - -.. tacn:: rtauto - :name: rtauto - - The :tacn:`rtauto` tactic solves propositional tautologies similarly to what - :tacn:`tauto` does. The main difference is that the proof term is built using a - reflection scheme applied to a sequent calculus proof of the goal. The search - procedure is also implemented using a different technique. - - Users should be aware that this difference may result in faster proof-search - but slower proof-checking, and :tacn:`rtauto` might not solve goals that - :tacn:`tauto` would be able to solve (e.g. goals involving universal - quantifiers). - - Note that this tactic is only available after a ``Require Import Rtauto``. - -.. tacn:: firstorder - :name: firstorder - - The tactic :tacn:`firstorder` is an experimental extension of :tacn:`tauto` to - first- order reasoning, written by Pierre Corbineau. It is not restricted to - usual logical connectives but instead may reason about any first-order class - inductive definition. - -.. opt:: Firstorder Solver @tactic - :name: Firstorder Solver - - The default tactic used by :tacn:`firstorder` when no rule applies is - :g:`auto with core`, it can be reset locally or globally using this option. - - .. cmd:: Print Firstorder Solver - - Prints the default tactic used by :tacn:`firstorder` when no rule applies. - -.. tacv:: firstorder @tactic - - Tries to solve the goal with :n:`@tactic` when no logical rule may apply. - -.. tacv:: firstorder using {+ @qualid} - - .. deprecated:: 8.3 - - Use the syntax below instead (with commas). - -.. tacv:: firstorder using {+, @qualid} - - Adds lemmas :n:`{+, @qualid}` to the proof-search environment. If :n:`@qualid` - refers to an inductive type, it is the collection of its constructors which are - added to the proof-search environment. - -.. tacv:: firstorder with {+ @ident} - - Adds lemmas from :tacn:`auto` hint bases :n:`{+ @ident}` to the proof-search - environment. - -.. tacv:: firstorder @tactic using {+, @qualid} with {+ @ident} - - This combines the effects of the different variants of :tacn:`firstorder`. - -.. opt:: Firstorder Depth @natural - :name: Firstorder Depth - - This option controls the proof-search depth bound. - -.. tacn:: congruence - :name: congruence - - The tactic :tacn:`congruence`, by Pierre Corbineau, implements the standard - Nelson and Oppen congruence closure algorithm, which is a decision procedure - for ground equalities with uninterpreted symbols. It also includes - constructor theory (see :tacn:`injection` and :tacn:`discriminate`). If the goal - is a non-quantified equality, congruence tries to prove it with non-quantified - equalities in the context. Otherwise it tries to infer a discriminable equality - from those in the context. Alternatively, congruence tries to prove that a - hypothesis is equal to the goal or to the negation of another hypothesis. - - :tacn:`congruence` is also able to take advantage of hypotheses stating - quantified equalities, but you have to provide a bound for the number of extra - equalities generated that way. Please note that one of the sides of the - equality must contain all the quantified variables in order for congruence to - match against it. - -.. example:: - - .. coqtop:: reset all - - Theorem T (A:Type) (f:A -> A) (g: A -> A -> A) a b: a=(f a) -> (g b (f a))=(f (f a)) -> (g a b)=(f (g b a)) -> (g a b)=a. - intros. - congruence. - Qed. - - Theorem inj (A:Type) (f:A -> A * A) (a c d: A) : f = pair a -> Some (f c) = Some (f d) -> c=d. - intros. - congruence. - Qed. - -.. tacv:: congruence @natural - - Tries to add at most :token:`natural` instances of hypotheses stating quantified equalities - to the problem in order to solve it. A bigger value of :token:`natural` does not make - success slower, only failure. You might consider adding some lemmas as - hypotheses using assert in order for :tacn:`congruence` to use them. - -.. tacv:: congruence with {+ @term} - :name: congruence with - - Adds :n:`{+ @term}` to the pool of terms used by :tacn:`congruence`. This helps - in case you have partially applied constructors in your goal. - -.. exn:: I don’t know how to handle dependent equality. - - The decision procedure managed to find a proof of the goal or of a - discriminable equality but this proof could not be built in Coq because of - dependently-typed functions. - -.. exn:: Goal is solvable by congruence but some arguments are missing. Try congruence with {+ @term}, replacing metavariables by arbitrary terms. - - The decision procedure could solve the goal with the provision that additional - arguments are supplied for some partially applied constructors. Any term of an - appropriate type will allow the tactic to successfully solve the goal. Those - additional arguments can be given to congruence by filling in the holes in the - terms given in the error message, using the :tacn:`congruence with` variant described above. - -.. flag:: Congruence Verbose - - This flag makes :tacn:`congruence` print debug information. - Checking properties of terms ---------------------------- @@ -4600,13 +2840,13 @@ symbol :g:`=`. :n:`simplify_eq @ident` where :n:`@ident` is the identifier for the last introduced hypothesis. -.. tacv:: simplify_eq @term with @bindings_list +.. tacv:: simplify_eq @term with @bindings This does the same as :n:`simplify_eq @term` but using the given bindings to instantiate parameters or hypotheses of :n:`@term`. .. tacv:: esimplify_eq @natural - esimplify_eq @term {? with @bindings_list} + esimplify_eq @term {? with @bindings} :name: esimplify_eq; _ This works the same as :tacn:`simplify_eq` but if the type of :n:`@term`, or the @@ -4653,189 +2893,6 @@ using the ``Require Import`` command. Use :tacn:`classical_right` to prove the right part of the disjunction with the assumption that the negation of left part holds. -.. _tactics-automating: - -Automating ------------- - - -.. tacn:: btauto - :name: btauto - - The tactic :tacn:`btauto` implements a reflexive solver for boolean - tautologies. It solves goals of the form :g:`t = u` where `t` and `u` are - constructed over the following grammar: - - .. prodn:: - btauto_term ::= @ident - | true - | false - | orb @btauto_term @btauto_term - | andb @btauto_term @btauto_term - | xorb @btauto_term @btauto_term - | negb @btauto_term - | if @btauto_term then @btauto_term else @btauto_term - - Whenever the formula supplied is not a tautology, it also provides a - counter-example. - - Internally, it uses a system very similar to the one of the ring - tactic. - - Note that this tactic is only available after a ``Require Import Btauto``. - - .. exn:: Cannot recognize a boolean equality. - - The goal is not of the form :g:`t = u`. Especially note that :tacn:`btauto` - doesn't introduce variables into the context on its own. - -.. tacv:: field - field_simplify {* @term} - field_simplify_eq - - The field tactic is built on the same ideas as ring: this is a - reflexive tactic that solves or simplifies equations in a field - structure. The main idea is to reduce a field expression (which is an - extension of ring expressions with the inverse and division - operations) to a fraction made of two polynomial expressions. - - Tactic :n:`field` is used to solve subgoals, whereas :n:`field_simplify {+ @term}` - replaces the provided terms by their reduced fraction. - :n:`field_simplify_eq` applies when the conclusion is an equation: it - simplifies both hand sides and multiplies so as to cancel - denominators. So it produces an equation without division nor inverse. - - All of these 3 tactics may generate a subgoal in order to prove that - denominators are different from zero. - - See :ref:`Theringandfieldtacticfamilies` for more information on the tactic and how to - declare new field structures. All declared field structures can be - printed with the Print Fields command. - -.. example:: - - .. coqtop:: reset all - - Require Import Reals. - Goal forall x y:R, - (x * y > 0)%R -> - (x * (1 / x + x / (x + y)))%R = - ((- 1 / y) * y * (- x * (x / (x + y)) - 1))%R. - - intros; field. - -.. seealso:: - - File plugins/ring/RealField.v for an example of instantiation, - theory theories/Reals for many examples of use of field. - -Non-logical tactics ------------------------- - - -.. tacn:: cycle @integer - :name: cycle - - Reorders the selected goals so that the first :n:`@integer` goals appear after the - other selected goals. - If :n:`@integer` is negative, it puts the last :n:`@integer` goals at the - beginning of the list. - The tactic is only useful with a goal selector, most commonly `all:`. - Note that other selectors reorder goals; `1,3: cycle 1` is not equivalent - to `all: cycle 1`. See :tacn:`… : … (goal selector)`. - -.. example:: - - .. coqtop:: none reset - - Parameter P : nat -> Prop. - - .. coqtop:: all abort - - Goal P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5. - repeat split. - all: cycle 2. - all: cycle -3. - -.. tacn:: swap @integer @integer - :name: swap - - Exchanges the position of the specified goals. - Negative values for :n:`@integer` indicate counting goals - backward from the end of the list of selected goals. Goals are indexed from 1. - The tactic is only useful with a goal selector, most commonly `all:`. - Note that other selectors reorder goals; `1,3: swap 1 3` is not equivalent - to `all: swap 1 3`. See :tacn:`… : … (goal selector)`. - -.. example:: - - .. coqtop:: all abort - - Goal P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5. - repeat split. - all: swap 1 3. - all: swap 1 -1. - -.. tacn:: revgoals - :name: revgoals - - Reverses the order of the selected goals. The tactic is only useful with a goal - selector, most commonly `all :`. Note that other selectors reorder goals; - `1,3: revgoals` is not equivalent to `all: revgoals`. See :tacn:`… : … (goal selector)`. - - .. example:: - - .. coqtop:: all abort - - Goal P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5. - repeat split. - all: revgoals. - -.. tacn:: shelve - :name: shelve - - This tactic moves all goals under focus to a shelf. While on the - shelf, goals will not be focused on. They can be solved by - unification, or they can be called back into focus with the command - :cmd:`Unshelve`. - - .. tacv:: shelve_unifiable - :name: shelve_unifiable - - Shelves only the goals under focus that are mentioned in other goals. - Goals that appear in the type of other goals can be solved by unification. - - .. example:: - - .. coqtop:: all abort - - Goal exists n, n=0. - refine (ex_intro _ _ _). - all: shelve_unifiable. - reflexivity. - -.. cmd:: Unshelve - - This command moves all the goals on the shelf (see :tacn:`shelve`) - from the shelf into focus, by appending them to the end of the current - list of focused goals. - -.. tacn:: unshelve @tactic - :name: unshelve - - Performs :n:`@tactic`, then unshelves existential variables added to the - shelf by the execution of :n:`@tactic`, prepending them to the current goal. - -.. tacn:: give_up - :name: give_up - - This tactic removes the focused goals from the proof. They are not - solved, and cannot be solved later in the proof. As the goals are not - solved, the proof cannot be closed. - - The ``give_up`` tactic can be used while editing a proof, to choose to - write the proof script in a non-sequential order. - Delaying solving unification constraints ---------------------------------------- diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 6c07253bce..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. @@ -433,7 +433,7 @@ Requests to the environment reference ::= @qualid | @string {? % @scope_key } - Displays the full name of objects from |Coq|'s various qualified namespaces such as terms, + Displays the full name of objects from Coq's various qualified namespaces such as terms, modules and Ltac, thereby showing the module they are defined in. It also displays notation definitions. :n:`@qualid` @@ -491,7 +491,7 @@ Printing flags .. flag:: Fast Name Printing - When turned on, |Coq| uses an asymptotically faster algorithm for the + When turned on, Coq uses an asymptotically faster algorithm for the generation of unambiguous names of bound variables while printing terms. While faster, it is also less clever and results in a typically less elegant display, e.g. it will generate more names rather than reusing certain names @@ -504,12 +504,12 @@ Printing flags Loading files ----------------- -|Coq| offers the possibility of loading different parts of a whole +Coq offers the possibility of loading different parts of a whole development stored in separate files. Their contents will be loaded as if they were entered from the keyboard. This means that the loaded -files are text files containing sequences of commands for |Coq|’s -toplevel. This kind of file is called a *script* for |Coq|. The standard -(and default) extension of |Coq|’s script files is .v. +files are text files containing sequences of commands for Coq’s +toplevel. This kind of file is called a *script* for Coq. The standard +(and default) extension of Coq’s script files is .v. .. cmd:: Load {? Verbose } {| @string | @ident } @@ -521,7 +521,7 @@ toplevel. This kind of file is called a *script* for |Coq|. The standard If :n:`@string` is specified, it must specify a complete filename. `~` and .. abbreviations are - allowed as well as shell variables. If no extension is specified, |Coq| + allowed as well as shell variables. If no extension is specified, Coq will use the default extension ``.v``. Files loaded this way can't leave proofs open, nor can :cmd:`Load` @@ -531,7 +531,7 @@ toplevel. This kind of file is called a *script* for |Coq|. The standard :cmd:`Require` loads `.vo` files that were previously compiled from `.v` files. - :n:`Verbose` displays the |Coq| output for each command and tactic + :n:`Verbose` displays the Coq output for each command and tactic in the loaded file, as if the commands and tactics were entered interactively. .. exn:: Can’t find file @ident on loadpath. @@ -556,14 +556,14 @@ file is a particular case of a module called a *library file*. .. cmd:: Require {? {| Import | Export } } {+ @qualid } :name: Require; Require Import; Require Export - Loads compiled modules into the |Coq| environment. For each :n:`@qualid`, which has the form + Loads compiled modules into the Coq environment. For each :n:`@qualid`, which has the form :n:`{* @ident__prefix . } @ident`, the command searches for the logical name represented by the :n:`@ident__prefix`\s and loads the compiled file :n:`@ident.vo` from the associated filesystem directory. The process is applied recursively to all the loaded files; if they contain :cmd:`Require` commands, those commands are executed as well. - The compiled files must have been compiled with the same version of |Coq|. + The compiled files must have been compiled with the same version of Coq. The compiled files are neither replayed nor rechecked. * :n:`Import` - additionally does an :cmd:`Import` on the loaded module, making components defined @@ -606,15 +606,15 @@ file is a particular case of a module called a *library file*. The command tried to load library file :n:`@ident`.vo that depends on some specific version of library :n:`@qualid` which is not the - one already loaded in the current |Coq| session. Probably :n:`@ident.v` was + one already loaded in the current Coq session. Probably :n:`@ident.v` was not properly recompiled with the last version of the file containing module :token:`qualid`. .. exn:: Bad magic number. The file :n:`@ident.vo` was found but either it is not a - |Coq| compiled module, or it was compiled with an incompatible - version of |Coq|. + Coq compiled module, or it was compiled with an incompatible + version of Coq. .. exn:: The file @ident.vo contains library @qualid__1 and not library @qualid__2. @@ -633,15 +633,16 @@ file is a particular case of a module called a *library file*. .. cmd:: Print Libraries This command displays the list of library files loaded in the - current |Coq| session. + current Coq session. .. cmd:: Declare ML Module {+ @string } 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 @@ -666,7 +667,7 @@ file is a particular case of a module called a *library file*. Loadpath ------------ -Loadpaths are preferably managed using |Coq| command line options (see +Loadpaths are preferably managed using Coq command line options (see Section :ref:`libraries-and-filesystem`) but there remain vernacular commands to manage them for practical purposes. Such commands are only meant to be issued in the toplevel, and using them in source files is discouraged. @@ -703,33 +704,35 @@ the toplevel, and using them in source files is discouraged. This command is equivalent to the command line option :n:`-R @string @dirpath`. It adds the physical directory string and all its - subdirectories to the current |Coq| loadpath. + subdirectories to the current Coq loadpath. .. cmd:: Remove LoadPath @string - This command removes the path :n:`@string` from the current |Coq| loadpath. + This command removes the path :n:`@string` from the current Coq loadpath. .. cmd:: Print LoadPath {? @dirpath } - This command displays the current |Coq| loadpath. If :n:`@dirpath` is specified, + This command displays the current Coq loadpath. If :n:`@dirpath` is specified, displays only the paths that extend that prefix. .. 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: @@ -789,13 +792,13 @@ Quitting and debugging .. cmd:: Quit - Causes |Coq| to exit. Valid only in coqtop. + Causes Coq to exit. Valid only in coqtop. .. cmd:: Drop This command temporarily enters the OCaml toplevel. - It is a debug facility used by |Coq|’s implementers. Valid only in the + It is a debug facility used by Coq’s implementers. Valid only in the bytecode version of coqtop. The OCaml command: @@ -804,10 +807,10 @@ Quitting and debugging #use "include";; adds the right loadpaths and loads some toplevel printers for all - abstract types of |Coq|- section_path, identifiers, terms, judgments, …. + abstract types of Coq- section_path, identifiers, terms, judgments, …. You can also use the file base_include instead, that loads only the pretty-printers for section_paths and identifiers. You can return back - to |Coq| with the command: + to Coq with the command: :: @@ -815,9 +818,9 @@ Quitting and debugging .. warning:: - #. It only works with the bytecode version of |Coq| (i.e. `coqtop.byte`, + #. It only works with the bytecode version of Coq (i.e. `coqtop.byte`, see Section `interactive-use`). - #. You must have compiled |Coq| from the source package and set the + #. You must have compiled Coq from the source package and set the environment variable COQTOP to the root of your copy of the sources (see Section `customization-by-environment-variables`). @@ -961,7 +964,7 @@ Controlling the reduction strategies and the conversion algorithm ---------------------------------------------------------------------- -|Coq| provides reduction strategies that the tactics can invoke and two +Coq provides reduction strategies that the tactics can invoke and two different algorithms to check the convertibility of types. The first conversion algorithm lazily compares applicative terms while the other is a brute-force but efficient algorithm that first normalizes the @@ -980,21 +983,16 @@ described first. This command has an effect on unfoldable constants, i.e. on constants defined by :cmd:`Definition` or :cmd:`Let` (with an explicit body), or by a command - assimilated to a definition such as :cmd:`Fixpoint`, :cmd:`Program Definition`, etc, + associated with a definition such as :cmd:`Fixpoint`, etc, or by a proof ended by :cmd:`Defined`. The command tells not to unfold the constants in the :n:`@reference` sequence in tactics using δ-conversion (unfolding a constant is replacing it by its definition). - :cmd:`Opaque` has also an effect on the conversion algorithm of |Coq|, telling - it to delay the unfolding of a constant as much as possible when |Coq| + :cmd:`Opaque` has also an effect on the conversion algorithm of Coq, telling + it to delay the unfolding of a constant as much as possible when Coq has to check the conversion (see Section :ref:`conversion-rules`) of two distinct applied constants. - .. seealso:: - - Sections :ref:`performingcomputations`, :ref:`tactics-automating`, - :ref:`proof-editing-mode` - .. cmd:: Transparent {+ @reference } This command accepts the :attr:`global` attribute. By default, the scope @@ -1015,10 +1013,7 @@ described first. There is no constant named :n:`@qualid` in the environment. - .. seealso:: - - Sections :ref:`performingcomputations`, - :ref:`tactics-automating`, :ref:`proof-editing-mode` +.. seealso:: :ref:`performingcomputations` and :ref:`proof-editing-mode` .. _vernac-strategy: @@ -1231,7 +1226,7 @@ in support libraries of plug-ins. .. _exposing-constants-to-ocaml-libraries: Exposing constants to OCaml libraries -````````````````````````````````````` +``````````````````````````````````````` .. cmd:: Register @qualid__1 as @qualid__2 @@ -1268,8 +1263,8 @@ Registering primitive operations .. cmd:: Primitive @ident_decl {? : @term } := #@ident Makes the primitive type or primitive operator :n:`#@ident` defined in OCaml - accessible in |Coq| commands and tactics. - For internal use by implementors of |Coq|'s standard library or standard library + accessible in Coq commands and tactics. + For internal use by implementors of Coq's standard library or standard library replacements. No space is allowed after the `#`. Invalid values give a syntax error. diff --git a/doc/sphinx/proofs/automatic-tactics/auto.rst b/doc/sphinx/proofs/automatic-tactics/auto.rst new file mode 100644 index 0000000000..cc4ab76502 --- /dev/null +++ b/doc/sphinx/proofs/automatic-tactics/auto.rst @@ -0,0 +1,689 @@ +.. _automation: + +========================= +Programmable proof search +========================= + +.. tacn:: auto + :name: auto + + This tactic implements a Prolog-like resolution procedure to solve the + current goal. It first tries to solve the goal using the :tacn:`assumption` + tactic, then it reduces the goal to an atomic one using :tacn:`intros` and + introduces the newly generated hypotheses as hints. Then it looks at + the list of tactics associated to the head symbol of the goal and + tries to apply one of them (starting from the tactics with lower + cost). This process is recursively applied to the generated subgoals. + + By default, :tacn:`auto` only uses the hypotheses of the current goal and + the hints of the database named ``core``. + + .. warning:: + + :tacn:`auto` uses a weaker version of :tacn:`apply` that is closer to + :tacn:`simple apply` so it is expected that sometimes :tacn:`auto` will + fail even if applying manually one of the hints would succeed. + + .. tacv:: auto @natural + + Forces the search depth to be :token:`natural`. The maximal search depth + is 5 by default. + + .. tacv:: auto with {+ @ident} + + Uses the hint databases :n:`{+ @ident}` in addition to the database ``core``. + + .. note:: + + Use the fake database `nocore` if you want to *not* use the `core` + database. + + .. tacv:: auto with * + + Uses all existing hint databases. Using this variant is highly discouraged + in finished scripts since it is both slower and less robust than the variant + where the required databases are explicitly listed. + + .. seealso:: + :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` for the list of + pre-defined databases and the way to create or extend a database. + + .. tacv:: auto using {+ @qualid__i} {? with {+ @ident } } + + Uses lemmas :n:`@qualid__i` in addition to hints. If :n:`@qualid` is an + inductive type, it is the collection of its constructors which are added + as hints. + + .. note:: + + The hints passed through the `using` clause are used in the same + way as if they were passed through a hint database. Consequently, + they use a weaker version of :tacn:`apply` and :n:`auto using @qualid` + may fail where :n:`apply @qualid` succeeds. + + Given that this can be seen as counter-intuitive, it could be useful + to have an option to use full-blown :tacn:`apply` for lemmas passed + through the `using` clause. Contributions welcome! + + .. tacv:: info_auto + + Behaves like :tacn:`auto` but shows the tactics it uses to solve the goal. This + variant is very useful for getting a better understanding of automation, or + to know what lemmas/assumptions were used. + + .. tacv:: debug auto + :name: debug auto + + Behaves like :tacn:`auto` but shows the tactics it tries to solve the goal, + including failing paths. + + .. tacv:: {? info_}auto {? @natural} {? using {+ @qualid}} {? with {+ @ident}} + + This is the most general form, combining the various options. + +.. tacv:: trivial + :name: trivial + + This tactic is a restriction of :tacn:`auto` that is not recursive + and tries only hints that cost `0`. Typically it solves trivial + equalities like :g:`X=X`. + + .. tacv:: trivial with {+ @ident} + trivial with * + trivial using {+ @qualid} + debug trivial + info_trivial + {? info_}trivial {? using {+ @qualid}} {? with {+ @ident}} + :name: _; _; _; debug trivial; info_trivial; _ + :undocumented: + +.. note:: + :tacn:`auto` and :tacn:`trivial` either solve completely the goal or + else succeed without changing the goal. Use :g:`solve [ auto ]` and + :g:`solve [ trivial ]` if you would prefer these tactics to fail when + they do not manage to solve the goal. + +.. flag:: Info Auto + Debug Auto + Info Trivial + Debug Trivial + + These flags enable printing of informative or debug information for + the :tacn:`auto` and :tacn:`trivial` tactics. + +.. tacn:: eauto + :name: eauto + + This tactic generalizes :tacn:`auto`. While :tacn:`auto` does not try + resolution hints which would leave existential variables in the goal, + :tacn:`eauto` does try them (informally speaking, it internally uses a tactic + close to :tacn:`simple eapply` instead of a tactic close to :tacn:`simple apply` + in the case of :tacn:`auto`). As a consequence, :tacn:`eauto` + can solve such a goal: + + .. example:: + + .. coqtop:: none + + Set Warnings "-deprecated-hint-without-locality". + + .. coqtop:: all + + Hint Resolve ex_intro : core. + Goal forall P:nat -> Prop, P 0 -> exists n, P n. + eauto. + + Note that ``ex_intro`` should be declared as a hint. + + + .. tacv:: {? info_}eauto {? @natural} {? using {+ @qualid}} {? with {+ @ident}} + + The various options for :tacn:`eauto` are the same as for :tacn:`auto`. + + :tacn:`eauto` also obeys the following flags: + + .. flag:: Info Eauto + Debug Eauto + :undocumented: + + .. seealso:: :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` + + +.. tacn:: autounfold with {+ @ident} + :name: autounfold + + This tactic unfolds constants that were declared through a :cmd:`Hint Unfold` + in the given databases. + +.. tacv:: autounfold with {+ @ident} in @goal_occurrences + + Performs the unfolding in the given clause (:token:`goal_occurrences`). + +.. tacv:: autounfold with * + + Uses the unfold hints declared in all the hint databases. + +.. tacn:: autorewrite with {+ @ident} + :name: autorewrite + + This tactic carries out rewritings according to the rewriting rule + bases :n:`{+ @ident}`. + + Each rewriting rule from the base :n:`@ident` is applied to the main subgoal until + it fails. Once all the rules have been processed, if the main subgoal has + progressed (e.g., if it is distinct from the initial main goal) then the rules + of this base are processed again. If the main subgoal has not progressed then + the next base is processed. For the bases, the behavior is exactly similar to + the processing of the rewriting rules. + + The rewriting rule bases are built with the :cmd:`Hint Rewrite` + command. + +.. warning:: + + This tactic may loop if you build non terminating rewriting systems. + +.. tacv:: autorewrite with {+ @ident} using @tactic + + Performs, in the same way, all the rewritings of the bases :n:`{+ @ident}` + applying tactic to the main subgoal after each rewriting step. + +.. tacv:: autorewrite with {+ @ident} in @qualid + + Performs all the rewritings in hypothesis :n:`@qualid`. + +.. tacv:: autorewrite with {+ @ident} in @qualid using @tactic + + Performs all the rewritings in hypothesis :n:`@qualid` applying :n:`@tactic` + to the main subgoal after each rewriting step. + +.. tacv:: autorewrite with {+ @ident} in @goal_occurrences + + Performs all the rewriting in the clause :n:`@goal_occurrences`. + +.. seealso:: + + :ref:`Hint-Rewrite <hintrewrite>` for feeding the database of lemmas used by + :tacn:`autorewrite` and :tacn:`autorewrite` for examples showing the use of this tactic. + +.. tacn:: easy + :name: easy + + This tactic tries to solve the current goal by a number of standard closing steps. + In particular, it tries to close the current goal using the closing tactics + :tacn:`trivial`, :tacn:`reflexivity`, :tacn:`symmetry`, :tacn:`contradiction` + and :tacn:`inversion` of hypothesis. + If this fails, it tries introducing variables and splitting and-hypotheses, + using the closing tactics afterwards, and splitting the goal using + :tacn:`split` and recursing. + + This tactic solves goals that belong to many common classes; in particular, many cases of + unsatisfiable hypotheses, and simple equality goals are usually solved by this tactic. + +.. tacv:: now @tactic + :name: now + + Run :n:`@tactic` followed by :tacn:`easy`. This is a notation for :n:`@tactic; easy`. + +Controlling automation +-------------------------- + +.. _thehintsdatabasesforautoandeauto: + +The hints databases for auto and eauto +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The hints for :tacn:`auto` and :tacn:`eauto` are stored in databases. Each database +maps head symbols to a list of hints. + +.. cmd:: Print Hint @ident + + Use this command + to display the hints associated to the head symbol :n:`@ident` + (see :ref:`Print Hint <printhint>`). Each hint has a cost that is a nonnegative + integer, and an optional pattern. The hints with lower cost are tried first. A + hint is tried by :tacn:`auto` when the conclusion of the current goal matches its + pattern or when it has no pattern. + +Creating Hint databases +``````````````````````` + +One can optionally declare a hint database using the command +:cmd:`Create HintDb`. If a hint is added to an unknown database, it will be +automatically created. + +.. cmd:: Create HintDb @ident {? discriminated} + + This command creates a new database named :n:`@ident`. The database is + implemented by a Discrimination Tree (DT) that serves as an index of + all the lemmas. The DT can use transparency information to decide if a + constant should be indexed or not + (c.f. :ref:`The hints databases for auto and eauto <thehintsdatabasesforautoandeauto>`), + making the retrieval more efficient. The legacy implementation (the default one + for new databases) uses the DT only on goals without existentials (i.e., :tacn:`auto` + goals), for non-Immediate hints and does not make use of transparency + hints, putting more work on the unification that is run after + retrieval (it keeps a list of the lemmas in case the DT is not used). + The new implementation enabled by the discriminated option makes use + of DTs in all cases and takes transparency information into account. + However, the order in which hints are retrieved from the DT may differ + from the order in which they were inserted, making this implementation + observationally different from the legacy one. + +.. cmd:: Hint @hint_definition : {+ @ident} + + The general command to add a hint to some databases :n:`{+ @ident}`. + + This command supports the :attr:`local`, :attr:`global` and :attr:`export` + locality attributes. When no locality is explictly given, the + command is :attr:`local` inside a section and :attr:`global` otherwise. + + + :attr:`local` hints are never visible from other modules, even if they + require or import the current module. Inside a section, the :attr:`local` + attribute is useless since hints do not survive anyway to the closure of + sections. + + + :attr:`export` are visible from other modules when they import the current + 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 + + No database name is given: the hint is registered in the ``core`` database. + + .. deprecated:: 8.10 + + .. cmdv:: Hint Resolve @qualid {? | {? @natural} {? @pattern}} : @ident + :name: Hint Resolve + + This command adds :n:`simple apply @qualid` to the hint list with the head + symbol of the type of :n:`@qualid`. The cost of that hint is the number of + subgoals generated by :n:`simple apply @qualid` or :n:`@natural` if specified. The + associated :n:`@pattern` is inferred from the conclusion of the type of + :n:`@qualid` or the given :n:`@pattern` if specified. In case the inferred type + of :n:`@qualid` does not start with a product the tactic added in the hint list + is :n:`exact @qualid`. In case this type can however be reduced to a type + starting with a product, the tactic :n:`simple apply @qualid` is also stored in + the hints list. If the inferred type of :n:`@qualid` contains a dependent + quantification on a variable which occurs only in the premisses of the type + and not in its conclusion, no instance could be inferred for the variable by + unification with the goal. In this case, the hint is added to the hint list + of :tacn:`eauto` instead of the hint list of auto and a warning is printed. A + typical example of a hint that is used only by :tacn:`eauto` is a transitivity + lemma. + + .. exn:: @qualid cannot be used as a hint + + The head symbol of the type of :n:`@qualid` is a bound variable + such that this tactic cannot be associated to a constant. + + .. cmdv:: Hint Resolve {+ @qualid} : @ident + + Adds each :n:`Hint Resolve @qualid`. + + .. cmdv:: Hint Resolve -> @qualid : @ident + + Adds the left-to-right implication of an equivalence as a hint (informally + the hint will be used as :n:`apply <- @qualid`, although as mentioned + before, the tactic actually used is a restricted version of + :tacn:`apply`). + + .. cmdv:: Hint Resolve <- @qualid + + Adds the right-to-left implication of an equivalence as a hint. + + .. cmdv:: Hint Immediate @qualid : @ident + :name: Hint Immediate + + This command adds :n:`simple apply @qualid; trivial` to the hint list associated + with the head symbol of the type of :n:`@ident` in the given database. This + tactic will fail if all the subgoals generated by :n:`simple apply @qualid` are + not solved immediately by the :tacn:`trivial` tactic (which only tries tactics + with cost 0).This command is useful for theorems such as the symmetry of + equality or :g:`n+1=m+1 -> n=m` that we may like to introduce with a limited + use in order to avoid useless proof-search. The cost of this tactic (which + never generates subgoals) is always 1, so that it is not used by :tacn:`trivial` + itself. + + .. exn:: @qualid cannot be used as a hint + :undocumented: + + .. cmdv:: Hint Immediate {+ @qualid} : @ident + + Adds each :n:`Hint Immediate @qualid`. + + .. cmdv:: Hint Constructors @qualid : @ident + :name: Hint Constructors + + If :token:`qualid` is an inductive type, this command adds all its constructors as + hints of type ``Resolve``. Then, when the conclusion of current goal has the form + :n:`(@qualid ...)`, :tacn:`auto` will try to apply each constructor. + + .. exn:: @qualid is not an inductive type + :undocumented: + + .. cmdv:: Hint Constructors {+ @qualid} : @ident + + Extends the previous command for several inductive types. + + .. cmdv:: Hint Unfold @qualid : @ident + :name: Hint Unfold + + This adds the tactic :n:`unfold @qualid` to the hint list that will only be + used when the head constant of the goal is :token:`qualid`. + Its cost is 4. + + .. cmdv:: Hint Unfold {+ @qualid} + + Extends the previous command for several defined constants. + + .. cmdv:: Hint Transparent {+ @qualid} : @ident + Hint Opaque {+ @qualid} : @ident + :name: Hint Transparent; Hint Opaque + + This adds transparency hints to the database, making :n:`@qualid` + transparent or opaque constants during resolution. This information is used + during unification of the goal with any lemma in the database and inside the + discrimination network to relax or constrain it in the case of discriminated + databases. + + .. cmdv:: Hint Variables {| Transparent | Opaque } : @ident + Hint Constants {| Transparent | Opaque } : @ident + :name: Hint Variables; Hint Constants + + This sets the transparency flag used during unification of + hints in the database for all constants or all variables, + overwriting the existing settings of opacity. It is advised + to use this just after a :cmd:`Create HintDb` command. + + .. cmdv:: Hint Extern @natural {? @pattern} => @tactic : @ident + :name: Hint Extern + + This hint type is to extend :tacn:`auto` with tactics other than :tacn:`apply` and + :tacn:`unfold`. For that, we must specify a cost, an optional :n:`@pattern` and a + :n:`@tactic` to execute. + + .. example:: + + .. coqtop:: none + + Set Warnings "-deprecated-hint-without-locality". + + .. coqtop:: in + + Hint Extern 4 (~(_ = _)) => discriminate : core. + + Now, when the head of the goal is a disequality, ``auto`` will try + discriminate if it does not manage to solve the goal with hints with a + cost less than 4. + + One can even use some sub-patterns of the pattern in + the tactic script. A sub-pattern is a question mark followed by an + identifier, like ``?X1`` or ``?X2``. Here is an example: + + .. example:: + + .. 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. + Goal forall a b:list (nat * nat), {a = b} + {a <> b}. + Info 1 auto with eqdec. + + .. cmdv:: Hint Cut @regexp : @ident + :name: Hint Cut + + .. warning:: + + These hints currently only apply to typeclass proof search and the + :tacn:`typeclasses eauto` tactic. + + This command can be used to cut the proof-search tree according to a regular + expression matching paths to be cut. The grammar for regular expressions is + the following. Beware, there is no operator precedence during parsing, one can + check with :cmd:`Print HintDb` to verify the current cut expression: + + .. prodn:: + regexp ::= @ident (hint or instance identifier) + | _ (any hint) + | @regexp | @regexp (disjunction) + | @regexp @regexp (sequence) + | @regexp * (Kleene star) + | emp (empty) + | eps (epsilon) + | ( @regexp ) + + The `emp` regexp does not match any search path while `eps` + matches the empty path. During proof search, the path of + successive successful hints on a search branch is recorded, as a + list of identifiers for the hints (note that :cmd:`Hint Extern`\’s do not have + an associated identifier). + Before applying any hint :n:`@ident` the current path `p` extended with + :n:`@ident` is matched against the current cut expression `c` associated to + the hint database. If matching succeeds, the hint is *not* applied. The + semantics of :n:`Hint Cut @regexp` is to set the cut expression + to :n:`c | regexp`, the initial cut expression being `emp`. + + .. cmdv:: Hint Mode @qualid {* {| + | ! | - } } : @ident + :name: Hint Mode + + This sets an optional mode of use of the identifier :n:`@qualid`. When + proof-search faces a goal that ends in an application of :n:`@qualid` to + arguments :n:`@term ... @term`, the mode tells if the hints associated to + :n:`@qualid` can be applied or not. A mode specification is a list of n ``+``, + ``!`` or ``-`` items that specify if an argument of the identifier is to be + treated as an input (``+``), if its head only is an input (``!``) or an output + (``-``) of the identifier. For a mode to match a list of arguments, input + terms and input heads *must not* contain existential variables or be + existential variables respectively, while outputs can be any term. Multiple + modes can be declared for a single identifier, in that case only one mode + needs to match the arguments for the hints to be applied. The head of a term + is understood here as the applicative head, or the match or projection + scrutinee’s head, recursively, casts being ignored. :cmd:`Hint Mode` is + especially useful for typeclasses, when one does not want to support default + instances and avoid ambiguity in general. Setting a parameter of a class as an + input forces proof-search to be driven by that index of the class, with ``!`` + giving more flexibility by allowing existentials to still appear deeper in the + index but not at its head. + + .. note:: + + + One can use a :cmd:`Hint Extern` with no pattern to do + pattern matching on hypotheses using ``match goal with`` + inside the tactic. + + + If you want to add hints such as :cmd:`Hint Transparent`, + :cmd:`Hint Cut`, or :cmd:`Hint Mode`, for typeclass + resolution, do not forget to put them in the + ``typeclass_instances`` hint database. + + +Hint databases defined in the Coq standard library +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Several hint databases are defined in the Coq standard library. The +actual content of a database is the collection of hints declared +to belong to this database in each of the various modules currently +loaded. Especially, requiring new modules may extend the database. +At Coq startup, only the core database is nonempty and can be used. + +:core: This special database is automatically used by ``auto``, except when + pseudo-database ``nocore`` is given to ``auto``. The core database + contains only basic lemmas about negation, conjunction, and so on. + Most of the hints in this database come from the Init and Logic directories. + +:arith: This database contains all lemmas about Peano’s arithmetic proved in the + directories Init and Arith. + +:zarith: contains lemmas about binary signed integers from the + directories theories/ZArith. The database also contains + high-cost hints that call :tacn:`lia` on equations and + inequalities in ``nat`` or ``Z``. + +:bool: contains lemmas about booleans, mostly from directory theories/Bool. + +:datatypes: is for lemmas about lists, streams and so on that are mainly proved + in the Lists subdirectory. + +:sets: contains lemmas about sets and relations from the directories Sets and + Relations. + +:typeclass_instances: contains all the typeclass instances declared in the + environment, including those used for ``setoid_rewrite``, + from the Classes directory. + +:fset: internal database for the implementation of the ``FSets`` library. + +:ordered_type: lemmas about ordered types (as defined in the legacy ``OrderedType`` module), + mainly used in the ``FSets`` and ``FMaps`` libraries. + +You are advised not to put your own hints in the core database, but +use one or several databases specific to your development. + +.. _removehints: + +.. cmd:: Remove Hints {+ @term} : {+ @ident} + + This command removes the hints associated to terms :n:`{+ @term}` in databases + :n:`{+ @ident}`. + +.. _printhint: + +.. cmd:: Print Hint + + This command displays all hints that apply to the current goal. It + fails if no proof is being edited, while the two variants can be used + at every moment. + +**Variants:** + + +.. cmd:: Print Hint @ident + + This command displays only tactics associated with :n:`@ident` in the hints + list. This is independent of the goal being edited, so this command will not + fail if no goal is being edited. + +.. cmd:: Print Hint * + + This command displays all declared hints. + +.. cmd:: Print HintDb @ident + + This command displays all hints from database :n:`@ident`. + +.. _hintrewrite: + +.. cmd:: Hint Rewrite {+ @term} : {+ @ident} + + This vernacular command adds the terms :n:`{+ @term}` (their types must be + equalities) in the rewriting bases :n:`{+ @ident}` with the default orientation + (left to right). Notice that the rewriting bases are distinct from the :tacn:`auto` + hint bases and that :tacn:`auto` does not take them into account. + + This command is synchronous with the section mechanism (see :ref:`section-mechanism`): + when closing a section, all aliases created by ``Hint Rewrite`` in that + section are lost. Conversely, when loading a module, all ``Hint Rewrite`` + declarations at the global level of that module are loaded. + +**Variants:** + +.. cmd:: Hint Rewrite -> {+ @term} : {+ @ident} + + This is strictly equivalent to the command above (we only make explicit the + orientation which otherwise defaults to ->). + +.. cmd:: Hint Rewrite <- {+ @term} : {+ @ident} + + Adds the rewriting rules :n:`{+ @term}` with a right-to-left orientation in + the bases :n:`{+ @ident}`. + +.. cmd:: Hint Rewrite {? {| -> | <- } } {+ @one_term } {? using @ltac_expr } {? : {* @ident } } + + When the rewriting rules :n:`{+ @term}` in :n:`{+ @ident}` will be used, the + tactic ``tactic`` will be applied to the generated subgoals, the main subgoal + excluded. + +.. cmd:: Print Rewrite HintDb @ident + + This command displays all rewrite hints contained in :n:`@ident`. + +Hint locality +~~~~~~~~~~~~~ + +Hints provided by the ``Hint`` commands are erased when closing a section. +Conversely, all hints of a module ``A`` that are not defined inside a +section (and not defined with option ``Local``) become available when the +module ``A`` is required (using e.g. ``Require A.``). + +As of today, hints only have a binary behavior regarding locality, as +described above: either they disappear at the end of a section scope, +or they remain global forever. This causes a scalability issue, +because hints coming from an unrelated part of the code may badly +influence another development. It can be mitigated to some extent +thanks to the :cmd:`Remove Hints` command, +but this is a mere workaround and has some limitations (for instance, external +hints cannot be removed). + +A proper way to fix this issue is to bind the hints to their module scope, as +for most of the other objects Coq uses. Hints should only be made available when +the module they are defined in is imported, not just required. It is very +difficult to change the historical behavior, as it would break a lot of scripts. +We propose a smooth transitional path by providing the :opt:`Loose Hint Behavior` +option which accepts three flags allowing for a fine-grained handling of +non-imported hints. + +.. opt:: Loose Hint Behavior {| "Lax" | "Warn" | "Strict" } + :name: Loose Hint Behavior + + This option accepts three values, which control the behavior of hints w.r.t. + :cmd:`Import`: + + - "Lax": this is the default, and corresponds to the historical behavior, + that is, hints defined outside of a section have a global scope. + + - "Warn": outputs a warning when a non-imported hint is used. Note that this + is an over-approximation, because a hint may be triggered by a run that + will eventually fail and backtrack, resulting in the hint not being + actually useful for the proof. + + - "Strict": changes the behavior of an unloaded hint to a immediate fail + tactic, allowing to emulate an import-scoped hint mechanism. + +.. _tactics-implicit-automation: + +Setting implicit automation tactics +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. cmd:: Proof with @tactic + + This command may be used to start a proof. It defines a default tactic + to be used each time a tactic command ``tactic``:sub:`1` is ended by ``...``. + In this case the tactic command typed by the user is equivalent to + ``tactic``:sub:`1` ``;tactic``. + + .. seealso:: :cmd:`Proof` in :ref:`proof-editing-mode`. + + + .. cmdv:: Proof with @tactic using {+ @ident} + + Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`proof-editing-mode` + + .. cmdv:: Proof using {+ @ident} with @tactic + + Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`proof-editing-mode` diff --git a/doc/sphinx/proofs/automatic-tactics/index.rst b/doc/sphinx/proofs/automatic-tactics/index.rst index a219770c69..c3712b109d 100644 --- a/doc/sphinx/proofs/automatic-tactics/index.rst +++ b/doc/sphinx/proofs/automatic-tactics/index.rst @@ -1,20 +1,22 @@ .. _automatic-tactics: ===================================================== -Built-in decision procedures and programmable tactics +Automatic solvers and programmable tactics ===================================================== Some tactics are largely automated and are able to solve complex -goals. This chapter presents both some decision procedures that can -be used to solve some specific categories of goals, and some -programmable tactics, that the user can instrument to handle some +goals. This chapter presents both built-in solvers that can +be used on specific categories of goals and +programmable tactics that the user can instrument to handle complex goals in new domains. .. toctree:: :maxdepth: 1 + logic ../../addendum/omega ../../addendum/micromega ../../addendum/ring ../../addendum/nsatz + auto ../../addendum/generalized-rewriting diff --git a/doc/sphinx/proofs/automatic-tactics/logic.rst b/doc/sphinx/proofs/automatic-tactics/logic.rst new file mode 100644 index 0000000000..5aaded2726 --- /dev/null +++ b/doc/sphinx/proofs/automatic-tactics/logic.rst @@ -0,0 +1,228 @@ +.. _decisionprocedures: + +============================== +Solvers for logic and equality +============================== + +.. tacn:: tauto + + This tactic implements a decision procedure for intuitionistic propositional + calculus based on the contraction-free sequent calculi LJT* of Roy Dyckhoff + :cite:`Dyc92`. Note that :tacn:`tauto` succeeds on any instance of an + intuitionistic tautological proposition. :tacn:`tauto` unfolds negations and + logical equivalence but does not unfold any other definition. + + .. example:: + + The following goal can be proved by :tacn:`tauto` whereas :tacn:`auto` would + fail: + + .. coqtop:: reset all + + Goal forall (x:nat) (P:nat -> Prop), x = 0 \/ P x -> x <> 0 -> P x. + intros. + tauto. + + Moreover, if it has nothing else to do, :tacn:`tauto` performs introductions. + Therefore, the use of :tacn:`intros` in the previous proof is unnecessary. + :tacn:`tauto` can for instance for: + + .. example:: + + .. coqtop:: reset all + + Goal forall (A:Prop) (P:nat -> Prop), A \/ (forall x:nat, ~ A -> P x) -> forall x:nat, ~ A -> P x. + tauto. + + .. note:: + In contrast, :tacn:`tauto` cannot solve the following goal + :g:`Goal forall (A:Prop) (P:nat -> Prop), A \/ (forall x:nat, ~ A -> P x) ->` + :g:`forall x:nat, ~ ~ (A \/ P x).` + because :g:`(forall x:nat, ~ A -> P x)` cannot be treated as atomic and + an instantiation of `x` is necessary. + + .. tacn:: dtauto + + While :tacn:`tauto` recognizes inductively defined connectives isomorphic to + the standard connectives ``and``, ``prod``, ``or``, ``sum``, ``False``, + ``Empty_set``, ``unit`` and ``True``, :tacn:`dtauto` also recognizes all inductive + types with one constructor and no indices, i.e. record-style connectives. + +.. todo would be nice to explain/discuss the various types of flags + that define the differences between these tactics. See Tauto.v/tauto.ml. + +.. tacn:: intuition {? @ltac_expr } + + Uses the search tree built by the decision procedure for :tacn:`tauto` + to generate a set of subgoals equivalent to the original one (but + simpler than it) and applies :n:`@ltac_expr` to them :cite:`Mun94`. If + :n:`@ltac_expr` is not specified, it defaults to :n:`auto with *` + If :n:`@ltac_expr` fails on some goals then :tacn:`intuition` fails. In fact, + :tacn:`tauto` is simply :g:`intuition fail`. + + :tacn:`intuition` recognizes inductively defined connectives + isomorphic to the standard connectives ``and``, ``prod``, ``or``, ``sum``, ``False``, + ``Empty_set``, ``unit`` and ``True``. + + .. example:: + + For instance, the tactic :g:`intuition auto` applied to the goal:: + + (forall (x:nat), P x) /\ B -> (forall (y:nat), P y) /\ P O \/ B /\ P O + + internally replaces it by the equivalent one:: + + (forall (x:nat), P x), B |- P O + + and then uses :tacn:`auto` which completes the proof. + + .. tacn:: dintuition {? @ltac_expr } + + In addition to the inductively defined connectives recognized by :tacn:`intuition`, + :tacn:`dintuition` also recognizes all inductive + types with one constructor and no indices, i.e. record-style connectives. + + .. flag:: Intuition Negation Unfolding + + Controls whether :tacn:`intuition` unfolds inner negations which do not need + to be unfolded. The flag is on by default. + +.. tacn:: rtauto + + Solves propositional tautologies similarly to + :tacn:`tauto`, but the proof term is built using a + reflection scheme applied to a sequent calculus proof of the goal. The search + procedure is also implemented using a different technique. + + Users should be aware that this difference may result in faster proof search + but slower proof checking, and :tacn:`rtauto` might not solve goals that + :tacn:`tauto` would be able to solve (e.g. goals involving universal + quantifiers). + + Note that this tactic is only available after a ``Require Import Rtauto``. + +.. tacn:: firstorder {? @ltac_expr } {? using {+, @qualid } } {? with {+ @ident } } + + An experimental extension of :tacn:`tauto` to + first-order reasoning. It is not restricted to + usual logical connectives but instead can reason about any first-order class + inductive definition. + + :token:`ltac_expr` + Tries to solve the goal with :token:`ltac_expr` when no logical rule applies. + If unspecified, the tactic uses the default from the :opt:`Firstorder Solver` + option. + + :n:`using {+, @qualid }` + Adds the lemmas :n:`{+, @qualid }` to the proof search environment. If :n:`@qualid` + refers to an inductive type, its constructors are + added to the proof search environment. + + :n:`with {+ @ident }` + Adds lemmas from :tacn:`auto` hint bases :n:`{+ @ident }` to the proof search + environment. + + .. opt:: Firstorder Solver @ltac_expr + + The default tactic used by :tacn:`firstorder` when no rule applies in + :g:`auto with core`. It can be set locally or globally using this option. + + .. cmd:: Print Firstorder Solver + + Prints the default tactic used by :tacn:`firstorder` when no rule applies. + + .. opt:: Firstorder Depth @natural + + Controls the proof search depth bound. + +.. tacn:: congruence {? @natural } {? with {+ @one_term } } + + :token:`natural` + Specifies the maximum number of hypotheses stating quantified equalities that may be added + to the problem in order to solve it. The default is 1000. + + :n:`{? with {+ @one_term } }` + Adds :n:`{+ @one_term }` to the pool of terms used by :tacn:`congruence`. This helps + in case you have partially applied constructors in your goal. + + Implements the standard + Nelson and Oppen congruence closure algorithm, which is a decision procedure + for ground equalities with uninterpreted symbols. It also includes + constructor theory (see :tacn:`injection` and :tacn:`discriminate`). If the goal + is a non-quantified equality, congruence tries to prove it with non-quantified + equalities in the context. Otherwise it tries to infer a discriminable equality + from those in the context. Alternatively, congruence tries to prove that a + hypothesis is equal to the goal or to the negation of another hypothesis. + + :tacn:`congruence` is also able to take advantage of hypotheses stating + quantified equalities, but you have to provide a bound for the number of extra + equalities generated that way. Please note that one of the sides of the + equality must contain all the quantified variables in order for congruence to + match against it. + + Increasing the maximum number of hypotheses may solve + problems that would have failed with a smaller value. It will make failures slower but it + won't make successes found with the smaller value any slower. + You may want to use :tacn:`assert` to add some lemmas as + hypotheses so that :tacn:`congruence` can use them. + + .. example:: + + .. coqtop:: reset all + + Theorem T (A:Type) (f:A -> A) (g: A -> A -> A) a b: a=(f a) -> (g b (f a))=(f (f a)) -> (g a b)=(f (g b a)) -> (g a b)=a. + intros. + congruence. + Qed. + + Theorem inj (A:Type) (f:A -> A * A) (a c d: A) : f = pair a -> Some (f c) = Some (f d) -> c=d. + intros. + congruence. + Qed. + + .. exn:: I don’t know how to handle dependent equality. + + The decision procedure managed to find a proof of the goal or of a + discriminable equality but this proof could not be built in Coq because of + dependently-typed functions. + + .. exn:: Goal is solvable by congruence but some arguments are missing. Try congruence with {+ @term}, replacing metavariables by arbitrary terms. + + The decision procedure could solve the goal with the provision that additional + arguments are supplied for some partially applied constructors. Any term of an + appropriate type will allow the tactic to successfully solve the goal. Those + additional arguments can be given to congruence by filling in the holes in the + terms given in the error message, using the `with` clause. + + .. flag:: Congruence Verbose + + Makes :tacn:`congruence` print debug information. + +.. tacn:: btauto + + The tactic :tacn:`btauto` implements a reflexive solver for boolean + tautologies. It solves goals of the form :g:`t = u` where `t` and `u` are + constructed over the following grammar: + + .. prodn:: + btauto_term ::= @ident + | true + | false + | orb @btauto_term @btauto_term + | andb @btauto_term @btauto_term + | xorb @btauto_term @btauto_term + | negb @btauto_term + | if @btauto_term then @btauto_term else @btauto_term + + Whenever the formula supplied is not a tautology, it also provides a + counter-example. + + Internally, it uses a system very similar to the one of the ring + tactic. + + Note that this tactic is only available after a ``Require Import Btauto``. + + .. exn:: Cannot recognize a boolean equality. + + The goal is not of the form :g:`t = u`. Especially note that :tacn:`btauto` + doesn't introduce variables into the context on its own. diff --git a/doc/sphinx/proofs/writing-proofs/index.rst b/doc/sphinx/proofs/writing-proofs/index.rst index a279a5957f..7724d7433c 100644 --- a/doc/sphinx/proofs/writing-proofs/index.rst +++ b/doc/sphinx/proofs/writing-proofs/index.rst @@ -1,8 +1,8 @@ .. _writing-proofs: -============== -Writing proofs -============== +=================== +Basic proof writing +=================== Coq is an interactive theorem prover, or proof assistant, which means that proofs can be constructed interactively through a dialog between @@ -27,8 +27,9 @@ flavors of tactics, including the SSReflect proof language. .. toctree:: :maxdepth: 1 - ../../proof-engine/proof-handling + proof-mode ../../proof-engine/tactics + rewriting ../../proof-engine/ssreflect-proof-language ../../proof-engine/detailed-tactic-examples ../../user-extensions/proof-schemes diff --git a/doc/sphinx/proofs/writing-proofs/proof-mode.rst b/doc/sphinx/proofs/writing-proofs/proof-mode.rst new file mode 100644 index 0000000000..40d032543f --- /dev/null +++ b/doc/sphinx/proofs/writing-proofs/proof-mode.rst @@ -0,0 +1,1043 @@ +.. _proofhandling: + +------------------- + Proof handling +------------------- + +In Coq’s proof editing mode all top-level commands documented in +Chapter :ref:`vernacularcommands` remain available and the user has access to specialized +commands dealing with proof development pragmas documented in this +section. They can also use some other specialized commands called +*tactics*. They are the very tools allowing the user to deal with +logical reasoning. They are documented in Chapter :ref:`tactics`. + +Coq user interfaces usually have a way of marking whether the user has +switched to proof editing mode. For instance, in coqtop the prompt ``Coq <`` is changed into +:n:`@ident <` where :token:`ident` is the declared name of the theorem currently edited. + +At each stage of a proof development, one has a list of goals to +prove. Initially, the list consists only in the theorem itself. After +having applied some tactics, the list of goals contains the subgoals +generated by the tactics. + +To each subgoal is associated a number of hypotheses called the *local context* +of the goal. Initially, the local context contains the local variables and +hypotheses of the current section (see Section :ref:`gallina-assumptions`) and +the local variables and hypotheses of the theorem statement. It is enriched by +the use of certain tactics (see e.g. :tacn:`intro`). + +When a proof is completed, the message ``Proof completed`` is displayed. +One can then register this proof as a defined constant in the +environment. Because there exists a correspondence between proofs and +terms of λ-calculus, known as the *Curry-Howard isomorphism* +:cite:`How80,Bar81,Gir89,H89`, Coq stores proofs as terms of |Cic|. Those +terms are called *proof terms*. + + +.. exn:: No focused proof. + + Coq raises this error message when one attempts to use a proof editing command + out of the proof editing mode. + +.. _proof-editing-mode: + +Entering and leaving proof editing mode +--------------------------------------- + +The proof editing mode is entered by asserting a statement, which typically is +the assertion of a theorem using an assertion command like :cmd:`Theorem`. The +list of assertion commands is given in :ref:`Assertions`. The command +:cmd:`Goal` can also be used. + +.. cmd:: Goal @type + + This is intended for quick assertion of statements, without knowing in + advance which name to give to the assertion, typically for quick + testing of the provability of a statement. If the proof of the + statement is eventually completed and validated, the statement is then + bound to the name ``Unnamed_thm`` (or a variant of this name not already + used for another statement). + +.. cmd:: Qed + + This command is available in interactive editing proof mode when the + proof is completed. Then :cmd:`Qed` extracts a proof term from the proof + script, switches back to Coq top-level and attaches the extracted + proof term to the declared name of the original goal. The name is + added to the environment as an opaque constant. + + .. exn:: Attempt to save an incomplete proof. + :undocumented: + + .. note:: + + Sometimes an error occurs when building the proof term, because + tactics do not enforce completely the term construction + constraints. + + The user should also be aware of the fact that since the + proof term is completely rechecked at this point, one may have to wait + a while when the proof is large. In some exceptional cases one may + even incur a memory overflow. + +.. cmd:: Save @ident + :name: Save + + Saves a completed proof with the name :token:`ident`, which + overrides any name provided by the :cmd:`Theorem` command or + its variants. + +.. cmd:: Defined {? @ident } + + Similar to :cmd:`Qed` and :cmd:`Save`, except the proof is made *transparent*, which means + that its content can be explicitly used for type checking and that it can be + unfolded in conversion tactics (see :ref:`performingcomputations`, + :cmd:`Opaque`, :cmd:`Transparent`). If :token:`ident` is specified, + the proof is defined with the given name, which overrides any name + provided by the :cmd:`Theorem` command or its variants. + +.. cmd:: Admitted + + This command is available in interactive editing mode to give up + the current proof and declare the initial goal as an axiom. + +.. cmd:: Abort {? {| All | @ident } } + + Cancels the current proof development, switching back to + the previous proof development, or to the Coq toplevel if no other + proof was being edited. + + :n:`@ident` + Aborts editing the proof named :n:`@ident` for use when you have + nested proofs. See also :flag:`Nested Proofs Allowed`. + + :n:`All` + Aborts all current proofs. + + .. exn:: No focused proof (No proof-editing in progress). + :undocumented: + +.. cmd:: Proof @term + :name: Proof `term` + + This command applies in proof editing mode. It is equivalent to + :n:`exact @term. Qed.` + That is, you have to give the full proof in one gulp, as a + proof term (see Section :ref:`applyingtheorems`). + + .. warning:: + + Use of this command is discouraged. In particular, it + doesn't work in Proof General because it must + immediately follow the command that opened proof mode, but + Proof General inserts :cmd:`Unset` :flag:`Silent` before it (see + `Proof General issue #498 + <https://github.com/ProofGeneral/PG/issues/498>`_). + +.. cmd:: Proof + + Is a no-op which is useful to delimit the sequence of tactic commands + which start a proof, after a :cmd:`Theorem` command. It is a good practice to + use :cmd:`Proof` as an opening parenthesis, closed in the script with a + closing :cmd:`Qed`. + + .. seealso:: :cmd:`Proof with` + +.. cmd:: Proof using @section_var_expr {? with @ltac_expr } + + .. insertprodn section_var_expr starred_ident_ref + + .. prodn:: + section_var_expr ::= {* @starred_ident_ref } + | {? - } @section_var_expr50 + section_var_expr50 ::= @section_var_expr0 - @section_var_expr0 + | @section_var_expr0 + @section_var_expr0 + | @section_var_expr0 + section_var_expr0 ::= @starred_ident_ref + | ( @section_var_expr ) {? * } + starred_ident_ref ::= @ident {? * } + | Type {? * } + | All + + Opens proof editing mode, declaring the set of + section variables (see :ref:`gallina-assumptions`) used by the proof. + At :cmd:`Qed` time, the + system verifies that the set of section variables used in + the proof is a subset of the declared one. + + The set of declared variables is closed under type dependency. For + example, if ``T`` is a variable and ``a`` is a variable of type + ``T``, then the commands ``Proof using a`` and ``Proof using T a`` + are equivalent. + + The set of declared variables always includes the variables used by + the statement. In other words ``Proof using e`` is equivalent to + ``Proof using Type + e`` for any declaration expression ``e``. + + :n:`- @section_var_expr50` + Use all section variables except those specified by :n:`@section_var_expr50` + + :n:`@section_var_expr0 + @section_var_expr0` + Use section variables from the union of both collections. + See :ref:`nameaset` to see how to form a named collection. + + :n:`@section_var_expr0 - @section_var_expr0` + Use section variables which are in the first collection but not in the + second one. + + :n:`{? * }` + Use the transitive closure of the specified collection. + + :n:`Type` + Use only section variables occurring in the statement. Specifying :n:`*` + uses the forward transitive closure of all the section variables occurring + in the statement. For example, if the variable ``H`` has type ``p < 5`` then + ``H`` is in ``p*`` since ``p`` occurs in the type of ``H``. + + :n:`All` + Use all section variables. + + .. seealso:: :ref:`tactics-implicit-automation` + +.. attr:: using + + This attribute can be applied to the :cmd:`Definition`, :cmd:`Example`, + :cmd:`Fixpoint` and :cmd:`CoFixpoint` commands as well as to :cmd:`Lemma` and + its variants. It takes + a :n:`@section_var_expr`, in quotes, as its value. This is equivalent to + specifying the same :n:`@section_var_expr` in + :cmd:`Proof using`. + + .. example:: + + .. coqtop:: all + + Section Test. + Variable n : nat. + Hypothesis Hn : n <> 0. + + #[using="Hn"] + Lemma example : 0 < n. + + .. coqtop:: in + + Abort. + End Test. + + +Proof using options +``````````````````` + +The following options modify the behavior of ``Proof using``. + + +.. opt:: Default Proof Using "@section_var_expr" + :name: Default Proof Using + + Use :n:`@section_var_expr` as the default ``Proof using`` value. E.g. ``Set Default + Proof Using "a b"`` will complete all ``Proof`` commands not followed by a + ``using`` part with ``using a b``. + + +.. flag:: Suggest Proof Using + + When :cmd:`Qed` is performed, suggest a ``using`` annotation if the user did not + provide one. + +.. _`nameaset`: + +Name a set of section hypotheses for ``Proof using`` +```````````````````````````````````````````````````` + +.. cmd:: Collection @ident := @section_var_expr + + This can be used to name a set of section + hypotheses, with the purpose of making ``Proof using`` annotations more + compact. + + .. example:: + + Define the collection named ``Some`` containing ``x``, ``y`` and ``z``:: + + Collection Some := x y z. + + Define the collection named ``Fewer`` containing only ``x`` and ``y``:: + + Collection Fewer := Some - z + + Define the collection named ``Many`` containing the set union or set + difference of ``Fewer`` and ``Some``:: + + Collection Many := Fewer + Some + Collection Many := Fewer - Some + + Define the collection named ``Many`` containing the set difference of + ``Fewer`` and the unnamed collection ``x y``:: + + Collection Many := Fewer - (x y) + + + +.. cmd:: Existential @natural {? : @type } := @term + + This command instantiates an existential variable. :token:`natural` is an index in + the list of uninstantiated existential variables displayed by :cmd:`Show Existentials`. + + This command is intended to be used to instantiate existential + variables when the proof is completed but some uninstantiated + 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 +``````````` + +When entering proof mode through commands such as :cmd:`Goal` and :cmd:`Proof`, +Coq picks by default the |Ltac| mode. Nonetheless, there exist other proof modes +shipped in the standard Coq installation, and furthermore some plugins define +their own proof modes. The default proof mode used when opening a proof can +be changed using the following option. + +.. opt:: Default Proof Mode @string + + Select the proof mode to use when starting a proof. Depending on the proof + mode, various syntactic constructs are allowed when writing an interactive + proof. All proof modes support vernacular commands; the proof mode determines + which tactic language and set of tactic definitions are available. The + possible option values are: + + `"Classic"` + Activates the |Ltac| language and the tactics with the syntax documented + in this manual. + Some tactics are not available until the associated plugin is loaded, + such as `SSR` or `micromega`. + This proof mode is set when the :term:`prelude` is loaded. + + `"Noedit"` + No tactic + language is activated at all. This is the default when the :term:`prelude` + is not loaded, e.g. through the `-noinit` option for `coqc`. + + `"Ltac2"` + Activates the Ltac2 language and the Ltac2-specific variants of the documented + tactics. + This value is only available after :cmd:`Requiring <Require>` Ltac2. + :cmd:`Importing <Import>` Ltac2 sets this mode. + + Some external plugins also define their own proof mode, which can be + activated with this command. + +Navigation in the proof tree +-------------------------------- + +.. cmd:: Undo {? {? To } @natural } + + Cancels the effect of the last :token:`natural` commands or tactics. + The :n:`To @natural` form goes back to the specified state number. + If :token:`natural` is not specified, the command goes back one command or tactic. + +.. cmd:: Restart + + Restores the proof editing process to the original goal. + + .. exn:: No focused proof to restart. + :undocumented: + +.. cmd:: Focus {? @natural } + + Focuses the attention on the first subgoal to prove or, if :token:`natural` is + specified, the :token:`natural`\-th. The + printing of the other subgoals is suspended until the focused subgoal + is solved or unfocused. + + .. deprecated:: 8.8 + + Prefer the use of bullets or focusing brackets with a goal selector (see below). + +.. cmd:: Unfocus + + This command restores to focus the goal that were suspended by the + last :cmd:`Focus` command. + + .. deprecated:: 8.8 + +.. cmd:: Unfocused + + Succeeds if the proof is fully unfocused, fails if there are some + goals out of focus. + +.. _curly-braces: + +.. index:: { + } + +.. todo: :name: "{"; "}" doesn't work, nor does :name: left curly bracket; right curly bracket, + hence the verbose names + +.. tacn:: {? {| @natural | [ @ident ] } : } %{ + %} + + .. todo + See https://github.com/coq/coq/issues/12004 and + https://github.com/coq/coq/issues/12825. + + ``{`` (without a terminating period) focuses on the first + goal. The subproof can only be + unfocused when it has been fully solved (*i.e.*, when there is no + focused goal left). Unfocusing is then handled by ``}`` (again, without a + terminating period). See also an example in the next section. + + Note that when a focused goal is proved a message is displayed + together with a suggestion about the right bullet or ``}`` to unfocus it + or focus the next one. + + :n:`@natural:` + Focuses on the :token:`natural`\-th subgoal to prove. + + :n:`[ @ident ]: %{` + Focuses on the named goal :token:`ident`. + + .. note:: + + Goals are just existential variables and existential variables do not + get a name by default. You can give a name to a goal by using :n:`refine ?[@ident]`. + You may also wrap this in an Ltac-definition like: + + .. coqtop:: in + + Ltac name_goal name := refine ?[name]. + + .. seealso:: :ref:`existential-variables` + + .. example:: + + This first example uses the Ltac definition above, and the named goals + only serve for documentation. + + .. coqtop:: all + + Goal forall n, n + 0 = n. + Proof. + induction n; [ name_goal base | name_goal step ]. + [base]: { + + .. coqtop:: all + + reflexivity. + + .. coqtop:: in + + } + + .. coqtop:: all + + [step]: { + + .. coqtop:: all + + simpl. + f_equal. + assumption. + } + Qed. + + This can also be a way of focusing on a shelved goal, for instance: + + .. coqtop:: all + + Goal exists n : nat, n = n. + eexists ?[x]. + reflexivity. + [x]: exact 0. + Qed. + + .. exn:: This proof is focused, but cannot be unfocused this way. + + You are trying to use ``}`` but the current subproof has not been fully solved. + + .. exn:: No such goal (@natural). + :undocumented: + + .. exn:: No such goal (@ident). + :undocumented: + + .. exn:: Brackets do not support multi-goal selectors. + + Brackets are used to focus on a single goal given either by its position + or by its name if it has one. + + .. seealso:: The error messages for bullets below. + +.. _bullets: + +Bullets +``````` + +Alternatively, proofs can be structured with bullets instead of ``{`` and ``}``. The +use of a bullet ``b`` for the first time focuses on the first goal ``g``, the +same bullet cannot be used again until the proof of ``g`` is completed, +then it is mandatory to focus the next goal with ``b``. The consequence is +that ``g`` and all goals present when ``g`` was focused are focused with the +same bullet ``b``. See the example below. + +Different bullets can be used to nest levels. The scope of bullet does +not go beyond enclosing ``{`` and ``}``, so bullets can be reused as further +nesting levels provided they are delimited by these. Bullets are made of +repeated ``-``, ``+`` or ``*`` symbols: + +.. prodn:: bullet ::= {| {+ - } | {+ + } | {+ * } } + +Note again that when a focused goal is proved a message is displayed +together with a suggestion about the right bullet or ``}`` to unfocus it +or focus the next one. + +.. note:: + + In Proof General (``Emacs`` interface to Coq), you must use + bullets with the priority ordering shown above to have a correct + indentation. For example ``-`` must be the outer bullet and ``**`` the inner + one in the example below. + +The following example script illustrates all these features: + +.. example:: + + .. coqtop:: all + + Goal (((True /\ True) /\ True) /\ True) /\ True. + Proof. + split. + - split. + + split. + ** { split. + - trivial. + - trivial. + } + ** trivial. + + trivial. + - assert True. + { trivial. } + assumption. + Qed. + +.. exn:: Wrong bullet @bullet__1: Current bullet @bullet__2 is not finished. + + Before using bullet :n:`@bullet__1` again, you should first finish proving + the current focused goal. + Note that :n:`@bullet__1` and :n:`@bullet__2` may be the same. + +.. exn:: Wrong bullet @bullet__1: Bullet @bullet__2 is mandatory here. + + You must put :n:`@bullet__2` to focus on the next goal. No other bullet is + allowed here. + +.. exn:: No such goal. Focus next goal with bullet @bullet. + + You tried to apply a tactic but no goals were under focus. + Using :n:`@bullet` is mandatory here. + +.. FIXME: the :noindex: below works around a Sphinx issue. + (https://github.com/sphinx-doc/sphinx/issues/4979) + It should be removed once that issue is fixed. + +.. exn:: No such goal. Try unfocusing with %}. + :noindex: + + You just finished a goal focused by ``{``, you must unfocus it with ``}``. + +Mandatory Bullets +~~~~~~~~~~~~~~~~~ + +Using :opt:`Default Goal Selector` with the ``!`` selector forces +tactic scripts to keep focus to exactly one goal (e.g. using bullets) +or use explicit goal selectors. + +Set Bullet Behavior +~~~~~~~~~~~~~~~~~~~ + +.. opt:: Bullet Behavior {| "None" | "Strict Subproofs" } + :name: Bullet Behavior + + This option controls the bullet behavior and can take two possible values: + + - "None": this makes bullets inactive. + - "Strict Subproofs": this makes bullets active (this is the default behavior). + +Modifying the order of goals +```````````````````````````` + +.. tacn:: cycle @integer + :name: cycle + + Reorders the selected goals so that the first :n:`@integer` goals appear after the + other selected goals. + If :n:`@integer` is negative, it puts the last :n:`@integer` goals at the + beginning of the list. + The tactic is only useful with a goal selector, most commonly `all:`. + Note that other selectors reorder goals; `1,3: cycle 1` is not equivalent + to `all: cycle 1`. See :tacn:`… : … (goal selector)`. + +.. example:: + + .. coqtop:: none reset + + Parameter P : nat -> Prop. + + .. coqtop:: all abort + + Goal P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5. + repeat split. + all: cycle 2. + all: cycle -3. + +.. tacn:: swap @integer @integer + :name: swap + + Exchanges the position of the specified goals. + Negative values for :n:`@integer` indicate counting goals + backward from the end of the list of selected goals. Goals are indexed from 1. + The tactic is only useful with a goal selector, most commonly `all:`. + Note that other selectors reorder goals; `1,3: swap 1 3` is not equivalent + to `all: swap 1 3`. See :tacn:`… : … (goal selector)`. + +.. example:: + + .. coqtop:: all abort + + Goal P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5. + repeat split. + all: swap 1 3. + all: swap 1 -1. + +.. tacn:: revgoals + :name: revgoals + + Reverses the order of the selected goals. The tactic is only useful with a goal + selector, most commonly `all :`. Note that other selectors reorder goals; + `1,3: revgoals` is not equivalent to `all: revgoals`. See :tacn:`… : … (goal selector)`. + + .. example:: + + .. coqtop:: all abort + + Goal P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5. + repeat split. + all: revgoals. + +Postponing the proof of some goals +`````````````````````````````````` + +.. tacn:: shelve + :name: shelve + + This tactic moves all goals under focus to a shelf. While on the + shelf, goals will not be focused on. They can be solved by + unification, or they can be called back into focus with the command + :cmd:`Unshelve`. + + .. tacv:: shelve_unifiable + :name: shelve_unifiable + + Shelves only the goals under focus that are mentioned in other goals. + Goals that appear in the type of other goals can be solved by unification. + + .. example:: + + .. coqtop:: all abort + + Goal exists n, n=0. + refine (ex_intro _ _ _). + all: shelve_unifiable. + reflexivity. + +.. cmd:: Unshelve + + This command moves all the goals on the shelf (see :tacn:`shelve`) + from the shelf into focus, by appending them to the end of the current + list of focused goals. + +.. tacn:: unshelve @tactic + :name: unshelve + + Performs :n:`@tactic`, then unshelves existential variables added to the + shelf by the execution of :n:`@tactic`, prepending them to the current goal. + +.. tacn:: give_up + :name: give_up + + This tactic removes the focused goals from the proof. They are not + solved, and cannot be solved later in the proof. As the goals are not + solved, the proof cannot be closed. + + The ``give_up`` tactic can be used while editing a proof, to choose to + write the proof script in a non-sequential order. + +.. _requestinginformation: + +Requesting information +---------------------- + + +.. cmd:: Show {? {| @ident | @natural } } + + Displays the current goals. + + :n:`@natural` + Display only the :token:`natural`\-th subgoal. + + :n:`@ident` + Displays the named goal :token:`ident`. This is useful in + particular to display a shelved goal but only works if the + corresponding existential variable has been named by the user + (see :ref:`existential-variables`) as in the following example. + + .. example:: + + .. coqtop:: all abort + + Goal exists n, n = 0. + eexists ?[n]. + Show n. + + .. exn:: No focused proof. + :undocumented: + + .. exn:: No such goal. + :undocumented: + +.. cmd:: Show Proof {? Diffs {? removed } } + + Displays the proof term generated by the tactics + that have been applied so far. If the proof is incomplete, the term + will contain holes, which correspond to subterms which are still to be + constructed. Each hole is an existential variable, which appears as a + question mark followed by an identifier. + + Specifying “Diffs” highlights the difference between the + current and previous proof step. By default, the command shows the + output once with additions highlighted. Including “removed” shows + the output twice: once showing removals and once showing additions. + It does not examine the :opt:`Diffs` option. See :ref:`showing_proof_diffs`. + +.. cmd:: Show Conjectures + + Prints the names of all the + theorems that are currently being proved. As it is possible to start + proving a previous lemma during the proof of a theorem, there may + be multiple names. + +.. cmd:: Show Intro + + If the current goal begins by at least one product, + prints the name of the first product as it would be + generated by an anonymous :tacn:`intro`. The aim of this command is to ease + the writing of more robust scripts. For example, with an appropriate + Proof General macro, it is possible to transform any anonymous :tacn:`intro` + into a qualified one such as ``intro y13``. In the case of a non-product + goal, it prints nothing. + +.. cmd:: Show Intros + + Similar to the previous command. + Simulates the naming process of :tacn:`intros`. + +.. cmd:: Show Existentials + + Displays all open goals / existential variables in the current proof + along with the type and the context of each variable. + +.. cmd:: Show Match @qualid + + Displays a template of the Gallina :token:`match<term_match>` + construct with a branch for each constructor of the type + :token:`qualid`. This is used internally by + `company-coq <https://github.com/cpitclaudel/company-coq>`_. + + .. example:: + + .. coqtop:: all + + Show Match nat. + + .. exn:: Unknown inductive type. + :undocumented: + +.. cmd:: Show Universes + + Displays the set of all universe constraints and + its normalized form at the current stage of the proof, useful for + debugging universe inconsistencies. + +.. cmd:: Show Goal @natural at @natural + + Available in coqtop. Displays a goal at a + proof state using the goal ID number and the proof state ID number. + It is primarily for use by tools such as Prooftree that need to fetch + goal history in this way. Prooftree is a tool for visualizing a proof + as a tree that runs in Proof General. + +.. cmd:: Guarded + + Some tactics (e.g. :tacn:`refine`) allow to build proofs using + fixpoint or co-fixpoint constructions. Due to the incremental nature + of interactive proof construction, the check of the termination (or + guardedness) of the recursive calls in the fixpoint or cofixpoint + constructions is postponed to the time of the completion of the proof. + + The command :cmd:`Guarded` allows checking if the guard condition for + fixpoint and cofixpoint is violated at some time of the construction + of the proof without having to wait the completion of the proof. + +.. _showing_diffs: + +Showing differences between proof steps +--------------------------------------- + +Coq can automatically highlight the differences between successive proof steps +and between values in some error messages. Coq can also highlight differences +in the proof term. +For example, the following screenshots of CoqIDE and coqtop show the application +of the same :tacn:`intros` tactic. The tactic creates two new hypotheses, highlighted in green. +The conclusion is entirely in pale green because although it’s changed, no tokens were added +to it. The second screenshot uses the "removed" option, so it shows the conclusion a +second time with the old text, with deletions marked in red. Also, since the hypotheses are +new, no line of old text is shown for them. + +.. comment screenshot produced with: + Inductive ev : nat -> Prop := + | ev_0 : ev 0 + | ev_SS : forall n : nat, ev n -> ev (S (S n)). + + Fixpoint double (n:nat) := + match n with + | O => O + | S n' => S (S (double n')) + end. + + Goal forall n, ev n -> exists k, n = double k. + intros n E. + +.. + + .. image:: ../../_static/diffs-coqide-on.png + :alt: CoqIDE with Set Diffs on + +.. + + .. image:: ../../_static/diffs-coqide-removed.png + :alt: CoqIDE with Set Diffs removed + +.. + + .. image:: ../../_static/diffs-coqtop-on3.png + :alt: coqtop with Set Diffs on + +This image shows an error message with diff highlighting in CoqIDE: + +.. + + .. image:: ../../_static/diffs-error-message.png + :alt: CoqIDE error message with diffs + +How to enable diffs +``````````````````` + +.. opt:: Diffs {| "on" | "off" | "removed" } + :name: Diffs + + The “on” setting highlights added tokens in green, while the “removed” setting + additionally reprints items with removed tokens in red. Unchanged tokens in + modified items are shown with pale green or red. Diffs in error messages + use red and green for the compared values; they appear regardless of the setting. + (Colors are user-configurable.) + +For coqtop, showing diffs can be enabled when starting coqtop with the +``-diffs on|off|removed`` command-line option or by setting the :opt:`Diffs` option +within Coq. You will need to provide the ``-color on|auto`` command-line option when +you start coqtop in either case. + +Colors for coqtop can be configured by setting the ``COQ_COLORS`` environment +variable. See section :ref:`customization-by-environment-variables`. Diffs +use the tags ``diff.added``, ``diff.added.bg``, ``diff.removed`` and ``diff.removed.bg``. + +In CoqIDE, diffs should be enabled from the ``View`` menu. Don’t use the ``Set Diffs`` +command in CoqIDE. You can change the background colors shown for diffs from the +``Edit | Preferences | Tags`` panel by changing the settings for the ``diff.added``, +``diff.added.bg``, ``diff.removed`` and ``diff.removed.bg`` tags. This panel also +lets you control other attributes of the highlights, such as the foreground +color, bold, italic, underline and strikeout. + +Proof General can also display Coq-generated proof diffs automatically. +Please see the PG documentation section +"`Showing Proof Diffs" <https://proofgeneral.github.io/doc/master/userman/Coq-Proof-General#Showing-Proof-Diffs>`_) +for details. + +How diffs are calculated +```````````````````````` + +Diffs are calculated as follows: + +1. Select the old proof state to compare to, which is the proof state before + the last tactic that changed the proof. Changes that only affect the view + of the proof, such as ``all: swap 1 2``, are ignored. + +2. For each goal in the new proof state, determine what old goal to compare + it to—the one it is derived from or is the same as. Match the hypotheses by + name (order is ignored), handling compacted items specially. + +3. For each hypothesis and conclusion (the “items”) in each goal, pass + them as strings to the lexer to break them into tokens. Then apply the + Myers diff algorithm :cite:`Myers` on the tokens and add appropriate highlighting. + +Notes: + +* Aside from the highlights, output for the "on" option should be identical + to the undiffed output. +* Goals completed in the last proof step will not be shown even with the + "removed" setting. + +.. comment The following screenshots show diffs working with multiple goals and with compacted + hypotheses. In the first one, notice that the goal ``P 1`` is not highlighted at + all after the split because it has not changed. + + .. todo: Use this script and remove the screenshots when COQ_COLORS + works for coqtop in sphinx + .. coqtop:: none + + Set Diffs "on". + Parameter P : nat -> Prop. + Goal P 1 /\ P 2 /\ P 3. + + .. coqtop:: out + + split. + + .. coqtop:: all abort + + 2: split. + + .. + + .. coqtop:: none + + Set Diffs "on". + Goal forall n m : nat, n + m = m + n. + Set Diffs "on". + + .. coqtop:: out + + intros n. + + .. coqtop:: all abort + + intros m. + +This screen shot shows the result of applying a :tacn:`split` tactic that replaces one goal +with 2 goals. Notice that the goal ``P 1`` is not highlighted at all after +the split because it has not changed. + +.. + + .. image:: ../../_static/diffs-coqide-multigoal.png + :alt: coqide with Set Diffs on with multiple goals + +Diffs may appear like this after applying a :tacn:`intro` tactic that results +in a compacted hypotheses: + +.. + + .. image:: ../../_static/diffs-coqide-compacted.png + :alt: coqide with Set Diffs on with compacted hypotheses + +.. _showing_proof_diffs: + +"Show Proof" differences +```````````````````````` + +To show differences in the proof term: + +- In coqtop and Proof General, use the :cmd:`Show Proof` `Diffs` command. + +- In CoqIDE, position the cursor on or just after a tactic to compare the proof term + after the tactic with the proof term before the tactic, then select + `View / Show Proof` from the menu or enter the associated key binding. + Differences will be shown applying the current `Show Diffs` setting + from the `View` menu. If the current setting is `Don't show diffs`, diffs + will not be shown. + + Output with the "added and removed" option looks like this: + + .. + + .. image:: ../../_static/diffs-show-proof.png + :alt: coqide with Set Diffs on with compacted hypotheses + +Controlling the effect of proof editing commands +------------------------------------------------ + + +.. opt:: Hyps Limit @natural + :name: Hyps Limit + + This option controls the maximum number of hypotheses displayed in goals + after the application of a tactic. All the hypotheses remain usable + in the proof development. + When unset, it goes back to the default mode which is to print all + available hypotheses. + + +.. flag:: Nested Proofs Allowed + + When turned on (it is off by default), this flag enables support for nested + proofs: a new assertion command can be inserted before the current proof is + finished, in which case Coq will temporarily switch to the proof of this + *nested lemma*. When the proof of the nested lemma is finished (with :cmd:`Qed` + or :cmd:`Defined`), its statement will be made available (as if it had been + proved before starting the previous proof) and Coq will switch back to the + proof of the previous assertion. + +.. flag:: Printing Goal Names + + When turned on, the name of the goal is printed in interactive + proof mode, which can be useful in cases of cross references + between goals. + +Controlling memory usage +------------------------ + +.. cmd:: Print Debug GC + + Prints heap usage statistics, which are values from the `stat` type of the `Gc` module + described + `here <https://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#TYPEstat>`_ + in the OCaml documentation. + The `live_words`, `heap_words` and `top_heap_words` values give the basic information. + Words are 8 bytes or 4 bytes, respectively, for 64- and 32-bit executables. + +When experiencing high memory usage the following commands can be used +to force Coq to optimize some of its internal data structures. + +.. cmd:: Optimize Proof + + Shrink the data structure used to represent the current proof. + + +.. cmd:: Optimize Heap + + Perform a heap compaction. This is generally an expensive operation. + See: `OCaml Gc.compact <http://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#VALcompact>`_ + There is also an analogous tactic :tacn:`optimize_heap`. + +Memory usage parameters can be set through the :ref:`OCAMLRUNPARAM <OCAMLRUNPARAM>` +environment variable. diff --git a/doc/sphinx/proofs/writing-proofs/rewriting.rst b/doc/sphinx/proofs/writing-proofs/rewriting.rst new file mode 100644 index 0000000000..f3f69a2fdc --- /dev/null +++ b/doc/sphinx/proofs/writing-proofs/rewriting.rst @@ -0,0 +1,857 @@ +================================= +Term rewriting and simplification +================================= + +.. _rewritingexpressions: + +Rewriting expressions +--------------------- + +These tactics use the equality :g:`eq:forall A:Type, A->A->Prop` defined in +file ``Logic.v`` (see :ref:`coq-library-logic`). The notation for :g:`eq T t u` is +simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. + +.. tacn:: rewrite @term + :name: rewrite + + This tactic applies to any goal. The type of :token:`term` must have the form + + ``forall (x``:sub:`1` ``:A``:sub:`1` ``) ... (x``:sub:`n` ``:A``:sub:`n` ``), eq term``:sub:`1` ``term``:sub:`2` ``.`` + + where :g:`eq` is the Leibniz equality or a registered setoid equality. + + Then :n:`rewrite @term` finds the first subterm matching `term`\ :sub:`1` in the goal, + resulting in instances `term`:sub:`1`' and `term`:sub:`2`' and then + replaces every occurrence of `term`:subscript:`1`' by `term`:subscript:`2`'. + Hence, some of the variables :g:`x`\ :sub:`i` are solved by unification, + and some of the types :g:`A`\ :sub:`1`:g:`, ..., A`\ :sub:`n` become new + subgoals. + + .. exn:: The @term provided does not end with an equation. + :undocumented: + + .. exn:: Tactic generated a subgoal identical to the original goal. This happens if @term does not occur in the goal. + :undocumented: + + .. tacv:: rewrite -> @term + + Is equivalent to :n:`rewrite @term` + + .. tacv:: rewrite <- @term + + Uses the equality :n:`@term`:sub:`1` :n:`= @term` :sub:`2` from right to left + + .. tacv:: rewrite @term in @goal_occurrences + + Analogous to :n:`rewrite @term` but rewriting is done following + the clause :token:`goal_occurrences`. For instance: + + + :n:`rewrite H in H'` will rewrite `H` in the hypothesis + ``H'`` instead of the current goal. + + :n:`rewrite H in H' at 1, H'' at - 2 |- *` means + :n:`rewrite H; rewrite H in H' at 1; rewrite H in H'' at - 2.` + In particular a failure will happen if any of these three simpler tactics + fails. + + :n:`rewrite H in * |-` will do :n:`rewrite H in H'` for all hypotheses + :g:`H'` different from :g:`H`. + A success will happen as soon as at least one of these simpler tactics succeeds. + + :n:`rewrite H in *` is a combination of :n:`rewrite H` and :n:`rewrite H in * |-` + that succeeds if at least one of these two tactics succeeds. + + Orientation :g:`->` or :g:`<-` can be inserted before the :token:`term` to rewrite. + + .. tacv:: rewrite @term at @occurrences + + Rewrite only the given :token:`occurrences` of :token:`term`. Occurrences are + specified from left to right as for pattern (:tacn:`pattern`). The rewrite is + always performed using setoid rewriting, even for Leibniz’s equality, so one + has to ``Import Setoid`` to use this variant. + + .. tacv:: rewrite @term by @tactic + + Use tactic to completely solve the side-conditions arising from the + :tacn:`rewrite`. + + .. tacv:: rewrite {+, @orientation @term} {? in @ident } + + Is equivalent to the `n` successive tactics :n:`{+; rewrite @term}`, each one + working on the first subgoal generated by the previous one. An :production:`orientation` + ``->`` or ``<-`` can be inserted before each :token:`term` to rewrite. One + unique clause can be added at the end after the keyword in; it will then + affect all rewrite operations. + + In all forms of rewrite described above, a :token:`term` to rewrite can be + immediately prefixed by one of the following modifiers: + + + `?` : the tactic :n:`rewrite ?@term` performs the rewrite of :token:`term` as many + times as possible (perhaps zero time). This form never fails. + + :n:`@natural?` : works similarly, except that it will do at most :token:`natural` rewrites. + + `!` : works as `?`, except that at least one rewrite should succeed, otherwise + the tactic fails. + + :n:`@natural!` (or simply :n:`@natural`) : precisely :token:`natural` rewrites of :token:`term` will be done, + leading to failure if these :token:`natural` rewrites are not possible. + + .. tacv:: erewrite @term + :name: erewrite + + This tactic works as :n:`rewrite @term` but turning + unresolved bindings into existential variables, if any, instead of + failing. It has the same variants as :tacn:`rewrite` has. + + .. flag:: Keyed Unification + + Makes higher-order unification used by :tacn:`rewrite` rely on a set of keys to drive + unification. The subterms, considered as rewriting candidates, must start with + the same key as the left- or right-hand side of the lemma given to rewrite, and the arguments + are then unified up to full reduction. + +.. tacn:: replace @term with @term’ + :name: replace + + This tactic applies to any goal. It replaces all free occurrences of :n:`@term` + in the current goal with :n:`@term’` and generates an equality :n:`@term = @term’` + as a subgoal. This equality is automatically solved if it occurs among + the assumptions, or if its symmetric form occurs. It is equivalent to + :n:`cut @term = @term’; [intro H`:sub:`n` :n:`; rewrite <- H`:sub:`n` :n:`; clear H`:sub:`n`:n:`|| assumption || symmetry; try assumption]`. + + .. exn:: Terms do not have convertible types. + :undocumented: + + .. tacv:: replace @term with @term’ by @tactic + + This acts as :n:`replace @term with @term’` but applies :token:`tactic` to solve the generated + subgoal :n:`@term = @term’`. + + .. tacv:: replace @term + + Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has + the form :n:`@term = @term’` or :n:`@term’ = @term`. + + .. tacv:: replace -> @term + + Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has + the form :n:`@term = @term’` + + .. tacv:: replace <- @term + + Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has + the form :n:`@term’ = @term` + + .. tacv:: replace @term {? with @term} in @goal_occurrences {? by @tactic} + replace -> @term in @goal_occurrences + replace <- @term in @goal_occurrences + + Acts as before but the replacements take place in the specified clauses + (:token:`goal_occurrences`) (see :ref:`performingcomputations`) and not + only in the conclusion of the goal. The clause argument must not contain + any ``type of`` nor ``value of``. + +.. tacn:: subst @ident + :name: subst + + This tactic applies to a goal that has :n:`@ident` in its context and (at + least) one hypothesis, say :g:`H`, of type :n:`@ident = t` or :n:`t = @ident` + with :n:`@ident` not occurring in :g:`t`. Then it replaces :n:`@ident` by + :g:`t` everywhere in the goal (in the hypotheses and in the conclusion) and + clears :n:`@ident` and :g:`H` from the context. + + If :n:`@ident` is a local definition of the form :n:`@ident := t`, it is also + unfolded and cleared. + + If :n:`@ident` is a section variable it is expected to have no + indirect occurrences in the goal, i.e. that no global declarations + implicitly depending on the section variable must be present in the + goal. + + .. note:: + + When several hypotheses have the form :n:`@ident = t` or :n:`t = @ident`, the + first one is used. + + + If :g:`H` is itself dependent in the goal, it is replaced by the proof of + reflexivity of equality. + + .. tacv:: subst {+ @ident} + + This is equivalent to :n:`subst @ident`:sub:`1`:n:`; ...; subst @ident`:sub:`n`. + + .. tacv:: subst + + This applies :tacn:`subst` repeatedly from top to bottom to all hypotheses of the + context for which an equality of the form :n:`@ident = t` or :n:`t = @ident` + or :n:`@ident := t` exists, with :n:`@ident` not occurring in + ``t`` and :n:`@ident` not a section variable with indirect + dependencies in the goal. + + .. flag:: Regular Subst Tactic + + This flag controls the behavior of :tacn:`subst`. When it is + activated (it is by default), :tacn:`subst` also deals with the following corner cases: + + + A context with ordered hypotheses :n:`@ident`:sub:`1` :n:`= @ident`:sub:`2` + and :n:`@ident`:sub:`1` :n:`= t`, or :n:`t′ = @ident`:sub:`1`` with `t′` not + a variable, and no other hypotheses of the form :n:`@ident`:sub:`2` :n:`= u` + or :n:`u = @ident`:sub:`2`; without the flag, a second call to + subst would be necessary to replace :n:`@ident`:sub:`2` by `t` or + `t′` respectively. + + The presence of a recursive equation which without the flag would + be a cause of failure of :tacn:`subst`. + + A context with cyclic dependencies as with hypotheses :n:`@ident`:sub:`1` :n:`= f @ident`:sub:`2` + and :n:`@ident`:sub:`2` :n:`= g @ident`:sub:`1` which without the + flag would be a cause of failure of :tacn:`subst`. + + Additionally, it prevents a local definition such as :n:`@ident := t` to be + unfolded which otherwise it would exceptionally unfold in configurations + containing hypotheses of the form :n:`@ident = u`, or :n:`u′ = @ident` + with `u′` not a variable. Finally, it preserves the initial order of + hypotheses, which without the flag it may break. + default. + + .. exn:: Cannot find any non-recursive equality over :n:`@ident`. + :undocumented: + + .. exn:: Section variable :n:`@ident` occurs implicitly in global declaration :n:`@qualid` present in hypothesis :n:`@ident`. + Section variable :n:`@ident` occurs implicitly in global declaration :n:`@qualid` present in the conclusion. + + Raised when the variable is a section variable with indirect + dependencies in the goal. + + +.. tacn:: stepl @term + :name: stepl + + This tactic is for chaining rewriting steps. It assumes a goal of the + form :n:`R @term @term` where ``R`` is a binary relation and relies on a + database of lemmas of the form :g:`forall x y z, R x y -> eq x z -> R z y` + where `eq` is typically a setoid equality. The application of :n:`stepl @term` + then replaces the goal by :n:`R @term @term` and adds a new goal stating + :n:`eq @term @term`. + + .. cmd:: Declare Left Step @term + + Adds :n:`@term` to the database used by :tacn:`stepl`. + + This tactic is especially useful for parametric setoids which are not accepted + as regular setoids for :tacn:`rewrite` and :tacn:`setoid_replace` (see + :ref:`Generalizedrewriting`). + + .. tacv:: stepl @term by @tactic + + This applies :n:`stepl @term` then applies :token:`tactic` to the second goal. + + .. tacv:: stepr @term by @tactic + :name: stepr + + This behaves as :tacn:`stepl` but on the right-hand-side of the binary + relation. Lemmas are expected to be of the form + :g:`forall x y z, R x y -> eq y z -> R x z`. + + .. cmd:: Declare Right Step @term + + Adds :n:`@term` to the database used by :tacn:`stepr`. + + +.. tacn:: change @term + :name: change + + This tactic applies to any goal. It implements the rule ``Conv`` given in + :ref:`subtyping-rules`. :g:`change U` replaces the current goal `T` + with `U` providing that `U` is well-formed and that `T` and `U` are + convertible. + + .. exn:: Not convertible. + :undocumented: + + .. tacv:: change @term with @term’ + + This replaces the occurrences of :n:`@term` by :n:`@term’` in the current goal. + The term :n:`@term` and :n:`@term’` must be convertible. + + .. tacv:: change @term at {+ @natural} with @term’ + + This replaces the occurrences numbered :n:`{+ @natural}` of :n:`@term` by :n:`@term’` + in the current goal. The terms :n:`@term` and :n:`@term’` must be convertible. + + .. exn:: Too few occurrences. + :undocumented: + + .. tacv:: change @term {? {? at {+ @natural}} with @term} in @ident + + This applies the :tacn:`change` tactic not to the goal but to the hypothesis :n:`@ident`. + + .. tacv:: now_show @term + + This is a synonym of :n:`change @term`. It can be used to + make some proof steps explicit when refactoring a proof script + to make it readable. + + .. seealso:: :ref:`Performing computations <performingcomputations>` + +.. _performingcomputations: + +Performing computations +--------------------------- + +.. insertprodn red_expr pattern_occ + +.. prodn:: + red_expr ::= red + | hnf + | simpl {? @delta_flag } {? @ref_or_pattern_occ } + | cbv {? @strategy_flag } + | cbn {? @strategy_flag } + | lazy {? @strategy_flag } + | compute {? @delta_flag } + | vm_compute {? @ref_or_pattern_occ } + | native_compute {? @ref_or_pattern_occ } + | unfold {+, @unfold_occ } + | fold {+ @one_term } + | pattern {+, @pattern_occ } + | @ident + delta_flag ::= {? - } [ {+ @reference } ] + strategy_flag ::= {+ @red_flag } + | @delta_flag + red_flag ::= beta + | iota + | match + | fix + | cofix + | zeta + | delta {? @delta_flag } + ref_or_pattern_occ ::= @reference {? at @occs_nums } + | @one_term {? at @occs_nums } + occs_nums ::= {+ {| @natural | @ident } } + | - {| @natural | @ident } {* @int_or_var } + int_or_var ::= @integer + | @ident + unfold_occ ::= @reference {? at @occs_nums } + pattern_occ ::= @one_term {? at @occs_nums } + +This set of tactics implements different specialized usages of the +tactic :tacn:`change`. + +All conversion tactics (including :tacn:`change`) can be parameterized by the +parts of the goal where the conversion can occur. This is done using +*goal clauses* which consists in a list of hypotheses and, optionally, +of a reference to the conclusion of the goal. For defined hypothesis +it is possible to specify if the conversion should occur on the type +part, the body part or both (default). + +Goal clauses are written after a conversion tactic (tactics :tacn:`set`, +:tacn:`rewrite`, :tacn:`replace` and :tacn:`autorewrite` also use goal +clauses) and are introduced by the keyword `in`. If no goal clause is +provided, the default is to perform the conversion only in the +conclusion. + +The syntax and description of the various goal clauses is the +following: + ++ :n:`in {+ @ident} |-` only in hypotheses :n:`{+ @ident}` ++ :n:`in {+ @ident} |- *` in hypotheses :n:`{+ @ident}` and in the + conclusion ++ :n:`in * |-` in every hypothesis ++ :n:`in *` (equivalent to in :n:`* |- *`) everywhere ++ :n:`in (type of @ident) (value of @ident) ... |-` in type part of + :n:`@ident`, in the value part of :n:`@ident`, etc. + +For backward compatibility, the notation :n:`in {+ @ident}` performs +the conversion in hypotheses :n:`{+ @ident}`. + +.. tacn:: cbv {? @strategy_flag } + lazy {? @strategy_flag } + :name: cbv; lazy + + These parameterized reduction tactics apply to any goal and perform + the normalization of the goal according to the specified flags. In + correspondence with the kinds of reduction considered in Coq namely + :math:`\beta` (reduction of functional application), :math:`\delta` + (unfolding of transparent constants, see :ref:`vernac-controlling-the-reduction-strategies`), + :math:`\iota` (reduction of + pattern matching over a constructed term, and unfolding of :g:`fix` and + :g:`cofix` expressions) and :math:`\zeta` (contraction of local definitions), the + flags are either ``beta``, ``delta``, ``match``, ``fix``, ``cofix``, + ``iota`` or ``zeta``. The ``iota`` flag is a shorthand for ``match``, ``fix`` + and ``cofix``. The ``delta`` flag itself can be refined into + :n:`delta [ {+ @qualid} ]` or :n:`delta - [ {+ @qualid} ]`, restricting in the first + case the constants to unfold to the constants listed, and restricting in the + second case the constant to unfold to all but the ones explicitly mentioned. + Notice that the ``delta`` flag does not apply to variables bound by a let-in + construction inside the :n:`@term` itself (use here the ``zeta`` flag). In + any cases, opaque constants are not unfolded (see :ref:`vernac-controlling-the-reduction-strategies`). + + Normalization according to the flags is done by first evaluating the + head of the expression into a *weak-head* normal form, i.e. until the + evaluation is blocked by a variable (or an opaque constant, or an + axiom), as e.g. in :g:`x u1 ... un` , or :g:`match x with ... end`, or + :g:`(fix f x {struct x} := ...) x`, or is a constructed form (a + :math:`\lambda`-expression, a constructor, a cofixpoint, an inductive type, a + product type, a sort), or is a redex that the flags prevent to reduce. Once a + weak-head normal form is obtained, subterms are recursively reduced using the + same strategy. + + Reduction to weak-head normal form can be done using two strategies: + *lazy* (``lazy`` tactic), or *call-by-value* (``cbv`` tactic). The lazy + strategy is a call-by-need strategy, with sharing of reductions: the + arguments of a function call are weakly evaluated only when necessary, + and if an argument is used several times then it is weakly computed + only once. This reduction is efficient for reducing expressions with + dead code. For instance, the proofs of a proposition :g:`exists x. P(x)` + reduce to a pair of a witness :g:`t`, and a proof that :g:`t` satisfies the + predicate :g:`P`. Most of the time, :g:`t` may be computed without computing + the proof of :g:`P(t)`, thanks to the lazy strategy. + + The call-by-value strategy is the one used in ML languages: the + arguments of a function call are systematically weakly evaluated + first. Despite the lazy strategy always performs fewer reductions than + the call-by-value strategy, the latter is generally more efficient for + evaluating purely computational expressions (i.e. with little dead code). + +.. tacv:: compute + cbv + :name: compute; _ + + These are synonyms for ``cbv beta delta iota zeta``. + +.. tacv:: lazy + + This is a synonym for ``lazy beta delta iota zeta``. + +.. tacv:: compute [ {+ @qualid} ] + cbv [ {+ @qualid} ] + + These are synonyms of :n:`cbv beta delta {+ @qualid} iota zeta`. + +.. tacv:: compute - [ {+ @qualid} ] + cbv - [ {+ @qualid} ] + + These are synonyms of :n:`cbv beta delta -{+ @qualid} iota zeta`. + +.. tacv:: lazy [ {+ @qualid} ] + lazy - [ {+ @qualid} ] + + These are respectively synonyms of :n:`lazy beta delta {+ @qualid} iota zeta` + and :n:`lazy beta delta -{+ @qualid} iota zeta`. + +.. tacv:: vm_compute + :name: vm_compute + + This tactic evaluates the goal using the optimized call-by-value evaluation + bytecode-based virtual machine described in :cite:`CompiledStrongReduction`. + This algorithm is dramatically more efficient than the algorithm used for the + :tacn:`cbv` tactic, but it cannot be fine-tuned. It is especially interesting for + full evaluation of algebraic objects. This includes the case of + reflection-based tactics. + +.. tacv:: native_compute + :name: native_compute + + This tactic evaluates the goal by compilation to OCaml as described + in :cite:`FullReduction`. If Coq is running in native code, it can be + typically two to five times faster than :tacn:`vm_compute`. Note however that the + compilation cost is higher, so it is worth using only for intensive + computations. + + .. flag:: NativeCompute Timing + + This flag causes all calls to the native compiler to print + timing information for the conversion to native code, + compilation, execution, and reification phases of native + compilation. Timing is printed in units of seconds of + wall-clock time. + + .. flag:: NativeCompute Profiling + + On Linux, if you have the ``perf`` profiler installed, this flag makes + it possible to profile :tacn:`native_compute` evaluations. + + .. opt:: NativeCompute Profile Filename @string + :name: NativeCompute Profile Filename + + This option specifies the profile output; the default is + ``native_compute_profile.data``. The actual filename used + will contain extra characters to avoid overwriting an existing file; that + filename is reported to the user. + That means you can individually profile multiple uses of + :tacn:`native_compute` in a script. From the Linux command line, run ``perf report`` + on the profile file to see the results. Consult the ``perf`` documentation + for more details. + +.. flag:: Debug Cbv + + This flag makes :tacn:`cbv` (and its derivative :tacn:`compute`) print + information about the constants it encounters and the unfolding decisions it + makes. + +.. tacn:: red + :name: red + + This tactic applies to a goal that has the form:: + + forall (x:T1) ... (xk:Tk), T + + with :g:`T` :math:`\beta`:math:`\iota`:math:`\zeta`-reducing to :g:`c t`:sub:`1` :g:`... t`:sub:`n` and :g:`c` a + constant. If :g:`c` is transparent then it replaces :g:`c` with its + definition (say :g:`t`) and then reduces + :g:`(t t`:sub:`1` :g:`... t`:sub:`n` :g:`)` according to :math:`\beta`:math:`\iota`:math:`\zeta`-reduction rules. + +.. exn:: Not reducible. + :undocumented: + +.. exn:: No head constant to reduce. + :undocumented: + +.. tacn:: hnf + :name: hnf + + This tactic applies to any goal. It replaces the current goal with its + head normal form according to the :math:`\beta`:math:`\delta`:math:`\iota`:math:`\zeta`-reduction rules, i.e. it + reduces the head of the goal until it becomes a product or an + irreducible term. All inner :math:`\beta`:math:`\iota`-redexes are also reduced. + The behavior of both :tacn:`hnf` can be tuned using the :cmd:`Arguments` command. + + Example: The term :g:`fun n : nat => S n + S n` is not reduced by :n:`hnf`. + +.. note:: + The :math:`\delta` rule only applies to transparent constants (see :ref:`vernac-controlling-the-reduction-strategies` + on transparency and opacity). + +.. tacn:: cbn + simpl + :name: cbn; simpl + + These tactics apply to any goal. They try to reduce a term to + something still readable instead of fully normalizing it. They perform + a sort of strong normalization with two key differences: + + + They unfold a constant if and only if it leads to a :math:`\iota`-reduction, + i.e. reducing a match or unfolding a fixpoint. + + While reducing a constant unfolding to (co)fixpoints, the tactics + use the name of the constant the (co)fixpoint comes from instead of + the (co)fixpoint definition in recursive calls. + + The :tacn:`cbn` tactic is claimed to be a more principled, faster and more + predictable replacement for :tacn:`simpl`. + + The :tacn:`cbn` tactic accepts the same flags as :tacn:`cbv` and + :tacn:`lazy`. The behavior of both :tacn:`simpl` and :tacn:`cbn` + can be tuned using the :cmd:`Arguments` command. + + .. todo add "See <subsection about controlling the behavior of reduction strategies>" + to TBA section + + Notice that only transparent constants whose name can be reused in the + recursive calls are possibly unfolded by :tacn:`simpl`. For instance a + constant defined by :g:`plus' := plus` is possibly unfolded and reused in + the recursive calls, but a constant such as :g:`succ := plus (S O)` is + never unfolded. This is the main difference between :tacn:`simpl` and :tacn:`cbn`. + The tactic :tacn:`cbn` reduces whenever it will be able to reuse it or not: + :g:`succ t` is reduced to :g:`S t`. + +.. tacv:: cbn [ {+ @qualid} ] + cbn - [ {+ @qualid} ] + + These are respectively synonyms of :n:`cbn beta delta [ {+ @qualid} ] iota zeta` + and :n:`cbn beta delta - [ {+ @qualid} ] iota zeta` (see :tacn:`cbn`). + +.. tacv:: simpl @pattern + + This applies :tacn:`simpl` only to the subterms matching + :n:`@pattern` in the current goal. + +.. tacv:: simpl @pattern at {+ @natural} + + This applies :tacn:`simpl` only to the :n:`{+ @natural}` occurrences of the subterms + matching :n:`@pattern` in the current goal. + + .. exn:: Too few occurrences. + :undocumented: + +.. tacv:: simpl @qualid + simpl @string + + This applies :tacn:`simpl` only to the applicative subterms whose head occurrence + is the unfoldable constant :n:`@qualid` (the constant can be referred to by + its notation using :n:`@string` if such a notation exists). + +.. tacv:: simpl @qualid at {+ @natural} + simpl @string at {+ @natural} + + This applies :tacn:`simpl` only to the :n:`{+ @natural}` applicative subterms whose + head occurrence is :n:`@qualid` (or :n:`@string`). + +.. flag:: Debug RAKAM + + This flag makes :tacn:`cbn` print various debugging information. + ``RAKAM`` is the Refolding Algebraic Krivine Abstract Machine. + +.. tacn:: unfold @qualid + :name: unfold + + This tactic applies to any goal. The argument qualid must denote a + defined transparent constant or local definition (see + :ref:`gallina-definitions` and + :ref:`vernac-controlling-the-reduction-strategies`). The tactic + :tacn:`unfold` applies the :math:`\delta` rule to each occurrence + of the constant to which :n:`@qualid` refers in the current goal + and then replaces it with its :math:`\beta\iota\zeta`-normal form. + Use the general reduction tactics if you want to avoid this final + reduction, for instance :n:`cbv delta [@qualid]`. + + .. exn:: Cannot coerce @qualid to an evaluable reference. + + This error is frequent when trying to unfold something that has + defined as an inductive type (or constructor) and not as a + definition. + + .. example:: + + .. coqtop:: abort all fail + + Goal 0 <= 1. + unfold le. + + This error can also be raised if you are trying to unfold + something that has been marked as opaque. + + .. example:: + + .. coqtop:: abort all fail + + Opaque Nat.add. + Goal 1 + 0 = 1. + unfold Nat.add. + + .. tacv:: unfold @qualid in @goal_occurrences + + Replaces :n:`@qualid` in hypothesis (or hypotheses) designated + by :token:`goal_occurrences` with its definition and replaces + the hypothesis with its :math:`\beta`:math:`\iota` normal form. + + .. tacv:: unfold {+, @qualid} + + Replaces :n:`{+, @qualid}` with their definitions and replaces + the current goal with its :math:`\beta`:math:`\iota` normal + form. + + .. tacv:: unfold {+, @qualid at @occurrences } + + The list :token:`occurrences` specify the occurrences of + :n:`@qualid` to be unfolded. Occurrences are located from left + to right. + + .. exn:: Bad occurrence number of @qualid. + :undocumented: + + .. exn:: @qualid does not occur. + :undocumented: + + .. tacv:: unfold @string + + If :n:`@string` denotes the discriminating symbol of a notation + (e.g. "+") or an expression defining a notation (e.g. `"_ + + _"`), and this notation denotes an application whose head symbol + is an unfoldable constant, then the tactic unfolds it. + + .. tacv:: unfold @string%@ident + + This is variant of :n:`unfold @string` where :n:`@string` gets + its interpretation from the scope bound to the delimiting key + :token:`ident` instead of its default interpretation (see + :ref:`Localinterpretationrulesfornotations`). + + .. tacv:: unfold {+, {| @qualid | @string{? %@ident } } {? at @occurrences } } {? in @goal_occurrences } + + This is the most general form. + +.. tacn:: fold @term + :name: fold + + This tactic applies to any goal. The term :n:`@term` is reduced using the + :tacn:`red` tactic. Every occurrence of the resulting :n:`@term` in the goal is + then replaced by :n:`@term`. This tactic is particularly useful when a fixpoint + definition has been wrongfully unfolded, making the goal very hard to read. + On the other hand, when an unfolded function applied to its argument has been + reduced, the :tacn:`fold` tactic won't do anything. + + .. example:: + + .. coqtop:: all abort + + Goal ~0=0. + unfold not. + Fail progress fold not. + pattern (0 = 0). + fold not. + + .. tacv:: fold {+ @term} + + Equivalent to :n:`fold @term ; ... ; fold @term`. + +.. tacn:: pattern @term + :name: pattern + + This command applies to any goal. The argument :n:`@term` must be a free + subterm of the current goal. The command pattern performs :math:`\beta`-expansion + (the inverse of :math:`\beta`-reduction) of the current goal (say :g:`T`) by + + + replacing all occurrences of :n:`@term` in :g:`T` with a fresh variable + + abstracting this variable + + applying the abstracted goal to :n:`@term` + + For instance, if the current goal :g:`T` is expressible as + :math:`\varphi`:g:`(t)` where the notation captures all the instances of :g:`t` + in :math:`\varphi`:g:`(t)`, then :n:`pattern t` transforms it into + :g:`(fun x:A =>` :math:`\varphi`:g:`(x)) t`. This tactic can be used, for + instance, when the tactic ``apply`` fails on matching. + +.. tacv:: pattern @term at {+ @natural} + + Only the occurrences :n:`{+ @natural}` of :n:`@term` are considered for + :math:`\beta`-expansion. Occurrences are located from left to right. + +.. tacv:: pattern @term at - {+ @natural} + + All occurrences except the occurrences of indexes :n:`{+ @natural }` + of :n:`@term` are considered for :math:`\beta`-expansion. Occurrences are located from + left to right. + +.. tacv:: pattern {+, @term} + + Starting from a goal :math:`\varphi`:g:`(t`:sub:`1` :g:`... t`:sub:`m`:g:`)`, + the tactic :n:`pattern t`:sub:`1`:n:`, ..., t`:sub:`m` generates the + equivalent goal + :g:`(fun (x`:sub:`1`:g:`:A`:sub:`1`:g:`) ... (x`:sub:`m` :g:`:A`:sub:`m` :g:`) =>`:math:`\varphi`:g:`(x`:sub:`1` :g:`... x`:sub:`m` :g:`)) t`:sub:`1` :g:`... t`:sub:`m`. + If :g:`t`:sub:`i` occurs in one of the generated types :g:`A`:sub:`j` these + occurrences will also be considered and possibly abstracted. + +.. tacv:: pattern {+, @term at {+ @natural}} + + This behaves as above but processing only the occurrences :n:`{+ @natural}` of + :n:`@term` starting from :n:`@term`. + +.. tacv:: pattern {+, @term {? at {? -} {+, @natural}}} + + This is the most general syntax that combines the different variants. + +.. tacn:: with_strategy @strategy_level_or_var [ {+ @reference } ] @ltac_expr3 + :name: with_strategy + + Executes :token:`ltac_expr3`, applying the alternate unfolding + behavior that the :cmd:`Strategy` command controls, but only for + :token:`ltac_expr3`. This can be useful for guarding calls to + reduction in tactic automation to ensure that certain constants are + never unfolded by tactics like :tacn:`simpl` and :tacn:`cbn` or to + ensure that unfolding does not fail. + + .. example:: + + .. coqtop:: all reset abort + + Opaque id. + Goal id 10 = 10. + Fail unfold id. + with_strategy transparent [id] unfold id. + + .. warning:: + + Use this tactic with care, as effects do not persist past the + end of the proof script. Notably, this fine-tuning of the + conversion strategy is not in effect during :cmd:`Qed` nor + :cmd:`Defined`, so this tactic is most useful either in + combination with :tacn:`abstract`, which will check the proof + early while the fine-tuning is still in effect, or to guard + calls to conversion in tactic automation to ensure that, e.g., + :tacn:`unfold` does not fail just because the user made a + constant :cmd:`Opaque`. + + This can be illustrated with the following example involving the + factorial function. + + .. coqtop:: in reset + + Fixpoint fact (n : nat) : nat := + match n with + | 0 => 1 + | S n' => n * fact n' + end. + + Suppose now that, for whatever reason, we want in general to + unfold the :g:`id` function very late during conversion: + + .. coqtop:: in + + Strategy 1000 [id]. + + If we try to prove :g:`id (fact n) = fact n` by + :tacn:`reflexivity`, it will now take time proportional to + :math:`n!`, because Coq will keep unfolding :g:`fact` and + :g:`*` and :g:`+` before it unfolds :g:`id`, resulting in a full + computation of :g:`fact n` (in unary, because we are using + :g:`nat`), which takes time :math:`n!`. We can see this cross + the relevant threshold at around :math:`n = 9`: + + .. coqtop:: all abort + + Goal True. + Time assert (id (fact 8) = fact 8) by reflexivity. + Time assert (id (fact 9) = fact 9) by reflexivity. + + Note that behavior will be the same if you mark :g:`id` as + :g:`Opaque` because while most reduction tactics refuse to + unfold :g:`Opaque` constants, conversion treats :g:`Opaque` as + merely a hint to unfold this constant last. + + We can get around this issue by using :tacn:`with_strategy`: + + .. coqtop:: all + + Goal True. + Fail Timeout 1 assert (id (fact 100) = fact 100) by reflexivity. + Time assert (id (fact 100) = fact 100) by with_strategy -1 [id] reflexivity. + + However, when we go to close the proof, we will run into + trouble, because the reduction strategy changes are local to the + tactic passed to :tacn:`with_strategy`. + + .. coqtop:: all abort fail + + exact I. + Timeout 1 Defined. + + We can fix this issue by using :tacn:`abstract`: + + .. coqtop:: all + + Goal True. + Time assert (id (fact 100) = fact 100) by with_strategy -1 [id] abstract reflexivity. + exact I. + Time Defined. + + On small examples this sort of behavior doesn't matter, but + because Coq is a super-linear performance domain in so many + places, unless great care is taken, tactic automation using + :tacn:`with_strategy` may not be robustly performant when + scaling the size of the input. + + .. warning:: + + In much the same way this tactic does not play well with + :cmd:`Qed` and :cmd:`Defined` without using :tacn:`abstract` as + an intermediary, this tactic does not play well with ``coqchk``, + even when used with :tacn:`abstract`, due to the inability of + tactics to persist information about conversion hints in the + proof term. See `#12200 + <https://github.com/coq/coq/issues/12200>`_ for more details. + +Conversion tactics applied to hypotheses +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. tacn:: @tactic in {+, @ident} + + Applies :token:`tactic` (any of the conversion tactics listed in this + section) to the hypotheses :n:`{+ @ident}`. + + If :token:`ident` is a local definition, then :token:`ident` can be replaced by + :n:`type of @ident` to address not the body but the type of the local + definition. + + Example: :n:`unfold not in (type of H1) (type of H3)`. diff --git a/doc/sphinx/refman-preamble.rst b/doc/sphinx/refman-preamble.rst index 05e665a43b..32d3e87e68 100644 --- a/doc/sphinx/refman-preamble.rst +++ b/doc/sphinx/refman-preamble.rst @@ -15,15 +15,9 @@ .. |c_i| replace:: `c`\ :math:`_{i}` .. |c_n| replace:: `c`\ :math:`_{n}` .. |Cic| replace:: CIC -.. |Coq| replace:: :smallcaps:`Coq` -.. |CoqIDE| replace:: :smallcaps:`CoqIDE` .. |eq_beta_delta_iota_zeta| replace:: `=`\ :math:`_{\beta\delta\iota\zeta}` -.. |Gallina| replace:: :smallcaps:`Gallina` .. |Latex| replace:: :smallcaps:`LaTeX` -.. |L_tac| replace:: `L`:sub:`tac` .. |Ltac| replace:: `L`:sub:`tac` -.. |ML| replace:: :smallcaps:`ML` -.. |OCaml| replace:: :smallcaps:`OCaml` .. |p_1| replace:: `p`\ :math:`_{1}` .. |p_i| replace:: `p`\ :math:`_{i}` .. |p_n| replace:: `p`\ :math:`_{n}` diff --git a/doc/sphinx/user-extensions/proof-schemes.rst b/doc/sphinx/user-extensions/proof-schemes.rst index 8e23e61018..f9d4864492 100644 --- a/doc/sphinx/user-extensions/proof-schemes.rst +++ b/doc/sphinx/user-extensions/proof-schemes.rst @@ -8,35 +8,36 @@ Proof schemes Generation of induction principles with ``Scheme`` -------------------------------------------------------- -The ``Scheme`` command is a high-level tool for generating automatically -(possibly mutual) induction principles for given types and sorts. Its -syntax follows the schema: +.. cmd:: Scheme {? @ident := } @scheme_kind {* with {? @ident := } @scheme_kind } -.. cmd:: Scheme @ident__1 := Induction for @ident__2 Sort @sort {* with @ident__i := Induction for @ident__j Sort @sort} + .. insertprodn scheme_kind sort_family - This command is a high-level tool for generating automatically + .. prodn:: + scheme_kind ::= Equality for @reference + | {| Induction | Minimality | Elimination | Case } for @reference Sort @sort_family + sort_family ::= Set + | Prop + | SProp + | Type + + A high-level tool for automatically generating (possibly mutual) induction principles for given types and sorts. - Each :n:`@ident__j` is a different inductive type identifier belonging to + Each :n:`@reference` is a different inductive type identifier belonging to the same package of mutual inductive definitions. - The command generates the :n:`@ident__i`\s to be mutually recursive - definitions. Each term :n:`@ident__i` proves a general principle of mutual - induction for objects in type :n:`@ident__j`. - -.. cmdv:: Scheme @ident := Minimality for @ident Sort @sort {* with @ident := Minimality for @ident' Sort @sort} - - Same as before but defines a non-dependent elimination principle more - natural in case of inductively defined relations. + The command generates the :n:`@ident`\s as mutually recursive + definitions. Each term :n:`@ident` proves a general principle of mutual + induction for objects in type :n:`@reference`. -.. cmdv:: Scheme Equality for @ident - :name: Scheme Equality + :n:`@ident` + The name of the scheme. If not provided, the scheme name will be determined automatically + from the sorts involved. - Tries to generate a Boolean equality and a proof of the decidability of the usual equality. If `ident` - involves some other inductive types, their equality has to be defined first. + :n:`Minimality for @reference Sort @sort_family` + Defines a non-dependent elimination principle more natural for inductively defined relations. -.. cmdv:: Scheme Induction for @ident Sort @sort {* with Induction for @ident Sort @sort} - - If you do not provide the name of the schemes, they will be automatically computed from the - sorts involved (works also with Minimality). + :n:`Equality for @reference` + Tries to generate a Boolean equality and a proof of the decidability of the usual equality. + If :token:`reference` involves other inductive types, their equality has to be defined first. .. example:: @@ -138,13 +139,13 @@ Automatic declaration of schemes Combined Scheme ~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Combined Scheme @ident from {+, @ident__i} +.. cmd:: Combined Scheme @ident__def from {+, @ident } This command is a tool for combining induction principles generated by the :cmd:`Scheme` command. - Each :n:`@ident__i` is a different inductive principle that must belong + Each :n:`@ident` is a different inductive principle that must belong to the same package of mutual inductive principle definitions. - This command generates :n:`@ident` to be the conjunction of the + This command generates :n:`@ident__def` as the conjunction of the principles: it is built from the common premises of the principles and concluded by the conjunction of their conclusions. In the case where all the inductive principles used are in sort @@ -197,32 +198,30 @@ Combined Scheme Generation of inversion principles with ``Derive`` ``Inversion`` ----------------------------------------------------------------- -.. cmd:: Derive Inversion @ident with @ident Sort @sort - Derive Inversion @ident with (forall {* @binder }, @ident @term) Sort @sort +.. cmd:: Derive Inversion @ident with @one_term {? Sort @sort_family } - This command generates an inversion principle for the - :tacn:`inversion ... using ...` tactic. The first :token:`ident` is the name - of the generated principle. The second :token:`ident` should be an inductive - predicate, and :n:`{* @binder }` the variables occurring in the term - :token:`term`. This command generates the inversion lemma for the sort - :token:`sort` corresponding to the instance :n:`forall {* @binder }, @ident @term`. - When applied, it is equivalent to having inverted the instance with the - tactic :g:`inversion`. + Generates an inversion lemma for the + :tacn:`inversion ... using ...` tactic. :token:`ident` is the name + of the generated lemma. :token:`one_term` should be in the form + :token:`qualid` or :n:`(forall {+ @binder }, @qualid @term)` where + :token:`qualid` is the name of an inductive + predicate and :n:`{+ @binder }` binds the variables occurring in the term + :token:`term`. The lemma is generated for the sort + :token:`sort_family` corresponding to :token:`one_term`. + Applying the lemma is equivalent to inverting the instance with the + :tacn:`inversion` tactic. -.. cmdv:: Derive Inversion_clear @ident with @ident Sort @sort - Derive Inversion_clear @ident with (forall {* @binder }, @ident @term) Sort @sort +.. cmd:: Derive Inversion_clear @ident with @one_term {? Sort @sort_family } When applied, it is equivalent to having inverted the instance with the tactic inversion replaced by the tactic `inversion_clear`. -.. cmdv:: Derive Dependent Inversion @ident with @ident Sort @sort - Derive Dependent Inversion @ident with (forall {* @binder }, @ident @term) Sort @sort +.. cmd:: Derive Dependent Inversion @ident with @one_term Sort @sort_family When applied, it is equivalent to having inverted the instance with the tactic `dependent inversion`. -.. cmdv:: Derive Dependent Inversion_clear @ident with @ident Sort @sort - Derive Dependent Inversion_clear @ident with (forall {* @binder }, @ident @term) Sort @sort +.. cmd:: Derive Dependent Inversion_clear @ident with @one_term Sort @sort_family When applied, it is equivalent to having inverted the instance with the tactic `dependent inversion_clear`. diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index d6db305300..f36767b207 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -13,7 +13,7 @@ The main commands to provide custom symbolic notations for terms are variant of :cmd:`Notation` which does not modify the parser; this provides a form of :ref:`abbreviation <Abbreviations>`. It is sometimes expected that the same symbolic notation has different meanings in -different contexts; to achieve this form of overloading, |Coq| offers a notion +different contexts; to achieve this form of overloading, Coq offers a notion of :ref:`notation scopes <Scopes>`. The main command to provide custom notations for tactics is :cmd:`Tactic Notation`. @@ -226,7 +226,7 @@ Coq printer. For example: However, printing, especially pretty-printing, also requires some care. We may want specific indentations, line breaks, alignment if on -several lines, etc. For pretty-printing, |Coq| relies on |ocaml| +several lines, etc. For pretty-printing, Coq relies on OCaml formatting library, which provides indentation and automatic line breaks depending on page width by means of *formatting boxes*. @@ -385,8 +385,8 @@ a :token:`decl_notations` clause after the definition of the (co)inductive type (co)recursive term (or after the definition of each of them in case of mutual definitions). The exact syntax is given by :n:`@decl_notation` for inductive, co-inductive, recursive and corecursive definitions and in :ref:`record-types` -for records. Note that only syntax modifiers that do not require to add or -change a parsing rule are accepted. +for records. Note that only syntax modifiers that do not require adding or +changing a parsing rule are accepted. .. insertprodn decl_notations decl_notation @@ -444,7 +444,7 @@ Displaying information about notations This command doesn't display all nonterminals of the grammar. For example, productions shown by `Print Grammar tactic` refer to nonterminals `tactic_then_locality` - and `tactic_then_gen` which are not shown and can't be printed. + and `for_each_goal` which are not shown and can't be printed. Most of the grammar in the documentation was updated in 8.12 to make it accurate and readable. This was done using a new developer tool that extracts the grammar from the @@ -454,7 +454,7 @@ Displaying information about notations definition where the nonterminal was referenced. This command shows the original grammar, so it won't exactly match the documentation. - The |Coq| parser is based on Camlp5. The documentation for + The Coq parser is based on Camlp5. The documentation for `Extensible grammars <http://camlp5.github.io/doc/htmlc/grammars.html>`_ is the most relevant but it assumes considerable knowledge. Here are the essentials: @@ -477,16 +477,16 @@ Displaying information about notations such as `1+2*3` in the usual way as `1+(2*3)`. However, most nonterminals have a single level. For example, this output from `Print Grammar tactic` shows the first 3 levels for - `tactic_expr`, designated as "5", "4" and "3". Level 3 is right-associative, + `ltac_expr`, designated as "5", "4" and "3". Level 3 is right-associative, which applies to the productions within it, such as the `try` construct:: - Entry tactic_expr is + Entry ltac_expr is [ "5" RIGHTA [ binder_tactic ] | "4" LEFTA [ SELF; ";"; binder_tactic | SELF; ";"; SELF - | SELF; ";"; tactic_then_locality; tactic_then_gen; "]" ] + | SELF; ";"; tactic_then_locality; for_each_goal; "]" ] | "3" RIGHTA [ IDENT "try"; SELF : @@ -510,7 +510,7 @@ Displaying information about notations The output for `Print Grammar constr` includes :cmd:`Notation` definitions, which are dynamically added to the grammar at run time. - For example, in the definition for `operconstr`, the production on the second line shown + For example, in the definition for `term`, the production on the second line shown here is defined by a :cmd:`Reserved Notation` command in `Notations.v`:: | "50" LEFTA @@ -521,7 +521,7 @@ Displaying information about notations The file `doc/tools/docgram/fullGrammar <http://github.com/coq/coq/blob/master/doc/tools/docgram/fullGrammar>`_ in the source tree extracts the full grammar for - |Coq| (not including notations and tactic notations defined in `*.v` files nor some optionally-loaded plugins) + Coq (not including notations and tactic notations defined in `*.v` files nor some optionally-loaded plugins) in a single file with minor changes to handle nonterminals using multiple levels (described in `doc/tools/docgram/README.md <http://github.com/coq/coq/blob/master/doc/tools/docgram/README.md>`_). This is complete and much easier to read than the grammar source files. @@ -1167,7 +1167,7 @@ Global interpretation rules for notations At any time, the interpretation of a notation for a term is done within a *stack* of notation scopes and lonely notations. If a -notation is defined in multiple scopes, |Coq| uses the interpretation from +notation is defined in multiple scopes, Coq uses the interpretation from the most recently opened notation scope or declared lonely notation. Note that "stack" is a misleading name. Each scope or lonely notation can only appear in @@ -1309,7 +1309,7 @@ recognized to be a ``Funclass`` instance, i.e., of type :g:`forall x:A, B` or .. _notation-scopes: Notation scopes used in the standard library of Coq -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We give an overview of the scopes used in the standard library of Coq. For a complete list of notations in each scope, use the commands :cmd:`Print @@ -1386,7 +1386,7 @@ Scopes` or :cmd:`Print Scope`. ``char_scope`` This scope includes interpretation for all strings of the form ``"c"`` where :g:`c` is an ASCII character, or of the form ``"nnn"`` where nnn is - a three-digits number (possibly with leading 0's), or of the form + a three-digit number (possibly with leading 0s), or of the form ``""""``. Their respective denotations are the ASCII code of :g:`c`, the decimal ASCII code ``nnn``, or the ascii code of the character ``"`` (i.e. the ASCII code 34), all of them being represented in the type :g:`ascii`. @@ -1553,16 +1553,18 @@ numbers (see :ref:`datatypes`). Number notations ~~~~~~~~~~~~~~~~ -.. cmd:: Number Notation @qualid__type @qualid__parse @qualid__print : @scope_name {? @numeral_modifier } +.. cmd:: Number Notation @qualid__type @qualid__parse @qualid__print {? ( {+, @number_modifier } ) } : @scope_name :name: Number Notation - .. insertprodn numeral_modifier numeral_modifier + .. insertprodn number_modifier number_string_via .. prodn:: - numeral_modifier ::= ( warning after @bignat ) - | ( abstract after @bignat ) + number_modifier ::= warning after @bignat + | abstract after @bignat + | @number_string_via + number_string_via ::= via @qualid mapping [ {+, {| @qualid => @qualid | [ @qualid ] => @qualid } } ] - This command allows the user to customize the way numeral literals + This command allows the user to customize the way number literals are parsed and printed. :n:`@qualid__type` @@ -1571,32 +1573,32 @@ Number notations parsing and printing functions, respectively. The parsing function :n:`@qualid__parse` should have one of the following types: - * :n:`Numeral.int -> @qualid__type` - * :n:`Numeral.int -> option @qualid__type` - * :n:`Numeral.uint -> @qualid__type` - * :n:`Numeral.uint -> option @qualid__type` + * :n:`Number.int -> @qualid__type` + * :n:`Number.int -> option @qualid__type` + * :n:`Number.uint -> @qualid__type` + * :n:`Number.uint -> option @qualid__type` * :n:`Z -> @qualid__type` * :n:`Z -> option @qualid__type` - * :n:`Numeral.numeral -> @qualid__type` - * :n:`Numeral.numeral -> option @qualid__type` + * :n:`Number.number -> @qualid__type` + * :n:`Number.number -> option @qualid__type` And the printing function :n:`@qualid__print` should have one of the following types: - * :n:`@qualid__type -> Numeral.int` - * :n:`@qualid__type -> option Numeral.int` - * :n:`@qualid__type -> Numeral.uint` - * :n:`@qualid__type -> option Numeral.uint` + * :n:`@qualid__type -> Number.int` + * :n:`@qualid__type -> option Number.int` + * :n:`@qualid__type -> Number.uint` + * :n:`@qualid__type -> option Number.uint` * :n:`@qualid__type -> Z` * :n:`@qualid__type -> option Z` - * :n:`@qualid__type -> Numeral.numeral` - * :n:`@qualid__type -> option Numeral.numeral` + * :n:`@qualid__type -> Number.number` + * :n:`@qualid__type -> option Number.number` .. deprecated:: 8.12 - Numeral notations on :g:`Decimal.uint`, :g:`Decimal.int` and - :g:`Decimal.decimal` are replaced respectively by numeral - notations on :g:`Numeral.uint`, :g:`Numeral.int` and - :g:`Numeral.numeral`. + Number notations on :g:`Decimal.uint`, :g:`Decimal.int` and + :g:`Decimal.decimal` are replaced respectively by number + notations on :g:`Number.uint`, :g:`Number.int` and + :g:`Number.number`. When parsing, the application of the parsing function :n:`@qualid__parse` to the number will be fully reduced, and universes @@ -1606,7 +1608,44 @@ Number notations function application, constructors, inductive type families, sorts, and primitive integers) will be considered for printing. - :n:`( warning after @bignat )` + .. _number-string-via: + + :n:`via @qualid__ind mapping [ {+, @qualid__constant => @qualid__constructor } ]` + When using this option, :n:`@qualid__type` no + longer needs to be an inductive type and is instead mapped to the + inductive type :n:`@qualid__ind` according to the provided + list of pairs, whose first component :n:`@qualid__constant` is a + constant of type :n:`@qualid__type` + (or a function of type :n:`{* _ -> } @qualid__type`) and the second a + constructor of type :n:`@qualid__ind`. The type + :n:`@qualid__type` is then replaced by :n:`@qualid__ind` in the + above parser and printer types. + + When :n:`@qualid__constant` is surrounded by square brackets, + all the implicit arguments of :n:`@qualid__constant` (whether maximally inserted or not) are ignored + when translating to :n:`@qualid__constructor` (i.e., before + applying :n:`@qualid__print`) and replaced with implicit + argument holes :g:`_` when translating from + :n:`@qualid__constructor` to :n:`@qualid__constant` (after + :n:`@qualid__parse`). See below for an :ref:`example <example-number-notation-implicit-args>`. + + .. note:: + The implicit status of the arguments is considered + only at notation declaration time, any further + modification of this status has no impact + on the previously declared notations. + + .. note:: + In case of multiple implicit options (for instance + :g:`Arguments eq_refl {A}%type_scope {x}, [_] _`), an + argument is considered implicit when it is implicit in any of the + options. + + .. note:: + To use a :token:`sort` as the target type :n:`@qualid__type`, use an :ref:`abbreviation <Abbreviations>` + as in the :ref:`example below <example-number-notation-non-inductive>`. + + :n:`warning after @bignat` displays a warning message about a possible stack overflow when calling :n:`@qualid__parse` to parse a literal larger than :n:`@bignat`. @@ -1616,11 +1655,11 @@ Number notations with :n:`(warning after @bignat)`, this warning is emitted when parsing a number greater than or equal to :token:`bignat`. - :n:`( abstract after @bignat )` + :n:`abstract after @bignat` returns :n:`(@qualid__parse m)` when parsing a literal :n:`m` that's greater than :n:`@bignat` rather than reducing it to a normal form. Here :g:`m` will be a - :g:`Numeral.int`, :g:`Numeral.uint`, :g:`Z` or :g:`Numeral.numeral`, depending on the + :g:`Number.int`, :g:`Number.uint`, :g:`Z` or :g:`Number.number`, depending on the type of the parsing function :n:`@qualid__parse`. This allows for a more compact representation of literals in types such as :g:`nat`, and limits parse failures due to stack overflow. Note that a @@ -1642,76 +1681,94 @@ Number notations As noted above, the :n:`(abstract after @natural)` directive has no effect when :n:`@qualid__parse` lands in an :g:`option` type. + .. exn:: 'via' and 'abstract' cannot be used together. + + With the :n:`abstract after` option, the parser function + :n:`@qualid__parse` does not reduce large numbers to a normal form, + which prevents doing the translation given in the :n:`mapping` list. + .. exn:: Cannot interpret this number as a value of type @type - The numeral notation registered for :token:`type` does not support + The number notation registered for :token:`type` does not support the given number. This error is given when the interpretation function returns :g:`None`, or if the interpretation is registered only for integers or non-negative integers, and the given number has a fractional or exponent part or is negative. - .. exn:: @qualid__parse should go from Numeral.int to @type or (option @type). Instead of Numeral.int, the types Numeral.uint or Z or Int63.int or Numeral.numeral could be used (you may need to require BinNums or Numeral or Int63 first). + .. exn:: @qualid__parse should go from Number.int to @type or (option @type). Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first). The parsing function given to the :cmd:`Number Notation` vernacular is not of the right type. - .. exn:: @qualid__print should go from @type to Numeral.int or (option Numeral.int). Instead of Numeral.int, the types Numeral.uint or Z or Int63.int or Numeral.numeral could be used (you may need to require BinNums or Numeral or Int63 first). + .. exn:: @qualid__print should go from @type to Number.int or (option Number.int). Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first). The printing function given to the :cmd:`Number Notation` vernacular is not of the right type. - .. exn:: Unexpected term @term while parsing a numeral notation. + .. exn:: Unexpected term @term while parsing a number notation. Parsing functions must always return ground terms, made up of - applications of constructors, inductive types, and primitive + function application, constructors, inductive type families, sorts and primitive integers. Parsing functions may not return terms containing axioms, bare (co)fixpoints, lambdas, etc. - .. exn:: Unexpected non-option term @term while parsing a numeral notation. + .. exn:: Unexpected non-option term @term while parsing a number notation. Parsing functions expected to return an :g:`option` must always return a concrete :g:`Some` or :g:`None` when applied to a concrete number expressed as a (hexa)decimal. They may not return opaque constants. + .. exn:: Multiple 'via' options. + + At most one :g:`via` option can be given. + + .. exn:: Multiple 'warning after' or 'abstract after' options. + + At most one :g:`warning after` or :g:`abstract after` option can be given. + .. _string-notations: String notations ~~~~~~~~~~~~~~~~ -.. cmd:: String Notation @qualid @qualid__parse @qualid__print : @scope_name +.. cmd:: String Notation @qualid__type @qualid__parse @qualid__print {? ( @number_string_via ) } : @scope_name :name: String Notation Allows the user to customize how strings are parsed and printed. - The token :n:`@qualid` should be the name of an inductive type, - while :n:`@qualid__parse` and :n:`@qualid__print` should be the names of the - parsing and printing functions, respectively. The parsing function - :n:`@qualid__parse` should have one of the following types: + :n:`@qualid__type` + the name of an inductive type, + while :n:`@qualid__parse` and :n:`@qualid__print` should be the names of the + parsing and printing functions, respectively. The parsing function + :n:`@qualid__parse` should have one of the following types: - * :n:`Byte.byte -> @qualid` - * :n:`Byte.byte -> option @qualid` - * :n:`list Byte.byte -> @qualid` - * :n:`list Byte.byte -> option @qualid` + * :n:`Byte.byte -> @qualid__type` + * :n:`Byte.byte -> option @qualid__type` + * :n:`list Byte.byte -> @qualid__type` + * :n:`list Byte.byte -> option @qualid__type` - The printing function :n:`@qualid__print` should have one of the - following types: + The printing function :n:`@qualid__print` should have one of the + following types: - * :n:`@qualid -> Byte.byte` - * :n:`@qualid -> option Byte.byte` - * :n:`@qualid -> list Byte.byte` - * :n:`@qualid -> option (list Byte.byte)` + * :n:`@qualid__type -> Byte.byte` + * :n:`@qualid__type -> option Byte.byte` + * :n:`@qualid__type -> list Byte.byte` + * :n:`@qualid__type -> option (list Byte.byte)` - When parsing, the application of the parsing function - :n:`@qualid__parse` to the string will be fully reduced, and universes - of the resulting term will be refreshed. + When parsing, the application of the parsing function + :n:`@qualid__parse` to the string will be fully reduced, and universes + of the resulting term will be refreshed. - Note that only fully-reduced ground terms (terms containing only - function application, constructors, inductive type families, - sorts, and primitive integers) will be considered for printing. + Note that only fully-reduced ground terms (terms containing only + function application, constructors, inductive type families, + sorts, and primitive integers) will be considered for printing. + + :n:`via @qualid__ind mapping [ {+, @qualid__constant => @qualid__constructor } ]` + works as for :ref:`number notations above <number-string-via>`. - .. exn:: Cannot interpret this string as a value of type @type + .. exn:: Cannot interpret this string as a value of type @type The string notation registered for :token:`type` does not support the given string. This error is given when the interpretation @@ -1730,7 +1787,7 @@ String notations .. exn:: Unexpected term @term while parsing a string notation. Parsing functions must always return ground terms, made up of - applications of constructors, inductive types, and primitive + function application, constructors, inductive type families, sorts and primitive integers. Parsing functions may not return terms containing axioms, bare (co)fixpoints, lambdas, etc. @@ -1741,16 +1798,37 @@ String notations concrete string expressed as a decimal. They may not return opaque constants. -The following errors apply to both string and numeral notations: +.. note:: + Number or string notations for parameterized inductive types can be + added by declaring an :ref:`abbreviation <Abbreviations>` for the + inductive which instantiates all parameters. See :ref:`example below <example-string-notation-parameterized-inductive>`. + +The following errors apply to both string and number notations: .. exn:: @type is not an inductive type. - String and numeral notations can only be declared for inductive types with no - arguments. + String and number notations can only be declared for inductive types. + Declare string or numeral notations for non-inductive types using :n:`@number_string_via`. + + .. exn:: @qualid was already mapped to @qualid and cannot be remapped to @qualid + + Duplicates are not allowed in the :n:`mapping` list. + + .. exn:: Missing mapping for constructor @qualid + + A mapping should be provided for :n:`@qualid` in the :n:`mapping` list. + + .. warn:: @type was already mapped to @type, mapping it also to @type might yield ill typed terms when using the notation. + + Two pairs in the :n:`mapping` list associate types that might be incompatible. + + .. warn:: Type of @qualid seems incompatible with the type of @qualid. Expected type is: @type instead of @type. This might yield ill typed terms when using the notation. + + A mapping given in the :n:`mapping` list associates a constant with a seemingly incompatible constructor. .. exn:: Cannot interpret in @scope_name because @qualid could not be found in the current environment. - The inductive type used to register the string or numeral notation is no + The inductive type used to register the string or number notation is no longer available in the environment. Most likely, this is because the notation was declared inside a functor for an inductive type inside the functor. This use case is not currently @@ -1779,6 +1857,198 @@ The following errors apply to both string and numeral notations: .. todo note on "single qualified identifiers" https://github.com/coq/coq/pull/11718#discussion_r415076703 +.. example:: Number Notation for radix 3 + + The following example parses and prints natural numbers + whose digits are :g:`0`, :g:`1` or :g:`2` as terms of the following + inductive type encoding radix 3 numbers. + + .. coqtop:: in reset + + Inductive radix3 : Set := + | x0 : radix3 + | x3 : radix3 -> radix3 + | x3p1 : radix3 -> radix3 + | x3p2 : radix3 -> radix3. + + We first define a parsing function + + .. coqtop:: in + + Definition of_uint_dec (u : Decimal.uint) : option radix3 := + let fix f u := match u with + | Decimal.Nil => Some x0 + | Decimal.D0 u => match f u with Some u => Some (x3 u) | None => None end + | Decimal.D1 u => match f u with Some u => Some (x3p1 u) | None => None end + | Decimal.D2 u => match f u with Some u => Some (x3p2 u) | None => None end + | _ => None end in + f (Decimal.rev u). + Definition of_uint (u : Number.uint) : option radix3 := + match u with Number.UIntDecimal u => of_uint_dec u | Number.UIntHexadecimal _ => None end. + + and a printing function + + .. coqtop:: in + + Definition to_uint_dec (x : radix3) : Decimal.uint := + let fix f x := match x with + | x0 => Decimal.Nil + | x3 x => Decimal.D0 (f x) + | x3p1 x => Decimal.D1 (f x) + | x3p2 x => Decimal.D2 (f x) end in + Decimal.rev (f x). + Definition to_uint (x : radix3) : Number.uint := Number.UIntDecimal (to_uint_dec x). + + before declaring the notation + + .. coqtop:: in + + Declare Scope radix3_scope. + Open Scope radix3_scope. + Number Notation radix3 of_uint to_uint : radix3_scope. + + We can check the printer + + .. coqtop:: all + + Check x3p2 (x3p1 x0). + + and the parser + + .. coqtop:: all + + Set Printing All. + Check 120. + + Digits other than :g:`0`, :g:`1` and :g:`2` are rejected. + + .. coqtop:: all fail + + Check 3. + +.. _example-number-notation-non-inductive: + +.. example:: Number Notation for a non inductive type + + The following example encodes the terms in the form :g:`sum unit ( ... (sum unit unit) ... )` + as the number of units in the term. For instance :g:`sum unit (sum unit unit)` + is encoded as :g:`3` while :g:`unit` is :g:`1` and :g:`0` stands for :g:`Empty_set`. + The inductive :g:`I` will be used as :n:`@qualid__ind`. + + .. coqtop:: in reset + + Inductive I := Iempty : I | Iunit : I | Isum : I -> I -> I. + + We then define :n:`@qualid__parse` and :n:`@qualid__print` + + .. coqtop:: in + + Definition of_uint (x : Number.uint) : I := + let fix f n := match n with + | O => Iempty | S O => Iunit + | S n => Isum Iunit (f n) end in + f (Nat.of_num_uint x). + + Definition to_uint (x : I) : Number.uint := + let fix f i := match i with + | Iempty => O | Iunit => 1 + | Isum i1 i2 => f i1 + f i2 end in + Nat.to_num_uint (f x). + + Inductive sum (A : Set) (B : Set) : Set := pair : A -> B -> sum A B. + + the number notation itself + + .. coqtop:: in + + Notation nSet := Set (only parsing). + Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum]) : type_scope. + + and check the printer + + .. coqtop:: all + + Local Open Scope type_scope. + Check sum unit (sum unit unit). + + and the parser + + .. coqtop:: all + + Set Printing All. + Check 3. + +.. _example-number-notation-implicit-args: + +.. example:: Number Notation with implicit arguments + + The following example parses and prints natural numbers between + :g:`0` and :g:`n-1` as terms of type :g:`Fin.t n`. + + .. coqtop:: all reset + + Require Import Vector. + Print Fin.t. + + Note the implicit arguments of :g:`Fin.F1` and :g:`Fin.FS`, + which won't appear in the corresponding inductive type. + + .. coqtop:: in + + Inductive I := I1 : I | IS : I -> I. + + Definition of_uint (x : Number.uint) : I := + let fix f n := match n with O => I1 | S n => IS (f n) end in + f (Nat.of_num_uint x). + + Definition to_uint (x : I) : Number.uint := + let fix f i := match i with I1 => O | IS n => S (f n) end in + Nat.to_num_uint (f x). + + Declare Scope fin_scope. + Delimit Scope fin_scope with fin. + Local Open Scope fin_scope. + Number Notation Fin.t of_uint to_uint (via I + mapping [[Fin.F1] => I1, [Fin.FS] => IS]) : fin_scope. + + Now :g:`2` is parsed as :g:`Fin.FS (Fin.FS Fin.F1)`, that is + :g:`@Fin.FS _ (@Fin.FS _ (@Fin.F1 _))`. + + .. coqtop:: all + + Check 2. + + which can be of type :g:`Fin.t 3` (numbers :g:`0`, :g:`1` and :g:`2`) + + .. coqtop:: all + + Check 2 : Fin.t 3. + + but cannot be of type :g:`Fin.t 2` (only :g:`0` and :g:`1`) + + .. coqtop:: all fail + + Check 2 : Fin.t 2. + +.. _example-string-notation-parameterized-inductive: + +.. example:: String Notation with a parameterized inductive type + + The parameter :g:`Byte.byte` for the parameterized inductive type + :g:`list` is given through an :ref:`abbreviation <Abbreviations>`. + + .. coqtop:: in reset + + Notation string := (list Byte.byte) (only parsing). + Definition id_string := @id string. + + String Notation string id_string id_string : list_scope. + + .. coqtop:: all + + Check "abc"%list. + .. _TacticNotation: Tactic Notations @@ -1894,12 +2164,12 @@ Tactic notations allow customizing the syntax of tactics. - :tacn:`unfold`, :tacn:`with_strategy` * - ``constr`` - - :token:`term` + - :token:`one_term` - a term - :tacn:`exact` * - ``uconstr`` - - :token:`term` + - :token:`one_term` - an untyped term - :tacn:`refine` diff --git a/doc/sphinx/using/libraries/funind.rst b/doc/sphinx/using/libraries/funind.rst index 738d64bfc3..93571ecebb 100644 --- a/doc/sphinx/using/libraries/funind.rst +++ b/doc/sphinx/using/libraries/funind.rst @@ -169,13 +169,24 @@ terminating functions. Tactics ------- -.. tacn:: functional induction (@qualid {+ @term}) +.. tacn:: functional induction @term {? using @one_term {? with @bindings } } {? as @simple_intropattern } :name: functional induction - The tactic functional induction performs case analysis and induction - following the definition of a function. It makes use of a principle + Performs case analysis and induction following the definition of a function + :token:`qualid`, which must be fully applied to its arguments as part of + :token:`term`. It uses a principle generated by :cmd:`Function` or :cmd:`Functional Scheme`. Note that this tactic is only available after a ``Require Import FunInd``. + See the :cmd:`Function` command. + + :n:`using @one_term` + Specifies the induction principle (aka elimination scheme). + + :n:`with @bindings` + Specifies the arguments of the induction principle. + + :n:`as @simple_intropattern` + Provides names for the introduced variables. .. example:: @@ -189,15 +200,6 @@ Tactics Qed. .. note:: - :n:`(@qualid {+ @term})` must be a correct full application - of :n:`@qualid`. In particular, the rules for implicit arguments are the - same as usual. For example use :n:`@@qualid` if you want to write implicit - arguments explicitly. - - .. note:: - Parentheses around :n:`@qualid {+ @term}` are not mandatory and can be skipped. - - .. note:: :n:`functional induction (f x1 x2 x3)` is actually a wrapper for :n:`induction x1, x2, x3, (f x1 x2 x3) using @qualid` followed by a cleaning phase, where :n:`@qualid` is the induction principle registered for :g:`f` @@ -218,22 +220,27 @@ Tactics .. exn:: Not the right number of induction arguments. :undocumented: - .. tacv:: functional induction (@qualid {+ @term}) as @simple_intropattern using @term with @bindings_list - - Similarly to :tacn:`induction` and :tacn:`elim`, this allows giving - explicitly the name of the introduced variables, the induction principle, and - the values of dependent premises of the elimination scheme, including - *predicates* for mutual induction when :n:`@qualid` is part of a mutually - recursive definition. - -.. tacn:: functional inversion @ident +.. tacn:: functional inversion {| @ident | @natural } {? @qualid } :name: functional inversion - :tacn:`functional inversion` is a tactic that performs inversion on hypothesis - :n:`@ident` of the form :n:`@qualid {+ @term} = @term` or :n:`@term = @qualid - {+ @term}` where :n:`@qualid` must have been defined using :cmd:`Function`. + Performs inversion on hypothesis + :n:`@ident` of the form :n:`@qualid {+ @term} = @term` or + :n:`@term = @qualid {+ @term}` when :n:`@qualid` is defined using :cmd:`Function`. Note that this tactic is only available after a ``Require Import FunInd``. + :n:`@natural` + Does the same thing as :n:`intros until @natural` followed by + :n:`functional inversion @ident` where :token:`ident` is the + identifier for the last introduced hypothesis. + + :n:`@qualid` + If the hypothesis :token:`ident` (or :token:`natural`) has a type of the form + :n:`@qualid__1 {+ @term__i } = @qualid__2 {+ @term__j }` where + :n:`@qualid__1` and :n:`@qualid__2` are valid candidates to + functional inversion, this variant allows choosing which :token:`qualid` + is inverted. + + .. exn:: Hypothesis @ident must contain at least one Function. :undocumented: @@ -242,39 +249,26 @@ Tactics This error may be raised when some inversion lemma failed to be generated by Function. - - .. tacv:: functional inversion @natural - - This does the same thing as :n:`intros until @natural` followed by - :n:`functional inversion @ident` where :token:`ident` is the - identifier for the last introduced hypothesis. - - .. tacv:: functional inversion @ident @qualid - functional inversion @natural @qualid - - If the hypothesis :token:`ident` (or :token:`natural`) has a type of the form - :n:`@qualid__1 {+ @term__i } = @qualid__2 {+ @term__j }` where - :n:`@qualid__1` and :n:`@qualid__2` are valid candidates to - functional inversion, this variant allows choosing which :token:`qualid` - is inverted. - .. _functional-scheme: Generation of induction principles with ``Functional`` ``Scheme`` ----------------------------------------------------------------- -.. cmd:: Functional Scheme @ident__0 := Induction for @ident' Sort @sort {* with @ident__i := Induction for @ident__i' Sort @sort} +.. cmd:: Functional Scheme @func_scheme_def {* with @func_scheme_def } + + .. insertprodn func_scheme_def func_scheme_def + + .. prodn:: + func_scheme_def ::= @ident := Induction for @qualid Sort @sort_family + + An experimental high-level tool that + automatically generates induction principles corresponding to functions that + may be mutually recursive. The command generates an + induction principle named :n:`@ident` for each given function named :n:`@qualid`. + The :n:`@qualid`\s must be given in the same order as when they were defined. - This command is a high-level experimental tool for - generating automatically induction principles corresponding to - (possibly mutually recursive) functions. First, it must be made - available via ``Require Import FunInd``. - Each :n:`@ident__i` is a different mutually defined function - name (the names must be in the same order as when they were defined). This - command generates the induction principle for each :n:`@ident__i`, following - the recursive structure and case analyses of the corresponding function - :n:`@ident__i'`. + Note the command must be made available via :cmd:`Require Import` ``FunInd``. .. warning:: diff --git a/doc/sphinx/using/libraries/writing.rst b/doc/sphinx/using/libraries/writing.rst index 325ea2af60..917edf0774 100644 --- a/doc/sphinx/using/libraries/writing.rst +++ b/doc/sphinx/using/libraries/writing.rst @@ -1,5 +1,5 @@ Writing Coq libraries and plugins -================================= +=================================== This section presents the part of the Coq language that is useful only to library and plugin authors. A tutorial for writing Coq plugins is diff --git a/doc/sphinx/using/tools/coqdoc.rst b/doc/sphinx/using/tools/coqdoc.rst index 9ac3d2adda..b68b2ed2a7 100644 --- a/doc/sphinx/using/tools/coqdoc.rst +++ b/doc/sphinx/using/tools/coqdoc.rst @@ -2,14 +2,14 @@ .. _coqdoc: -Documenting |Coq| files with coqdoc +Documenting Coq files with coqdoc ----------------------------------- -coqdoc is a documentation tool for the proof assistant |Coq|, similar to +coqdoc is a documentation tool for the proof assistant Coq, similar to ``javadoc`` or ``ocamldoc``. The task of coqdoc is -#. to produce a nice |Latex| and/or HTML document from |Coq| source files, +#. to produce a nice |Latex| and/or HTML document from Coq source files, readable for a human and not only for the proof assistant; #. to help the user navigate his own (or third-party) sources. @@ -18,9 +18,9 @@ coqdoc is a documentation tool for the proof assistant |Coq|, similar to Principles ~~~~~~~~~~ -Documentation is inserted into |Coq| files as *special comments*. Thus +Documentation is inserted into Coq files as *special comments*. Thus your files will compile as usual, whether you use coqdoc or not. coqdoc -presupposes that the given |Coq| files are well-formed (at least +presupposes that the given Coq files are well-formed (at least lexically). Documentation starts with ``(**``, followed by a space, and ends with ``*)``. The documentation format is inspired by Todd A. Coram’s *Almost Free Text (AFT)* tool: it is mainly ``ASCII`` text with @@ -29,10 +29,10 @@ shouldn’t fail, whatever the input is. But remember: “garbage in, garbage out”. -|Coq| material inside documentation. +Coq material inside documentation. ++++++++++++++++++++++++++++++++++++ -|Coq| material is quoted between the delimiters ``[`` and ``]``. Square brackets +Coq material is quoted between the delimiters ``[`` and ``]``. Square brackets may be nested, the inner ones being understood as being part of the quoted code (thus you can quote a term like ``fun x => u`` by writing ``[fun x => u]``). Inside quotations, the code is pretty-printed in the same @@ -46,7 +46,7 @@ Pretty-printing. ++++++++++++++++ coqdoc uses different faces for identifiers and keywords. The pretty- -printing of |Coq| tokens (identifiers or symbols) can be controlled +printing of Coq tokens (identifiers or symbols) can be controlled using one of the following commands: :: @@ -63,7 +63,7 @@ or (** printing *token* $...LATEX math...$ #...html...# *) -It gives the |Latex| and HTML texts to be produced for the given |Coq| +It gives the |Latex| and HTML texts to be produced for the given Coq token. Either the |Latex| or the HTML rule may be omitted, causing the default pretty-printing to be used for this token. @@ -91,7 +91,7 @@ commands. The recognition of tokens is done by a (``ocaml``) lex automaton and thus applies the longest-match rule. For instance, `->~` - is recognized as a single token, where |Coq| sees two tokens. It is the + is recognized as a single token, where Coq sees two tokens. It is the responsibility of the user to insert space between tokens *or* to give pretty-printing rules for the possible combinations, e.g. @@ -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 @@ -217,7 +225,7 @@ Then invoke coqdoc or ``coqdoc --glob-from file`` to tell coqdoc to look for name resolutions in the file ``file`` (it will look in ``file.glob`` by default). -Identifiers from the |Coq| standard library are linked to the Coq website +Identifiers from the Coq standard library are linked to the Coq website `<http://coq.inria.fr/library/>`_. This behavior can be changed using command line options ``--no-externals`` and ``--coqlib``; see below. @@ -280,12 +288,12 @@ Usage coqdoc is invoked on a shell command line as follows: ``coqdoc <options and files>``. Any command line argument which is not an option is considered to be a -file (even if it starts with a ``-``). |Coq| files are identified by the +file (even if it starts with a ``-``). Coq files are identified by the suffixes ``.v`` and ``.g`` and |Latex| files by the suffix ``.tex``. :HTML output: This is the default output format. One HTML file is created for - each |Coq| file given on the command line, together with a file + each Coq file given on the command line, together with a file ``index.html`` (unless ``option-no-index is passed``). The HTML pages use a style sheet named ``style.css``. Such a file is distributed with coqdoc. :|Latex| output: A single |Latex| file is created, on standard @@ -295,7 +303,7 @@ suffixes ``.v`` and ``.g`` and |Latex| files by the suffix ``.tex``. document . DVI and PostScript can be produced directly with the options ``-dvi`` and ``-ps`` respectively. :TEXmacs output: To translate the input files to TEXmacs format, - to be used by the TEXmacs |Coq| interface. + to be used by the TEXmacs Coq interface. @@ -357,18 +365,18 @@ Command line options **Hyperlink options** - :--glob-from file: Make references using |Coq| globalizations from file + :--glob-from file: Make references using Coq globalizations from file file. (Such globalizations are obtained with Coq option ``-dump-glob``). - :--no-externals: Do not insert links to the |Coq| standard library. + :--no-externals: Do not insert links to the Coq standard library. :--external url coqdir: Use given URL for linking references whose name starts with prefix ``coqdir``. :--coqlib url: Set base URL for the Coq standard library (default is `<http://coq.inria.fr/library/>`_). This is equivalent to ``--external url Coq``. - :-R dir coqdir: Recursively map physical directory dir to |Coq| logical - directory ``coqdir`` (similarly to |Coq| option ``-R``). - :-Q dir coqdir: Map physical directory dir to |Coq| logical - directory ``coqdir`` (similarly to |Coq| option ``-Q``). + :-R dir coqdir: Recursively map physical directory dir to Coq logical + directory ``coqdir`` (similarly to Coq option ``-R``). + :-Q dir coqdir: Map physical directory dir to Coq logical + directory ``coqdir`` (similarly to Coq option ``-Q``). .. note:: @@ -420,7 +428,7 @@ Command line options :--plain-comments: Do not interpret comments, simply copy them as plain-text. :--interpolate: Use the globalization information to typeset - identifiers appearing in |Coq| escapings inside comments. + identifiers appearing in Coq escapings inside comments. **Language options** diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index 4d2972ef8f..e4f0967794 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -1,3 +1,4 @@ +theories/Init/Numeral.v theories/btauto/Algebra.v theories/btauto/Btauto.v theories/btauto/Reflect.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 7c1328916b..7201dc6a0e 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -22,7 +22,7 @@ through the <tt>Require Import</tt> command.</p> theories/Init/Nat.v theories/Init/Decimal.v theories/Init/Hexadecimal.v - theories/Init/Numeral.v + theories/Init/Number.v theories/Init/Peano.v theories/Init/Specif.v theories/Init/Tactics.v @@ -238,6 +238,7 @@ through the <tt>Require Import</tt> command.</p> theories/Numbers/DecimalN.v theories/Numbers/DecimalZ.v theories/Numbers/DecimalQ.v + theories/Numbers/DecimalR.v theories/Numbers/DecimalString.v theories/Numbers/HexadecimalFacts.v theories/Numbers/HexadecimalNat.v @@ -245,6 +246,7 @@ through the <tt>Require Import</tt> command.</p> theories/Numbers/HexadecimalN.v theories/Numbers/HexadecimalZ.v theories/Numbers/HexadecimalQ.v + theories/Numbers/HexadecimalR.v theories/Numbers/HexadecimalString.v </dd> @@ -704,7 +706,6 @@ through the <tt>Require Import</tt> command.</p> </dt> <dd> theories/Compat/AdmitAxiom.v - theories/Compat/Coq810.v theories/Compat/Coq811.v theories/Compat/Coq812.v theories/Compat/Coq813.v diff --git a/doc/tools/coqrst/notations/TacticNotations.g b/doc/tools/coqrst/notations/TacticNotations.g index f29c69eeaf..70107eba46 100644 --- a/doc/tools/coqrst/notations/TacticNotations.g +++ b/doc/tools/coqrst/notations/TacticNotations.g @@ -43,7 +43,8 @@ LGROUP: '{+' | '{*' | '{?'; LBRACE: '{'; RBRACE: '}'; // todo: need a cleaner way to escape the 3-character strings here -ESCAPED: '%{' | '%}' | '%|' | '`%{' | '@%{'; +ESCAPED: '%{' | '%}' | '%|' | '`%{' | '@%{' | + '%|-' | '%|->' | '%||' | '%|||' | '%||||'; // for SSR PIPE: '|'; ATOM: '@' | '_' | ~[@_{}| ]+; ID: '@' ('_'? [a-zA-Z0-9])+; diff --git a/doc/tools/coqrst/notations/TacticNotationsLexer.py b/doc/tools/coqrst/notations/TacticNotationsLexer.py index 7bda849010..a7ad55ad34 100644 --- a/doc/tools/coqrst/notations/TacticNotationsLexer.py +++ b/doc/tools/coqrst/notations/TacticNotationsLexer.py @@ -8,35 +8,40 @@ import sys def serializedATN(): with StringIO() as buf: buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\2\f") - buf.write("S\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") + buf.write("f\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") buf.write("\4\b\t\b\4\t\t\t\4\n\t\n\4\13\t\13\3\2\3\2\3\2\3\3\3\3") buf.write("\3\3\3\3\3\3\3\3\5\3!\n\3\3\4\3\4\3\5\3\5\3\6\3\6\3\6") - buf.write("\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\5\6\63\n\6\3\7\3") - buf.write("\7\3\b\3\b\6\b9\n\b\r\b\16\b:\5\b=\n\b\3\t\3\t\5\tA\n") - buf.write("\t\3\t\6\tD\n\t\r\t\16\tE\3\n\3\n\3\n\6\nK\n\n\r\n\16") - buf.write("\nL\3\13\6\13P\n\13\r\13\16\13Q\2\2\f\3\3\5\4\7\5\t\6") - buf.write("\13\7\r\b\17\t\21\n\23\13\25\f\3\2\5\4\2BBaa\6\2\"\"B") - buf.write("Baa}\177\5\2\62;C\\c|\2^\2\3\3\2\2\2\2\5\3\2\2\2\2\7\3") - buf.write("\2\2\2\2\t\3\2\2\2\2\13\3\2\2\2\2\r\3\2\2\2\2\17\3\2\2") - buf.write("\2\2\21\3\2\2\2\2\23\3\2\2\2\2\25\3\2\2\2\3\27\3\2\2\2") - buf.write("\5 \3\2\2\2\7\"\3\2\2\2\t$\3\2\2\2\13\62\3\2\2\2\r\64") - buf.write("\3\2\2\2\17<\3\2\2\2\21>\3\2\2\2\23G\3\2\2\2\25O\3\2\2") - buf.write("\2\27\30\7}\2\2\30\31\7~\2\2\31\4\3\2\2\2\32\33\7}\2\2") - buf.write("\33!\7-\2\2\34\35\7}\2\2\35!\7,\2\2\36\37\7}\2\2\37!\7") - buf.write("A\2\2 \32\3\2\2\2 \34\3\2\2\2 \36\3\2\2\2!\6\3\2\2\2\"") - buf.write("#\7}\2\2#\b\3\2\2\2$%\7\177\2\2%\n\3\2\2\2&\'\7\'\2\2") - buf.write("\'\63\7}\2\2()\7\'\2\2)\63\7\177\2\2*+\7\'\2\2+\63\7~") - buf.write("\2\2,-\7b\2\2-.\7\'\2\2.\63\7}\2\2/\60\7B\2\2\60\61\7") - buf.write("\'\2\2\61\63\7}\2\2\62&\3\2\2\2\62(\3\2\2\2\62*\3\2\2") - buf.write("\2\62,\3\2\2\2\62/\3\2\2\2\63\f\3\2\2\2\64\65\7~\2\2\65") - buf.write("\16\3\2\2\2\66=\t\2\2\2\679\n\3\2\28\67\3\2\2\29:\3\2") - buf.write("\2\2:8\3\2\2\2:;\3\2\2\2;=\3\2\2\2<\66\3\2\2\2<8\3\2\2") - buf.write("\2=\20\3\2\2\2>C\7B\2\2?A\7a\2\2@?\3\2\2\2@A\3\2\2\2A") - buf.write("B\3\2\2\2BD\t\4\2\2C@\3\2\2\2DE\3\2\2\2EC\3\2\2\2EF\3") - buf.write("\2\2\2F\22\3\2\2\2GH\7a\2\2HJ\7a\2\2IK\t\4\2\2JI\3\2\2") - buf.write("\2KL\3\2\2\2LJ\3\2\2\2LM\3\2\2\2M\24\3\2\2\2NP\7\"\2\2") - buf.write("ON\3\2\2\2PQ\3\2\2\2QO\3\2\2\2QR\3\2\2\2R\26\3\2\2\2\13") - buf.write("\2 \62:<@ELQ\2") + buf.write("\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3") + buf.write("\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6\3\6") + buf.write("\3\6\5\6F\n\6\3\7\3\7\3\b\3\b\6\bL\n\b\r\b\16\bM\5\bP") + buf.write("\n\b\3\t\3\t\5\tT\n\t\3\t\6\tW\n\t\r\t\16\tX\3\n\3\n\3") + buf.write("\n\6\n^\n\n\r\n\16\n_\3\13\6\13c\n\13\r\13\16\13d\2\2") + buf.write("\f\3\3\5\4\7\5\t\6\13\7\r\b\17\t\21\n\23\13\25\f\3\2\5") + buf.write("\4\2BBaa\6\2\"\"BBaa}\177\5\2\62;C\\c|\2v\2\3\3\2\2\2") + buf.write("\2\5\3\2\2\2\2\7\3\2\2\2\2\t\3\2\2\2\2\13\3\2\2\2\2\r") + buf.write("\3\2\2\2\2\17\3\2\2\2\2\21\3\2\2\2\2\23\3\2\2\2\2\25\3") + buf.write("\2\2\2\3\27\3\2\2\2\5 \3\2\2\2\7\"\3\2\2\2\t$\3\2\2\2") + buf.write("\13E\3\2\2\2\rG\3\2\2\2\17O\3\2\2\2\21Q\3\2\2\2\23Z\3") + buf.write("\2\2\2\25b\3\2\2\2\27\30\7}\2\2\30\31\7~\2\2\31\4\3\2") + buf.write("\2\2\32\33\7}\2\2\33!\7-\2\2\34\35\7}\2\2\35!\7,\2\2\36") + buf.write("\37\7}\2\2\37!\7A\2\2 \32\3\2\2\2 \34\3\2\2\2 \36\3\2") + buf.write("\2\2!\6\3\2\2\2\"#\7}\2\2#\b\3\2\2\2$%\7\177\2\2%\n\3") + buf.write("\2\2\2&\'\7\'\2\2\'F\7}\2\2()\7\'\2\2)F\7\177\2\2*+\7") + buf.write("\'\2\2+F\7~\2\2,-\7b\2\2-.\7\'\2\2.F\7}\2\2/\60\7B\2\2") + buf.write("\60\61\7\'\2\2\61F\7}\2\2\62\63\7\'\2\2\63\64\7~\2\2\64") + buf.write("F\7/\2\2\65\66\7\'\2\2\66\67\7~\2\2\678\7/\2\28F\7@\2") + buf.write("\29:\7\'\2\2:;\7~\2\2;F\7~\2\2<=\7\'\2\2=>\7~\2\2>?\7") + buf.write("~\2\2?F\7~\2\2@A\7\'\2\2AB\7~\2\2BC\7~\2\2CD\7~\2\2DF") + buf.write("\7~\2\2E&\3\2\2\2E(\3\2\2\2E*\3\2\2\2E,\3\2\2\2E/\3\2") + buf.write("\2\2E\62\3\2\2\2E\65\3\2\2\2E9\3\2\2\2E<\3\2\2\2E@\3\2") + buf.write("\2\2F\f\3\2\2\2GH\7~\2\2H\16\3\2\2\2IP\t\2\2\2JL\n\3\2") + buf.write("\2KJ\3\2\2\2LM\3\2\2\2MK\3\2\2\2MN\3\2\2\2NP\3\2\2\2O") + buf.write("I\3\2\2\2OK\3\2\2\2P\20\3\2\2\2QV\7B\2\2RT\7a\2\2SR\3") + buf.write("\2\2\2ST\3\2\2\2TU\3\2\2\2UW\t\4\2\2VS\3\2\2\2WX\3\2\2") + buf.write("\2XV\3\2\2\2XY\3\2\2\2Y\22\3\2\2\2Z[\7a\2\2[]\7a\2\2\\") + buf.write("^\t\4\2\2]\\\3\2\2\2^_\3\2\2\2_]\3\2\2\2_`\3\2\2\2`\24") + buf.write("\3\2\2\2ac\7\"\2\2ba\3\2\2\2cd\3\2\2\2db\3\2\2\2de\3\2") + buf.write("\2\2e\26\3\2\2\2\13\2 EMOSX_d\2") return buf.getvalue() diff --git a/doc/tools/docgram/README.md b/doc/tools/docgram/README.md index 4d38955fa8..6c507e1d57 100644 --- a/doc/tools/docgram/README.md +++ b/doc/tools/docgram/README.md @@ -42,7 +42,7 @@ for documentation purposes: First, nonterminals that use levels (`"5" RIGHTA` below) are modified, for example: ``` - tactic_expr: + ltac_expr: [ "5" RIGHTA [ te = binder_tactic -> { te } ] [ "4" ... @@ -179,6 +179,8 @@ grammar with its productions and removing the non-terminal. Each should appear as a separate production. (Doesn't work recursively; splicing for both `A: [ | B ]` and `B: [ | C ]` must be done in separate SPLICE operations.) +`OPTINREF` - applies the local `OPTINREF` edit to every nonterminal + `EXPAND` - expands LIST0, LIST1, LIST* ... SEP and OPT constructs into new non-terminals diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 1e9be8dded..4c1956d172 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -19,7 +19,8 @@ lglob: [ ] hint: [ -| "Extern" natural OPT constr_pattern "=>" tactic +| REPLACE "Extern" natural OPT Constr.constr_pattern "=>" Pltac.tactic +| WITH "Extern" natural OPT constr_pattern "=>" tactic ] (* todo: does ARGUMENT EXTEND make the symbol global? It is in both extraargs and extratactics *) @@ -28,19 +29,12 @@ strategy_level_or_var: [ | strategy_level ] -operconstr0: [ -| "ltac" ":" "(" tactic_expr5 ")" -] - EXTRAARGS_natural: [ | DELETENT ] EXTRAARGS_lconstr: [ | DELETENT ] EXTRAARGS_strategy_level: [ | DELETENT ] -G_LTAC_hint: [ | DELETENT ] -G_LTAC_operconstr0: [ | DELETENT ] -G_REWRITE_binders: [ +binders: [ | DELETE Pcoq.Constr.binders -| binders ] G_TACTIC_in_clause: [ @@ -50,7 +44,6 @@ G_TACTIC_in_clause: [ ] SPLICE: [ -| G_REWRITE_binders | G_TACTIC_in_clause ] @@ -86,38 +79,44 @@ RENAME: [ | G_LTAC2_eqn_ipat ltac2_eqn_ipat | G_LTAC2_conversion ltac2_conversion | G_LTAC2_oriented_rewriter ltac2_oriented_rewriter -| G_LTAC2_tactic_then_gen ltac2_tactic_then_gen +| G_LTAC2_for_each_goal ltac2_for_each_goal | G_LTAC2_tactic_then_last ltac2_tactic_then_last | G_LTAC2_as_name ltac2_as_name | G_LTAC2_as_ipat ltac2_as_ipat | G_LTAC2_by_tactic ltac2_by_tactic | G_LTAC2_match_list ltac2_match_list +| G_SSRMATCHING_cpattern ssr_one_term_pattern ] -(* renames to eliminate qualified names - put other renames at the end *) +(* Renames to eliminate qualified names. + Put other renames at the end *) RENAME: [ (* map missing names for rhs *) | Constr.constr term | Constr.global global | Constr.lconstr lconstr -| Constr.lconstr_pattern cpattern +| Constr.cpattern cpattern | G_vernac.query_command query_command -| G_vernac.section_subset_expr section_subset_expr +| G_vernac.section_subset_expr section_var_expr | Prim.ident ident | Prim.reference reference +| Prim.string string +| Prim.integer integer +| Prim.qualid qualid +| Prim.natural natural | Pvernac.Vernac_.main_entry vernac_control | Tactic.tactic tactic +| Pltac.ltac_expr ltac_expr5 (* SSR *) +| Pcoq.Constr.constr term +| Prim.identref ident (* | G_vernac.def_body def_body -| Pcoq.Constr.constr term | Prim.by_notation by_notation -| Prim.identref ident | Prim.natural natural *) -| Vernac.rec_definition rec_definition +| Vernac.fix_definition fix_definition (* todo: hmm, rename adds 1 prodn to closed_binder?? *) | Constr.closed_binder closed_binder ] @@ -152,11 +151,16 @@ DELETE: [ | test_array_closing (* SSR *) -(* | ssr_null_entry *) -(* +| ssr_null_entry | ssrtermkind (* todo: rename as "test..." *) -| term_annotation (* todo: rename as "test..." *) +| ssrdoarg (* todo: this and the next one should be removed from the grammar? *) +| ssrseqdir +| ssrindex +| ssrintrosarg +| ssrtclarg +| term_annotation (* todo: what is this? *) | test_idcomma +| test_ident_no_do | test_nohidden | test_not_ssrslashnum | test_ssr_rw_syntax @@ -167,10 +171,6 @@ DELETE: [ | test_ssrslashnum01 | test_ssrslashnum10 | test_ssrslashnum11 -| test_ident_no_do -| ssrdoarg (* todo: this and the next one should be removed from the grammar? *) -| ssrseqdir -*) (* unused *) | constr_comma_sequence' @@ -178,52 +178,38 @@ DELETE: [ | constr_may_eval ] -(* ssrintrosarg: [ | DELETENT ] *) - (* additional nts to be spliced *) -hyp: [ -| var -] - tactic_then_last: [ -| REPLACE "|" LIST0 ( OPT tactic_expr5 ) SEP "|" -| WITH LIST0 ( "|" ( OPT tactic_expr5 ) ) +| REPLACE "|" LIST0 ( OPT ltac_expr5 ) SEP "|" +| WITH LIST0 ( "|" ( OPT ltac_expr5 ) ) ] goal_tactics: [ -| LIST0 ( OPT tactic_expr5 ) SEP "|" +| LIST0 ( OPT ltac_expr5 ) SEP "|" ] -tactic_then_gen: [ | DELETENT ] +for_each_goal: [ | DELETENT ] -tactic_then_gen: [ +for_each_goal: [ | goal_tactics -| OPT ( goal_tactics "|" ) OPT tactic_expr5 ".." OPT ( "|" goal_tactics ) -] - -tactic_then_last: [ -| OPTINREF +| OPT ( goal_tactics "|" ) OPT ltac_expr5 ".." OPT ( "|" goal_tactics ) ] ltac2_tactic_then_last: [ -| REPLACE "|" LIST0 ( OPT tac2expr6 ) SEP "|" (* Ltac2 plugin *) -| WITH LIST0 ( "|" OPT tac2expr6 ) TAG Ltac2 +| REPLACE "|" LIST0 ( OPT ltac2_expr6 ) SEP "|" (* Ltac2 plugin *) +| WITH LIST0 ( "|" OPT ltac2_expr6 ) TAG Ltac2 ] ltac2_goal_tactics: [ -| LIST0 ( OPT tac2expr6 ) SEP "|" TAG Ltac2 +| LIST0 ( OPT ltac2_expr6 ) SEP "|" TAG Ltac2 ] -ltac2_tactic_then_gen: [ | DELETENT ] +ltac2_for_each_goal: [ | DELETENT ] -ltac2_tactic_then_gen: [ +ltac2_for_each_goal: [ | ltac2_goal_tactics TAG Ltac2 -| OPT ( ltac2_goal_tactics "|" ) OPT tac2expr6 ".." OPT ( "|" ltac2_goal_tactics ) TAG Ltac2 -] - -ltac2_tactic_then_last: [ -| OPTINREF +| OPT ( ltac2_goal_tactics "|" ) OPT ltac2_expr6 ".." OPT ( "|" ltac2_goal_tactics ) TAG Ltac2 ] reference: [ | DELETENT ] @@ -261,60 +247,70 @@ let_type_cstr: [ | type_cstr ] -(* rename here because we want to use "return_type" for something else *) -RENAME: [ -| return_type as_return_type -] - case_item: [ -| REPLACE operconstr100 OPT [ "as" name ] OPT [ "in" pattern200 ] -| WITH operconstr100 OPT ("as" name) OPT [ "in" pattern200 ] +| REPLACE term100 OPT [ "as" name ] OPT [ "in" pattern200 ] +| WITH term100 OPT ("as" name) OPT [ "in" pattern200 ] ] binder_constr: [ -| MOVETO term_forall_or_fun "forall" open_binders "," operconstr200 -| MOVETO term_forall_or_fun "fun" open_binders "=>" operconstr200 -| MOVETO term_let "let" name binders let_type_cstr ":=" operconstr200 "in" operconstr200 -| MOVETO term_if "if" operconstr200 as_return_type "then" operconstr200 "else" operconstr200 -| MOVETO term_fix "let" "fix" fix_decl "in" operconstr200 -| MOVETO term_cofix "let" "cofix" cofix_decl "in" operconstr200 -| MOVETO term_let "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" operconstr200 "in" operconstr200 -| MOVETO term_let "let" "'" pattern200 ":=" operconstr200 "in" operconstr200 -| MOVETO term_let "let" "'" pattern200 ":=" operconstr200 case_type "in" operconstr200 -| MOVETO term_let "let" "'" pattern200 "in" pattern200 ":=" operconstr200 case_type "in" operconstr200 +| MOVETO term_forall_or_fun "forall" open_binders "," term200 +| MOVETO term_forall_or_fun "fun" open_binders "=>" term200 +| MOVETO term_let "let" name binders let_type_cstr ":=" term200 "in" term200 +(*| MOVETO term_let "let" ":" ssr_mpat ":=" lconstr "in" lconstr TAG SSR *) +| DELETE "let" ":" ssr_mpat ":=" lconstr "in" lconstr TAG SSR (* todo: restore for ssr *) +| REPLACE "let" ":" ssr_mpat "in" pattern200 ":=" lconstr ssr_rtype "in" lconstr (* ssr plugin *) +| WITH "let" ":" ssr_mpat OPT ( "in" pattern200 ) ":=" lconstr ssr_rtype "in" lconstr TAG SSR +| DELETE "let" ":" ssr_mpat ":=" lconstr ssr_rtype "in" lconstr (* SSR plugin *) +| DELETE "let" ":" ssr_mpat OPT ( "in" pattern200 ) ":=" lconstr ssr_rtype "in" lconstr TAG SSR (* todo: restore for SSR *) +(*| MOVETO term_let "let" ":" ssr_mpat OPT ( "in" pattern200 ) ":=" lconstr ssr_rtype "in" lconstr TAG SSR*) +| MOVETO term_if "if" term200 as_return_type "then" term200 "else" term200 +| REPLACE "if" term200 "is" ssr_dthen ssr_else +| WITH "if" term200 [ "is" | "isn't" ] ssr_dthen ssr_else TAG SSR +| DELETE "if" term200 "isn't" ssr_dthen ssr_else +| DELETE "if" term200 [ "is" | "isn't" ] ssr_dthen ssr_else TAG SSR (* todo: restore for SSR *) +| MOVETO term_fix "let" "fix" fix_decl "in" term200 +| MOVETO term_cofix "let" "cofix" cofix_body "in" term200 +| MOVETO term_let "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" term200 "in" term200 +| MOVETO term_let "let" "'" pattern200 ":=" term200 "in" term200 +| MOVETO term_let "let" "'" pattern200 ":=" term200 case_type "in" term200 +| MOVETO term_let "let" "'" pattern200 "in" pattern200 ":=" term200 case_type "in" term200 | MOVETO term_fix "fix" fix_decls | MOVETO term_cofix "cofix" cofix_decls ] term_let: [ -| REPLACE "let" name binders let_type_cstr ":=" operconstr200 "in" operconstr200 -| WITH "let" name let_type_cstr ":=" operconstr200 "in" operconstr200 -| "let" name LIST1 binder let_type_cstr ":=" operconstr200 "in" operconstr200 +| REPLACE "let" name binders let_type_cstr ":=" term200 "in" term200 +| WITH "let" name let_type_cstr ":=" term200 "in" term200 +| "let" name LIST1 binder let_type_cstr ":=" term200 "in" term200 (* Don't need to document that "( )" is equivalent to "()" *) -| REPLACE "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" operconstr200 "in" operconstr200 -| WITH "let" "(" LIST0 name SEP "," ")" as_return_type ":=" operconstr200 "in" operconstr200 -| REPLACE "let" "'" pattern200 ":=" operconstr200 "in" operconstr200 -| WITH "let" "'" pattern200 ":=" operconstr200 OPT case_type "in" operconstr200 -| DELETE "let" "'" pattern200 ":=" operconstr200 case_type "in" operconstr200 +| 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 +| 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: [ -| MOVETO qualid_annotated global univ_instance +| MOVETO qualid_annotated global univ_annot | MOVETO primitive_notations NUMBER | MOVETO primitive_notations string | MOVETO term_evar "_" -| REPLACE "?" "[" ident "]" -| WITH "?[" ident "]" -| MOVETO term_evar "?[" ident "]" +| REPLACE "?" "[" identref "]" +| WITH "?[" identref "]" +| MOVETO term_evar "?[" identref "]" | REPLACE "?" "[" pattern_ident "]" | WITH "?[" pattern_ident "]" | MOVETO term_evar "?[" pattern_ident "]" | MOVETO term_evar pattern_ident evar_instance ] -tactic_expr0: [ -| REPLACE "[" ">" tactic_then_gen "]" -| WITH "[>" tactic_then_gen "]" +ltac_expr0: [ +| REPLACE "[" ">" for_each_goal "]" +| WITH "[>" for_each_goal "]" +| DELETE ssrparentacarg ] (* lexer token *) @@ -341,68 +337,68 @@ scope_delimiter: [ ] type: [ -| operconstr200 +| term200 ] -operconstr100: [ -| REPLACE operconstr99 "<:" operconstr200 -| WITH operconstr99 "<:" type -| MOVETO term_cast operconstr99 "<:" type -| REPLACE operconstr99 "<<:" operconstr200 -| WITH operconstr99 "<<:" type -| MOVETO term_cast operconstr99 "<<:" type -| REPLACE operconstr99 ":" operconstr200 -| WITH operconstr99 ":" type -| MOVETO term_cast operconstr99 ":" type -| MOVETO term_cast operconstr99 ":>" +term100: [ +| REPLACE term99 "<:" term200 +| WITH term99 "<:" type +| MOVETO term_cast term99 "<:" type +| REPLACE term99 "<<:" term200 +| WITH term99 "<<:" type +| MOVETO term_cast term99 "<<:" type +| REPLACE term99 ":" term200 +| WITH term99 ":" type +| MOVETO term_cast term99 ":" type +| MOVETO term_cast term99 ":>" ] constr: [ -| REPLACE "@" global univ_instance +| REPLACE "@" global univ_annot | WITH "@" qualid_annotated | MOVETO term_explicit "@" qualid_annotated ] -operconstr10: [ +term10: [ (* Separate this LIST0 in the nonempty and the empty case *) (* The empty case is covered by constr *) -| REPLACE "@" global univ_instance LIST0 operconstr9 -| WITH "@" qualid_annotated LIST1 operconstr9 -| REPLACE operconstr9 +| REPLACE "@" global univ_annot LIST0 term9 +| WITH "@" qualid_annotated LIST1 term9 +| REPLACE term9 | WITH constr -| MOVETO term_application operconstr9 LIST1 appl_arg -| MOVETO term_application "@" qualid_annotated LIST1 operconstr9 +| MOVETO term_application term9 LIST1 arg +| MOVETO term_application "@" qualid_annotated LIST1 term9 (* fixme: add in as a prodn somewhere *) -| MOVETO dangling_pattern_extension_rule "@" pattern_identref LIST1 identref +| MOVETO dangling_pattern_extension_rule "@" pattern_ident LIST1 identref | DELETE dangling_pattern_extension_rule ] -operconstr9: [ +term9: [ (* @Zimmi48: Special token .. is for use in the Notation command. (see bug_3304.v) *) -| DELETE ".." operconstr0 ".." +| DELETE ".." term0 ".." ] -operconstr1: [ -| REPLACE operconstr0 ".(" global LIST0 appl_arg ")" -| WITH operconstr0 ".(" global LIST0 appl_arg ")" (* huh? *) -| REPLACE operconstr0 "%" IDENT -| WITH operconstr0 "%" scope_key -| MOVETO term_scope operconstr0 "%" scope_key -| MOVETO term_projection operconstr0 ".(" global LIST0 appl_arg ")" -| MOVETO term_projection operconstr0 ".(" "@" global LIST0 ( operconstr9 ) ")" +term1: [ +| REPLACE term0 ".(" global LIST0 arg ")" +| WITH term0 ".(" global LIST0 arg ")" (* huh? *) +| REPLACE term0 "%" IDENT +| WITH term0 "%" scope_key +| MOVETO term_scope term0 "%" scope_key +| MOVETO term_projection term0 ".(" global LIST0 arg ")" +| MOVETO term_projection term0 ".(" "@" global LIST0 ( term9 ) ")" ] -operconstr0: [ +term0: [ (* @Zimmi48: This rule is a hack, according to Hugo, and should not be shown in the manual. *) | DELETE "{" binder_constr "}" | REPLACE "{|" record_declaration bar_cbrace | WITH "{|" LIST0 field_def SEP ";" OPT ";" bar_cbrace | MOVETO term_record "{|" LIST0 field_def SEP ";" OPT ";" bar_cbrace -| MOVETO term_generalizing "`{" operconstr200 "}" -| MOVETO term_generalizing "`(" operconstr200 ")" -| MOVETO term_ltac "ltac" ":" "(" tactic_expr5 ")" -| REPLACE "[" "|" array_elems "|" lconstr type_cstr "|" "]" univ_instance -| WITH "[|" array_elems "|" lconstr type_cstr "|]" univ_instance +| MOVETO term_generalizing "`{" term200 "}" +| MOVETO term_generalizing "`(" term200 ")" +| MOVETO term_ltac "ltac" ":" "(" ltac_expr5 ")" +| REPLACE "[" "|" array_elems "|" lconstr type_cstr "|" "]" univ_annot +| WITH "[|" array_elems "|" lconstr type_cstr "|]" univ_annot ] fix_decls: [ @@ -412,9 +408,9 @@ fix_decls: [ ] cofix_decls: [ -| DELETE cofix_decl -| REPLACE cofix_decl "with" LIST1 cofix_decl SEP "with" "for" identref -| WITH cofix_decl OPT ( LIST1 ( "with" cofix_decl ) "for" identref ) +| DELETE cofix_body +| REPLACE cofix_body "with" LIST1 cofix_body SEP "with" "for" identref +| WITH cofix_body OPT ( LIST1 ( "with" cofix_body ) "for" identref ) ] fields_def: [ @@ -478,6 +474,7 @@ closed_binder: [ | MOVETO generalizing_binder "`(" LIST1 typeclass_constraint SEP "," ")" | MOVETO generalizing_binder "`{" LIST1 typeclass_constraint SEP "," "}" | MOVETO generalizing_binder "`[" LIST1 typeclass_constraint SEP "," "]" +| DELETE [ "of" | "&" ] term99 (* todo: remove for SSR *) ] name_colon: [ @@ -485,11 +482,11 @@ name_colon: [ ] typeclass_constraint: [ -| EDIT ADD_OPT "!" operconstr200 -| REPLACE "{" name "}" ":" [ "!" | ] operconstr200 -| WITH "{" name "}" ":" OPT "!" operconstr200 -| REPLACE name ":" [ "!" | ] operconstr200 -| WITH name ":" OPT "!" operconstr200 +| EDIT ADD_OPT "!" term200 +| REPLACE "{" name "}" ":" [ "!" | ] term200 +| WITH "{" name "}" ":" OPT "!" term200 +| REPLACE name ":" [ "!" | ] term200 +| WITH name ":" OPT "!" term200 ] (* ?? From the grammar, Prim.name seems to be only "_" but ident is also accepted "*) @@ -535,17 +532,15 @@ eqn: [ | WITH LIST1 [ LIST1 pattern100 SEP "," ] SEP "|" "=>" lconstr ] -universe_increment: [ -| OPTINREF -] - -evar_instance: [ -| OPTINREF -] - (* No constructor syntax, OPT [ "|" binders ] is not supported for Record *) record_definition: [ -| opt_coercion ident_decl binders OPT [ ":" type ] OPT [ identref ] "{" record_fields "}" decl_notations +| opt_coercion ident_decl binders OPT [ ":" sort ] OPT ( ":=" OPT [ identref ] "{" record_fields "}" ) +] + +(* No mutual recursion, no inductive classes, type must be a sort *) +(* constructor is optional but "Class record_definition" covers that case *) +singleton_class_definition: [ +| opt_coercion ident_decl binders OPT [ ":" sort ] ":=" constructor ] (* No record syntax, opt_coercion not supported for Variant, := ... required *) @@ -562,15 +557,16 @@ gallina: [ | "CoInductive" inductive_definition LIST0 ( "with" inductive_definition ) | "Variant" variant_definition LIST0 ( "with" variant_definition ) | [ "Record" | "Structure" ] record_definition LIST0 ( "with" record_definition ) -| "Class" inductive_definition LIST0 ( "with" inductive_definition ) -| REPLACE "Fixpoint" LIST1 rec_definition SEP "with" -| WITH "Fixpoint" rec_definition LIST0 ( "with" rec_definition ) -| REPLACE "Let" "Fixpoint" LIST1 rec_definition SEP "with" -| WITH "Let" "Fixpoint" rec_definition LIST0 ( "with" rec_definition ) -| REPLACE "CoFixpoint" LIST1 corec_definition SEP "with" -| WITH "CoFixpoint" corec_definition LIST0 ( "with" corec_definition ) -| REPLACE "Let" "CoFixpoint" LIST1 corec_definition SEP "with" -| WITH "Let" "CoFixpoint" corec_definition LIST0 ( "with" corec_definition ) +| "Class" record_definition +| "Class" singleton_class_definition +| REPLACE "Fixpoint" LIST1 fix_definition SEP "with" +| WITH "Fixpoint" fix_definition LIST0 ( "with" fix_definition ) +| REPLACE "Let" "Fixpoint" LIST1 fix_definition SEP "with" +| WITH "Let" "Fixpoint" fix_definition LIST0 ( "with" fix_definition ) +| REPLACE "CoFixpoint" LIST1 cofix_definition SEP "with" +| WITH "CoFixpoint" cofix_definition LIST0 ( "with" cofix_definition ) +| REPLACE "Let" "CoFixpoint" LIST1 cofix_definition SEP "with" +| WITH "Let" "CoFixpoint" cofix_definition LIST0 ( "with" cofix_definition ) | REPLACE "Scheme" LIST1 scheme SEP "with" | WITH "Scheme" scheme LIST0 ( "with" scheme ) ] @@ -579,10 +575,6 @@ finite_token: [ | DELETENT ] -constructor_list_or_record_decl: [ -| OPTINREF -] - record_fields: [ | REPLACE record_field ";" record_fields | WITH LIST0 record_field SEP ";" OPT ";" @@ -598,11 +590,6 @@ inline: [ | REPLACE "Inline" "(" natural ")" | WITH "Inline" OPT ( "(" natural ")" ) | DELETE "Inline" -| OPTINREF -] - -univ_instance: [ -| OPTINREF ] univ_decl: [ @@ -610,18 +597,14 @@ univ_decl: [ | WITH "@{" LIST0 identref OPT "+" OPT [ "|" LIST0 univ_constraint SEP "," OPT "+" ] "}" ] -of_type_with_opt_coercion: [ +of_type: [ | DELETENT ] -of_type_with_opt_coercion: [ +of_type: [ | [ ":" | ":>" ] type ] -attribute_value: [ -| OPTINREF -] - def_body: [ | DELETE binders ":=" reduce lconstr | REPLACE binders ":" lconstr ":=" reduce lconstr @@ -630,14 +613,6 @@ def_body: [ | WITH LIST0 binder ":" type ] -reduce: [ -| OPTINREF -] - -occs: [ -| OPTINREF -] - delta_flag: [ | REPLACE "-" "[" LIST1 smart_global "]" | WITH OPT "-" "[" LIST1 smart_global "]" @@ -651,15 +626,6 @@ ltac2_delta_flag: [ ltac2_branches: [ | EDIT ADD_OPT "|" LIST1 branch SEP "|" (* Ltac2 plugin *) -| OPTINREF -] - -RENAME: [ -| red_flag ltac2_red_flag -| red_flags red_flag -] - -RENAME: [ ] strategy_flag: [ @@ -668,7 +634,6 @@ strategy_flag: [ (*| REPLACE LIST1 red_flags | WITH LIST1 red_flag*) | (* empty *) -| OPTINREF ] filtered_import: [ @@ -677,25 +642,19 @@ filtered_import: [ | DELETE global ] -functor_app_annot: [ -| OPTINREF -] - is_module_expr: [ | REPLACE ":=" module_expr_inl LIST0 ext_module_expr | WITH ":=" LIST1 module_expr_inl SEP "<+" -| OPTINREF ] is_module_type: [ | REPLACE ":=" module_type_inl LIST0 ext_module_type | WITH ":=" LIST1 module_type_inl SEP "<+" -| OPTINREF ] gallina_ext: [ -| REPLACE "Arguments" smart_global LIST0 argument_spec_block OPT [ "," LIST1 [ LIST0 more_implicits_block ] SEP "," ] OPT [ ":" LIST1 arguments_modifier SEP "," ] -| WITH "Arguments" smart_global LIST0 argument_spec_block LIST0 [ "," LIST0 more_implicits_block ] OPT [ ":" LIST1 arguments_modifier SEP "," ] +| REPLACE "Arguments" smart_global LIST0 arg_specs OPT [ "," LIST1 [ LIST0 implicits_alt ] SEP "," ] OPT [ ":" LIST1 args_modifier SEP "," ] +| WITH "Arguments" smart_global LIST0 arg_specs LIST0 [ "," LIST0 implicits_alt ] OPT [ ":" LIST1 args_modifier SEP "," ] | REPLACE "Implicit" "Type" reserv_list | WITH "Implicit" [ "Type" | "Types" ] reserv_list | DELETE "Implicit" "Types" reserv_list @@ -713,6 +672,10 @@ gallina_ext: [ | REPLACE "Coercion" by_notation ":" class_rawexpr ">->" class_rawexpr | WITH "Coercion" smart_global ":" class_rawexpr ">->" class_rawexpr +(* semantically restricted per https://github.com/coq/coq/pull/12936#discussion_r492705820 *) +| REPLACE "Coercion" global OPT univ_decl def_body +| WITH "Coercion" ident OPT univ_decl def_body + | REPLACE "Include" "Type" module_type_inl LIST0 ext_module_type | WITH "Include" "Type" LIST1 module_type_inl SEP "<+" @@ -720,21 +683,17 @@ gallina_ext: [ | WITH "Generalizable" [ [ "Variable" | "Variables" ] LIST1 identref | "All" "Variables" | "No" "Variables" ] (* don't show Export for Set, Unset *) -| REPLACE "Export" "Set" option_table option_setting -| WITH "Set" option_table option_setting -| REPLACE "Export" "Unset" option_table -| WITH "Unset" option_table -| REPLACE "Instance" instance_name ":" operconstr200 hint_info [ ":=" "{" record_declaration "}" | ":=" lconstr | ] -| WITH "Instance" instance_name ":" operconstr200 hint_info OPT [ ":=" "{" record_declaration "}" | ":=" lconstr ] +| REPLACE "Export" "Set" setting_name option_setting +| WITH "Set" setting_name option_setting +| REPLACE "Export" "Unset" setting_name +| WITH "Unset" setting_name +| REPLACE "Instance" instance_name ":" term200 hint_info [ ":=" "{" record_declaration "}" | ":=" lconstr | ] +| WITH "Instance" instance_name ":" type hint_info OPT [ ":=" "{" record_declaration "}" | ":=" lconstr ] | REPLACE "From" global "Require" export_token LIST1 global | WITH "From" dirpath "Require" export_token LIST1 global ] -export_token: [ -| OPTINREF -] - (* lexer stuff *) LEFTQMARK: [ | "?" @@ -787,6 +746,7 @@ subsequent_letter: [ ident: [ | DELETE IDENT +| DELETE IDENT (* 2nd copy from SSR *) | first_letter LIST0 subsequent_letter ] @@ -815,92 +775,97 @@ DELETE: [ | tactic_then_locality ] -tactic_expr5: [ -(* make these look consistent with use of binder_tactic in other tactic_expr* *) +ltac_expr5: [ +(* make these look consistent with use of binder_tactic in other ltac_expr* *) | DELETE binder_tactic -| DELETE tactic_expr4 -| [ tactic_expr4 | binder_tactic ] +| DELETE ltac_expr4 +| [ ltac_expr4 | binder_tactic ] ] ltac_constructs: [ (* repeated in main ltac grammar - need to create a COPY edit *) -| tactic_expr3 ";" [ tactic_expr3 | binder_tactic ] -| tactic_expr3 ";" "[" tactic_then_gen "]" +| ltac_expr3 ";" [ ltac_expr3 | binder_tactic ] +| ltac_expr3 ";" "[" for_each_goal "]" -| tactic_expr1 "+" [ tactic_expr2 | binder_tactic ] -| tactic_expr1 "||" [ tactic_expr2 | binder_tactic ] +| ltac_expr1 "+" [ ltac_expr2 | binder_tactic ] +| ltac_expr1 "||" [ ltac_expr2 | binder_tactic ] -(* | qualid LIST0 tactic_arg add later due renaming tactic_arg *) +(* | qualid LIST0 tactic_value add later due renaming tactic_value *) -| "[>" tactic_then_gen "]" -| toplevel_selector tactic_expr5 +| "[>" for_each_goal "]" +| toplevel_selector ltac_expr5 ] -tactic_expr4: [ -| REPLACE tactic_expr3 ";" tactic_then_gen "]" -| WITH tactic_expr3 ";" "[" tactic_then_gen "]" -| REPLACE tactic_expr3 ";" binder_tactic -| WITH tactic_expr3 ";" [ tactic_expr3 | binder_tactic ] -| DELETE tactic_expr3 ";" tactic_expr3 +ltac_expr4: [ +| REPLACE ltac_expr3 ";" for_each_goal "]" +| WITH ltac_expr3 ";" "[" for_each_goal "]" +| REPLACE ltac_expr3 ";" binder_tactic +| WITH ltac_expr3 ";" [ ltac_expr3 | binder_tactic ] +| DELETE ltac_expr3 ";" ltac_expr3 +| MOVETO simple_tactic ltac_expr5 ";" "first" ssr_first_else TAG SSR +| MOVETO simple_tactic ltac_expr5 ";" "first" ssrseqarg TAG SSR +| MOVETO simple_tactic ltac_expr5 ";" "last" ssrseqarg TAG SSR +| DELETE simple_tactic ] l3_tactic: [ ] -tactic_expr3: [ -| DELETE "abstract" tactic_expr2 -| REPLACE "abstract" tactic_expr2 "using" ident -| WITH "abstract" tactic_expr2 OPT ( "using" ident ) +ltac_expr3: [ +| DELETE "abstract" ltac_expr2 +| REPLACE "abstract" ltac_expr2 "using" ident +| WITH "abstract" ltac_expr2 OPT ( "using" ident ) | l3_tactic +| EDIT "do" ADD_OPT int_or_var ssrmmod ssrdotac ssrclauses TAG SSR | MOVEALLBUT ltac_builtins | l3_tactic -| tactic_expr2 +| ltac_expr2 ] l2_tactic: [ ] -tactic_expr2: [ -| REPLACE tactic_expr1 "+" binder_tactic -| WITH tactic_expr1 "+" [ tactic_expr2 | binder_tactic ] -| DELETE tactic_expr1 "+" tactic_expr2 -| REPLACE tactic_expr1 "||" binder_tactic -| WITH tactic_expr1 "||" [ tactic_expr2 | binder_tactic ] -| DELETE tactic_expr1 "||" tactic_expr2 -| MOVETO ltac_builtins "tryif" tactic_expr5 "then" tactic_expr5 "else" tactic_expr2 +ltac_expr2: [ +| REPLACE ltac_expr1 "+" binder_tactic +| WITH ltac_expr1 "+" [ ltac_expr2 | binder_tactic ] +| DELETE ltac_expr1 "+" ltac_expr2 +| REPLACE ltac_expr1 "||" binder_tactic +| WITH ltac_expr1 "||" [ ltac_expr2 | binder_tactic ] +| DELETE ltac_expr1 "||" ltac_expr2 +| MOVETO ltac_builtins "tryif" ltac_expr5 "then" ltac_expr5 "else" ltac_expr2 | l2_tactic | DELETE ltac_builtins ] l1_tactic: [ ] -tactic_expr1: [ +ltac_expr1: [ | EDIT match_key ADD_OPT "reverse" "goal" "with" match_context_list "end" | MOVETO simple_tactic match_key OPT "reverse" "goal" "with" match_context_list "end" -| MOVETO simple_tactic match_key tactic_expr5 "with" match_list "end" +| MOVETO simple_tactic match_key ltac_expr5 "with" match_list "end" | REPLACE failkw [ int_or_var | ] LIST0 message_token | WITH failkw OPT int_or_var LIST0 message_token -| REPLACE reference LIST0 tactic_arg_compat -| WITH reference LIST1 tactic_arg_compat +| REPLACE reference LIST0 tactic_arg +| WITH reference LIST1 tactic_arg | l1_tactic | DELETE simple_tactic | MOVEALLBUT ltac_builtins | l1_tactic -| tactic_arg -| reference LIST1 tactic_arg_compat -| tactic_expr0 +| tactic_value +| reference LIST1 tactic_arg +| ltac_expr0 ] (* split match_context_rule *) goal_pattern: [ -| LIST0 match_hyps SEP "," "|-" match_pattern -| "[" LIST0 match_hyps SEP "," "|-" match_pattern "]" +| LIST0 match_hyp SEP "," "|-" match_pattern +| "[" LIST0 match_hyp SEP "," "|-" match_pattern "]" | "_" ] match_context_rule: [ -| DELETE LIST0 match_hyps SEP "," "|-" match_pattern "=>" tactic_expr5 -| DELETE "[" LIST0 match_hyps SEP "," "|-" match_pattern "]" "=>" tactic_expr5 -| DELETE "_" "=>" tactic_expr5 -| goal_pattern "=>" tactic_expr5 +| DELETE LIST0 match_hyp SEP "," "|-" match_pattern "=>" ltac_expr5 +| DELETE "[" LIST0 match_hyp SEP "," "|-" match_pattern "]" "=>" ltac_expr5 +| DELETE "_" "=>" ltac_expr5 +| goal_pattern "=>" ltac_expr5 ] match_context_list: [ @@ -913,10 +878,10 @@ match_list: [ match_rule: [ (* redundant; match_pattern -> term -> _ *) -| DELETE "_" "=>" tactic_expr5 +| DELETE "_" "=>" ltac_expr5 ] -selector_body: [ +selector: [ | REPLACE range_selector_or_nth (* depends on whether range_selector_or_nth is deleted first *) | WITH LIST1 range_selector SEP "," ] @@ -1083,8 +1048,8 @@ simple_tactic: [ | EDIT "psatz_R" ADD_OPT int_or_var tactic | EDIT "psatz_Q" ADD_OPT int_or_var tactic | EDIT "psatz_Z" ADD_OPT int_or_var tactic -| REPLACE "subst" LIST1 var -| WITH "subst" OPT ( LIST1 var ) +| REPLACE "subst" LIST1 hyp +| WITH "subst" LIST0 hyp | DELETE "subst" | DELETE "congruence" | DELETE "congruence" natural @@ -1095,10 +1060,55 @@ simple_tactic: [ | REPLACE "show" "ltac" "profile" "cutoff" integer | WITH "show" "ltac" "profile" OPT [ "cutoff" integer | string ] | DELETE "show" "ltac" "profile" string -(* perversely, the mlg uses "tactic3" instead of "tactic_expr3" *) +(* perversely, the mlg uses "tactic3" instead of "ltac_expr3" *) | DELETE "transparent_abstract" tactic3 | REPLACE "transparent_abstract" tactic3 "using" ident -| WITH "transparent_abstract" tactic_expr3 OPT ( "using" ident ) +| WITH "transparent_abstract" ltac_expr3 OPT ( "using" ident ) +| "typeclasses" "eauto" OPT "bfs" OPT int_or_var OPT ( "with" LIST1 preident ) +| DELETE "typeclasses" "eauto" "bfs" OPT int_or_var "with" LIST1 preident +| DELETE "typeclasses" "eauto" OPT int_or_var "with" LIST1 preident +| DELETE "typeclasses" "eauto" "bfs" OPT int_or_var +| DELETE "typeclasses" "eauto" OPT int_or_var +(* in Tactic Notation: *) +| "setoid_replace" constr "with" constr OPT ( "using" "relation" constr ) OPT ( "in" hyp ) + OPT ( "at" LIST1 int_or_var ) OPT ( "by" ltac_expr3 ) +| REPLACE "apply" ssrapplyarg (* SSR plugin *) +| WITH "apply" OPT ssrapplyarg TAG SSR +| DELETE "apply" +| REPLACE "elim" ssrarg ssrclauses (* SSR plugin *) +| WITH "elim" OPT ( ssrarg ssrclauses ) TAG SSR +| DELETE "elim" (* SSR plugin *) +| REPLACE "case" ssrcasearg ssrclauses (* SSR plugin *) +| WITH "case" OPT ( ssrcasearg ssrclauses ) TAG SSR +| DELETE "case" (* SSR plugin *) +| REPLACE "under" ssrrwarg ssrintros_ne "do" ssrhint3arg (* SSR plugin *) +| WITH "under" ssrrwarg OPT ssrintros_ne OPT ( "do" ssrhint3arg ) TAG SSR +| DELETE "under" ssrrwarg (* SSR plugin *) +| DELETE "under" ssrrwarg ssrintros_ne (* SSR plugin *) +| DELETE "under" ssrrwarg "do" ssrhint3arg (* SSR plugin *) +| REPLACE "move" ssrmovearg ssrrpat (* SSR plugin *) +| WITH "move" OPT ( OPT ssrmovearg ssrrpat ) TAG SSR +| DELETE "move" ssrrpat (* SSR plugin *) +| DELETE "move" (* SSR plugin *) +| REPLACE "suff" "have" ssrhpats_nobs ssrhavefwd (* SSR plugin *) +| WITH [ "suff" | "suffices" ] OPT ( "have" ssrhpats_nobs ) ssrhavefwd TAG SSR +| DELETE "suffices" "have" ssrhpats_nobs ssrhavefwd (* SSR plugin *) +| REPLACE "suff" ssrsufffwd (* SSR plugin *) +| WITH [ "suff" | "suffices" ] ssrsufffwd TAG SSR +| DELETE "suffices" ssrsufffwd (* SSR plugin *) +| REPLACE "have" "suff" ssrhpats_nobs ssrhavefwd (* SSR plugin *) +| WITH "have" [ "suff" | "suffices" ] ssrhpats_nobs ssrhavefwd TAG SSR +| DELETE "have" "suffices" ssrhpats_nobs ssrhavefwd (* SSR plugin *) +| REPLACE "gen" "have" ssrclear ssr_idcomma ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| WITH [ "gen" | "generally" ] "have" ssrclear ssr_idcomma ssrhpats_nobs ssrwlogfwd ssrhint TAG SSR +| DELETE "generally" "have" ssrclear ssr_idcomma ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| REPLACE "wlog" "suff" ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| WITH [ "wlog" | "without loss" ] OPT [ "suff" | "suffices" ] ssrhpats_nobs ssrwlogfwd ssrhint TAG SSR +| DELETE "wlog" "suffices" ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| DELETE "wlog" ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| DELETE "without" "loss" ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| DELETE "without" "loss" "suff" ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| DELETE "without" "loss" "suffices" ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) ] (* todo: don't use DELETENT for this *) @@ -1130,14 +1140,31 @@ printable: [ | INSERTALL "Print" ] +add_zify: [ +| [ "InjTyp" | "BinOp" | "UnOp" | "CstOp" | "BinRel" | "UnOpSpec" | "BinOpSpec" ] TAG Micromega +| [ "PropOp" | "PropBinOp" | "PropUOp" | "Saturate" ]TAG Micromega +] + +show_zify: [ +| [ "InjTyp" | "BinOp" | "UnOp" | "CstOp" | "BinRel" | "UnOpSpec" | "BinOpSpec" | "Spec" ] TAG Micromega +] + +scheme_kind: [ +| DELETE "Induction" "for" smart_global "Sort" sort_family +| DELETE "Minimality" "for" smart_global "Sort" sort_family +| DELETE "Elimination" "for" smart_global "Sort" sort_family +| DELETE "Case" "for" smart_global "Sort" sort_family +| [ "Induction" | "Minimality" | "Elimination" | "Case" ] "for" smart_global "Sort" sort_family +] + command: [ | REPLACE "Print" printable | WITH printable | "SubClass" ident_decl def_body | REPLACE "Ltac" LIST1 ltac_tacdef_body SEP "with" | WITH "Ltac" ltac_tacdef_body LIST0 ( "with" ltac_tacdef_body ) -| REPLACE "Function" LIST1 function_rec_definition_loc SEP "with" (* funind plugin *) -| WITH "Function" function_rec_definition_loc LIST0 ( "with" function_rec_definition_loc ) (* funind plugin *) +| REPLACE "Function" LIST1 function_fix_definition SEP "with" (* funind plugin *) +| WITH "Function" function_fix_definition LIST0 ( "with" function_fix_definition ) (* funind plugin *) | REPLACE "Functional" "Scheme" LIST1 fun_scheme_arg SEP "with" (* funind plugin *) | WITH "Functional" "Scheme" fun_scheme_arg LIST0 ( "with" fun_scheme_arg ) (* funind plugin *) | DELETE "Cd" @@ -1148,16 +1175,16 @@ command: [ | WITH "Back" OPT natural | REPLACE "Load" [ "Verbose" | ] [ ne_string | IDENT ] | WITH "Load" OPT "Verbose" [ ne_string | IDENT ] -| DELETE "Unset" option_table -| REPLACE "Set" option_table option_setting -| WITH OPT "Export" "Set" option_table (* set flag *) -| REPLACE "Test" option_table "for" LIST1 table_value -| WITH "Test" option_table OPT ( "for" LIST1 table_value ) -| DELETE "Test" option_table +| DELETE "Unset" setting_name +| REPLACE "Set" setting_name option_setting +| WITH OPT "Export" "Set" setting_name (* set flag *) +| REPLACE "Test" setting_name "for" LIST1 table_value +| WITH "Test" setting_name OPT ( "for" LIST1 table_value ) +| DELETE "Test" setting_name (* hide the fact that table names are limited to 2 IDENTs *) | REPLACE "Add" IDENT IDENT LIST1 table_value -| WITH "Add" option_table LIST1 table_value +| WITH "Add" setting_name LIST1 table_value | DELETE "Add" IDENT LIST1 table_value | DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "as" ident | DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "as" ident @@ -1202,7 +1229,7 @@ command: [ | WITH "Next" "Obligation" OPT ( "of" ident ) withtac | DELETE "Next" "Obligation" withtac | REPLACE "Obligation" natural "of" ident ":" lglob withtac -| WITH "Obligation" natural OPT ( "of" ident ) OPT ( ":" lglob withtac ) +| WITH "Obligation" natural OPT ( "of" ident ) OPT ( ":" type withtac ) | DELETE "Obligation" natural "of" ident withtac | DELETE "Obligation" natural ":" lglob withtac | DELETE "Obligation" natural withtac @@ -1215,7 +1242,7 @@ command: [ (* hide the fact that table names are limited to 2 IDENTs *) | REPLACE "Remove" IDENT IDENT LIST1 table_value -| WITH "Remove" option_table LIST1 table_value +| WITH "Remove" setting_name LIST1 table_value | DELETE "Remove" IDENT LIST1 table_value | DELETE "Restore" "State" IDENT | DELETE "Restore" "State" ne_string @@ -1232,13 +1259,14 @@ command: [ | REPLACE "Solve" "All" "Obligations" "with" tactic | WITH "Solve" "All" "Obligations" OPT ( "with" tactic ) | DELETE "Solve" "All" "Obligations" +| DELETE "Solve" "Obligations" "of" ident "with" tactic +| DELETE "Solve" "Obligations" "of" ident +| DELETE "Solve" "Obligations" "with" tactic +| DELETE "Solve" "Obligations" +| "Solve" "Obligations" OPT ( "of" ident ) OPT ( "with" tactic ) | REPLACE "Solve" "Obligation" natural "of" ident "with" tactic | WITH "Solve" "Obligation" natural OPT ( "of" ident ) "with" tactic -| DELETE "Solve" "Obligations" | DELETE "Solve" "Obligation" natural "with" tactic -| REPLACE "Solve" "Obligations" "of" ident "with" tactic -| WITH "Solve" "Obligations" OPT ( OPT ( "of" ident ) "with" tactic ) -| DELETE "Solve" "Obligations" "with" tactic | DELETE "Undo" | DELETE "Undo" natural | REPLACE "Undo" "To" natural @@ -1261,16 +1289,38 @@ command: [ | WITH "Declare" "Scope" scope_name (* odd that these are in command while other notation-related ones are in syntax *) -| REPLACE "Numeral" "Notation" reference reference reference ":" ident numnotoption -| WITH "Numeral" "Notation" reference reference reference ":" scope_name numnotoption -| REPLACE "String" "Notation" reference reference reference ":" ident -| WITH "String" "Notation" reference reference reference ":" scope_name +| REPLACE "Number" "Notation" reference reference reference OPT number_options ":" ident +| WITH "Number" "Notation" reference reference reference OPT number_options ":" scope_name +| REPLACE "Numeral" "Notation" reference reference reference ":" ident deprecated_number_modifier +| WITH "Numeral" "Notation" reference reference reference ":" scope_name deprecated_number_modifier +| REPLACE "String" "Notation" reference reference reference OPT string_option ":" ident +| WITH "String" "Notation" reference reference reference OPT string_option ":" scope_name | DELETE "Ltac2" ltac2_entry (* was split up *) -] - -option_setting: [ -| OPTINREF +| DELETE "Add" "Zify" "InjTyp" constr (* micromega plugin *) +| DELETE "Add" "Zify" "BinOp" constr (* micromega plugin *) +| DELETE "Add" "Zify" "UnOp" constr (* micromega plugin *) +| DELETE "Add" "Zify" "CstOp" constr (* micromega plugin *) +| DELETE "Add" "Zify" "BinRel" constr (* micromega plugin *) +| DELETE "Add" "Zify" "PropOp" constr (* micromega plugin *) +| DELETE "Add" "Zify" "PropBinOp" constr (* micromega plugin *) +| DELETE "Add" "Zify" "PropUOp" constr (* micromega plugin *) +| DELETE "Add" "Zify" "BinOpSpec" constr (* micromega plugin *) +| DELETE "Add" "Zify" "UnOpSpec" constr (* micromega plugin *) +| DELETE "Add" "Zify" "Saturate" constr (* micromega plugin *) +| "Add" "Zify" add_zify constr TAG Micromega + +| DELETE "Show" "Zify" "InjTyp" (* micromega plugin *) +| DELETE "Show" "Zify" "BinOp" (* micromega plugin *) +| DELETE "Show" "Zify" "UnOp" (* micromega plugin *) +| DELETE "Show" "Zify" "CstOp" (* micromega plugin *) +| DELETE "Show" "Zify" "BinRel" (* micromega plugin *) +| DELETE "Show" "Zify" "UnOpSpec" (* micromega plugin *) +| DELETE "Show" "Zify" "BinOpSpec" (* micromega plugin *) +(* keep this one | "Show" "Zify" "Spec" (* micromega plugin *)*) +| "Show" "Zify" show_zify TAG Micromega +| REPLACE "Goal" lconstr +| WITH "Goal" type ] syntax: [ @@ -1298,7 +1348,7 @@ syntax_modifier: [ | WITH LIST1 IDENT SEP "," "at" level ] -syntax_extension_type: [ +explicit_subentry: [ | REPLACE "strict" "pattern" "at" "level" natural | WITH "strict" "pattern" OPT ( "at" "level" natural ) | DELETE "strict" "pattern" @@ -1308,31 +1358,27 @@ syntax_extension_type: [ | DELETE "constr" (* covered by another prod *) ] -numnotoption: [ -| OPTINREF -] - binder_tactic: [ -| REPLACE "let" [ "rec" | ] LIST1 let_clause SEP "with" "in" tactic_expr5 -| WITH "let" OPT "rec" let_clause LIST0 ( "with" let_clause ) "in" tactic_expr5 +| REPLACE "let" [ "rec" | ] LIST1 let_clause SEP "with" "in" ltac_expr5 +| WITH "let" OPT "rec" let_clause LIST0 ( "with" let_clause ) "in" ltac_expr5 | MOVEALLBUT ltac_builtins ] -record_binder_body: [ -| REPLACE binders of_type_with_opt_coercion lconstr -| WITH binders of_type_with_opt_coercion -| REPLACE binders of_type_with_opt_coercion lconstr ":=" lconstr -| WITH binders of_type_with_opt_coercion ":=" lconstr +field_body: [ +| REPLACE binders of_type lconstr +| WITH binders of_type +| REPLACE binders of_type lconstr ":=" lconstr +| WITH binders of_type ":=" lconstr ] -simple_assum_coe: [ -| REPLACE LIST1 ident_decl of_type_with_opt_coercion lconstr -| WITH LIST1 ident_decl of_type_with_opt_coercion +assumpt: [ +| REPLACE LIST1 ident_decl of_type lconstr +| WITH LIST1 ident_decl of_type ] constructor_type: [ -| REPLACE binders [ of_type_with_opt_coercion lconstr | ] -| WITH binders OPT of_type_with_opt_coercion +| REPLACE binders [ of_type lconstr | ] +| WITH binders OPT of_type ] (* todo: is this really correct? Search for "Pvernac.register_proof_mode" *) @@ -1376,12 +1422,12 @@ legacy_attr: [ sentence: [ ] (* productions defined below *) -rec_definition: [ +fix_definition: [ | REPLACE ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notations | WITH ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notations ] -corec_definition: [ +cofix_definition: [ | REPLACE ident_decl binders type_cstr OPT [ ":=" lconstr ] decl_notations | WITH ident_decl binders type_cstr OPT [ ":=" lconstr ] decl_notations ] @@ -1389,16 +1435,15 @@ corec_definition: [ type_cstr: [ | REPLACE ":" lconstr | WITH ":" type -| OPTINREF ] inductive_definition: [ | REPLACE opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] opt_constructors_or_fields decl_notations -| WITH opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" type ] opt_constructors_or_fields decl_notations +| WITH opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" type ] opt_constructors_or_fields decl_notations ] (* note that constructor -> identref constructor_type *) -constructor_list_or_record_decl: [ +constructors_or_record: [ | DELETE "|" LIST1 constructor SEP "|" | REPLACE identref constructor_type "|" LIST1 constructor SEP "|" | WITH OPT "|" LIST1 constructor SEP "|" @@ -1409,15 +1454,11 @@ constructor_list_or_record_decl: [ ] record_binder: [ -| REPLACE name record_binder_body -| WITH name OPT record_binder_body +| REPLACE name field_body +| WITH name OPT field_body | DELETE name ] -at_level_opt: [ -| OPTINREF -] - query_command: [ | REPLACE "Eval" red_expr "in" lconstr "." | WITH "Eval" red_expr "in" lconstr @@ -1452,10 +1493,6 @@ vernac_toplevel: [ | DELETE vernac_control ] -in_or_out_modules: [ -| OPTINREF -] - vernac_control: [ (* replacing vernac_control with command is cheating a little; they can't refer to the vernac_toplevel commands. @@ -1471,90 +1508,8 @@ vernac_control: [ | DELETE decorated_vernac ] -orient: [ -| OPTINREF -] - -in_hyp_as: [ -| OPTINREF -] - -as_name: [ -| OPTINREF -] - -hloc: [ -| OPTINREF -] - -as_or_and_ipat: [ -| OPTINREF -] - -hintbases: [ -| OPTINREF -] - -as_ipat: [ -| OPTINREF -] - -auto_using: [ -| OPTINREF -] - -with_bindings: [ -| OPTINREF -] - -eqn_ipat: [ -| OPTINREF -] - -withtac: [ -| OPTINREF -] - of_module_type: [ | (* empty *) -| OPTINREF -] - - -clause_dft_all: [ -| OPTINREF -] - -opt_clause: [ -| OPTINREF -] - -with_names: [ -| OPTINREF -] - -in_hyp_list: [ -| OPTINREF -] - -struct_annot: [ -| OPTINREF -] - -firstorder_using: [ -| OPTINREF -] - -fun_ind_using: [ -| OPTINREF -] - -by_arg_tac: [ -| OPTINREF -] - -by_tactic: [ -| OPTINREF ] rewriter: [ @@ -1577,7 +1532,7 @@ ltac2_rewriter: [ | OPT natural OPT [ "?" | "!" ] ltac2_constr_with_bindings ] -tac2expr0: [ +ltac2_expr0: [ | DELETE "(" ")" ] @@ -1601,31 +1556,10 @@ record_declaration: [ fields_def: [ | DELETENT ] -hint_info: [ -| OPTINREF -] - -debug: [ -| OPTINREF -] - -eauto_search_strategy: [ -| OPTINREF -] - - constr_body: [ | DELETE ":=" lconstr | REPLACE ":" lconstr ":=" lconstr -| WITH OPT ( ":" lconstr ) ":=" lconstr -] - -opt_hintbases: [ -| OPTINREF -] - -opthints: [ -| OPTINREF +| WITH OPT ( ":" type ) ":=" lconstr ] scheme: [ @@ -1634,10 +1568,6 @@ scheme: [ | WITH OPT ( identref ":=" ) scheme_kind ] -instance_name: [ -| OPTINREF -] - simple_reserv: [ | REPLACE LIST1 identref ":" lconstr | WITH LIST1 identref ":" type @@ -1656,22 +1586,9 @@ ltac2_in_clause: [ | DELETE LIST0 ltac2_hypident_occ SEP "," (* Ltac2 plugin *) ] -concl_occ: [ -| OPTINREF -] - -opt_coercion: [ -| OPTINREF -] - -opt_constructors_or_fields: [ -| OPTINREF -] - decl_notations: [ | REPLACE "where" LIST1 decl_notation SEP decl_sep | WITH "where" decl_notation LIST0 (decl_sep decl_notation ) -| OPTINREF ] module_expr: [ @@ -1732,15 +1649,6 @@ decl_notation: [ | WITH ne_lstring ":=" constr syntax_modifiers OPT [ ":" scope_name ] ] -syntax_modifiers: [ -| OPTINREF -] - - -only_parsing: [ -| OPTINREF -] - ltac_production_item: [ | REPLACE ident "(" ident OPT ltac_production_sep ")" | WITH ident OPT ( "(" ident OPT ltac_production_sep ")" ) @@ -1754,9 +1662,9 @@ input_fun: [ ] let_clause: [ -| DELETE identref ":=" tactic_expr5 -| REPLACE "_" ":=" tactic_expr5 -| WITH name ":=" tactic_expr5 +| DELETE identref ":=" ltac_expr5 +| REPLACE "_" ":=" ltac_expr5 +| WITH name ":=" ltac_expr5 ] tactic_mode: [ @@ -1769,13 +1677,20 @@ tactic_mode: [ | ltac_info tactic | MOVETO command ltac_info tactic | DELETE command +| REPLACE OPT toplevel_selector "{" +(* semantically restricted *) +| WITH OPT ( [ natural | "[" ident "]" ] ":" ) "{" +| MOVETO simple_tactic OPT ( [ natural | "[" ident "]" ] ":" ) "{" +| DELETE simple_tactic ] -sexpr: [ +tactic_mode: [ | DELETENT ] + +ltac2_scope: [ | REPLACE syn_node (* Ltac2 plugin *) | WITH name TAG Ltac2 -| REPLACE syn_node "(" LIST1 sexpr SEP "," ")" (* Ltac2 plugin *) -| WITH name "(" LIST1 sexpr SEP "," ")" TAG Ltac2 +| REPLACE syn_node "(" LIST1 ltac2_scope SEP "," ")" (* Ltac2 plugin *) +| WITH name "(" LIST1 ltac2_scope SEP "," ")" TAG Ltac2 ] syn_node: [ | DELETENT ] @@ -1785,7 +1700,7 @@ RENAME: [ ] toplevel_selector: [ -| selector_body +| selector | "all" | "!" (* par is accepted even though it's not in the .mlg *) @@ -1793,7 +1708,7 @@ toplevel_selector: [ ] toplevel_selector_temp: [ -| DELETE selector_body ":" +| DELETE selector ":" | DELETE "all" ":" | DELETE "!" ":" | toplevel_selector ":" @@ -1834,7 +1749,7 @@ query_command: [ ] (* re-add as a placeholder *) sentence: [ | OPT attributes command "." | OPT attributes OPT ( natural ":" ) query_command "." -| OPT attributes OPT ( toplevel_selector ":" ) tactic_expr5 [ "." | "..." ] +| OPT attributes OPT ( toplevel_selector ":" ) ltac_expr5 [ "." | "..." ] | control_command ] @@ -1855,30 +1770,33 @@ ltac_defined_tactics: [ | "lra" | "nia" | "nra" +| "over" TAG SSR | "split_Rabs" | "split_Rmult" | "tauto" -| "time_constr" tactic_expr5 +| "time_constr" ltac_expr5 | "zify" ] (* todo: need careful review; assume that "[" ... "]" are literals *) tactic_notation_tactics: [ -| "assert_fails" tactic_expr3 -| "assert_succeeds" tactic_expr3 -| "field" OPT ( "[" LIST1 operconstr200 "]" ) -| "field_simplify" OPT ( "[" LIST1 operconstr200 "]" ) LIST1 operconstr200 OPT ( "in" ident ) -| "field_simplify_eq" OPT ( "[" LIST1 operconstr200 "]" ) OPT ( "in" ident ) -| "intuition" OPT tactic_expr5 -| "nsatz" OPT ( "with" "radicalmax" ":=" operconstr200 "strategy" ":=" operconstr200 "parameters" ":=" operconstr200 "variables" ":=" operconstr200 ) -| "psatz" operconstr200 OPT int_or_var -| "ring" OPT ( "[" LIST1 operconstr200 "]" ) -| "ring_simplify" OPT ( "[" LIST1 operconstr200 "]" ) LIST1 operconstr200 OPT ( "in" ident ) (* todo: ident was "hyp", worth keeping? *) +| "assert_fails" ltac_expr3 +| "assert_succeeds" ltac_expr3 +| "dintuition" OPT ltac_expr5 +| "dtauto" +| "field" OPT ( "[" LIST1 constr "]" ) +| "field_simplify" OPT ( "[" LIST1 constr "]" ) LIST1 constr OPT ( "in" ident ) +| "field_simplify_eq" OPT ( "[" LIST1 constr "]" ) OPT ( "in" ident ) +| "intuition" OPT ltac_expr5 (* todo: Not too keen on things like "with_power_flags" in tauto.ml, not easy to follow *) +| "nsatz" OPT ( "with" "radicalmax" ":=" constr "strategy" ":=" constr "parameters" ":=" constr "variables" ":=" constr ) +| "psatz" constr OPT int_or_var +| "ring" OPT ( "[" LIST1 constr "]" ) +| "ring_simplify" OPT ( "[" LIST1 constr "]" ) LIST1 constr OPT ( "in" ident ) (* todo: ident was "hyp", worth keeping? *) ] (* defined in OCaml outside of mlgs *) -tactic_arg: [ -| "uconstr" ":" "(" operconstr200 ")" +tactic_value: [ +| "uconstr" ":" "(" term200 ")" | MOVEALLBUT simple_tactic ] @@ -1886,10 +1804,6 @@ nonterminal: [ ] value_tactic: [ ] -RENAME: [ -| tactic_arg tactic_value -] - syn_value: [ | IDENT; ":" "(" nonterminal ")" ] @@ -1908,8 +1822,8 @@ ltac2_match_key: [ ] ltac2_constructs: [ -| ltac2_match_key tac2expr6 "with" ltac2_match_list "end" -| ltac2_match_key OPT "reverse" "goal" "with" gmatch_list "end" +| ltac2_match_key ltac2_expr6 "with" ltac2_match_list "end" +| ltac2_match_key OPT "reverse" "goal" "with" goal_match_list "end" ] simple_tactic: [ @@ -1921,9 +1835,9 @@ simple_tactic: [ ] tacdef_body: [ -| REPLACE global LIST1 input_fun ltac_def_kind tactic_expr5 -| WITH global LIST0 input_fun ltac_def_kind tactic_expr5 -| DELETE global ltac_def_kind tactic_expr5 +| REPLACE global LIST1 input_fun ltac_def_kind ltac_expr5 +| WITH global LIST0 input_fun ltac_def_kind ltac_expr5 +| DELETE global ltac_def_kind ltac_expr5 ] tac2def_typ: [ @@ -1975,10 +1889,6 @@ DELETE: [ | test_ltac1_env ] -mut_flag: [ -| OPTINREF -] - rec_flag: [ | OPTINREF ] @@ -1993,19 +1903,7 @@ SPLICE: [ | ltac2_orient ] -tac2typ_prm: [ -| OPTINREF -] - -tac2type_body: [ -| OPTINREF -] - -atomic_tac2pat: [ -| OPTINREF -] - -tac2expr0: [ +ltac2_expr0: [ (* | DELETE "(" ")" (* covered by "()" prodn *) | REPLACE "{" [ | LIST1 tac2rec_fieldexpr OPT ";" ] "}" @@ -2018,13 +1916,13 @@ tac2expr0: [ use LIST1? *) SPLICE: [ -| tac2expr4 +| ltac2_expr4 ] -tac2expr3: [ -| REPLACE tac2expr2 "," LIST1 tac2expr2 SEP "," (* Ltac2 plugin *) -| WITH LIST1 tac2expr2 SEP "," TAG Ltac2 -| DELETE tac2expr2 (* Ltac2 plugin *) +ltac2_expr3: [ +| REPLACE ltac2_expr2 "," LIST1 ltac2_expr2 SEP "," (* Ltac2 plugin *) +| WITH LIST1 ltac2_expr2 SEP "," TAG Ltac2 +| DELETE ltac2_expr2 (* Ltac2 plugin *) ] tac2rec_fieldexprs: [ @@ -2032,7 +1930,6 @@ tac2rec_fieldexprs: [ | DELETE tac2rec_fieldexpr ";" | DELETE tac2rec_fieldexpr | LIST1 tac2rec_fieldexpr OPT ";" -| OPTINREF ] tac2rec_fields: [ @@ -2040,7 +1937,6 @@ tac2rec_fields: [ | DELETE tac2rec_field ";" | DELETE tac2rec_field | LIST1 tac2rec_field SEP ";" OPT ";" TAG Ltac2 -| OPTINREF ] (* todo: weird productions, ints only after an initial "-"??: @@ -2054,46 +1950,6 @@ ltac2_occs_nums: [ | WITH OPT "-" LIST1 nat_or_anti TAG Ltac2 ] -syn_level: [ -| OPTINREF -] - -ltac2_delta_flag: [ -| OPTINREF -] - -ltac2_occs: [ -| OPTINREF -] - -ltac2_concl_occ: [ -| OPTINREF -] - -ltac2_with_bindings: [ -| OPTINREF -] - -ltac2_as_or_and_ipat: [ -| OPTINREF -] - -ltac2_eqn_ipat: [ -| OPTINREF -] - -ltac2_as_name: [ -| OPTINREF -] - -ltac2_as_ipat: [ -| OPTINREF -] - -ltac2_by_tactic: [ -| OPTINREF -] - ltac2_entry: [ | REPLACE tac2def_typ (* Ltac2 plugin *) | WITH "Ltac2" tac2def_typ @@ -2105,7 +1961,7 @@ ltac2_entry: [ | WITH "Ltac2" tac2def_val | REPLACE tac2def_ext (* Ltac2 plugin *) | WITH "Ltac2" tac2def_ext -| "Ltac2" "Notation" [ string | lident ] ":=" tac2expr6 TAG Ltac2 (* variant *) +| "Ltac2" "Notation" [ string | lident ] ":=" ltac2_expr6 TAG Ltac2 (* variant *) | MOVEALLBUT command (* todo: MOVEALLBUT should ignore tag on "but" prodns *) ] @@ -2128,34 +1984,23 @@ SPLICE: [ | tac2def_ext | tac2def_syn | tac2def_mut -| mut_flag | rec_flag | locident -| syn_level -| tac2rec_fieldexprs -| tac2type_body | tac2alg_constructors -| tac2rec_fields | ltac2_binder | branch | anti ] -tac2expr5: [ -| REPLACE "let" OPT "rec" LIST1 ltac2_let_clause SEP "with" "in" tac2expr6 (* Ltac2 plugin *) -| WITH "let" OPT "rec" ltac2_let_clause LIST0 ( "with" ltac2_let_clause ) "in" tac2expr6 TAG Ltac2 -| MOVETO simple_tactic "match" tac2expr5 "with" OPT ltac2_branches "end" (* Ltac2 plugin *) +ltac2_expr5: [ +| REPLACE "let" OPT "rec" LIST1 ltac2_let_clause SEP "with" "in" ltac2_expr6 (* Ltac2 plugin *) +| WITH "let" OPT "rec" ltac2_let_clause LIST0 ( "with" ltac2_let_clause ) "in" ltac2_expr6 TAG Ltac2 +| MOVETO simple_tactic "match" ltac2_expr5 "with" ltac2_branches "end" (* Ltac2 plugin *) +| MOVETO simple_tactic "if" ltac2_expr5 "then" ltac2_expr5 "else" ltac2_expr5 (* Ltac2 plugin *) | DELETE simple_tactic ] -RENAME: [ -| Prim.string string -| Prim.integer integer -| Prim.qualid qualid -| Prim.natural natural -] - -gmatch_list: [ +goal_match_list: [ | EDIT ADD_OPT "|" LIST1 gmatch_rule SEP "|" (* Ltac2 plugin *) ] @@ -2190,8 +2035,358 @@ q_clause: [ ] ltac2_induction_clause: [ -| REPLACE ltac2_destruction_arg OPT ltac2_as_or_and_ipat OPT ltac2_eqn_ipat OPT clause (* Ltac2 plugin *) -| WITH ltac2_destruction_arg OPT ltac2_as_or_and_ipat OPT ltac2_eqn_ipat OPT ltac2_clause TAG Ltac2 +| REPLACE ltac2_destruction_arg ltac2_as_or_and_ipat ltac2_eqn_ipat OPT clause (* Ltac2 plugin *) +| WITH ltac2_destruction_arg ltac2_as_or_and_ipat ltac2_eqn_ipat OPT ltac2_clause TAG Ltac2 +] + +starredidentref: [ +| EDIT identref ADD_OPT "*" +| EDIT "Type" ADD_OPT "*" +| "All" +] + +ssexpr0: [ +| DELETE "(" LIST0 starredidentref ")" +| DELETE "(" LIST0 starredidentref ")" "*" +| DELETE "(" ssexpr35 ")" +| DELETE "(" ssexpr35 ")" "*" +| "(" section_subset_expr ")" OPT "*" +] + +ssexpr35: [ +| EDIT ADD_OPT "-" ssexpr50 +] + +simple_binding: [ +| REPLACE "(" ident ":=" lconstr ")" +| WITH "(" [ ident | natural ] ":=" lconstr ")" +| DELETE "(" natural ":=" lconstr ")" +] + + +subprf: [ +| MOVEALLBUT simple_tactic +| "{" (* should be removed. See https://github.com/coq/coq/issues/12004 *) +] + +ltac2_expr: [ +| DELETE _ltac2_expr +] + +ssrfwdview: [ +| REPLACE "/" ast_closure_term ssrfwdview (* SSR plugin *) +| WITH LIST1 ( "/" ast_closure_term ) TAG SSR +| DELETE "/" ast_closure_term (* SSR plugin *) +] + +ssrfwd: [ +| REPLACE ":" ast_closure_lterm ":=" ast_closure_lterm (* SSR plugin *) +| WITH OPT ( ":" ast_closure_lterm ) ":=" ast_closure_lterm TAG SSR +| DELETE ":=" ast_closure_lterm (* SSR plugin *) +] + +ssrsetfwd: [ +| REPLACE ":" ast_closure_lterm ":=" "{" ssrocc "}" cpattern (* SSR plugin *) +| WITH OPT ( ":" ast_closure_lterm ) ":=" [ "{" ssrocc "}" cpattern | lcpattern ] TAG SSR +| DELETE ":" ast_closure_lterm ":=" lcpattern (* SSR plugin *) +| DELETE ":=" "{" ssrocc "}" cpattern (* SSR plugin *) +| DELETE ":=" lcpattern (* SSR plugin *) +] + + +(* per @gares *) +ssrdgens: [ +| REPLACE ":" ssrgen ssrdgens_tl (* SSR plugin *) +| WITH ":" ssrgen OPT ( "/" ssrgen ) TAG SSR +] + +ssrdgens_tl: [ | DELETENT ] + +ssrgen: [ +| REPLACE ssrdocc cpattern (* SSR plugin *) +| WITH cpattern LIST0 [ LIST1 ident | cpattern ] TAG SSR +| DELETE cpattern (* SSR plugin *) +] + +OPTINREF: [ ] + +ssrortacs: [ +| EDIT ssrtacarg "|" ADD_OPT ssrortacs (* ssr plugin *) +| EDIT "|" ADD_OPT ssrortacs (* ssr plugin *) +| EDIT ADD_OPT ssrtacarg "|" OPT ssrortacs +] + +ssrocc: [ +| REPLACE natural LIST0 natural (* SSR plugin *) +| WITH [ natural | "+" | "-" ] LIST0 natural TAG SSR +| DELETE "-" LIST0 natural (* SSR plugin *) +| DELETE "+" LIST0 natural (* SSR plugin *) +] + +ssripat: [ +| DELETE ssrdocc "->" (* SSR plugin *) +| DELETE ssrdocc "<-" (* SSR plugin *) +| REPLACE ssrdocc (* SSR plugin *) +| WITH ssrdocc OPT [ "->" | "<-" ] TAG SSR +| DELETE "->" (* SSR plugin *) +| DELETE "<-" (* SSR plugin *) +| DELETE "-/" "=" (* SSR plugin *) +| DELETE "-/" "/" (* SSR plugin *) +| DELETE "-/" integer "/" (* SSR plugin *) +| DELETE "-/" integer "/=" (* SSR plugin *) +| REPLACE "-/" integer "/" integer "=" (* SSR plugin *) +| WITH "-/" integer [ "/=" | "/" | "/" integer "=" ] TAG SSR +| DELETE "-/" "/=" (* SSR plugin *) +| DELETE "-//" "=" (* SSR plugin *) +| DELETE "[" ":" LIST0 ident "]" (* SSR plugin *) +] + +ssrsimpl_ne: [ +| DELETE "/" natural "/" "=" (* SSR plugin *) +(* parsed but not supported per @gares *) +| DELETE "/" natural "/" (* SSR plugin *) +| DELETE "/" natural "=" (* SSR plugin *) +| DELETE "//" natural "=" (* SSR plugin *) +] + +hat: [ +| DELETE "^" "~" ident (* SSR plugin *) +| DELETE "^" "~" natural (* SSR plugin *) +] + +ssriorpat: [ +| ssripats OPT ( [ "|" | "|-" ] ssriorpat ) TAG SSR +| DELETE OPT ssripats "|" ssriorpat (* SSR plugin *) +| DELETE OPT ssripats "|-" ">" ssriorpat (* SSR plugin *) +| DELETE OPT ssripats "|-" ssriorpat (* SSR plugin *) +(* "|->" | "||" | "|||" | "||||" are parsing hacks *) +| DELETE OPT ssripats "|->" ssriorpat (* SSR plugin *) +| DELETE OPT ssripats "||" ssriorpat (* SSR plugin *) +| DELETE OPT ssripats "|||" ssriorpat (* SSR plugin *) +| DELETE OPT ssripats "||||" ssriorpat (* SSR plugin *) +| DELETE OPT ssripats (* SSR plugin *) +] + +ssrbinder: [ +| REPLACE "(" ssrbvar LIST1 ssrbvar ":" lconstr ")" (* SSR plugin *) +| WITH "(" LIST1 ssrbvar ":" lconstr ")" TAG SSR +| REPLACE "(" ssrbvar ":" lconstr ":=" lconstr ")" (* SSR plugin *) +| WITH "(" ssrbvar OPT ( ":" lconstr ) OPT ( ":=" lconstr ) ")" TAG SSR +| DELETE "(" ssrbvar ")" (* SSR plugin *) +| DELETE "(" ssrbvar ":" lconstr ")" (* SSR plugin *) +| DELETE "(" ssrbvar ":=" lconstr ")" (* SSR plugin *) +] + +ssrhavefwd: [ +| REPLACE ":" ast_closure_lterm ":=" ast_closure_lterm (* SSR plugin *) +| WITH ":" ast_closure_lterm ":=" OPT ast_closure_lterm TAG SSR +| DELETE ":" ast_closure_lterm ":=" (* SSR plugin *) +| DELETE ":=" ast_closure_lterm (* SSR plugin *) +] + +ssrmult_ne: [ +| EDIT ADD_OPT natural ssrmmod TAG SSR +] + +rpattern: [ +| REPLACE lconstr "in" lconstr "in" lconstr (* SSR plugin *) +| WITH OPT ( OPT ( OPT ( OPT lconstr "in" ) lconstr ) "in" ) lconstr TAG SSR +| DELETE lconstr (* SSR plugin *) +| DELETE "in" lconstr (* SSR plugin *) +| DELETE lconstr "in" lconstr (* SSR plugin *) +| DELETE "in" lconstr "in" lconstr (* SSR plugin *) +] + +ssrrule_ne: [ +| DELETE ssrsimpl_ne (* SSR plugin *) +| REPLACE [ "/" ssrterm | ssrterm | ssrsimpl_ne ] (* SSR plugin *) +| WITH [ OPT "/" ssrterm | ssrsimpl_ne ] TAG SSR +] + +ssrunlockarg: [ +| REPLACE "{" ssrocc "}" ssrterm (* SSR plugin *) +| WITH OPT ( "{" ssrocc "}" ) ssrterm TAG SSR +| DELETE ssrterm (* SSR plugin *) +] + +ssrclauses: [ +| REPLACE "in" ssrclausehyps "|-" "*" (* SSR plugin *) +| WITH "in" ssrclausehyps OPT "|-" OPT "*" TAG SSR +| DELETE "in" ssrclausehyps "|-" (* SSR plugin *) +| DELETE "in" ssrclausehyps "*" (* SSR plugin *) +| DELETE "in" ssrclausehyps (* SSR plugin *) +| REPLACE "in" "|-" "*" (* SSR plugin *) +| WITH "in" [ "*" | "*" "|-" | "|-" "*" ] TAG SSR +| DELETE "in" "*" (* SSR plugin *) +| DELETE "in" "*" "|-" (* SSR plugin *) +] + +ssrclausehyps: [ +| REPLACE ssrwgen "," ssrclausehyps (* SSR plugin *) +| WITH ssrwgen LIST0 ( OPT "," ssrwgen ) TAG SSR +| DELETE ssrwgen ssrclausehyps (* SSR plugin *) +| DELETE ssrwgen (* SSR plugin *) +] + +ssrwgen: [ +| DELETE ssrhoi_hyp (* SSR plugin *) +| REPLACE "@" ssrhoi_hyp (* SSR plugin *) +| WITH OPT "@" ssrhoi_hyp TAG SSR +| REPLACE "(" ssrhoi_id ":=" lcpattern ")" (* SSR plugin *) +| WITH "(" ssrhoi_id OPT ( ":=" lcpattern ) ")" TAG SSR +| DELETE "(" ssrhoi_id ")" (* SSR plugin *) +| DELETE "(" "@" ssrhoi_id ":=" lcpattern ")" (* SSR plugin *) +] + +ssrcongrarg: [ +| REPLACE natural constr ssrdgens (* SSR plugin *) +| WITH OPT natural constr OPT ssrdgens TAG SSR +| DELETE natural constr (* SSR plugin *) +| DELETE constr ssrdgens (* SSR plugin *) +| DELETE constr (* SSR plugin *) +] + +ssrviewpos: [ +| DELETE "for" "apply" "/" "/" (* SSR plugin *) +] + +ssrhintref: [ +| REPLACE constr "|" natural (* SSR plugin *) +| WITH constr OPT ( "|" natural ) TAG SSR +| DELETE constr (* SSR plugin *) +] + +ssr_search_arg: [ +| REPLACE "-" ssr_search_item OPT ssr_search_arg (* SSR plugin *) +| WITH LIST1 ( "-" ssr_search_item ) TAG SSR +| DELETE ssr_search_item OPT ssr_search_arg (* SSR plugin *) +] + +ssr_search_item: [ +| DELETE string (* SSR plugin *) +| REPLACE string "%" preident (* SSR plugin *) +| WITH string OPT ( "%" preident ) TAG SSR +] + +modloc: [ +| REPLACE "-" global (* SSR plugin *) +| WITH OPT "-" global TAG SSR +| DELETE global +] + +ssrmmod: [ +| DELETE LEFTQMARK (* SSR plugin *) (* duplicate *) +] + +clear_switch: [ +| "{" LIST0 ident "}" +] + +ssrrwocc: [ +| REPLACE "{" LIST0 ssrhyp "}" (* SSR plugin *) +| WITH clear_switch +] + +ssrrwarg: [ +| EDIT "{" ADD_OPT ssrocc "}" OPT ssrpattern_squarep ssrrule_ne TAG SSR +| REPLACE "{" LIST1 ssrhyp "}" ssrpattern_ne_squarep ssrrule_ne (* SSR plugin *) +| WITH OPT ( OPT ( "{" LIST1 ssrhyp "}" ) ssrpattern_ne_squarep ) ssrrule_ne TAG SSR +| DELETE ssrpattern_ne_squarep ssrrule_ne (* SSR plugin *) +| DELETE ssrrule_ne (* SSR plugin *) +] + +ssrpattern_squarep: [ (* fix inconsistency *) +| REPLACE "[" rpattern "]" (* SSR plugin *) +| WITH ssrpattern_ne_squarep TAG SSR +] + +ssripats_ne: [ +| REPLACE ssripat OPT ssripats (* SSR plugin *) +| WITH LIST1 ssripat TAG SSR +] + +ssripats: [ (* fix inconsistency *) +| REPLACE ssripat OPT ssripats (* SSR plugin *) +| WITH ssripats_ne TAG SSR +] + +lcpattern: [ +(* per @gares *) +| DELETE "Qed" lconstr +] + +ssrapplyarg: [ +| EDIT ADD_OPT ssrbwdview ":" ssragen OPT ssragens OPT ssrintros TAG SSR +] + +constr_with_bindings_arg: [ +| EDIT ADD_OPT ">" constr_with_bindings TAG SSR +] + +destruction_arg: [ +| DELETE constr_with_bindings +] + +ssrhintarg: [ +| EDIT "[" ADD_OPT ssrortacs "]" TAG SSR +] + + +ssrhint3arg: [ +| EDIT "[" ADD_OPT ssrortacs "]" TAG SSR +] + + +ssr_first: [ +| DELETE ssr_first ssrintros_ne (* SSR plugin *) +| REPLACE "[" LIST0 ltac_expr5 SEP "|" "]" (* SSR plugin *) +| WITH "[" LIST0 ltac_expr5 SEP "|" "]" LIST0 ssrintros_ne TAG SSR +] + +ssr_first_else: [ +| EDIT ssr_first ADD_OPT ssrorelse TAG SSR +] + +ssrseqarg: [ +| EDIT ADD_OPT ssrseqidx ssrswap TAG SSR +] + +ssr_dpat: [ +| REPLACE ssr_mpat "in" pattern200 ssr_rtype (* SSR plugin *) +| WITH ssr_mpat OPT ( OPT ( "in" pattern200 ) ssr_rtype ) TAG SSR +| DELETE ssr_mpat ssr_rtype (* SSR plugin *) +| DELETE ssr_mpat (* SSR plugin *) +] + +ssr_one_term_pattern: [ +| DELETE "Qed" constr +] + +ssrarg: [ +| EDIT ADD_OPT ssrfwdview OPT ssreqid ssrdgens OPT ssrintros (* SSR plugin *) +] + +ssragen: [ +| REPLACE "{" LIST1 ssrhyp "}" ssrterm (* SSR plugin *) +| WITH OPT ( "{" LIST1 ssrhyp "}" ) ssrterm TAG SSR +| DELETE ssrterm (* SSR plugin *) +] + +ssrbinder: [ +| REPLACE [ "of" | "&" ] term99 (* SSR plugin *) +| WITH "of" term99 TAG SSR +| "&" term99 TAG SSR +] + +firstorder_rhs: [ +| DELETE OPT firstorder_using +| DELETE "with" LIST1 preident +| REPLACE OPT firstorder_using "with" LIST1 preident +| WITH OPT firstorder_using OPT ( "with" LIST1 preident ) +] + +attribute: [ +| DELETE "using" OPT attr_value ] SPLICE: [ @@ -2204,7 +2399,6 @@ SPLICE: [ | NUMBER | STRING | hyp -| var | identref | pattern_ident | constr_eval (* splices as multiple prods *) @@ -2214,10 +2408,10 @@ SPLICE: [ | ltac_selector | Constr.ident | attribute_list -| operconstr99 -| operconstr90 -| operconstr9 -| operconstr8 +| term99 +| term90 +| term9 +| term8 | pattern200 | pattern99 | pattern90 @@ -2230,18 +2424,16 @@ SPLICE: [ | bar_cbrace | lconstr -(* +(* SSR *) | ast_closure_term | ast_closure_lterm | ident_no_do | ssrterm | ssrtacarg | ssrtac3arg -| ssrtclarg | ssrhyp | ssrhoi_hyp | ssrhoi_id -| ssrindex | ssrhpats | ssrhpats_nobs | ssrfwdid @@ -2256,19 +2448,41 @@ SPLICE: [ | ssrcofixfwd | ssrfixfwd | ssrhavefwdwbinders -| ssripats_ne | ssrparentacarg | ssrposefwd -*) - +| ssrstruct +| ssrrpat +| ssrhint +| ssrpattern_squarep +| ssrhintref +| ssr_search_item +| ssr_modlocs +| modloc +| ssrexactarg +| ssrclear +| ssrmult +| ssripats +| ssrintros +| ssrrule +| ssrpattern_squarep +| ssrcongrarg +| ssrdotac +| ssrunlockarg +| ssr_search_arg +| ssrortacarg +| ssrsetfwd +| ssr_idcomma +| ssr_dthen +| ssr_else +| ssr_rtype +| ssreqid | preident | lpar_id_coloneq | binders | casted_constr | check_module_types -| constr_pattern | decl_sep -| function_rec_definition_loc (* loses funind annotation *) +| function_fix_definition (* loses funind annotation *) | glob | glob_constr_with_bindings | id_or_meta @@ -2286,7 +2500,6 @@ SPLICE: [ | decorated_vernac | ext_module_expr | ext_module_type -| pattern_identref | test | binder_constr | atomic_constr @@ -2354,7 +2567,6 @@ SPLICE: [ | intropatterns | instance_name | failkw -| selector | ne_in_or_out_modules | search_queries | locatable @@ -2377,95 +2589,79 @@ SPLICE: [ | refglobals (* Ltac2 *) | syntax_modifiers | array_elems -| ltac2_expr | G_LTAC2_input_fun | ltac2_simple_intropattern_closed | ltac2_with_bindings +| int_or_id +| fun_ind_using +| with_names +| eauto_search_strategy_name +| constr_with_bindings +| simple_binding +| ssexpr35 (* strange in mlg, ssexpr50 is after this *) +| number_string_mapping +| number_options +| string_option +| tac2type_body +| tac2rec_fields +| mut_flag +| tac2rec_fieldexprs +| syn_level +| firstorder_rhs +| firstorder_using ] (* end SPLICE *) RENAME: [ | tactic3 ltac_expr3 (* todo: can't figure out how this gets mapped by coqpp *) | tactic1 ltac_expr1 (* todo: can't figure out how this gets mapped by coqpp *) | tactic0 ltac_expr0 (* todo: can't figure out how this gets mapped by coqpp *) -| ltac1_expr ltac_expr -| tactic_expr5 ltac_expr -| tactic_expr4 ltac_expr4 -| tactic_expr3 ltac_expr3 -| tactic_expr2 ltac_expr2 -| tactic_expr1 ltac_expr1 -| tactic_expr0 ltac_expr0 +| ltac_expr5 ltac_expr (* | nonsimple_intropattern intropattern (* ltac2 *) *) -| operconstr200 term (* historical name *) -| operconstr100 term100 -| operconstr10 term10 -| operconstr1 term1 -| operconstr0 term0 +| term200 term | pattern100 pattern -| match_constr term_match (*| impl_ident_tail impl_ident*) -| ssexpr35 ssexpr (* strange in mlg, ssexpr50 is after this *) - -| tactic_then_gen for_each_goal -| ltac2_tactic_then_gen ltac2_for_each_goal -| selector_body selector -| match_hyps match_hyp +| ssexpr50 section_var_expr50 +| ssexpr0 section_var_expr0 +| section_subset_expr section_var_expr +| fun_scheme_arg func_scheme_def | BULLET bullet -| fix_decl fix_body -| cofix_decl cofix_body -(* todo: it's confusing that Constr.constr and constr are different things *) -| constr one_term -| appl_arg arg -| rec_definition fix_definition -| corec_definition cofix_definition -| univ_instance univ_annot -| simple_assum_coe assumpt -| of_type_with_opt_coercion of_type -| attribute_value attr_value -| constructor_list_or_record_decl constructors_or_record -| record_binder_body field_body -| class_rawexpr class -| smart_global reference +| constr one_term (* many, many, many *) +| class_rawexpr class (* OCaml reserved word *) +| smart_global reference (* many, many *) (* | searchabout_query search_item *) -| option_table setting_name -| argument_spec_block arg_specs -| more_implicits_block implicits_alt -| arguments_modifier args_modifier -| constr_as_binder_kind binder_interp -| syntax_extension_type explicit_subentry -| numnotoption numeral_modifier -| tactic_arg_compat tactic_arg -| lconstr_pattern cpattern -| Pltac.tactic ltac_expr -| sexpr ltac2_scope -| tac2type5 ltac2_type -| tac2type2 ltac2_type2 -| tac2type1 ltac2_type1 -| tac2type0 ltac2_type0 -| typ_param ltac2_typevar -| tac2expr6 ltac2_expr -| tac2expr5 ltac2_expr5 -| tac2expr3 ltac2_expr3 -| tac2expr2 ltac2_expr2 -| tac2expr1 ltac2_expr1 -| tac2expr0 ltac2_expr0 -| gmatch_list goal_match_list +| Pltac.tactic ltac_expr (* many uses in EXTENDs *) +| ltac2_type5 ltac2_type +| ltac2_expr6 ltac2_expr +| starredidentref starred_ident_ref +| ssrocc ssr_occurrences +| ssrsimpl_ne s_item +| ssrclear_ne ssrclear +| ssrmult_ne mult +| ssripats_ne ssripats +| ssrrule_ne r_item +| ssrintros_ne ssrintros +| ssrpattern_ne_squarep ssrpattern_squarep +| ssrrwarg rewrite_item +| ssrrwocc occ_or_clear +| rpattern rewrite_pattern +| ssripat i_item +| ssrwgen gen_item +| ssrfwd ssrdefbody +| ssrclauses ssr_in +| ssrcpat ssrblockpat +| constr_pattern one_pattern ] simple_tactic: [ -(* due to renaming of tactic_arg; Use LIST1 for function application *) +(* due to renaming of tactic_value; Use LIST1 for function application *) | qualid LIST1 tactic_arg ] -(* todo: doesn't work if up above... maybe because 'clause' doesn't exist? *) -clause_dft_concl: [ -| OPTINREF -] - SPLICE: [ | gallina | gallina_ext @@ -2479,7 +2675,7 @@ SPLICE: [ | ltac_defined_tactics | tactic_notation_tactics ] -(* todo: ssrreflect*.rst ref to fix_body is incorrect *) +(* todo: ssrreflect*.rst ref to fix_decl is incorrect *) REACHABLE: [ | command @@ -2518,17 +2714,7 @@ NOTINRSTS: [ | q_constr_matching | q_goal_matching -(* todo: figure these out -(*Warning: editedGrammar: Undefined symbol 'ltac1_expr' *) -| dangling_pattern_extension_rule -| vernac_aux -| subprf -| tactic_mode -| tac2expr_in_env (* no refs *) -| tac2mode (* no refs *) -| ltac_use_default (* from tac2mode *) -| tacticals -*) + ] REACHABLE: [ diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index 177abe53fc..92a745c863 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -12,12 +12,14 @@ open Coqpp_parser open Coqpp_ast let exit_code = ref 0 +let error_count = ref 0 let show_warn = ref true let fprintf = Printf.fprintf let error s = exit_code := 1; + incr error_count; Printf.eprintf "Error: "; Printf.eprintf s @@ -309,6 +311,11 @@ let rec output_prodn = function | "{|" -> "%{%|" | "`{" -> "`%{" | "@{" -> "@%{" + | "|-" -> "%|-" + | "|->" -> "%|->" + | "||" -> "%||" + | "|||" -> "%|||" + | "||||" -> "%||||" | "{" | "}" | "|" -> "%" ^ s @@ -354,10 +361,9 @@ and prod_to_prodn prod = String.concat " " (prod_to_prodn_r prod) let get_tag file prod = List.fold_left (fun rv sym -> match sym with - (* todo: temporarily limited to Ltac2 tags in prodn when not in ltac2.rst *) - | Sedit2 ("TAG", s2) - when (s2 = "Ltac2" || s2 = "not Ltac2") && - file <> "doc/sphinx/proof-engine/ltac2.rst" -> " " ^ s2 + (* todo: only Ltac2 and SSR for now, outside of their main chapters *) + | Sedit2 ("TAG", "Ltac2") when file <> "doc/sphinx/proof-engine/ltac2.rst" -> " Ltac2" + | Sedit2 ("TAG", "SSR") when file <> "doc/sphinx/proof-engine/ssreflect-proof-language.rst" -> " SSR" | _ -> rv ) "" prod @@ -538,12 +544,11 @@ let autoloaded_mlgs = [ (* in the order they are loaded by Coq *) "plugins/ltac/g_eqdecide.mlg"; "plugins/ltac/g_tactic.mlg"; "plugins/ltac/g_ltac.mlg"; - "plugins/syntax/g_string.mlg"; "plugins/btauto/g_btauto.mlg"; "plugins/rtauto/g_rtauto.mlg"; "plugins/cc/g_congruence.mlg"; "plugins/firstorder/g_ground.mlg"; - "plugins/syntax/g_numeral.mlg"; + "plugins/syntax/g_number_string.mlg"; ] @@ -555,6 +560,10 @@ let level_regex = Str.regexp "[a-zA-Z0-9_]*$" let get_plugin_name file = if file = "user-contrib/Ltac2/g_ltac2.mlg" then "Ltac2" + (* todo: would be better if g_search.mlg has an "ssr" prefix *) + else if List.mem file ["plugins/ssr/ssrparser.mlg"; "plugins/ssr/ssrvernac.mlg"; + "plugins/ssrmatching/g_ssrmatching.mlg"; "plugins/ssrsearch/g_search.mlg"] then + "SSR" else if Str.string_match plugin_regex file 0 then Str.matched_group 1 file else @@ -564,12 +573,12 @@ let read_mlg g is_edit ast file level_renames symdef_map = let res = ref [] in let locals = ref StringSet.empty in let dup_renames = ref StringMap.empty in - let add_prods nt prods = + let add_prods nt prods gramext_globals = if not is_edit then - if NTMap.mem nt !g.map && nt <> "command" && nt <> "simple_tactic" then begin + if NTMap.mem nt !g.map && not (List.mem nt gramext_globals) && nt <> "command" && nt <> "simple_tactic" then begin let new_name = String.uppercase_ascii (Filename.remove_extension (Filename.basename file)) ^ "_" ^ nt in dup_renames := StringMap.add nt new_name !dup_renames; - Printf.printf "** dup sym %s -> %s in %s\n" nt new_name file + if false then Printf.printf "** dup local sym %s -> %s in %s\n" nt new_name file end; add_symdef nt file symdef_map; let plugin = get_plugin_name file in @@ -590,11 +599,12 @@ let read_mlg g is_edit ast file level_renames symdef_map = | Some s -> s | None -> "" in + let gramext_globals = ref grammar_ext.gramext_globals in List.iter (fun ent -> let len = List.length ent.gentry_rules in List.iteri (fun i rule -> let nt = ent.gentry_name in - if not (List.mem nt grammar_ext.gramext_globals) then + if not (List.mem nt !gramext_globals) then locals := StringSet.add nt !locals; let level = (get_label rule.grule_label) in let level = if level <> "" then level else @@ -625,8 +635,11 @@ let read_mlg g is_edit ast file level_renames symdef_map = if cur_level <> nt && i+1 < len then edited @ [[Snterm next_level]] else - edited in - add_prods cur_level prods_to_add) + edited + in + if cur_level <> nt && List.mem nt !gramext_globals then + gramext_globals := cur_level :: !gramext_globals; + add_prods cur_level prods_to_add !gramext_globals) ent.gentry_rules ) grammar_ext.gramext_entries @@ -636,16 +649,16 @@ let read_mlg g is_edit ast file level_renames symdef_map = | Some c -> String.trim c.code in add_prods node - (List.map (fun r -> cvt_ext r.vernac_toks) vernac_ext.vernacext_rules) + (List.map (fun r -> cvt_ext r.vernac_toks) vernac_ext.vernacext_rules) [] | VernacArgumentExt vernac_argument_ext -> add_prods vernac_argument_ext.vernacargext_name - (List.map (fun r -> cvt_ext r.tac_toks) vernac_argument_ext.vernacargext_rules) + (List.map (fun r -> cvt_ext r.tac_toks) vernac_argument_ext.vernacargext_rules) [] | TacticExt tactic_ext -> add_prods "simple_tactic" - (List.map (fun r -> cvt_ext r.tac_toks) tactic_ext.tacext_rules) + (List.map (fun r -> cvt_ext r.tac_toks) tactic_ext.tacext_rules) [] | ArgumentExt argument_ext -> add_prods argument_ext.argext_name - (List.map (fun r -> cvt_ext r.tac_toks) argument_ext.argext_rules) + (List.map (fun r -> cvt_ext r.tac_toks) argument_ext.argext_rules) [] | _ -> () in @@ -1191,6 +1204,15 @@ let edit_all_prods g op eprods = | "DELETE" -> do_it op eprods 1; true | "SPLICE" -> do_it op eprods 1; true | "MERGE" -> do_it op eprods 2; true + | "OPTINREF" -> + List.iter (fun nt -> + let prods = NTMap.find nt !g.map in + if has_match [] prods then begin + let prods' = remove_prod [] prods nt in + g_update_prods g nt prods'; + global_repl g [(Snterm nt)] [(Sopt (Snterm nt))] + end) + !g.order; true | "EXPAND" -> if List.length eprods > 1 || List.length (List.hd eprods) <> 0 then error "'EXPAND:' expects a single empty production\n"; @@ -1727,6 +1749,7 @@ let open_temp_bin file = let match_cmd_regex = Str.regexp "[a-zA-Z0-9_ ]+" let match_subscripts = Str.regexp "__[a-zA-Z0-9]+" +let remove_subscrs str = Str.global_replace match_subscripts "" str let find_longest_match prods str = let get_pfx str = String.trim (if Str.string_match match_cmd_regex str 0 then Str.matched_string str else "") in @@ -1740,7 +1763,6 @@ let find_longest_match prods str = in aux 0 in - let remove_subscrs str = Str.global_replace match_subscripts "" str in let slen = String.length str in let str_pfx = get_pfx str in @@ -1895,25 +1917,18 @@ let process_rst g file args seen tac_prods cmd_prods = (* "doc/sphinx/proof-engine/ssreflect-proof-language.rst"]*) (* in*) - let cmd_replace_files = [ - "doc/sphinx/language/core/records.rst"; - "doc/sphinx/language/core/sections.rst"; - "doc/sphinx/language/extensions/implicit-arguments.rst"; - "doc/sphinx/language/extensions/arguments-command.rst"; - "doc/sphinx/language/gallina-extensions.rst"; - "doc/sphinx/language/gallina-specification-language.rst"; - "doc/sphinx/language/using/libraries/funind.rst"; - "doc/sphinx/proof-engine/ltac.rst"; - "doc/sphinx/proof-engine/ltac2.rst"; - "doc/sphinx/proof-engine/vernacular-commands.rst"; - "doc/sphinx/user-extensions/syntax-extensions.rst"; - "doc/sphinx/proof-engine/vernacular-commands.rst" + let cmd_exclude_files = [ + "doc/sphinx/proof-engine/ssreflect-proof-language.rst"; + "doc/sphinx/proofs/automatic-tactics/auto.rst"; + "doc/sphinx/proofs/writing-proofs/rewriting.rst"; + "doc/sphinx/proofs/writing-proofs/proof-mode.rst"; + "doc/sphinx/proof-engine/tactics.rst"; ] in let save_n_get_more direc pfx first_rhs seen_map prods = let replace rhs prods = - if StringSet.is_empty prods || not (List.mem file cmd_replace_files) then + if StringSet.is_empty prods || (List.mem file cmd_exclude_files) then rhs (* no change *) else let mtch, multi, best = find_longest_match prods rhs in @@ -1921,12 +1936,15 @@ let process_rst g file args seen tac_prods cmd_prods = if mtch = rhs then rhs (* no change *) else if mtch = "" then begin - warn "%s line %d: NO MATCH `%s`\n" file !linenum rhs; - if best <> "" then - warn "%s line %d: BEST `%s`\n" file !linenum best; + error "%s line %d: NO MATCH for `%s`\n" file !linenum rhs; + if best <> "" then begin + Printf.eprintf " closest match is: `%s`\n" best; + Printf.eprintf " Please update the rst manually while preserving any subscripts, e.g. 'NT__sub'\n" + end; rhs end else if multi then begin - warn "%s line %d: MULTIMATCH `%s`\n" file !linenum rhs; + error "%s line %d: MULTIPLE MATCHES for `%s`\n" file !linenum rhs; + Printf.eprintf " Please update the rst manually while preserving any subscripts, e.g. 'NT__sub'\n"; rhs end else mtch (* update cmd/tacn *) @@ -1939,7 +1957,7 @@ let process_rst g file args seen tac_prods cmd_prods = fprintf new_rst "%s%s\n" pfx (replace first_rhs prods); - map := NTMap.add first_rhs (file, !linenum) !map; + map := NTMap.add (remove_subscrs first_rhs) (file, !linenum) !map; while let nextline = getline() in ignore (Str.string_match contin_regex nextline 0); @@ -2015,10 +2033,11 @@ let report_omitted_prods g seen label split = (if first = "" then nt else first), nt, n + 1, total + 1) ("", "", 0, 0) !g.order in maybe_warn first last n; -(* List.iter (fun nt -> - if not (NTMap.mem nt seen || (List.mem nt included)) then - warn "%s %s not included in .rst files\n" "Nonterminal" nt) - !g.order;*) + Printf.printf "\n\n"; + NTMap.iter (fun nt _ -> + if not (NTMap.mem nt seen || (List.mem nt included)) then + warn "%s %s not included in .rst files\n" "Nonterminal" nt) + !g.map; if total <> 0 then Printf.eprintf "TOTAL %ss not included = %d\n" label total @@ -2081,13 +2100,11 @@ let process_grammar args = print_in_order out g `MLG !g.order StringSet.empty; close_out out; finish_with_file (dir "orderedGrammar") args; - check_singletons g +(* check_singletons g*) (* print_dominated g*) - end; - let seen = ref { nts=NTMap.empty; tacs=NTMap.empty; tacvs=NTMap.empty; cmds=NTMap.empty; cmdvs=NTMap.empty } in - let args = { args with no_update = false } in (* always update rsts in place for now *) - if !exit_code = 0 then begin + let seen = ref { nts=NTMap.empty; tacs=NTMap.empty; tacvs=NTMap.empty; cmds=NTMap.empty; cmdvs=NTMap.empty } in + let args = { args with no_update = false } in (* always update rsts in place for now *) let plist nt = let list = (List.map (fun t -> String.trim (prod_to_prodn t)) (NTMap.find nt !g.map)) in @@ -2098,7 +2115,6 @@ let process_grammar args = report_omitted_prods g !seen.nts "Nonterminal" ""; let out = open_out (dir "updated_rsts") in close_out out; - end; (* if args.check_tacs then @@ -2107,7 +2123,6 @@ let process_grammar args = report_omitted_prods cmd_list !seen.cmds "Command" "\n "; *) - if !exit_code = 0 then begin (* generate report on cmds or tacs *) let cmdReport outfile cmdStr cmd_nts cmds cmdvs = let rstCmds = StringSet.of_list (List.map (fun b -> let c, _ = b in c) (NTMap.bindings cmds)) in @@ -2116,7 +2131,7 @@ let process_grammar args = StringSet.union set (StringSet.of_list (List.map (fun p -> String.trim (prod_to_prodn p)) (NTMap.find nt !prodn_gram.map))) ) StringSet.empty cmd_nts in let allCmds = StringSet.union rstCmdvs (StringSet.union rstCmds gramCmds) in - let out = open_temp_bin (dir outfile) in + let out = open_out_bin (dir outfile) in StringSet.iter (fun c -> let rsts = StringSet.mem c rstCmds in let gram = StringSet.mem c gramCmds in @@ -2130,7 +2145,6 @@ let process_grammar args = fprintf out "%s%s %s\n" pfx var c) allCmds; close_out out; - finish_with_file (dir outfile) args; Printf.printf "# %s in rsts, gram, total = %d %d %d\n" cmdStr (StringSet.cardinal gramCmds) (StringSet.cardinal rstCmds) (StringSet.cardinal allCmds); in @@ -2142,17 +2156,16 @@ let process_grammar args = let tac_nts = ["simple_tactic"] in if args.check_tacs then - cmdReport "prodnTactics" "tacs" tac_nts !seen.tacs !seen.tacvs - end; + cmdReport "prodnTactics" "tacs" tac_nts !seen.tacs !seen.tacvs; - (* generate prodnGrammar for reference *) - if !exit_code = 0 && not args.verify then begin - let out = open_temp_bin (dir "prodnGrammar") in - print_in_order out prodn_gram `PRODN !prodn_gram.order StringSet.empty; - close_out out; - finish_with_file (dir "prodnGrammar") args - end - end + (* generate prodnGrammar for reference *) + if not args.verify then begin + let out = open_out_bin (dir "prodnGrammar") in + print_in_order out prodn_gram `PRODN !prodn_gram.order StringSet.empty; + close_out out; + end + end (* if !exit_code = 0 *) + end (* if not args.fullGrammar *) let parse_args () = let suffix_regex = Str.regexp ".*\\.\\([a-z]+\\)$" in @@ -2182,5 +2195,7 @@ let () = if !exit_code = 0 then begin process_grammar args end; + if !error_count > 0 then + Printf.eprintf "%d error(s)\n" !error_count; exit !exit_code (*with _ -> Printexc.print_backtrace stdout; exit 1*) 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 73641976e3..033ece04de 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -17,7 +17,7 @@ constr_pattern: [ | constr ] -lconstr_pattern: [ +cpattern: [ | lconstr ] @@ -58,67 +58,68 @@ universe: [ ] lconstr: [ -| operconstr200 +| term200 ] constr: [ -| operconstr8 -| "@" global univ_instance +| term8 +| "@" global univ_annot ] -operconstr200: [ +term200: [ | binder_constr -| operconstr100 +| term100 ] -operconstr100: [ -| operconstr99 "<:" operconstr200 -| operconstr99 "<<:" operconstr200 -| operconstr99 ":" operconstr200 -| operconstr99 ":>" -| operconstr99 +term100: [ +| term99 "<:" term200 +| term99 "<<:" term200 +| term99 ":" term200 +| term99 ":>" +| term99 ] -operconstr99: [ -| operconstr90 +term99: [ +| term90 ] -operconstr90: [ -| operconstr10 +term90: [ +| term10 ] -operconstr10: [ -| operconstr9 LIST1 appl_arg -| "@" global univ_instance LIST0 operconstr9 -| "@" pattern_identref LIST1 identref -| operconstr9 +term10: [ +| term9 LIST1 arg +| "@" global univ_annot LIST0 term9 +| "@" pattern_ident LIST1 identref +| term9 ] -operconstr9: [ -| ".." operconstr0 ".." -| operconstr8 +term9: [ +| ".." term0 ".." +| term8 ] -operconstr8: [ -| operconstr1 +term8: [ +| term1 ] -operconstr1: [ -| operconstr0 ".(" global LIST0 appl_arg ")" -| operconstr0 ".(" "@" global LIST0 ( operconstr9 ) ")" -| operconstr0 "%" IDENT -| operconstr0 +term1: [ +| term0 ".(" global LIST0 arg ")" +| term0 ".(" "@" global LIST0 ( term9 ) ")" +| term0 "%" IDENT +| term0 ] -operconstr0: [ +term0: [ | atomic_constr -| match_constr -| "(" operconstr200 ")" +| term_match +| "(" term200 ")" | "{|" record_declaration bar_cbrace | "{" binder_constr "}" -| "`{" operconstr200 "}" -| test_array_opening "[" "|" array_elems "|" lconstr type_cstr test_array_closing "|" "]" univ_instance -| "`(" operconstr200 ")" +| "`{" term200 "}" +| test_array_opening "[" "|" array_elems "|" lconstr type_cstr test_array_closing "|" "]" univ_annot +| "`(" term200 ")" +| "ltac" ":" "(" Pltac.ltac_expr ")" ] array_elems: [ @@ -140,38 +141,43 @@ field_def: [ ] binder_constr: [ -| "forall" open_binders "," operconstr200 -| "fun" open_binders "=>" operconstr200 -| "let" name binders let_type_cstr ":=" operconstr200 "in" operconstr200 -| "let" "fix" fix_decl "in" operconstr200 -| "let" "cofix" cofix_decl "in" operconstr200 -| "let" [ "(" LIST0 name SEP "," ")" | "()" ] return_type ":=" operconstr200 "in" operconstr200 -| "let" "'" pattern200 ":=" operconstr200 "in" operconstr200 -| "let" "'" pattern200 ":=" operconstr200 case_type "in" operconstr200 -| "let" "'" pattern200 "in" pattern200 ":=" operconstr200 case_type "in" operconstr200 -| "if" operconstr200 return_type "then" operconstr200 "else" operconstr200 +| "forall" open_binders "," term200 +| "fun" open_binders "=>" term200 +| "let" name binders let_type_cstr ":=" term200 "in" term200 +| "let" "fix" fix_decl "in" term200 +| "let" "cofix" cofix_body "in" term200 +| "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" term200 "in" term200 +| "let" "'" pattern200 ":=" term200 "in" term200 +| "let" "'" pattern200 ":=" term200 case_type "in" term200 +| "let" "'" pattern200 "in" pattern200 ":=" term200 case_type "in" term200 +| "if" term200 as_return_type "then" term200 "else" term200 | "fix" fix_decls | "cofix" cofix_decls +| "if" term200 "is" ssr_dthen ssr_else (* SSR plugin *) +| "if" term200 "isn't" ssr_dthen ssr_else (* SSR plugin *) +| "let" ":" ssr_mpat ":=" lconstr "in" lconstr (* SSR plugin *) +| "let" ":" ssr_mpat ":=" lconstr ssr_rtype "in" lconstr (* SSR plugin *) +| "let" ":" ssr_mpat "in" pattern200 ":=" lconstr ssr_rtype "in" lconstr (* SSR plugin *) ] -appl_arg: [ -| test_lpar_id_coloneq "(" ident ":=" lconstr ")" -| operconstr9 +arg: [ +| test_lpar_id_coloneq "(" identref ":=" lconstr ")" +| term9 ] atomic_constr: [ -| global univ_instance +| global univ_annot | sort | NUMBER | string | "_" -| "?" "[" ident "]" +| "?" "[" identref "]" | "?" "[" pattern_ident "]" | pattern_ident evar_instance ] inst: [ -| ident ":=" lconstr +| identref ":=" lconstr ] evar_instance: [ @@ -179,7 +185,7 @@ evar_instance: [ | ] -univ_instance: [ +univ_annot: [ | "@{" LIST0 universe_level "}" | ] @@ -198,31 +204,31 @@ fix_decls: [ ] cofix_decls: [ -| cofix_decl -| cofix_decl "with" LIST1 cofix_decl SEP "with" "for" identref +| cofix_body +| cofix_body "with" LIST1 cofix_body SEP "with" "for" identref ] fix_decl: [ -| identref binders_fixannot type_cstr ":=" operconstr200 +| identref binders_fixannot type_cstr ":=" term200 ] -cofix_decl: [ -| identref binders type_cstr ":=" operconstr200 +cofix_body: [ +| identref binders type_cstr ":=" term200 ] -match_constr: [ +term_match: [ | "match" LIST1 case_item SEP "," OPT case_type "with" branches "end" ] case_item: [ -| operconstr100 OPT [ "as" name ] OPT [ "in" pattern200 ] +| term100 OPT [ "as" name ] OPT [ "in" pattern200 ] ] case_type: [ -| "return" operconstr100 +| "return" term100 ] -return_type: [ +as_return_type: [ | OPT [ OPT [ "as" name ] case_type ] ] @@ -253,7 +259,7 @@ pattern200: [ ] pattern100: [ -| pattern99 ":" operconstr200 +| pattern99 ":" term200 | pattern99 ] @@ -308,6 +314,7 @@ open_binders: [ binders: [ | LIST0 binder +| Pcoq.Constr.binders ] binder: [ @@ -332,13 +339,14 @@ closed_binder: [ | "`{" LIST1 typeclass_constraint SEP "," "}" | "`[" LIST1 typeclass_constraint SEP "," "]" | "'" pattern0 +| [ "of" | "&" ] term99 (* SSR plugin *) ] typeclass_constraint: [ -| "!" operconstr200 -| "{" name "}" ":" [ "!" | ] operconstr200 -| test_name_colon name ":" [ "!" | ] operconstr200 -| operconstr200 +| "!" term200 +| "{" name "}" ":" [ "!" | ] term200 +| test_name_colon name ":" [ "!" | ] term200 +| term200 ] type_cstr: [ @@ -362,16 +370,12 @@ pattern_ident: [ | LEFTQMARK ident ] -pattern_identref: [ -| pattern_ident -] - -var: [ +identref: [ | ident ] -identref: [ -| ident +hyp: [ +| identref ] field: [ @@ -510,7 +514,7 @@ command: [ | "Remove" "Hints" LIST1 global opt_hintbases | "Hint" hint opt_hintbases | "Comments" LIST0 comment -| "Declare" "Instance" ident_decl binders ":" operconstr200 hint_info +| "Declare" "Instance" ident_decl binders ":" term200 hint_info | "Declare" "Scope" IDENT | "Pwd" | "Cd" @@ -529,13 +533,13 @@ command: [ | "Print" "Namespace" dirpath | "Inspect" natural | "Add" "ML" "Path" ne_string -| "Set" option_table option_setting -| "Unset" option_table -| "Print" "Table" option_table +| "Set" setting_name option_setting +| "Unset" setting_name +| "Print" "Table" setting_name | "Add" IDENT IDENT LIST1 table_value | "Add" IDENT LIST1 table_value -| "Test" option_table "for" LIST1 table_value -| "Test" option_table +| "Test" setting_name "for" LIST1 table_value +| "Test" setting_name | "Remove" IDENT IDENT LIST1 table_value | "Remove" IDENT LIST1 table_value | "Write" "State" IDENT @@ -573,7 +577,7 @@ command: [ | "Show" "Extraction" (* extraction plugin *) | "Set" "Firstorder" "Solver" tactic | "Print" "Firstorder" "Solver" -| "Function" LIST1 function_rec_definition_loc SEP "with" (* funind plugin *) +| "Function" LIST1 function_fix_definition SEP "with" (* funind plugin *) | "Functional" "Scheme" LIST1 fun_scheme_arg SEP "with" (* funind plugin *) | "Functional" "Case" fun_scheme_arg (* funind plugin *) | "Generate" "graph" "for" reference (* funind plugin *) @@ -596,9 +600,9 @@ command: [ | "Optimize" "Proof" | "Optimize" "Heap" | "Hint" "Cut" "[" hints_path "]" opthints -| "Typeclasses" "Transparent" LIST0 reference -| "Typeclasses" "Opaque" LIST0 reference -| "Typeclasses" "eauto" ":=" debug eauto_search_strategy OPT integer +| "Typeclasses" "Transparent" LIST1 reference +| "Typeclasses" "Opaque" LIST1 reference +| "Typeclasses" "eauto" ":=" debug eauto_search_strategy OPT natural | "Proof" "with" Pltac.tactic OPT [ "using" G_vernac.section_subset_expr ] | "Proof" "using" G_vernac.section_subset_expr OPT [ "with" Pltac.tactic ] | "Tactic" "Notation" OPT ltac_tactic_level LIST1 ltac_production_item ":=" tactic @@ -615,6 +619,7 @@ command: [ | "Solve" "Obligation" natural "of" ident "with" tactic | "Solve" "Obligation" natural "with" tactic | "Solve" "Obligations" "of" ident "with" tactic +| "Solve" "Obligations" "of" ident | "Solve" "Obligations" "with" tactic | "Solve" "Obligations" | "Solve" "All" "Obligations" "with" tactic @@ -635,20 +640,20 @@ command: [ | "Add" "Relation" constr constr "reflexivity" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident | "Add" "Relation" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident | "Add" "Relation" constr constr "transitivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "reflexivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "as" ident -| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "symmetry" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "reflexivity" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "transitivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" binders ":" constr constr "as" ident +| "Add" "Parametric" "Relation" binders ":" constr constr "symmetry" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" binders ":" constr constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" binders ":" constr constr "transitivity" "proved" "by" constr "as" ident | "Add" "Setoid" constr constr constr "as" ident -| "Add" "Parametric" "Setoid" G_REWRITE_binders ":" constr constr constr "as" ident +| "Add" "Parametric" "Setoid" binders ":" constr constr constr "as" ident | "Add" "Morphism" constr ":" ident | "Declare" "Morphism" constr ":" ident | "Add" "Morphism" constr "with" "signature" lconstr "as" ident -| "Add" "Parametric" "Morphism" G_REWRITE_binders ":" constr "with" "signature" lconstr "as" ident +| "Add" "Parametric" "Morphism" binders ":" constr "with" "signature" lconstr "as" ident | "Print" "Rewrite" "HintDb" preident | "Reset" "Ltac" "Profile" | "Show" "Ltac" "Profile" @@ -689,11 +694,15 @@ command: [ | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" constr OPT field_mods (* ring plugin *) | "Print" "Fields" (* ring plugin *) -| "Number" "Notation" reference reference reference ":" ident numnotoption -| "Numeral" "Notation" reference reference reference ":" ident numnotoption -| "String" "Notation" reference reference reference ":" ident +| "Prenex" "Implicits" LIST1 global (* SSR plugin *) +| "Print" "Hint" "View" ssrviewpos (* SSR plugin *) +| "Hint" "View" ssrviewposspc LIST1 ssrhintref (* SSR plugin *) +| "Search" ssr_search_arg ssr_modlocs (* SSR plugin *) +| "Number" "Notation" reference reference reference OPT number_options ":" ident +| "Numeral" "Notation" reference reference reference ":" ident deprecated_number_modifier +| "String" "Notation" reference reference reference OPT string_option ":" ident | "Ltac2" ltac2_entry (* Ltac2 plugin *) -| "Ltac2" "Eval" ltac2_expr (* Ltac2 plugin *) +| "Ltac2" "Eval" ltac2_expr6 (* Ltac2 plugin *) | "Print" "Ltac2" reference (* Ltac2 plugin *) ] @@ -716,6 +725,7 @@ hint: [ | "Mode" global mode | "Unfold" LIST1 global | "Constructors" LIST1 global +| "Extern" natural OPT Constr.constr_pattern "=>" Pltac.tactic ] constr_body: [ @@ -748,10 +758,11 @@ attribute_list: [ ] attribute: [ -| ident attribute_value +| ident attr_value +| "using" attr_value ] -attribute_value: [ +attr_value: [ | "=" string | "(" attribute_list ")" | @@ -798,10 +809,10 @@ gallina: [ | def_token ident_decl def_body | "Let" ident_decl def_body | finite_token LIST1 inductive_definition SEP "with" -| "Fixpoint" LIST1 rec_definition SEP "with" -| "Let" "Fixpoint" LIST1 rec_definition SEP "with" -| "CoFixpoint" LIST1 corec_definition SEP "with" -| "Let" "CoFixpoint" LIST1 corec_definition SEP "with" +| "Fixpoint" LIST1 fix_definition SEP "with" +| "Let" "Fixpoint" LIST1 fix_definition SEP "with" +| "CoFixpoint" LIST1 cofix_definition SEP "with" +| "Let" "CoFixpoint" LIST1 cofix_definition SEP "with" | "Scheme" LIST1 scheme SEP "with" | "Combined" "Scheme" identref "from" LIST1 identref SEP "," | "Register" global "as" qualid @@ -900,7 +911,7 @@ decl_notations: [ ] opt_constructors_or_fields: [ -| ":=" constructor_list_or_record_decl +| ":=" constructors_or_record | ] @@ -908,7 +919,7 @@ inductive_definition: [ | opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" lconstr ] opt_constructors_or_fields decl_notations ] -constructor_list_or_record_decl: [ +constructors_or_record: [ | "|" LIST1 constructor SEP "|" | identref constructor_type "|" LIST1 constructor SEP "|" | identref constructor_type @@ -922,11 +933,11 @@ opt_coercion: [ | ] -rec_definition: [ +fix_definition: [ | ident_decl binders_fixannot type_cstr OPT [ ":=" lconstr ] decl_notations ] -corec_definition: [ +cofix_definition: [ | ident_decl binders type_cstr OPT [ ":=" lconstr ] decl_notations ] @@ -953,39 +964,39 @@ record_fields: [ | ] -record_binder_body: [ -| binders of_type_with_opt_coercion lconstr -| binders of_type_with_opt_coercion lconstr ":=" lconstr +field_body: [ +| binders of_type lconstr +| binders of_type lconstr ":=" lconstr | binders ":=" lconstr ] record_binder: [ | name -| name record_binder_body +| name field_body ] assum_list: [ | LIST1 assum_coe -| simple_assum_coe +| assumpt ] assum_coe: [ -| "(" simple_assum_coe ")" +| "(" assumpt ")" ] -simple_assum_coe: [ -| LIST1 ident_decl of_type_with_opt_coercion lconstr +assumpt: [ +| LIST1 ident_decl of_type lconstr ] constructor_type: [ -| binders [ of_type_with_opt_coercion lconstr | ] +| binders [ of_type lconstr | ] ] constructor: [ | identref constructor_type ] -of_type_with_opt_coercion: [ +of_type: [ | ":>" | ":" ">" | ":" @@ -1014,16 +1025,17 @@ gallina_ext: [ | "Coercion" global ":" class_rawexpr ">->" class_rawexpr | "Coercion" by_notation ":" class_rawexpr ">->" class_rawexpr | "Context" LIST1 binder -| "Instance" instance_name ":" operconstr200 hint_info [ ":=" "{" record_declaration "}" | ":=" lconstr | ] +| "Instance" instance_name ":" term200 hint_info [ ":=" "{" record_declaration "}" | ":=" lconstr | ] | "Existing" "Instance" global hint_info | "Existing" "Instances" LIST1 global OPT [ "|" natural ] | "Existing" "Class" global -| "Arguments" smart_global LIST0 argument_spec_block OPT [ "," LIST1 [ LIST0 more_implicits_block ] SEP "," ] OPT [ ":" LIST1 arguments_modifier SEP "," ] +| "Arguments" smart_global LIST0 arg_specs OPT [ "," LIST1 [ LIST0 implicits_alt ] SEP "," ] OPT [ ":" LIST1 args_modifier SEP "," ] | "Implicit" "Type" reserv_list | "Implicit" "Types" reserv_list | "Generalizable" [ "All" "Variables" | "No" "Variables" | [ "Variable" | "Variables" ] LIST1 identref ] -| "Export" "Set" option_table option_setting -| "Export" "Unset" option_table +| "Export" "Set" setting_name option_setting +| "Export" "Unset" setting_name +| "Import" "Prenex" "Implicits" (* SSR plugin *) ] filtered_import: [ @@ -1145,7 +1157,7 @@ ssexpr0: [ | "(" ssexpr35 ")" "*" ] -arguments_modifier: [ +args_modifier: [ | "simpl" "nomatch" | "simpl" "never" | "default" "implicits" @@ -1167,7 +1179,7 @@ argument_spec: [ | OPT "!" name OPT scope_delimiter ] -argument_spec_block: [ +arg_specs: [ | argument_spec | "/" | "&" @@ -1176,7 +1188,7 @@ argument_spec_block: [ | "{" LIST1 argument_spec "}" OPT scope_delimiter ] -more_implicits_block: [ +implicits_alt: [ | name | "[" LIST1 name "]" | "{" LIST1 name "}" @@ -1285,7 +1297,7 @@ table_value: [ | STRING ] -option_table: [ +setting_name: [ | LIST1 IDENT ] @@ -1394,9 +1406,9 @@ syntax_modifier: [ | "only" "parsing" | "format" STRING OPT STRING | IDENT; "," LIST1 IDENT SEP "," "at" level -| IDENT; "at" level OPT constr_as_binder_kind -| IDENT constr_as_binder_kind -| IDENT syntax_extension_type +| IDENT; "at" level OPT binder_interp +| IDENT binder_interp +| IDENT explicit_subentry ] syntax_modifiers: [ @@ -1404,19 +1416,19 @@ syntax_modifiers: [ | ] -syntax_extension_type: [ +explicit_subentry: [ | "ident" | "global" | "bigint" | "binder" | "constr" -| "constr" at_level_opt OPT constr_as_binder_kind +| "constr" at_level_opt OPT binder_interp | "pattern" | "pattern" "at" "level" natural | "strict" "pattern" | "strict" "pattern" "at" "level" natural | "closed" "binder" -| "custom" IDENT at_level_opt OPT constr_as_binder_kind +| "custom" IDENT at_level_opt OPT binder_interp ] at_level_opt: [ @@ -1424,7 +1436,7 @@ at_level_opt: [ | ] -constr_as_binder_kind: [ +binder_interp: [ | "as" "ident" | "as" "pattern" | "as" "strict" "pattern" @@ -1551,7 +1563,7 @@ simple_tactic: [ | "notypeclasses" "refine" uconstr | "simple" "notypeclasses" "refine" uconstr | "solve_constraints" -| "subst" LIST1 var +| "subst" LIST1 hyp | "subst" | "simple" "subst" | "evar" test_lpar_id_colon "(" ident ":" lconstr ")" @@ -1611,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 @@ -1619,6 +1632,7 @@ simple_tactic: [ | "convert_concl_no_check" constr | "typeclasses" "eauto" "bfs" OPT int_or_var "with" LIST1 preident | "typeclasses" "eauto" OPT int_or_var "with" LIST1 preident +| "typeclasses" "eauto" "bfs" OPT int_or_var | "typeclasses" "eauto" OPT int_or_var | "head_of_constr" ident constr | "not_evar" constr @@ -1745,6 +1759,51 @@ simple_tactic: [ | "ring_lookup" tactic0 "[" LIST0 constr "]" LIST1 constr (* ring plugin *) | "field_lookup" tactic "[" LIST0 constr "]" LIST1 constr (* ring plugin *) | "rtauto" +| "by" ssrhintarg (* SSR plugin *) +| "clear" natural (* SSR plugin *) +| "move" ssrmovearg ssrrpat (* SSR plugin *) +| "move" ssrmovearg ssrclauses (* SSR plugin *) +| "move" ssrrpat (* SSR plugin *) +| "move" (* SSR plugin *) +| "case" ssrcasearg ssrclauses (* SSR plugin *) +| "case" (* SSR plugin *) +| "elim" ssrarg ssrclauses (* SSR plugin *) +| "elim" (* SSR plugin *) +| "apply" ssrapplyarg (* SSR plugin *) +| "apply" (* SSR plugin *) +| "exact" ssrexactarg (* SSR plugin *) +| "exact" (* SSR plugin *) +| "exact" "<:" lconstr (* SSR plugin *) +| "congr" ssrcongrarg (* SSR plugin *) +| "ssrinstancesofruleL2R" ssrterm (* SSR plugin *) +| "ssrinstancesofruleR2L" ssrterm (* SSR plugin *) +| "rewrite" ssrrwargs ssrclauses (* SSR plugin *) +| "unlock" ssrunlockargs ssrclauses (* SSR plugin *) +| "pose" ssrfixfwd (* SSR plugin *) +| "pose" ssrcofixfwd (* SSR plugin *) +| "pose" ssrfwdid ssrposefwd (* SSR plugin *) +| "set" ssrfwdid ssrsetfwd ssrclauses (* SSR plugin *) +| "abstract" ssrdgens (* SSR plugin *) +| "have" ssrhavefwdwbinders (* SSR plugin *) +| "have" "suff" ssrhpats_nobs ssrhavefwd (* SSR plugin *) +| "have" "suffices" ssrhpats_nobs ssrhavefwd (* SSR plugin *) +| "suff" "have" ssrhpats_nobs ssrhavefwd (* SSR plugin *) +| "suffices" "have" ssrhpats_nobs ssrhavefwd (* SSR plugin *) +| "suff" ssrsufffwd (* SSR plugin *) +| "suffices" ssrsufffwd (* SSR plugin *) +| "wlog" ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| "wlog" "suff" ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| "wlog" "suffices" ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| "without" "loss" ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| "without" "loss" "suff" ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| "without" "loss" "suffices" ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| "gen" "have" ssrclear ssr_idcomma ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| "generally" "have" ssrclear ssr_idcomma ssrhpats_nobs ssrwlogfwd ssrhint (* SSR plugin *) +| "under" ssrrwarg (* SSR plugin *) +| "under" ssrrwarg ssrintros_ne (* SSR plugin *) +| "under" ssrrwarg ssrintros_ne "do" ssrhint3arg (* SSR plugin *) +| "under" ssrrwarg "do" ssrhint3arg (* SSR plugin *) +| "ssrinstancesoftpat" G_SSRMATCHING_cpattern (* SSR plugin *) ] mlname: [ @@ -1765,9 +1824,7 @@ language: [ ] firstorder_using: [ -| "using" reference -| "using" reference "," LIST1 reference SEP "," -| "using" reference reference LIST0 reference +| "using" LIST1 reference SEP "," | ] @@ -1791,8 +1848,8 @@ auto_using': [ | (* funind plugin *) ] -function_rec_definition_loc: [ -| Vernac.rec_definition (* funind plugin *) +function_fix_definition: [ +| Vernac.fix_definition (* funind plugin *) ] fun_scheme_arg: [ @@ -1811,7 +1868,7 @@ EXTRAARGS_natural: [ occurrences: [ | LIST1 integer -| var +| hyp ] glob: [ @@ -1851,6 +1908,10 @@ by_arg_tac: [ in_clause: [ | in_clause' +| "*" occs +| "*" "|-" concl_occ +| LIST0 hypident_occ SEP "," "|-" concl_occ +| LIST0 hypident_occ SEP "," ] test_lpar_id_colon: [ @@ -1925,16 +1986,16 @@ eauto_search_strategy: [ ] tactic_then_last: [ -| "|" LIST0 ( OPT tactic_expr5 ) SEP "|" +| "|" LIST0 ( OPT ltac_expr5 ) SEP "|" | ] -tactic_then_gen: [ -| tactic_expr5 "|" tactic_then_gen -| tactic_expr5 ".." tactic_then_last +for_each_goal: [ +| ltac_expr5 "|" for_each_goal +| ltac_expr5 ".." tactic_then_last | ".." tactic_then_last -| tactic_expr5 -| "|" tactic_then_gen +| ltac_expr5 +| "|" for_each_goal | ] @@ -1942,61 +2003,70 @@ tactic_then_locality: [ | "[" OPT ">" ] -tactic_expr5: [ +ltac_expr5: [ | binder_tactic -| tactic_expr4 -] - -tactic_expr4: [ -| tactic_expr3 ";" binder_tactic -| tactic_expr3 ";" tactic_expr3 -| tactic_expr3 ";" tactic_then_locality tactic_then_gen "]" -| tactic_expr3 -] - -tactic_expr3: [ -| "try" tactic_expr3 -| "do" int_or_var tactic_expr3 -| "timeout" int_or_var tactic_expr3 -| "time" OPT string tactic_expr3 -| "repeat" tactic_expr3 -| "progress" tactic_expr3 -| "once" tactic_expr3 -| "exactly_once" tactic_expr3 -| "infoH" tactic_expr3 -| "abstract" tactic_expr2 -| "abstract" tactic_expr2 "using" ident -| selector tactic_expr3 -| tactic_expr2 -] - -tactic_expr2: [ -| tactic_expr1 "+" binder_tactic -| tactic_expr1 "+" tactic_expr2 -| "tryif" tactic_expr5 "then" tactic_expr5 "else" tactic_expr2 -| tactic_expr1 "||" binder_tactic -| tactic_expr1 "||" tactic_expr2 -| tactic_expr1 -] - -tactic_expr1: [ +| ltac_expr4 +] + +ltac_expr4: [ +| ltac_expr3 ";" binder_tactic +| ltac_expr3 ";" ltac_expr3 +| ltac_expr3 ";" tactic_then_locality for_each_goal "]" +| ltac_expr3 +| ltac_expr5 ";" "first" ssr_first_else (* SSR plugin *) +| ltac_expr5 ";" "first" ssrseqarg (* SSR plugin *) +| ltac_expr5 ";" "last" ssrseqarg (* SSR plugin *) +] + +ltac_expr3: [ +| "try" ltac_expr3 +| "do" int_or_var ltac_expr3 +| "timeout" int_or_var ltac_expr3 +| "time" OPT string ltac_expr3 +| "repeat" ltac_expr3 +| "progress" ltac_expr3 +| "once" ltac_expr3 +| "exactly_once" ltac_expr3 +| "infoH" ltac_expr3 +| "abstract" ltac_expr2 +| "abstract" ltac_expr2 "using" ident +| "only" selector ":" ltac_expr3 +| ltac_expr2 +| "do" ssrmmod ssrdotac ssrclauses (* SSR plugin *) +| "do" ssrortacarg ssrclauses (* SSR plugin *) +| "do" int_or_var ssrmmod ssrdotac ssrclauses (* SSR plugin *) +| "abstract" ssrdgens (* SSR plugin *) +] + +ltac_expr2: [ +| ltac_expr1 "+" binder_tactic +| ltac_expr1 "+" ltac_expr2 +| "tryif" ltac_expr5 "then" ltac_expr5 "else" ltac_expr2 +| ltac_expr1 "||" binder_tactic +| ltac_expr1 "||" ltac_expr2 +| ltac_expr1 +] + +ltac_expr1: [ | match_key "goal" "with" match_context_list "end" | match_key "reverse" "goal" "with" match_context_list "end" -| match_key tactic_expr5 "with" match_list "end" -| "first" "[" LIST0 tactic_expr5 SEP "|" "]" -| "solve" "[" LIST0 tactic_expr5 SEP "|" "]" +| match_key ltac_expr5 "with" match_list "end" +| "first" "[" LIST0 ltac_expr5 SEP "|" "]" +| "solve" "[" LIST0 ltac_expr5 SEP "|" "]" | "idtac" LIST0 message_token | failkw [ int_or_var | ] LIST0 message_token | simple_tactic -| tactic_arg -| reference LIST0 tactic_arg_compat -| tactic_expr0 +| tactic_value +| reference LIST0 tactic_arg +| ltac_expr0 +| ltac_expr5 ssrintros_ne (* SSR plugin *) ] -tactic_expr0: [ -| "(" tactic_expr5 ")" -| "[" ">" tactic_then_gen "]" +ltac_expr0: [ +| "(" ltac_expr5 ")" +| "[" ">" for_each_goal "]" | tactic_atom +| ssrparentacarg (* SSR plugin *) ] failkw: [ @@ -2005,17 +2075,17 @@ failkw: [ ] binder_tactic: [ -| "fun" LIST1 input_fun "=>" tactic_expr5 -| "let" [ "rec" | ] LIST1 let_clause SEP "with" "in" tactic_expr5 +| "fun" LIST1 input_fun "=>" ltac_expr5 +| "let" [ "rec" | ] LIST1 let_clause SEP "with" "in" ltac_expr5 ] -tactic_arg_compat: [ -| tactic_arg +tactic_arg: [ +| tactic_value | Constr.constr | "()" ] -tactic_arg: [ +tactic_value: [ | constr_eval | "fresh" LIST0 fresh_id | "type_term" uconstr @@ -2056,26 +2126,26 @@ input_fun: [ ] let_clause: [ -| identref ":=" tactic_expr5 -| "_" ":=" tactic_expr5 -| identref LIST1 input_fun ":=" tactic_expr5 +| identref ":=" ltac_expr5 +| "_" ":=" ltac_expr5 +| identref LIST1 input_fun ":=" ltac_expr5 ] match_pattern: [ -| "context" OPT Constr.ident "[" Constr.lconstr_pattern "]" -| Constr.lconstr_pattern +| "context" OPT Constr.ident "[" Constr.cpattern "]" +| Constr.cpattern ] -match_hyps: [ +match_hyp: [ | name ":" match_pattern | name ":=" "[" match_pattern "]" ":" match_pattern | name ":=" match_pattern ] match_context_rule: [ -| LIST0 match_hyps SEP "," "|-" match_pattern "=>" tactic_expr5 -| "[" LIST0 match_hyps SEP "," "|-" match_pattern "]" "=>" tactic_expr5 -| "_" "=>" tactic_expr5 +| LIST0 match_hyp SEP "," "|-" match_pattern "=>" ltac_expr5 +| "[" LIST0 match_hyp SEP "," "|-" match_pattern "]" "=>" ltac_expr5 +| "_" "=>" ltac_expr5 ] match_context_list: [ @@ -2084,8 +2154,8 @@ match_context_list: [ ] match_rule: [ -| match_pattern "=>" tactic_expr5 -| "_" "=>" tactic_expr5 +| match_pattern "=>" ltac_expr5 +| "_" "=>" ltac_expr5 ] match_list: [ @@ -2105,12 +2175,12 @@ ltac_def_kind: [ ] tacdef_body: [ -| Constr.global LIST1 input_fun ltac_def_kind tactic_expr5 -| Constr.global ltac_def_kind tactic_expr5 +| Constr.global LIST1 input_fun ltac_def_kind ltac_expr5 +| Constr.global ltac_def_kind ltac_expr5 ] tactic: [ -| tactic_expr5 +| ltac_expr5 ] range_selector: [ @@ -2123,17 +2193,13 @@ range_selector_or_nth: [ | natural OPT [ "," LIST1 range_selector SEP "," ] ] -selector_body: [ +selector: [ | range_selector_or_nth | test_bracket_ident "[" ident "]" ] -selector: [ -| "only" selector_body ":" -] - toplevel_selector: [ -| selector_body ":" +| selector ":" | "!" ":" | "all" ":" ] @@ -2145,14 +2211,6 @@ tactic_mode: [ | "par" ":" OPT ltac_info tactic ltac_use_default ] -G_LTAC_hint: [ -| "Extern" natural OPT Constr.constr_pattern "=>" Pltac.tactic -] - -G_LTAC_operconstr0: [ -| "ltac" ":" "(" Pltac.tactic_expr ")" -] - ltac_selector: [ | toplevel_selector ] @@ -2223,10 +2281,6 @@ rewstrategy: [ | "fold" constr ] -G_REWRITE_binders: [ -| Pcoq.Constr.binders -] - int_or_var: [ | integer | identref @@ -2329,7 +2383,7 @@ intropattern: [ ] simple_intropattern: [ -| simple_intropattern_closed LIST0 [ "%" operconstr0 ] +| simple_intropattern_closed LIST0 [ "%" term0 ] ] simple_intropattern_closed: [ @@ -2358,7 +2412,7 @@ with_bindings: [ | ] -red_flags: [ +red_flag: [ | "beta" | "iota" | "match" @@ -2375,7 +2429,7 @@ delta_flag: [ ] strategy_flag: [ -| LIST1 red_flags +| LIST1 red_flag | delta_flag ] @@ -2399,32 +2453,27 @@ hypident: [ | id_or_meta | "(" "type" "of" id_or_meta ")" | "(" "value" "of" id_or_meta ")" +| "(" "type" "of" Prim.identref ")" (* SSR plugin *) +| "(" "value" "of" Prim.identref ")" (* SSR plugin *) ] hypident_occ: [ | hypident occs ] -G_TACTIC_in_clause: [ -| "*" occs -| "*" "|-" concl_occ -| LIST0 hypident_occ SEP "," "|-" concl_occ -| LIST0 hypident_occ SEP "," -] - clause_dft_concl: [ -| "in" G_TACTIC_in_clause +| "in" in_clause | occs | ] clause_dft_all: [ -| "in" G_TACTIC_in_clause +| "in" in_clause | ] opt_clause: [ -| "in" G_TACTIC_in_clause +| "in" in_clause | "at" occs_nums | ] @@ -2502,7 +2551,7 @@ as_name: [ ] by_tactic: [ -| "by" tactic_expr3 +| "by" ltac_expr3 | ] @@ -2555,12 +2604,630 @@ field_mods: [ | "(" LIST1 field_mod SEP "," ")" (* ring plugin *) ] -numnotoption: [ +ssrtacarg: [ +| ltac_expr5 (* SSR plugin *) +] + +ssrtac3arg: [ +| ltac_expr3 (* SSR plugin *) +] + +ssrtclarg: [ +| ssrtacarg (* SSR plugin *) +] + +ssrhyp: [ +| ident (* SSR plugin *) +] + +ssrhoi_hyp: [ +| ident (* SSR plugin *) +] + +ssrhoi_id: [ +| ident (* SSR plugin *) +] + +ssrsimpl_ne: [ +| "//=" (* SSR plugin *) +| "/=" (* SSR plugin *) +| test_ssrslashnum11 "/" natural "/" natural "=" (* SSR plugin *) +| test_ssrslashnum10 "/" natural "/" (* SSR plugin *) +| test_ssrslashnum10 "/" natural "=" (* SSR plugin *) +| test_ssrslashnum10 "/" natural "/=" (* SSR plugin *) +| test_ssrslashnum10 "/" natural "/" "=" (* SSR plugin *) +| test_ssrslashnum01 "//" natural "=" (* SSR plugin *) +| test_ssrslashnum00 "//" (* SSR plugin *) +] + +ssrclear_ne: [ +| "{" LIST1 ssrhyp "}" (* SSR plugin *) +] + +ssrclear: [ +| ssrclear_ne (* SSR plugin *) +| (* SSR plugin *) +] + +ssrindex: [ +] + +ssrocc: [ +| natural LIST0 natural (* SSR plugin *) +| "-" LIST0 natural (* SSR plugin *) +| "+" LIST0 natural (* SSR plugin *) +] + +ssrmmod: [ +| "!" (* SSR plugin *) +| LEFTQMARK (* SSR plugin *) +| "?" (* SSR plugin *) +] + +ssrmult_ne: [ +| natural ssrmmod (* SSR plugin *) +| ssrmmod (* SSR plugin *) +] + +ssrmult: [ +| ssrmult_ne (* SSR plugin *) +| (* SSR plugin *) +] + +ssrdocc: [ +| "{" ssrocc "}" (* SSR plugin *) +| "{" LIST0 ssrhyp "}" (* SSR plugin *) +] + +ssrterm: [ +| ssrtermkind Pcoq.Constr.constr (* SSR plugin *) +] + +ast_closure_term: [ +| term_annotation constr (* SSR plugin *) +] + +ast_closure_lterm: [ +| term_annotation lconstr (* SSR plugin *) +] + +ssrbwdview: [ +| test_not_ssrslashnum "/" Pcoq.Constr.constr (* SSR plugin *) +| test_not_ssrslashnum "/" Pcoq.Constr.constr ssrbwdview (* SSR plugin *) +] + +ssrfwdview: [ +| test_not_ssrslashnum "/" ast_closure_term (* SSR plugin *) +| test_not_ssrslashnum "/" ast_closure_term ssrfwdview (* SSR plugin *) +] + +ident_no_do: [ +| test_ident_no_do IDENT (* SSR plugin *) +] + +ssripat: [ +| "_" (* SSR plugin *) +| "*" (* SSR plugin *) +| ">" (* SSR plugin *) +| ident_no_do (* SSR plugin *) +| "?" (* SSR plugin *) +| "+" (* SSR plugin *) +| "++" (* SSR plugin *) +| ssrsimpl_ne (* SSR plugin *) +| ssrdocc "->" (* SSR plugin *) +| ssrdocc "<-" (* SSR plugin *) +| ssrdocc (* SSR plugin *) +| "->" (* SSR plugin *) +| "<-" (* SSR plugin *) +| "-" (* SSR plugin *) +| "-/" "=" (* SSR plugin *) +| "-/=" (* SSR plugin *) +| "-/" "/" (* SSR plugin *) +| "-//" (* SSR plugin *) +| "-/" integer "/" (* SSR plugin *) +| "-/" "/=" (* SSR plugin *) +| "-//" "=" (* SSR plugin *) +| "-//=" (* SSR plugin *) +| "-/" integer "/=" (* SSR plugin *) +| "-/" integer "/" integer "=" (* SSR plugin *) +| ssrfwdview (* SSR plugin *) +| "[" ":" LIST0 ident "]" (* SSR plugin *) +| "[:" LIST0 ident "]" (* SSR plugin *) +| ssrcpat (* SSR plugin *) +] + +ssripats: [ +| ssripat ssripats (* SSR plugin *) +| (* SSR plugin *) +] + +ssriorpat: [ +| ssripats "|" ssriorpat (* SSR plugin *) +| ssripats "|-" ">" ssriorpat (* SSR plugin *) +| ssripats "|-" ssriorpat (* SSR plugin *) +| ssripats "|->" ssriorpat (* SSR plugin *) +| ssripats "||" ssriorpat (* SSR plugin *) +| ssripats "|||" ssriorpat (* SSR plugin *) +| ssripats "||||" ssriorpat (* SSR plugin *) +| ssripats (* SSR plugin *) +] + +ssrcpat: [ +| test_nohidden "[" hat "]" (* SSR plugin *) +| test_nohidden "[" ssriorpat "]" (* SSR plugin *) +| test_nohidden "[=" ssriorpat "]" (* SSR plugin *) +] + +hat: [ +| "^" ident (* SSR plugin *) +| "^" "~" ident (* SSR plugin *) +| "^" "~" natural (* SSR plugin *) +| "^~" ident (* SSR plugin *) +| "^~" natural (* SSR plugin *) +] + +ssripats_ne: [ +| ssripat ssripats (* SSR plugin *) +] + +ssrhpats: [ +| ssripats (* SSR plugin *) +] + +ssrhpats_wtransp: [ +| ssripats (* SSR plugin *) +| ssripats "@" ssripats (* SSR plugin *) +] + +ssrhpats_nobs: [ +| ssripats (* SSR plugin *) +] + +ssrrpat: [ +| "->" (* SSR plugin *) +| "<-" (* SSR plugin *) +] + +ssrintros_ne: [ +| "=>" ssripats_ne (* SSR plugin *) +] + +ssrintros: [ +| ssrintros_ne (* SSR plugin *) +| (* SSR plugin *) +] + +ssrintrosarg: [ +] + +ssrfwdid: [ +| test_ssrfwdid Prim.ident (* SSR plugin *) +] + +ssrortacs: [ +| ssrtacarg "|" ssrortacs (* SSR plugin *) +| ssrtacarg "|" (* SSR plugin *) +| ssrtacarg (* SSR plugin *) +| "|" ssrortacs (* SSR plugin *) +| "|" (* SSR plugin *) +] + +ssrhintarg: [ +| "[" "]" (* SSR plugin *) +| "[" ssrortacs "]" (* SSR plugin *) +| ssrtacarg (* SSR plugin *) +] + +ssrhint3arg: [ +| "[" "]" (* SSR plugin *) +| "[" ssrortacs "]" (* SSR plugin *) +| ssrtac3arg (* SSR plugin *) +] + +ssrortacarg: [ +| "[" ssrortacs "]" (* SSR plugin *) +] + +ssrhint: [ +| (* SSR plugin *) +| "by" ssrhintarg (* SSR plugin *) +] + +ssrwgen: [ +| ssrclear_ne (* SSR plugin *) +| ssrhoi_hyp (* SSR plugin *) +| "@" ssrhoi_hyp (* SSR plugin *) +| "(" ssrhoi_id ":=" lcpattern ")" (* SSR plugin *) +| "(" ssrhoi_id ")" (* SSR plugin *) +| "(@" ssrhoi_id ":=" lcpattern ")" (* SSR plugin *) +| "(" "@" ssrhoi_id ":=" lcpattern ")" (* SSR plugin *) +] + +ssrclausehyps: [ +| ssrwgen "," ssrclausehyps (* SSR plugin *) +| ssrwgen ssrclausehyps (* SSR plugin *) +| ssrwgen (* SSR plugin *) +] + +ssrclauses: [ +| "in" ssrclausehyps "|-" "*" (* SSR plugin *) +| "in" ssrclausehyps "|-" (* SSR plugin *) +| "in" ssrclausehyps "*" (* SSR plugin *) +| "in" ssrclausehyps (* SSR plugin *) +| "in" "|-" "*" (* SSR plugin *) +| "in" "*" (* SSR plugin *) +| "in" "*" "|-" (* SSR plugin *) +| (* SSR plugin *) +] + +ssrfwd: [ +| ":=" ast_closure_lterm (* SSR plugin *) +| ":" ast_closure_lterm ":=" ast_closure_lterm (* SSR plugin *) +] + +ssrbvar: [ +| ident (* SSR plugin *) +| "_" (* SSR plugin *) +] + +ssrbinder: [ +| ssrbvar (* SSR plugin *) +| "(" ssrbvar ")" (* SSR plugin *) +| "(" ssrbvar ":" lconstr ")" (* SSR plugin *) +| "(" ssrbvar LIST1 ssrbvar ":" lconstr ")" (* SSR plugin *) +| "(" ssrbvar ":" lconstr ":=" lconstr ")" (* SSR plugin *) +| "(" ssrbvar ":=" lconstr ")" (* SSR plugin *) +| [ "of" | "&" ] term99 (* SSR plugin *) +] + +ssrstruct: [ +| "{" "struct" ident "}" (* SSR plugin *) +| (* SSR plugin *) +] + +ssrposefwd: [ +| LIST0 ssrbinder ssrfwd (* SSR plugin *) +] + +ssrfixfwd: [ +| "fix" ssrbvar LIST0 ssrbinder ssrstruct ssrfwd (* SSR plugin *) +] + +ssrcofixfwd: [ +| "cofix" ssrbvar LIST0 ssrbinder ssrfwd (* SSR plugin *) +] + +ssrsetfwd: [ +| ":" ast_closure_lterm ":=" "{" ssrocc "}" cpattern (* SSR plugin *) +| ":" ast_closure_lterm ":=" lcpattern (* SSR plugin *) +| ":=" "{" ssrocc "}" cpattern (* SSR plugin *) +| ":=" lcpattern (* SSR plugin *) +] + +ssrhavefwd: [ +| ":" ast_closure_lterm ssrhint (* SSR plugin *) +| ":" ast_closure_lterm ":=" ast_closure_lterm (* SSR plugin *) +| ":" ast_closure_lterm ":=" (* SSR plugin *) +| ":=" ast_closure_lterm (* SSR plugin *) +] + +ssrhavefwdwbinders: [ +| ssrhpats_wtransp LIST0 ssrbinder ssrhavefwd (* SSR plugin *) +] + +ssrdoarg: [ +] + +ssrseqarg: [ +| ssrswap (* SSR plugin *) +| ssrseqidx ssrortacarg OPT ssrorelse (* SSR plugin *) +| ssrseqidx ssrswap (* SSR plugin *) +| ltac_expr3 (* SSR plugin *) +] + +ssrseqidx: [ +| test_ssrseqvar Prim.ident (* SSR plugin *) +| Prim.natural (* SSR plugin *) +] + +ssrswap: [ +| "first" (* SSR plugin *) +| "last" (* SSR plugin *) +] + +ssrorelse: [ +| "||" ltac_expr2 (* SSR plugin *) +] + +Prim.ident: [ +| IDENT ssr_null_entry (* SSR plugin *) +] + +ssrparentacarg: [ +| "(" ltac_expr5 ")" (* SSR plugin *) +] + +ssrdotac: [ +| ltac_expr3 (* SSR plugin *) +| ssrortacarg (* SSR plugin *) +] + +ssrseqdir: [ +] + +ssr_first: [ +| ssr_first ssrintros_ne (* SSR plugin *) +| "[" LIST0 ltac_expr5 SEP "|" "]" (* SSR plugin *) +] + +ssr_first_else: [ +| ssr_first ssrorelse (* SSR plugin *) +| ssr_first (* SSR plugin *) +] + +ssrgen: [ +| ssrdocc cpattern (* SSR plugin *) +| cpattern (* SSR plugin *) +] + +ssrdgens_tl: [ +| "{" LIST1 ssrhyp "}" cpattern ssrdgens_tl (* SSR plugin *) +| "{" LIST1 ssrhyp "}" (* SSR plugin *) +| "{" ssrocc "}" cpattern ssrdgens_tl (* SSR plugin *) +| "/" ssrdgens_tl (* SSR plugin *) +| cpattern ssrdgens_tl (* SSR plugin *) +| (* SSR plugin *) +] + +ssrdgens: [ +| ":" ssrgen ssrdgens_tl (* SSR plugin *) +] + +ssreqid: [ +| test_ssreqid ssreqpat (* SSR plugin *) +| test_ssreqid (* SSR plugin *) +] + +ssreqpat: [ +| Prim.ident (* SSR plugin *) +| "_" (* SSR plugin *) +| "?" (* SSR plugin *) +| "+" (* SSR plugin *) +| ssrdocc "->" (* SSR plugin *) +| ssrdocc "<-" (* SSR plugin *) +| "->" (* SSR plugin *) +| "<-" (* SSR plugin *) +] + +ssrarg: [ +| ssrfwdview ssreqid ssrdgens ssrintros (* SSR plugin *) +| ssrfwdview ssrclear ssrintros (* SSR plugin *) +| ssreqid ssrdgens ssrintros (* SSR plugin *) +| ssrclear_ne ssrintros (* SSR plugin *) +| ssrintros_ne (* SSR plugin *) +] + +ssrmovearg: [ +| ssrarg (* SSR plugin *) +] + +ssrcasearg: [ +| ssrarg (* SSR plugin *) +] + +ssragen: [ +| "{" LIST1 ssrhyp "}" ssrterm (* SSR plugin *) +| ssrterm (* SSR plugin *) +] + +ssragens: [ +| "{" LIST1 ssrhyp "}" ssrterm ssragens (* SSR plugin *) +| "{" LIST1 ssrhyp "}" (* SSR plugin *) +| ssrterm ssragens (* SSR plugin *) +| (* SSR plugin *) +] + +ssrapplyarg: [ +| ":" ssragen ssragens ssrintros (* SSR plugin *) +| ssrclear_ne ssrintros (* SSR plugin *) +| ssrintros_ne (* SSR plugin *) +| ssrbwdview ":" ssragen ssragens ssrintros (* SSR plugin *) +| ssrbwdview ssrclear ssrintros (* SSR plugin *) +] + +ssrexactarg: [ +| ":" ssragen ssragens (* SSR plugin *) +| ssrbwdview ssrclear (* SSR plugin *) +| ssrclear_ne (* SSR plugin *) +] + +ssrcongrarg: [ +| natural constr ssrdgens (* SSR plugin *) +| natural constr (* SSR plugin *) +| constr ssrdgens (* SSR plugin *) +| constr (* SSR plugin *) +] + +ssrrwocc: [ +| "{" LIST0 ssrhyp "}" (* SSR plugin *) +| "{" ssrocc "}" (* SSR plugin *) +| (* SSR plugin *) +] + +ssrrule_ne: [ +| test_not_ssrslashnum [ "/" ssrterm | ssrterm | ssrsimpl_ne ] (* SSR plugin *) +| ssrsimpl_ne (* SSR plugin *) +] + +ssrrule: [ +| ssrrule_ne (* SSR plugin *) +| (* SSR plugin *) +] + +ssrpattern_squarep: [ +| "[" rpattern "]" (* SSR plugin *) +| (* SSR plugin *) +] + +ssrpattern_ne_squarep: [ +| "[" rpattern "]" (* SSR plugin *) +] + +ssrrwarg: [ +| "-" ssrmult ssrrwocc ssrpattern_squarep ssrrule_ne (* SSR plugin *) +| "-/" ssrterm (* SSR plugin *) +| ssrmult_ne ssrrwocc ssrpattern_squarep ssrrule_ne (* SSR plugin *) +| "{" LIST1 ssrhyp "}" ssrpattern_ne_squarep ssrrule_ne (* SSR plugin *) +| "{" LIST1 ssrhyp "}" ssrrule (* SSR plugin *) +| "{" ssrocc "}" ssrpattern_squarep ssrrule_ne (* SSR plugin *) +| "{" "}" ssrpattern_squarep ssrrule_ne (* SSR plugin *) +| ssrpattern_ne_squarep ssrrule_ne (* SSR plugin *) +| ssrrule_ne (* SSR plugin *) +] + +ssrrwargs: [ +| test_ssr_rw_syntax LIST1 ssrrwarg (* SSR plugin *) +] + +ssrunlockarg: [ +| "{" ssrocc "}" ssrterm (* SSR plugin *) +| ssrterm (* SSR plugin *) +] + +ssrunlockargs: [ +| LIST0 ssrunlockarg (* SSR plugin *) +] + +ssrsufffwd: [ +| ssrhpats LIST0 ssrbinder ":" ast_closure_lterm ssrhint (* SSR plugin *) +] + +ssrwlogfwd: [ +| ":" LIST0 ssrwgen "/" ast_closure_lterm (* SSR plugin *) +] + +ssr_idcomma: [ +| (* SSR plugin *) +| test_idcomma [ IDENT | "_" ] "," (* SSR plugin *) +] + +ssr_rtype: [ +| "return" term100 (* SSR plugin *) +] + +ssr_mpat: [ +| pattern200 (* SSR plugin *) +] + +ssr_dpat: [ +| ssr_mpat "in" pattern200 ssr_rtype (* SSR plugin *) +| ssr_mpat ssr_rtype (* SSR plugin *) +| ssr_mpat (* SSR plugin *) +] + +ssr_dthen: [ +| ssr_dpat "then" lconstr (* SSR plugin *) +] + +ssr_elsepat: [ +| "else" (* SSR plugin *) +] + +ssr_else: [ +| ssr_elsepat lconstr (* SSR plugin *) +] + +ssrhintref: [ +| constr (* SSR plugin *) +| constr "|" natural (* SSR plugin *) +] + +ssrviewpos: [ +| "for" "move" "/" (* SSR plugin *) +| "for" "apply" "/" (* SSR plugin *) +| "for" "apply" "/" "/" (* SSR plugin *) +| "for" "apply" "//" (* SSR plugin *) +| (* SSR plugin *) +] + +ssrviewposspc: [ +| ssrviewpos (* SSR plugin *) +] + +rpattern: [ +| lconstr (* SSR plugin *) +| "in" lconstr (* SSR plugin *) +| lconstr "in" lconstr (* SSR plugin *) +| "in" lconstr "in" lconstr (* SSR plugin *) +| lconstr "in" lconstr "in" lconstr (* SSR plugin *) +| lconstr "as" lconstr "in" lconstr (* SSR plugin *) +] + +G_SSRMATCHING_cpattern: [ +| "Qed" constr (* SSR plugin *) +| ssrtermkind constr (* SSR plugin *) +] + +lcpattern: [ +| "Qed" lconstr (* SSR plugin *) +| ssrtermkind lconstr (* SSR plugin *) +] + +ssrpatternarg: [ +| rpattern (* SSR plugin *) +] + +ssr_search_item: [ +| string (* SSR plugin *) +| string "%" preident (* SSR plugin *) +| constr_pattern (* SSR plugin *) +] + +ssr_search_arg: [ +| "-" ssr_search_item ssr_search_arg (* SSR plugin *) +| ssr_search_item ssr_search_arg (* SSR plugin *) +| (* SSR plugin *) +] + +ssr_modlocs: [ +| (* SSR plugin *) +| "in" LIST1 modloc (* SSR plugin *) +] + +modloc: [ +| "-" global (* SSR plugin *) +| global (* SSR plugin *) +] + +deprecated_number_modifier: [ | | "(" "warning" "after" bignat ")" | "(" "abstract" "after" bignat ")" ] +number_string_mapping: [ +| reference "=>" reference +| "[" reference "]" "=>" reference +] + +number_string_via: [ +| "via" reference "mapping" "[" LIST1 number_string_mapping SEP "," "]" +] + +number_modifier: [ +| "warning" "after" bignat +| "abstract" "after" bignat +| number_string_via +] + +number_options: [ +| "(" LIST1 number_modifier SEP "," ")" +] + +string_option: [ +| "(" number_string_via ")" +] + tac2pat1: [ | Prim.qualid LIST1 tac2pat0 (* Ltac2 plugin *) | Prim.qualid (* Ltac2 plugin *) @@ -2578,50 +3245,51 @@ tac2pat0: [ atomic_tac2pat: [ | (* Ltac2 plugin *) -| tac2pat1 ":" tac2type5 (* Ltac2 plugin *) +| tac2pat1 ":" ltac2_type5 (* Ltac2 plugin *) | tac2pat1 "," LIST0 tac2pat1 SEP "," (* Ltac2 plugin *) | tac2pat1 (* Ltac2 plugin *) ] -tac2expr6: [ -| tac2expr5 ";" tac2expr6 (* Ltac2 plugin *) -| tac2expr5 (* Ltac2 plugin *) +ltac2_expr6: [ +| ltac2_expr5 ";" ltac2_expr6 (* Ltac2 plugin *) +| ltac2_expr5 (* Ltac2 plugin *) ] -tac2expr5: [ -| "fun" LIST1 G_LTAC2_input_fun "=>" tac2expr6 (* Ltac2 plugin *) -| "let" rec_flag LIST1 G_LTAC2_let_clause SEP "with" "in" tac2expr6 (* Ltac2 plugin *) -| "match" tac2expr5 "with" G_LTAC2_branches "end" (* Ltac2 plugin *) -| tac2expr4 (* Ltac2 plugin *) +ltac2_expr5: [ +| "fun" LIST1 G_LTAC2_input_fun "=>" ltac2_expr6 (* Ltac2 plugin *) +| "let" rec_flag LIST1 G_LTAC2_let_clause SEP "with" "in" ltac2_expr6 (* Ltac2 plugin *) +| "match" ltac2_expr5 "with" G_LTAC2_branches "end" (* Ltac2 plugin *) +| "if" ltac2_expr5 "then" ltac2_expr5 "else" ltac2_expr5 (* Ltac2 plugin *) +| ltac2_expr4 (* Ltac2 plugin *) ] -tac2expr4: [ -| tac2expr3 (* Ltac2 plugin *) +ltac2_expr4: [ +| ltac2_expr3 (* Ltac2 plugin *) ] -tac2expr3: [ -| tac2expr2 "," LIST1 tac2expr2 SEP "," (* Ltac2 plugin *) -| tac2expr2 (* Ltac2 plugin *) +ltac2_expr3: [ +| ltac2_expr2 "," LIST1 ltac2_expr2 SEP "," (* Ltac2 plugin *) +| ltac2_expr2 (* Ltac2 plugin *) ] -tac2expr2: [ -| tac2expr1 "::" tac2expr2 (* Ltac2 plugin *) -| tac2expr1 (* Ltac2 plugin *) +ltac2_expr2: [ +| ltac2_expr1 "::" ltac2_expr2 (* Ltac2 plugin *) +| ltac2_expr1 (* Ltac2 plugin *) ] -tac2expr1: [ -| tac2expr0 LIST1 tac2expr0 (* Ltac2 plugin *) -| tac2expr0 ".(" Prim.qualid ")" (* Ltac2 plugin *) -| tac2expr0 ".(" Prim.qualid ")" ":=" tac2expr5 (* Ltac2 plugin *) -| tac2expr0 (* Ltac2 plugin *) +ltac2_expr1: [ +| ltac2_expr0 LIST1 ltac2_expr0 (* Ltac2 plugin *) +| ltac2_expr0 ".(" Prim.qualid ")" (* Ltac2 plugin *) +| ltac2_expr0 ".(" Prim.qualid ")" ":=" ltac2_expr5 (* Ltac2 plugin *) +| ltac2_expr0 (* Ltac2 plugin *) ] -tac2expr0: [ -| "(" tac2expr6 ")" (* Ltac2 plugin *) -| "(" tac2expr6 ":" tac2type5 ")" (* Ltac2 plugin *) +ltac2_expr0: [ +| "(" ltac2_expr6 ")" (* Ltac2 plugin *) +| "(" ltac2_expr6 ":" ltac2_type5 ")" (* Ltac2 plugin *) | "()" (* Ltac2 plugin *) | "(" ")" (* Ltac2 plugin *) -| "[" LIST0 tac2expr5 SEP ";" "]" (* Ltac2 plugin *) +| "[" LIST0 ltac2_expr5 SEP ";" "]" (* Ltac2 plugin *) | "{" tac2rec_fieldexprs "}" (* Ltac2 plugin *) | G_LTAC2_tactic_atom (* Ltac2 plugin *) ] @@ -2633,7 +3301,7 @@ G_LTAC2_branches: [ ] branch: [ -| tac2pat1 "=>" tac2expr6 (* Ltac2 plugin *) +| tac2pat1 "=>" ltac2_expr6 (* Ltac2 plugin *) ] rec_flag: [ @@ -2646,7 +3314,7 @@ mut_flag: [ | (* Ltac2 plugin *) ] -typ_param: [ +ltac2_typevar: [ | "'" Prim.ident (* Ltac2 plugin *) ] @@ -2660,48 +3328,48 @@ G_LTAC2_tactic_atom: [ | "constr" ":" "(" Constr.lconstr ")" (* Ltac2 plugin *) | "open_constr" ":" "(" Constr.lconstr ")" (* Ltac2 plugin *) | "ident" ":" "(" lident ")" (* Ltac2 plugin *) -| "pattern" ":" "(" Constr.lconstr_pattern ")" (* Ltac2 plugin *) +| "pattern" ":" "(" Constr.cpattern ")" (* Ltac2 plugin *) | "reference" ":" "(" globref ")" (* Ltac2 plugin *) | "ltac1" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) | "ltac1val" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) ] ltac1_expr_in_env: [ -| test_ltac1_env LIST0 locident "|-" ltac1_expr (* Ltac2 plugin *) -| ltac1_expr (* Ltac2 plugin *) +| test_ltac1_env LIST0 locident "|-" ltac_expr5 (* Ltac2 plugin *) +| ltac_expr5 (* Ltac2 plugin *) ] tac2expr_in_env: [ -| test_ltac1_env LIST0 locident "|-" tac2expr6 (* Ltac2 plugin *) -| tac2expr6 (* Ltac2 plugin *) +| test_ltac1_env LIST0 locident "|-" ltac2_expr6 (* Ltac2 plugin *) +| ltac2_expr6 (* Ltac2 plugin *) ] G_LTAC2_let_clause: [ -| let_binder ":=" tac2expr6 (* Ltac2 plugin *) +| let_binder ":=" ltac2_expr6 (* Ltac2 plugin *) ] let_binder: [ | LIST1 G_LTAC2_input_fun (* Ltac2 plugin *) ] -tac2type5: [ -| tac2type2 "->" tac2type5 (* Ltac2 plugin *) -| tac2type2 (* Ltac2 plugin *) +ltac2_type5: [ +| ltac2_type2 "->" ltac2_type5 (* Ltac2 plugin *) +| ltac2_type2 (* Ltac2 plugin *) ] -tac2type2: [ -| tac2type1 "*" LIST1 tac2type1 SEP "*" (* Ltac2 plugin *) -| tac2type1 (* Ltac2 plugin *) +ltac2_type2: [ +| ltac2_type1 "*" LIST1 ltac2_type1 SEP "*" (* Ltac2 plugin *) +| ltac2_type1 (* Ltac2 plugin *) ] -tac2type1: [ -| tac2type0 Prim.qualid (* Ltac2 plugin *) -| tac2type0 (* Ltac2 plugin *) +ltac2_type1: [ +| ltac2_type0 Prim.qualid (* Ltac2 plugin *) +| ltac2_type0 (* Ltac2 plugin *) ] -tac2type0: [ -| "(" LIST1 tac2type5 SEP "," ")" OPT Prim.qualid (* Ltac2 plugin *) -| typ_param (* Ltac2 plugin *) +ltac2_type0: [ +| "(" LIST1 ltac2_type5 SEP "," ")" OPT Prim.qualid (* Ltac2 plugin *) +| ltac2_typevar (* Ltac2 plugin *) | "_" (* Ltac2 plugin *) | Prim.qualid (* Ltac2 plugin *) ] @@ -2720,7 +3388,7 @@ G_LTAC2_input_fun: [ ] tac2def_body: [ -| G_LTAC2_binder LIST0 G_LTAC2_input_fun ":=" tac2expr6 (* Ltac2 plugin *) +| G_LTAC2_binder LIST0 G_LTAC2_input_fun ":=" ltac2_expr6 (* Ltac2 plugin *) ] tac2def_val: [ @@ -2728,11 +3396,11 @@ tac2def_val: [ ] tac2def_mut: [ -| "Set" Prim.qualid OPT [ "as" locident ] ":=" tac2expr6 (* Ltac2 plugin *) +| "Set" Prim.qualid OPT [ "as" locident ] ":=" ltac2_expr6 (* Ltac2 plugin *) ] tac2typ_knd: [ -| tac2type5 (* Ltac2 plugin *) +| ltac2_type5 (* Ltac2 plugin *) | "[" ".." "]" (* Ltac2 plugin *) | "[" tac2alg_constructors "]" (* Ltac2 plugin *) | "{" tac2rec_fields "}" (* Ltac2 plugin *) @@ -2745,7 +3413,7 @@ tac2alg_constructors: [ tac2alg_constructor: [ | Prim.ident (* Ltac2 plugin *) -| Prim.ident "(" LIST0 tac2type5 SEP "," ")" (* Ltac2 plugin *) +| Prim.ident "(" LIST0 ltac2_type5 SEP "," ")" (* Ltac2 plugin *) ] tac2rec_fields: [ @@ -2756,7 +3424,7 @@ tac2rec_fields: [ ] tac2rec_field: [ -| mut_flag Prim.ident ":" tac2type5 (* Ltac2 plugin *) +| mut_flag Prim.ident ":" ltac2_type5 (* Ltac2 plugin *) ] tac2rec_fieldexprs: [ @@ -2767,13 +3435,13 @@ tac2rec_fieldexprs: [ ] tac2rec_fieldexpr: [ -| Prim.qualid ":=" tac2expr1 (* Ltac2 plugin *) +| Prim.qualid ":=" ltac2_expr1 (* Ltac2 plugin *) ] tac2typ_prm: [ | (* Ltac2 plugin *) -| typ_param (* Ltac2 plugin *) -| "(" LIST1 typ_param SEP "," ")" (* Ltac2 plugin *) +| ltac2_typevar (* Ltac2 plugin *) +| "(" LIST1 ltac2_typevar SEP "," ")" (* Ltac2 plugin *) ] tac2typ_def: [ @@ -2791,7 +3459,7 @@ tac2def_typ: [ ] tac2def_ext: [ -| "@" "external" locident ":" tac2type5 ":=" Prim.string Prim.string (* Ltac2 plugin *) +| "@" "external" locident ":" ltac2_type5 ":=" Prim.string Prim.string (* Ltac2 plugin *) ] syn_node: [ @@ -2799,11 +3467,11 @@ syn_node: [ | Prim.ident (* Ltac2 plugin *) ] -sexpr: [ +ltac2_scope: [ | Prim.string (* Ltac2 plugin *) | Prim.integer (* Ltac2 plugin *) | syn_node (* Ltac2 plugin *) -| syn_node "(" LIST1 sexpr SEP "," ")" (* Ltac2 plugin *) +| syn_node "(" LIST1 ltac2_scope SEP "," ")" (* Ltac2 plugin *) ] syn_level: [ @@ -2812,7 +3480,7 @@ syn_level: [ ] tac2def_syn: [ -| "Notation" LIST1 sexpr syn_level ":=" tac2expr6 (* Ltac2 plugin *) +| "Notation" LIST1 ltac2_scope syn_level ":=" ltac2_expr6 (* Ltac2 plugin *) ] lident: [ @@ -3030,28 +3698,28 @@ q_rewriting: [ ] G_LTAC2_tactic_then_last: [ -| "|" LIST0 ( OPT tac2expr6 ) SEP "|" (* Ltac2 plugin *) +| "|" LIST0 ( OPT ltac2_expr6 ) SEP "|" (* Ltac2 plugin *) | (* Ltac2 plugin *) ] -G_LTAC2_tactic_then_gen: [ -| tac2expr6 "|" G_LTAC2_tactic_then_gen (* Ltac2 plugin *) -| tac2expr6 ".." G_LTAC2_tactic_then_last (* Ltac2 plugin *) +G_LTAC2_for_each_goal: [ +| ltac2_expr6 "|" G_LTAC2_for_each_goal (* Ltac2 plugin *) +| ltac2_expr6 ".." G_LTAC2_tactic_then_last (* Ltac2 plugin *) | ".." G_LTAC2_tactic_then_last (* Ltac2 plugin *) -| tac2expr6 (* Ltac2 plugin *) -| "|" G_LTAC2_tactic_then_gen (* Ltac2 plugin *) +| ltac2_expr6 (* Ltac2 plugin *) +| "|" G_LTAC2_for_each_goal (* Ltac2 plugin *) | (* Ltac2 plugin *) ] q_dispatch: [ -| G_LTAC2_tactic_then_gen (* Ltac2 plugin *) +| G_LTAC2_for_each_goal (* Ltac2 plugin *) ] q_occurrences: [ | G_LTAC2_occs (* Ltac2 plugin *) ] -red_flag: [ +ltac2_red_flag: [ | "beta" (* Ltac2 plugin *) | "iota" (* Ltac2 plugin *) | "match" (* Ltac2 plugin *) @@ -3082,7 +3750,7 @@ G_LTAC2_delta_flag: [ ] G_LTAC2_strategy_flag: [ -| LIST1 red_flag (* Ltac2 plugin *) +| LIST1 ltac2_red_flag (* Ltac2 plugin *) | G_LTAC2_delta_flag (* Ltac2 plugin *) ] @@ -3100,12 +3768,12 @@ q_hintdb: [ ] G_LTAC2_match_pattern: [ -| "context" OPT Prim.ident "[" Constr.lconstr_pattern "]" (* Ltac2 plugin *) -| Constr.lconstr_pattern (* Ltac2 plugin *) +| "context" OPT Prim.ident "[" Constr.cpattern "]" (* Ltac2 plugin *) +| Constr.cpattern (* Ltac2 plugin *) ] G_LTAC2_match_rule: [ -| G_LTAC2_match_pattern "=>" tac2expr6 (* Ltac2 plugin *) +| G_LTAC2_match_pattern "=>" ltac2_expr6 (* Ltac2 plugin *) ] G_LTAC2_match_list: [ @@ -3126,16 +3794,16 @@ gmatch_pattern: [ ] gmatch_rule: [ -| gmatch_pattern "=>" tac2expr6 (* Ltac2 plugin *) +| gmatch_pattern "=>" ltac2_expr6 (* Ltac2 plugin *) ] -gmatch_list: [ +goal_match_list: [ | LIST1 gmatch_rule SEP "|" (* Ltac2 plugin *) | "|" LIST1 gmatch_rule SEP "|" (* Ltac2 plugin *) ] q_goal_matching: [ -| gmatch_list (* Ltac2 plugin *) +| goal_match_list (* Ltac2 plugin *) ] move_location: [ @@ -3169,7 +3837,7 @@ G_LTAC2_as_ipat: [ ] G_LTAC2_by_tactic: [ -| "by" tac2expr6 (* Ltac2 plugin *) +| "by" ltac2_expr6 (* Ltac2 plugin *) | (* Ltac2 plugin *) ] @@ -3192,11 +3860,11 @@ ltac2_entry: [ ] ltac2_expr: [ -| tac2expr6 (* Ltac2 plugin *) +| _ltac2_expr (* Ltac2 plugin *) ] tac2mode: [ -| ltac2_expr ltac_use_default (* Ltac2 plugin *) +| ltac2_expr6 ltac_use_default (* Ltac2 plugin *) | G_vernac.query_command (* Ltac2 plugin *) ] diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 61befe9f1f..dfd3a18908 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -3,10 +3,6 @@ doc_grammar will modify this file to add/remove nonterminals and productions to match editedGrammar, which will remove comments. Not compiled into Coq *) DOC_GRAMMAR -tactic_mode: [ -| OPT ( toplevel_selector ":" ) "{" -] - term: [ | term_forall_or_fun | term_let @@ -178,10 +174,129 @@ subsequent_letter: [ | [ first_letter | digit | "'" | unicode_id_part ] ] -firstorder_rhs: [ -| OPT firstorder_using -| "with" LIST1 ident -| OPT firstorder_using "with" LIST1 ident +ssrarg: [ +| OPT ssrfwdview OPT ssreqpat ssrdgens OPT ssrintros +| ssrfwdview OPT ssrclear OPT ssrintros (* SSR plugin *) +| ssrclear OPT ssrintros (* SSR plugin *) +| ssrintros (* SSR plugin *) +] + +ssreqpat: [ +| ident (* SSR plugin *) +| "_" (* SSR plugin *) +| "?" (* SSR plugin *) +| "+" (* SSR plugin *) +| ssrdocc "->" (* SSR plugin *) +| ssrdocc "<-" (* SSR plugin *) +| "->" (* SSR plugin *) +| "<-" (* SSR plugin *) +] + +ssrapplyarg: [ +| ssrclear OPT ssrintros (* SSR plugin *) +| ssrintros (* SSR plugin *) +| OPT ssrbwdview ":" ssragen OPT ssragens OPT ssrintros (* SSR plugin *) +| ssrbwdview OPT ssrclear OPT ssrintros (* SSR plugin *) +] + +ssragen: [ +| OPT ( "{" LIST1 ident "}" ) term (* SSR plugin *) +] + +ssragens: [ +| "{" LIST1 ident "}" term OPT ssragens (* SSR plugin *) +| "{" LIST1 ident "}" (* SSR plugin *) +| term OPT ssragens (* SSR plugin *) +] + +ssrintros: [ +| "=>" ssripats (* SSR plugin *) +] + +ssrbwdview: [ +| "/" term (* SSR plugin *) +| "/" term ssrbwdview (* SSR plugin *) +] + +ssrdgens: [ +| ":" ssrgen OPT ( "/" ssrgen ) (* SSR plugin *) +] + +ssrgen: [ +| cpattern LIST0 [ LIST1 ident | cpattern ] (* SSR plugin *) +] + +rewrite_item: [ +| "-" OPT mult OPT occ_or_clear OPT ssrpattern_squarep r_item (* SSR plugin *) +| mult OPT occ_or_clear OPT ssrpattern_squarep r_item (* SSR plugin *) +| "-/" term (* SSR plugin *) +| OPT ( OPT ( "{" LIST1 ident "}" ) ssrpattern_squarep ) r_item (* SSR plugin *) +| "{" LIST1 ident "}" OPT r_item (* SSR plugin *) +| "{" OPT ssr_occurrences "}" OPT ssrpattern_squarep r_item (* SSR plugin *) +] + +occ_or_clear: [ +| clear_switch +| "{" ssr_occurrences "}" (* SSR plugin *) +] + +clear_switch: [ +| "{" LIST0 ident "}" +] + +ssr_occurrences: [ +| [ natural | "+" | "-" ] LIST0 natural (* SSR plugin *) +] + +r_item: [ +| [ OPT "/" term | s_item ] (* SSR plugin *) +] + +ssrpattern_squarep: [ +| "[" rewrite_pattern "]" (* SSR plugin *) +] + +rewrite_pattern: [ +| OPT ( OPT ( OPT ( OPT term "in" ) term ) "in" ) term (* SSR plugin *) +| term "as" term "in" term (* SSR plugin *) +] + +ssr_in: [ +| "in" ssrclausehyps OPT "|-" OPT "*" (* SSR plugin *) +| "in" [ "*" | "*" "|-" | "|-" "*" ] (* SSR plugin *) +] + +ssrclausehyps: [ +| gen_item LIST0 ( OPT "," gen_item ) (* SSR plugin *) +] + +gen_item: [ +| ssrclear (* SSR plugin *) +| OPT "@" ident (* SSR plugin *) +| "(" ident OPT ( ":=" lcpattern ) ")" (* SSR plugin *) +| "(@" ident ":=" lcpattern ")" (* SSR plugin *) +] + +ssrclear: [ +| "{" LIST1 ident "}" (* SSR plugin *) +] + +lcpattern: [ +| term +] + +ssrsufffwd: [ +| OPT ssripats LIST0 ssrbinder ":" term OPT ( "by" ssrhintarg ) (* SSR plugin *) +] + +ssrviewpos: [ +| "for" "move" "/" (* SSR plugin *) +| "for" "apply" "/" (* SSR plugin *) +| "for" "apply" "//" (* SSR plugin *) +] + +ssr_one_term_pattern: [ +| one_term (* SSR plugin *) ] where: [ @@ -191,6 +306,15 @@ where: [ | "before" ident ] +add_zify: [ +| [ "InjTyp" | "BinOp" | "UnOp" | "CstOp" | "BinRel" | "UnOpSpec" | "BinOpSpec" ] (* Micromega plugin *) +| [ "PropOp" | "PropBinOp" | "PropUOp" | "Saturate" ] (* Micromega plugin *) +] + +show_zify: [ +| [ "InjTyp" | "BinOp" | "UnOp" | "CstOp" | "BinRel" | "UnOpSpec" | "BinOpSpec" | "Spec" ] (* Micromega plugin *) +] + REACHABLE: [ | command | simple_tactic @@ -310,16 +434,20 @@ 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 ] term_fix: [ -| "let" "fix" fix_body "in" term -| "fix" fix_body OPT ( LIST1 ( "with" fix_body ) "for" ident ) +| "let" "fix" fix_decl "in" term +| "fix" fix_decl OPT ( LIST1 ( "with" fix_decl ) "for" ident ) ] -fix_body: [ +fix_decl: [ | ident LIST0 binder OPT fixannot OPT ( ":" type ) ":=" term ] @@ -342,9 +470,17 @@ term_if: [ | "if" term OPT [ OPT [ "as" name ] "return" term100 ] "then" term "else" term ] +ssr_dpat: [ +| pattern OPT ( OPT ( "in" pattern ) "return" term100 ) (* SSR plugin *) +] + 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 @@ -448,9 +584,7 @@ vernac_aux: [ ] subprf: [ -| bullet | "{" -| "}" ] fix_definition: [ @@ -538,8 +672,12 @@ variant_definition: [ | ident_decl LIST0 binder OPT [ "|" LIST0 binder ] OPT [ ":" type ] ":=" OPT "|" LIST1 constructor SEP "|" OPT decl_notations ] +singleton_class_definition: [ +| OPT ">" ident_decl LIST0 binder OPT [ ":" sort ] ":=" constructor +] + record_definition: [ -| OPT ">" ident_decl LIST0 binder OPT [ ":" type ] OPT ident "{" LIST0 record_field SEP ";" OPT ";" "}" OPT decl_notations +| OPT ">" ident_decl LIST0 binder OPT [ ":" sort ] OPT ( ":=" OPT ident "{" LIST0 record_field SEP ";" OPT ";" "}" ) ] record_field: [ @@ -561,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: [ @@ -573,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 "," ")" ] ] @@ -582,11 +724,8 @@ cofix_definition: [ ] scheme_kind: [ -| "Induction" "for" reference "Sort" sort_family -| "Minimality" "for" reference "Sort" sort_family -| "Elimination" "for" reference "Sort" sort_family -| "Case" "for" reference "Sort" sort_family | "Equality" "for" reference +| [ "Induction" | "Minimality" | "Elimination" | "Case" ] "for" reference "Sort" sort_family ] sort_family: [ @@ -597,7 +736,11 @@ sort_family: [ ] hint_info: [ -| "|" OPT natural OPT one_term +| "|" OPT natural OPT one_pattern +] + +one_pattern: [ +| one_term ] module_binder: [ @@ -714,7 +857,7 @@ simple_reserv: [ ] command: [ -| "Goal" term +| "Goal" type | "Pwd" | "Cd" OPT string | "Load" OPT "Verbose" [ string | ident ] @@ -723,6 +866,8 @@ command: [ | "Locate" "Term" reference | "Locate" "Module" qualid | "Info" natural ltac_expr +| "Add" "Zify" add_zify one_term (* Micromega plugin *) +| "Show" "Zify" show_zify (* Micromega plugin *) | "Locate" "Ltac" qualid | "Locate" "Library" qualid | "Locate" "File" string @@ -798,7 +943,7 @@ command: [ | "Extraction" "NoInline" LIST1 qualid (* extraction plugin *) | "Print" "Extraction" "Inline" (* extraction plugin *) | "Reset" "Extraction" "Inline" (* extraction plugin *) -| "Extraction" "Implicit" qualid "[" LIST0 int_or_id "]" (* extraction plugin *) +| "Extraction" "Implicit" qualid "[" LIST0 [ ident | integer ] "]" (* extraction plugin *) | "Extraction" "Blacklist" LIST1 ident (* extraction plugin *) | "Print" "Extraction" "Blacklist" (* extraction plugin *) | "Reset" "Extraction" "Blacklist" (* extraction plugin *) @@ -810,7 +955,7 @@ command: [ | "Proof" "Mode" string | "Proof" term | "Abort" OPT [ "All" | ident ] -| "Existential" natural OPT ( ":" term ) ":=" term +| "Existential" natural OPT ( ":" type ) ":=" term | "Admitted" | "Qed" | "Save" ident @@ -835,10 +980,10 @@ command: [ | "Comments" LIST0 [ one_term | string | natural ] | "Declare" "Instance" ident_decl LIST0 binder ":" term OPT hint_info | "Declare" "Scope" scope_name -| "Obligation" natural OPT ( "of" ident ) OPT ( ":" term OPT ( "with" ltac_expr ) ) +| "Obligation" natural OPT ( "of" ident ) OPT ( ":" type OPT ( "with" ltac_expr ) ) | "Next" "Obligation" OPT ( "of" ident ) OPT ( "with" ltac_expr ) | "Solve" "Obligation" natural OPT ( "of" ident ) "with" ltac_expr -| "Solve" "Obligations" OPT ( OPT ( "of" ident ) "with" ltac_expr ) +| "Solve" "Obligations" OPT ( "of" ident ) OPT ( "with" ltac_expr ) | "Solve" "All" "Obligations" OPT ( "with" ltac_expr ) | "Admit" "Obligations" OPT ( "of" ident ) | "Obligation" "Tactic" ":=" ltac_expr @@ -862,17 +1007,6 @@ command: [ | "Reset" "Ltac" "Profile" | "Show" "Ltac" "Profile" OPT [ "CutOff" integer | string ] | "Show" "Lia" "Profile" (* micromega plugin *) -| "Add" "Zify" "InjTyp" one_term (* micromega plugin *) -| "Add" "Zify" "BinOp" one_term (* micromega plugin *) -| "Add" "Zify" "UnOp" one_term (* micromega plugin *) -| "Add" "Zify" "CstOp" one_term (* micromega plugin *) -| "Add" "Zify" "BinRel" one_term (* micromega plugin *) -| "Add" "Zify" "PropOp" one_term (* micromega plugin *) -| "Add" "Zify" "PropBinOp" one_term (* micromega plugin *) -| "Add" "Zify" "PropUOp" one_term (* micromega plugin *) -| "Add" "Zify" "BinOpSpec" one_term (* micromega plugin *) -| "Add" "Zify" "UnOpSpec" one_term (* micromega plugin *) -| "Add" "Zify" "Saturate" one_term (* micromega plugin *) | "Add" "InjTyp" one_term (* micromega plugin *) | "Add" "BinOp" one_term (* micromega plugin *) | "Add" "UnOp" one_term (* micromega plugin *) @@ -884,25 +1018,21 @@ command: [ | "Add" "BinOpSpec" one_term (* micromega plugin *) | "Add" "UnOpSpec" one_term (* micromega plugin *) | "Add" "Saturate" one_term (* micromega plugin *) -| "Show" "Zify" "InjTyp" (* micromega plugin *) -| "Show" "Zify" "BinOp" (* micromega plugin *) -| "Show" "Zify" "UnOp" (* micromega plugin *) -| "Show" "Zify" "CstOp" (* micromega plugin *) -| "Show" "Zify" "BinRel" (* micromega plugin *) -| "Show" "Zify" "UnOpSpec" (* micromega plugin *) -| "Show" "Zify" "BinOpSpec" (* micromega plugin *) | "Show" "Zify" "Spec" (* micromega plugin *) | "Add" "Ring" ident ":" one_term OPT ( "(" LIST1 ring_mod SEP "," ")" ) (* ring plugin *) | "Print" "Rings" (* ring plugin *) | "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* ring plugin *) | "Print" "Fields" (* ring plugin *) -| "Number" "Notation" qualid qualid qualid ":" ident OPT numeral_modifier | "Hint" "Cut" "[" hints_path "]" OPT ( ":" LIST1 ident ) -| "Typeclasses" "Transparent" LIST0 qualid -| "Typeclasses" "Opaque" LIST0 qualid -| "Typeclasses" "eauto" ":=" OPT "debug" OPT ( "(" eauto_search_strategy_name ")" ) OPT integer -| "Proof" "with" ltac_expr OPT [ "using" section_subset_expr ] -| "Proof" "using" section_subset_expr OPT [ "with" ltac_expr ] +| "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_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 +| "Proof" "with" ltac_expr OPT [ "using" section_var_expr ] +| "Proof" "using" section_var_expr OPT [ "with" ltac_expr ] | "Tactic" "Notation" OPT ( "(" "at" "level" natural ")" ) LIST1 ltac_production_item ":=" ltac_expr | "Print" "Rewrite" "HintDb" ident | "Print" "Ltac" qualid @@ -911,8 +1041,8 @@ command: [ | "Set" "Firstorder" "Solver" ltac_expr | "Print" "Firstorder" "Solver" | "Function" fix_definition LIST0 ( "with" fix_definition ) -| "Functional" "Scheme" fun_scheme_arg LIST0 ( "with" fun_scheme_arg ) -| "Functional" "Case" fun_scheme_arg (* funind plugin *) +| "Functional" "Scheme" func_scheme_def LIST0 ( "with" func_scheme_def ) +| "Functional" "Case" func_scheme_def (* funind plugin *) | "Generate" "graph" "for" qualid (* funind plugin *) | "Hint" "Rewrite" OPT [ "->" | "<-" ] LIST1 one_term OPT ( "using" ltac_expr ) OPT ( ":" LIST0 ident ) | "Derive" "Inversion_clear" ident "with" one_term OPT ( "Sort" sort_family ) @@ -921,8 +1051,9 @@ command: [ | "Derive" "Dependent" "Inversion_clear" ident "with" one_term "Sort" sort_family | "Declare" "Left" "Step" one_term | "Declare" "Right" "Step" one_term -| "Numeral" "Notation" qualid qualid qualid ":" scope_name OPT numeral_modifier -| "String" "Notation" qualid qualid qualid ":" scope_name +| "Number" "Notation" qualid qualid qualid OPT ( "(" LIST1 number_modifier SEP "," ")" ) ":" scope_name +| "Numeral" "Notation" qualid qualid qualid ":" scope_name OPT deprecated_number_modifier +| "String" "Notation" qualid qualid qualid OPT ( "(" number_string_via ")" ) ":" scope_name | "SubClass" ident_decl def_body | thm_token ident_decl LIST0 binder ":" type LIST0 [ "with" ident_decl LIST0 binder ":" type ] | assumption_token OPT ( "Inline" OPT ( "(" natural ")" ) ) [ LIST1 ( "(" assumpt ")" ) | assumpt ] @@ -944,13 +1075,14 @@ command: [ | "CoInductive" inductive_definition LIST0 ( "with" inductive_definition ) | "Variant" variant_definition LIST0 ( "with" variant_definition ) | [ "Record" | "Structure" ] record_definition LIST0 ( "with" record_definition ) -| "Class" inductive_definition LIST0 ( "with" inductive_definition ) +| "Class" record_definition +| "Class" singleton_class_definition | "Module" OPT [ "Import" | "Export" ] ident LIST0 module_binder OPT of_module_type OPT ( ":=" LIST1 module_expr_inl SEP "<+" ) | "Module" "Type" ident LIST0 module_binder LIST0 ( "<:" module_type_inl ) OPT ( ":=" LIST1 module_type_inl SEP "<+" ) | "Declare" "Module" OPT [ "Import" | "Export" ] ident LIST0 module_binder ":" module_type_inl | "Section" ident | "End" ident -| "Collection" ident ":=" section_subset_expr +| "Collection" ident ":=" section_var_expr | "Require" OPT [ "Import" | "Export" ] LIST1 qualid | "From" dirpath "Require" OPT [ "Import" | "Export" ] LIST1 qualid | "Import" LIST1 filtered_import @@ -962,11 +1094,11 @@ command: [ | "Strategy" LIST1 [ strategy_level "[" LIST1 reference "]" ] | "Canonical" OPT "Structure" ident_decl def_body | "Canonical" OPT "Structure" reference -| "Coercion" qualid OPT univ_decl def_body +| "Coercion" ident OPT univ_decl def_body | "Identity" "Coercion" ident ":" class ">->" class | "Coercion" reference ":" class ">->" class | "Context" LIST1 binder -| "Instance" OPT ( ident_decl LIST0 binder ) ":" term OPT hint_info OPT [ ":=" "{" LIST0 field_def "}" | ":=" term ] +| "Instance" OPT ( ident_decl LIST0 binder ) ":" type OPT hint_info OPT [ ":=" "{" LIST0 field_def "}" | ":=" term ] | "Existing" "Instance" qualid OPT hint_info | "Existing" "Instances" LIST1 qualid OPT [ "|" natural ] | "Existing" "Class" qualid @@ -975,6 +1107,7 @@ command: [ | "Generalizable" [ [ "Variable" | "Variables" ] LIST1 ident | "All" "Variables" | "No" "Variables" ] | "Set" setting_name OPT [ integer | string ] | "Unset" setting_name +| "Import" "Prenex" "Implicits" (* SSR plugin *) | "Open" "Scope" scope | "Close" "Scope" scope | "Delimit" "Scope" scope_name "with" scope_key @@ -990,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 ) @@ -1012,35 +1145,26 @@ command: [ | "Show" "Goal" natural "at" natural ] -section_subset_expr: [ -| LIST0 starredidentref -| ssexpr -] - -ssexpr: [ -| "-" ssexpr50 -| ssexpr50 +section_var_expr: [ +| LIST0 starred_ident_ref +| OPT "-" section_var_expr50 ] -ssexpr50: [ -| ssexpr0 "-" ssexpr0 -| ssexpr0 "+" ssexpr0 -| ssexpr0 +section_var_expr50: [ +| section_var_expr0 "-" section_var_expr0 +| section_var_expr0 "+" section_var_expr0 +| section_var_expr0 ] -ssexpr0: [ -| starredidentref -| "(" LIST0 starredidentref ")" -| "(" LIST0 starredidentref ")" "*" -| "(" ssexpr ")" -| "(" ssexpr ")" "*" +section_var_expr0: [ +| starred_ident_ref +| "(" section_var_expr ")" OPT "*" ] -starredidentref: [ -| ident -| ident "*" -| "Type" -| "Type" "*" +starred_ident_ref: [ +| ident OPT "*" +| "Type" OPT "*" +| "All" ] dirpath: [ @@ -1059,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 ] @@ -1088,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: [ @@ -1137,13 +1261,11 @@ lident: [ destruction_arg: [ | natural -| constr_with_bindings | constr_with_bindings_arg ] constr_with_bindings_arg: [ -| ">" constr_with_bindings -| constr_with_bindings +| OPT ">" one_term OPT ( "with" bindings ) (* SSR plugin *) ] clause_dft_concl: [ @@ -1163,8 +1285,8 @@ hypident_occ: [ hypident: [ | ident -| "(" "type" "of" ident ")" -| "(" "value" "of" ident ")" +| "(" "type" "of" ident ")" (* SSR plugin *) +| "(" "value" "of" ident ")" (* SSR plugin *) ] concl_occ: [ @@ -1262,11 +1384,6 @@ qhyp: [ | lident (* Ltac2 plugin *) ] -int_or_id: [ -| ident -| integer (* extraction plugin *) -] - language: [ | "OCaml" (* extraction plugin *) | "Haskell" (* extraction plugin *) @@ -1274,10 +1391,6 @@ language: [ | "JSON" (* extraction plugin *) ] -fun_scheme_arg: [ -| ident ":=" "Induction" "for" qualid "Sort" sort_family (* funind plugin *) -] - ring_mod: [ | "decidable" one_term (* ring plugin *) | "abstract" (* ring plugin *) @@ -1298,11 +1411,133 @@ field_mod: [ | "completeness" one_term (* ring plugin *) ] -numeral_modifier: [ +ssrmmod: [ +| "!" (* SSR plugin *) +| "?" (* SSR plugin *) +] + +mult: [ +| OPT natural ssrmmod (* SSR plugin *) +] + +ssrwlogfwd: [ +| ":" LIST0 gen_item "/" term (* SSR plugin *) +] + +ssrhintarg: [ +| "[" OPT ssrortacs "]" (* SSR plugin *) +| ltac_expr (* SSR plugin *) +] + +ssrortacs: [ +| OPT ltac_expr "|" OPT ssrortacs +| ltac_expr (* SSR plugin *) +] + +ssrhint3arg: [ +| "[" OPT ssrortacs "]" (* SSR plugin *) +| ltac_expr3 (* SSR plugin *) +] + +ssrdefbody: [ +| OPT ( ":" term ) ":=" term (* SSR plugin *) +] + +i_item: [ +| "_" (* SSR plugin *) +| "*" (* SSR plugin *) +| ">" (* SSR plugin *) +| ident +| "?" (* SSR plugin *) +| "+" (* SSR plugin *) +| "++" (* SSR plugin *) +| s_item (* SSR plugin *) +| ssrdocc OPT [ "->" | "<-" ] (* SSR plugin *) +| "-" (* SSR plugin *) +| "-/=" (* SSR plugin *) +| "-//" (* SSR plugin *) +| "-//=" (* SSR plugin *) +| "-/" integer [ "/=" | "/" | "/" integer "=" ] (* SSR plugin *) +| ssrfwdview (* SSR plugin *) +| "[:" LIST0 ident "]" (* SSR plugin *) +| ssrblockpat (* SSR plugin *) +] + +ssrhpats_wtransp: [ +| OPT ssripats (* SSR plugin *) +| OPT ssripats "@" OPT ssripats (* SSR plugin *) +] + +ssripats: [ +| LIST1 i_item (* SSR plugin *) +] + +s_item: [ +| "//" (* SSR plugin *) +| "/=" (* SSR plugin *) +| "//=" (* SSR plugin *) +| "/" natural "/" natural "=" (* SSR plugin *) +| "/" natural "/=" (* SSR plugin *) +] + +ssrdocc: [ +| "{" ssr_occurrences "}" (* SSR plugin *) +| "{" LIST0 ident "}" (* SSR plugin *) +] + +ssrfwdview: [ +| LIST1 ( "/" one_term ) (* SSR plugin *) +] + +hat: [ +| "^" ident (* SSR plugin *) +| "^~" ident (* SSR plugin *) +| "^~" natural (* SSR plugin *) +] + +ssriorpat: [ +| ssripats OPT ( [ "|" | "|-" ] ssriorpat ) (* SSR plugin *) +] + +ssrblockpat: [ +| "[" hat "]" (* SSR plugin *) +| "[" ssriorpat "]" (* SSR plugin *) +| "[=" ssriorpat "]" (* SSR plugin *) +] + +ssrbinder: [ +| ssrbvar (* SSR plugin *) +| "(" LIST1 ssrbvar ":" term ")" (* SSR plugin *) +| "(" ssrbvar OPT ( ":" term ) OPT ( ":=" term ) ")" (* SSR plugin *) +| "of" term10 (* SSR plugin *) +| "&" term10 (* SSR plugin *) +] + +ssrbvar: [ +| ident (* SSR plugin *) +| "_" (* SSR plugin *) +] + +ssrhavefwd: [ +| ":" term OPT ( "by" ssrhintarg ) (* SSR plugin *) +| ":" term ":=" OPT term (* SSR plugin *) +] + +deprecated_number_modifier: [ | "(" "warning" "after" bignat ")" | "(" "abstract" "after" bignat ")" ] +number_modifier: [ +| "warning" "after" bignat +| "abstract" "after" bignat +| number_string_via +] + +number_string_via: [ +| "via" qualid "mapping" "[" LIST1 [ qualid "=>" qualid | "[" qualid "]" "=>" qualid ] SEP "," "]" +] + hints_path: [ | "(" hints_path ")" | hints_path "*" @@ -1314,11 +1549,6 @@ hints_path: [ | hints_path hints_path ] -eauto_search_strategy_name: [ -| "bfs" -| "dfs" -] - class: [ | "Funclass" | "Sortclass" @@ -1390,7 +1620,7 @@ simple_tactic: [ | "eright" OPT ( "with" bindings ) | "constructor" OPT int_or_var OPT ( "with" bindings ) | "econstructor" OPT ( int_or_var OPT ( "with" bindings ) ) -| "specialize" constr_with_bindings OPT ( "as" simple_intropattern ) +| "specialize" one_term OPT ( "with" bindings ) OPT ( "as" simple_intropattern ) | "symmetry" OPT ( "in" in_clause ) | "split" OPT ( "with" bindings ) | "esplit" OPT ( "with" bindings ) @@ -1411,6 +1641,10 @@ simple_tactic: [ | "generalize" "dependent" one_term | "replace" one_term "with" one_term OPT clause_dft_concl OPT ( "by" ltac_expr3 ) | "replace" OPT [ "->" | "<-" ] one_term OPT clause_dft_concl +| "setoid_replace" one_term "with" one_term OPT ( "using" "relation" one_term ) OPT ( "in" ident ) OPT ( "at" LIST1 int_or_var ) OPT ( "by" ltac_expr3 ) +| OPT ( [ natural | "[" ident "]" ] ":" ) "{" +| bullet +| "}" | "try" ltac_expr3 | "do" int_or_var ltac_expr3 | "timeout" int_or_var ltac_expr3 @@ -1422,11 +1656,14 @@ simple_tactic: [ | "infoH" ltac_expr3 | "abstract" ltac_expr2 OPT ( "using" ident ) | "only" selector ":" ltac_expr3 +| "do" "[" ssrortacs "]" OPT ssr_in (* SSR plugin *) +| "do" OPT int_or_var ssrmmod [ ltac_expr3 | "[" ssrortacs "]" (* SSR plugin *) ] OPT ssr_in (* SSR plugin *) | "tryif" ltac_expr "then" ltac_expr "else" ltac_expr2 | "first" "[" LIST0 ltac_expr SEP "|" "]" | "solve" "[" LIST0 ltac_expr SEP "|" "]" | "idtac" LIST0 [ ident | string | natural ] | [ "fail" | "gfail" ] OPT int_or_var LIST0 [ ident | string | natural ] +| ltac_expr ssrintros (* SSR plugin *) | "fun" LIST1 name "=>" ltac_expr | "eval" red_expr "in" term | "context" ident "[" term "]" @@ -1456,7 +1693,7 @@ simple_tactic: [ | "decompose" "sum" one_term | "decompose" "record" one_term | "absurd" one_term -| "contradiction" OPT constr_with_bindings +| "contradiction" OPT ( one_term OPT ( "with" bindings ) ) | "autorewrite" OPT "*" "with" LIST1 ident OPT clause_dft_concl OPT ( "using" ltac_expr ) | "rewrite" "*" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) OPT ( "at" occurrences OPT ( "by" ltac_expr3 ) ) | "rewrite" "*" OPT [ "->" | "<-" ] one_term "at" occurrences "in" ident OPT ( "by" ltac_expr3 ) @@ -1465,7 +1702,7 @@ simple_tactic: [ | "notypeclasses" "refine" one_term | "simple" "notypeclasses" "refine" one_term | "solve_constraints" -| "subst" OPT ( LIST1 ident ) +| "subst" LIST0 ident | "simple" "subst" | "evar" "(" ident ":" term ")" | "evar" one_term @@ -1525,13 +1762,12 @@ 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 ) | "convert_concl_no_check" one_term -| "typeclasses" "eauto" "bfs" OPT int_or_var "with" LIST1 ident -| "typeclasses" "eauto" OPT int_or_var "with" LIST1 ident -| "typeclasses" "eauto" OPT int_or_var +| "typeclasses" "eauto" OPT "bfs" OPT int_or_var OPT ( "with" LIST1 ident ) | "head_of_constr" ident one_term | "not_evar" one_term | "is_ground" one_term @@ -1540,9 +1776,9 @@ simple_tactic: [ | "progress_evars" ltac_expr | "rewrite_strat" rewstrategy OPT ( "in" ident ) | "rewrite_db" ident OPT ( "in" ident ) -| "substitute" OPT [ "->" | "<-" ] constr_with_bindings -| "setoid_rewrite" OPT [ "->" | "<-" ] constr_with_bindings OPT ( "at" occurrences ) OPT ( "in" ident ) -| "setoid_rewrite" OPT [ "->" | "<-" ] constr_with_bindings "in" ident "at" occurrences +| "substitute" OPT [ "->" | "<-" ] one_term OPT ( "with" bindings ) +| "setoid_rewrite" OPT [ "->" | "<-" ] one_term OPT ( "with" bindings ) OPT ( "at" occurrences ) OPT ( "in" ident ) +| "setoid_rewrite" OPT [ "->" | "<-" ] one_term OPT ( "with" bindings ) "in" ident "at" occurrences | "setoid_symmetry" OPT ( "in" ident ) | "setoid_reflexivity" | "setoid_transitivity" one_term @@ -1555,8 +1791,8 @@ simple_tactic: [ | "eapply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as | "simple" "apply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as | "simple" "eapply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as -| "elim" constr_with_bindings_arg OPT ( "using" constr_with_bindings ) -| "eelim" constr_with_bindings_arg OPT ( "using" constr_with_bindings ) +| "elim" constr_with_bindings_arg OPT ( "using" one_term OPT ( "with" bindings ) ) +| "eelim" constr_with_bindings_arg OPT ( "using" one_term OPT ( "with" bindings ) ) | "case" induction_clause_list | "ecase" induction_clause_list | "fix" ident natural OPT ( "with" LIST1 fixdecl ) @@ -1616,11 +1852,11 @@ simple_tactic: [ | "rtauto" | "congruence" OPT natural OPT ( "with" LIST1 one_term ) | "f_equal" -| "firstorder" OPT ltac_expr firstorder_rhs +| "firstorder" OPT ltac_expr OPT ( "using" LIST1 qualid SEP "," ) OPT ( "with" LIST1 ident ) | "gintuition" OPT ltac_expr | "functional" "inversion" [ ident | natural ] OPT qualid (* funind plugin *) -| "functional" "induction" term OPT fun_ind_using OPT with_names (* funind plugin *) -| "soft" "functional" "induction" LIST1 one_term OPT fun_ind_using OPT with_names (* funind plugin *) +| "functional" "induction" term OPT ( "using" one_term OPT ( "with" bindings ) ) OPT ( "as" simple_intropattern ) (* funind plugin *) +| "soft" "functional" "induction" LIST1 one_term OPT ( "using" one_term OPT ( "with" bindings ) ) OPT ( "as" simple_intropattern ) (* funind plugin *) | "psatz_Z" OPT int_or_var ltac_expr | "xlia" ltac_expr (* micromega plugin *) | "xnlia" ltac_expr (* micromega plugin *) @@ -1643,12 +1879,47 @@ simple_tactic: [ | "protect_fv" string OPT ( "in" ident ) | "ring_lookup" ltac_expr0 "[" LIST0 one_term "]" LIST1 one_term (* ring plugin *) | "field_lookup" ltac_expr "[" LIST0 one_term "]" LIST1 one_term (* ring plugin *) +| "ring_lookup" ltac_expr0 "[" LIST0 one_term "]" LIST1 one_term (* ring plugin *) +| "field_lookup" ltac_expr "[" LIST0 one_term "]" LIST1 one_term (* ring plugin *) +| "by" ssrhintarg (* SSR plugin *) +| "clear" natural (* SSR plugin *) +| "move" OPT ( OPT ssrarg [ "->" | "<-" ] ) (* SSR plugin *) +| "move" ssrarg OPT ssr_in (* SSR plugin *) +| "case" OPT ( ssrarg OPT ssr_in ) (* SSR plugin *) +| "elim" OPT ( ssrarg OPT ssr_in ) (* SSR plugin *) +| "apply" OPT ssrapplyarg (* SSR plugin *) +| "exact" [ ":" ssragen OPT ssragens | ssrbwdview OPT ssrclear | ssrclear ] (* SSR plugin *) +| "exact" (* SSR plugin *) +| "exact" "<:" term (* SSR plugin *) +| "congr" OPT natural one_term OPT ssrdgens (* SSR plugin *) +| "ssrinstancesofruleL2R" term (* SSR plugin *) +| "ssrinstancesofruleR2L" term (* SSR plugin *) +| "rewrite" LIST1 rewrite_item OPT ssr_in (* SSR plugin *) +| "unlock" LIST0 ( OPT ( "{" ssr_occurrences "}" ) term ) OPT ssr_in (* SSR plugin *) +| "pose" "fix" ssrbvar LIST0 ssrbinder OPT ( "{" "struct" ident "}" ) ssrdefbody (* SSR plugin *) +| "pose" "cofix" ssrbvar LIST0 ssrbinder ssrdefbody (* SSR plugin *) +| "pose" ident LIST0 ssrbinder ssrdefbody (* SSR plugin *) +| "set" ident OPT ( ":" term ) ":=" [ "{" ssr_occurrences "}" cpattern | lcpattern ] OPT ssr_in (* SSR plugin *) +| "abstract" ssrdgens (* SSR plugin *) +| "have" ssrhpats_wtransp LIST0 ssrbinder ssrhavefwd (* SSR plugin *) +| "have" [ "suff" | "suffices" ] OPT ssripats ssrhavefwd (* SSR plugin *) +| [ "suff" | "suffices" ] OPT ( "have" OPT ssripats ) ssrhavefwd (* SSR plugin *) +| [ "suff" | "suffices" ] ssrsufffwd (* SSR plugin *) +| [ "wlog" | "without loss" ] OPT [ "suff" | "suffices" ] OPT ssripats ssrwlogfwd OPT ( "by" ssrhintarg ) (* SSR plugin *) +| [ "gen" | "generally" ] "have" OPT ssrclear OPT ( [ ident | "_" ] "," ) OPT ssripats ssrwlogfwd OPT ( "by" ssrhintarg ) (* SSR plugin *) +| "under" rewrite_item OPT ssrintros OPT ( "do" ssrhint3arg ) (* SSR plugin *) +| "ssrinstancesoftpat" ssr_one_term_pattern (* SSR plugin *) +| ltac_expr ";" "first" ssr_first_else (* SSR plugin *) +| ltac_expr ";" "first" ssrseqarg (* SSR plugin *) +| ltac_expr ";" "last" ssrseqarg (* SSR plugin *) | match_key OPT "reverse" "goal" "with" OPT "|" LIST1 ( goal_pattern "=>" ltac_expr ) SEP "|" "end" | match_key ltac_expr "with" OPT "|" LIST1 ( match_pattern "=>" ltac_expr ) SEP "|" "end" | "classical_left" | "classical_right" | "contradict" ident +| "dintuition" OPT ltac_expr | "discrR" +| "dtauto" | "easy" | "exfalso" | "inversion_sigma" @@ -1656,6 +1927,7 @@ simple_tactic: [ | "lra" | "nia" | "nra" +| "over" (* SSR plugin *) | "split_Rabs" | "split_Rmult" | "tauto" @@ -1663,15 +1935,16 @@ simple_tactic: [ | "zify" | "assert_fails" ltac_expr3 | "assert_succeeds" ltac_expr3 -| "field" OPT ( "[" LIST1 term "]" ) -| "field_simplify" OPT ( "[" LIST1 term "]" ) LIST1 term OPT ( "in" ident ) -| "field_simplify_eq" OPT ( "[" LIST1 term "]" ) OPT ( "in" ident ) +| "field" OPT ( "[" LIST1 one_term "]" ) +| "field_simplify" OPT ( "[" LIST1 one_term "]" ) LIST1 one_term OPT ( "in" ident ) +| "field_simplify_eq" OPT ( "[" LIST1 one_term "]" ) OPT ( "in" ident ) | "intuition" OPT ltac_expr -| "nsatz" OPT ( "with" "radicalmax" ":=" term "strategy" ":=" term "parameters" ":=" term "variables" ":=" term ) -| "psatz" term OPT int_or_var -| "ring" OPT ( "[" LIST1 term "]" ) -| "ring_simplify" OPT ( "[" LIST1 term "]" ) LIST1 term OPT ( "in" ident ) +| "nsatz" OPT ( "with" "radicalmax" ":=" one_term "strategy" ":=" one_term "parameters" ":=" one_term "variables" ":=" one_term ) +| "psatz" one_term OPT int_or_var +| "ring" OPT ( "[" LIST1 one_term "]" ) +| "ring_simplify" OPT ( "[" LIST1 one_term "]" ) LIST1 one_term OPT ( "in" ident ) | "match" ltac2_expr5 "with" OPT ltac2_branches "end" +| "if" ltac2_expr5 "then" ltac2_expr5 "else" ltac2_expr5 | qualid LIST1 tactic_arg ] @@ -1705,20 +1978,25 @@ as_name: [ | "as" ident ] +oriented_rewriter: [ +| OPT [ "->" | "<-" ] rewriter +] + rewriter: [ | OPT natural OPT [ "?" | "!" ] constr_with_bindings_arg ] -oriented_rewriter: [ -| OPT [ "->" | "<-" ] rewriter +induction_clause_list: [ +| LIST1 induction_clause SEP "," OPT ( "using" one_term OPT ( "with" bindings ) ) OPT opt_clause ] induction_clause: [ | destruction_arg OPT as_or_and_ipat OPT eqn_ipat OPT opt_clause ] -induction_clause_list: [ -| LIST1 induction_clause SEP "," OPT ( "using" constr_with_bindings ) OPT opt_clause +opt_clause: [ +| "in" in_clause +| "at" occs_nums ] auto_using: [ @@ -1764,13 +2042,8 @@ simple_intropattern_closed: [ | naming_intropattern ] -simple_binding: [ -| "(" ident ":=" term ")" -| "(" natural ":=" term ")" -] - bindings: [ -| LIST1 simple_binding +| LIST1 ( "(" [ ident | natural ] ":=" term ")" ) | LIST1 one_term ] @@ -1862,7 +2135,7 @@ q_rewriting: [ ] ltac2_oriented_rewriter: [ -| [ "->" | "<-" ] ltac2_rewriter (* Ltac2 plugin *) +| OPT [ "->" | "<-" ] ltac2_rewriter (* Ltac2 plugin *) ] ltac2_rewriter: [ @@ -2148,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 ) ] @@ -2158,11 +2431,6 @@ clause_dft_all: [ | "in" in_clause ] -opt_clause: [ -| "in" in_clause -| "at" occs_nums -] - in_hyp_as: [ | "in" ident OPT as_ipat ] @@ -2184,28 +2452,14 @@ cofixdecl: [ | "(" ident LIST0 simple_binder ":" term ")" ] -constr_with_bindings: [ -| one_term OPT ( "with" bindings ) -] - conversion: [ | one_term | one_term "with" one_term | one_term "at" occs_nums "with" one_term ] -firstorder_using: [ -| "using" qualid -| "using" qualid "," LIST1 qualid SEP "," -| "using" qualid qualid LIST0 qualid -] - -fun_ind_using: [ -| "using" constr_with_bindings (* funind plugin *) -] - -with_names: [ -| "as" simple_intropattern (* funind plugin *) +func_scheme_def: [ +| ident ":=" "Induction" "for" qualid "Sort" sort_family (* funind plugin *) ] occurrences: [ @@ -2309,6 +2563,34 @@ tactic_atom: [ | "()" ] +ssrseqarg: [ +| ssrseqidx "[" ssrortacs "]" OPT ssrorelse (* SSR plugin *) +| OPT ssrseqidx ssrswap (* SSR plugin *) +| ltac_expr3 (* SSR plugin *) +] + +ssrseqidx: [ +| ident (* SSR plugin *) +| natural (* SSR plugin *) +] + +ssrorelse: [ +| "||" ltac_expr2 (* SSR plugin *) +] + +ssrswap: [ +| "first" (* SSR plugin *) +| "last" (* SSR plugin *) +] + +ssr_first_else: [ +| ssr_first OPT ssrorelse (* SSR plugin *) +] + +ssr_first: [ +| "[" LIST0 ltac_expr SEP "|" "]" LIST0 ssrintros (* SSR plugin *) +] + let_clause: [ | name ":=" ltac_expr | ident LIST1 name ":=" ltac_expr 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 36297fe243..c29de27efb 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -127,9 +127,9 @@ let isRef sigma c = match kind sigma c with let isRefX sigma x c = let open GlobRef in match x, kind sigma c with - | ConstRef c, Const (c', _) -> Constant.equal c c' - | IndRef i, Ind (i', _) -> eq_ind i i' - | ConstructRef i, Construct (i', _) -> eq_constructor i i' + | ConstRef c, Const (c', _) -> Constant.CanOrd.equal c c' + | IndRef i, Ind (i', _) -> Ind.CanOrd.equal i i' + | ConstructRef i, Construct (i', _) -> Construct.CanOrd.equal i i' | VarRef id, Var id' -> Id.equal id id' | _ -> false @@ -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 *) @@ -514,7 +517,7 @@ let compare_head_gen_proj env sigma equ eqs eqc' nargs m n = | Proj (p, c), App (f, args) | App (f, args), Proj (p, c) -> (match kind f with - | Const (p', u) when Constant.equal (Projection.constant p) p' -> + | Const (p', u) when Environ.QConstant.equal env (Projection.constant p) p' -> let npars = Projection.npars p in if Array.length args == npars + 1 then eqc' 0 c args.(npars) @@ -563,6 +566,9 @@ let universes_of_constr sigma c = | Array (u,_,_,_) -> let s = LSet.fold LSet.add (Instance.levels (EInstance.kind sigma u)) s in fold sigma aux s c + | Case (_,_,CaseInvert {univs;args=_},_,_) -> + let s = LSet.fold LSet.add (Instance.levels (EInstance.kind sigma univs)) s in + fold sigma aux s c | _ -> fold sigma aux s c in aux LSet.empty c @@ -625,6 +631,9 @@ let subst_var subst c = of_constr (Vars.subst_var subst (to_constr c)) let subst_univs_level_constr subst c = of_constr (Vars.subst_univs_level_constr subst (to_constr c)) +let subst_univs_constr subst c = + of_constr (UnivSubst.subst_univs_constr subst (to_constr c)) + (** Operations that dot NOT commute with evar-normalization *) let noccurn sigma n term = let rec occur_rec n c = match kind sigma c with diff --git a/engine/eConstr.mli b/engine/eConstr.mli index a018f4064f..882dfe2848 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -295,6 +295,7 @@ val closedn : Evd.evar_map -> int -> t -> bool val closed0 : Evd.evar_map -> t -> bool val subst_univs_level_constr : Univ.universe_level_subst -> t -> t +val subst_univs_constr : Univ.universe_subst -> t -> t val subst_of_rel_context_instance : rel_context -> t list -> t list 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/termops.ml b/engine/termops.ml index 467b269e37..693945d5ac 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -1145,9 +1145,9 @@ let compare_constr_univ sigma f cv_pb t1 t2 = Sort s1, Sort s2 -> base_sort_cmp cv_pb (ESorts.kind sigma s1) (ESorts.kind sigma s2) | Prod (_,t1,c1), Prod (_,t2,c2) -> f Reduction.CONV t1 t2 && f cv_pb c1 c2 - | Const (c, u), Const (c', u') -> Constant.equal c c' - | Ind (i, _), Ind (i', _) -> eq_ind i i' - | Construct (i, _), Construct (i', _) -> eq_constructor i i' + | Const (c, u), Const (c', u') -> Constant.CanOrd.equal c c' + | Ind (i, _), Ind (i', _) -> Ind.CanOrd.equal i i' + | Construct (i, _), Construct (i', _) -> Construct.CanOrd.equal i i' | _ -> EConstr.compare_constr sigma (fun t1 t2 -> f Reduction.CONV t1 t2) t1 t2 let constr_cmp sigma cv_pb t1 t2 = 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/ide/coqide/coq.ml b/ide/coqide/coq.ml index 1167b8199e..b8228df2aa 100644 --- a/ide/coqide/coq.ml +++ b/ide/coqide/coq.ml @@ -550,6 +550,7 @@ struct let existential = BoolOpt ["Printing"; "Existential"; "Instances"] let universes = BoolOpt ["Printing"; "Universes"] let unfocused = BoolOpt ["Printing"; "Unfocused"] + let goal_names = BoolOpt ["Printing"; "Goal"; "Names"] let diff = StringOpt ["Diffs"] type 'a descr = { opts : 'a t list; init : 'a; label : string } @@ -568,7 +569,8 @@ struct { opts = [universes]; init = false; label = "Display _universe levels" }; { opts = [all_basic;existential;universes]; init = false; label = "Display all _low-level contents" }; - { opts = [unfocused]; init = false; label = "Display _unfocused goals" } + { opts = [unfocused]; init = false; label = "Display _unfocused goals" }; + { opts = [goal_names]; init = false; label = "Display _goal names" } ] let diff_item = { opts = [diff]; init = "off"; label = "Display _proof diffs" } diff --git a/ide/coqide/coqide_ui.ml b/ide/coqide/coqide_ui.ml index 6540fc6fca..badfabf07e 100644 --- a/ide/coqide/coqide_ui.ml +++ b/ide/coqide/coqide_ui.ml @@ -85,6 +85,7 @@ let init () = \n <menuitem action='Display universe levels' />\ \n <menuitem action='Display all low-level contents' />\ \n <menuitem action='Display unfocused goals' />\ +\n <menuitem action='Display goal names' />\ \n <separator/>\ \n <menuitem action='Unset diff' />\ \n <menuitem action='Set diff' />\ diff --git a/ide/coqide/idetop.ml b/ide/coqide/idetop.ml index 297dc3a706..602acefa7c 100644 --- a/ide/coqide/idetop.ml +++ b/ide/coqide/idetop.ml @@ -195,7 +195,7 @@ let concl_next_tac = let process_goal sigma g = let env = Goal.V82.env sigma g in let min_env = Environ.reset_context env in - let id = Goal.uid g in + let id = if Printer.print_goal_names () then Names.Id.to_string (Termops.evar_suggested_name g sigma) else "" in let ccl = pr_letype_env ~goal_concl_style:true env sigma (Goal.V82.concl sigma g) in @@ -206,7 +206,7 @@ let process_goal sigma g = let (_env, hyps) = Context.Compacted.fold process_hyp (Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in - { Interface.goal_hyp = List.rev hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; } + { Interface.goal_hyp = List.rev hyps; Interface.goal_ccl = ccl; Interface.goal_id = id } let process_goal_diffs diff_goal_map oldp nsigma ng = let open Evd in @@ -317,7 +317,7 @@ let pattern_of_string ?env s = | None -> Global.env () | Some e -> e in - let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in + let constr = Pcoq.parse_string Pcoq.Constr.cpattern s in let (_, pat) = Constrintern.intern_constr_pattern env (Evd.from_env env) constr in pat diff --git a/ide/coqide/wg_ProofView.ml b/ide/coqide/wg_ProofView.ml index 1de63953af..8e451c9917 100644 --- a/ide/coqide/wg_ProofView.ml +++ b/ide/coqide/wg_ProofView.ml @@ -52,7 +52,7 @@ let hook_tag_cb tag menu_content sel_cb hover_cb = let mode_tactic sel_cb (proof : #GText.view_skel) goals ~unfoc_goals hints = match goals with | [] -> assert false - | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: rem_goals -> + | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; Interface.goal_id = cur_id } :: rem_goals -> let on_hover sel_start sel_stop = proof#buffer#remove_tag ~start:proof#buffer#start_iter @@ -68,11 +68,11 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals ~unfoc_goals hints = mat let head_str = Printf.sprintf "%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "s" else "") in - let goal_str ?(shownum=false) index total = - if shownum then Printf.sprintf - "______________________________________(%d/%d)\n" index total - else Printf.sprintf - "______________________________________\n" + let goal_str ?(shownum=false) index total id = + let annot = + if CString.is_empty id then if shownum then Printf.sprintf "(%d/%d)" index total else "" + else Printf.sprintf "(?%s)" id in + Printf.sprintf "______________________________________%s\n" annot in (* Insert current goal and its hypotheses *) let hyps_hints, goal_hints = match hints with @@ -103,13 +103,13 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals ~unfoc_goals hints = mat [tag] else [] in - proof#buffer#insert (goal_str ~shownum:true 1 goals_cnt); + proof#buffer#insert (goal_str ~shownum:true 1 goals_cnt cur_id); insert_xml ~tags:[Tags.Proof.goal] proof#buffer (Richpp.richpp_of_pp width cur_goal); proof#buffer#insert "\n" in (* Insert remaining goals (no hypotheses) *) - let fold_goal ?(shownum=false) i _ { Interface.goal_ccl = g } = - proof#buffer#insert (goal_str ~shownum i goals_cnt); + let fold_goal ?(shownum=false) i _ { Interface.goal_ccl = g; Interface.goal_id = id } = + proof#buffer#insert (goal_str ~shownum i goals_cnt id); insert_xml proof#buffer (Richpp.richpp_of_pp width g); proof#buffer#insert "\n" in @@ -178,12 +178,16 @@ let display mode (view : #GText.view_skel) goals hints evars = | _, _, _, _ -> (* No foreground proofs, but still unfocused ones *) let total = List.length bg in - let goal_str index = Printf.sprintf - "______________________________________(%d/%d)\n" index total + let goal_str index id = + let annot = + if CString.is_empty id then Printf.sprintf "(%d/%d)" index total + else Printf.sprintf "(?%s)" id in + Printf.sprintf + "______________________________________%s\n" annot in view#buffer#insert "This subproof is complete, but there are some unfocused goals:\n\n"; let iter i goal = - let () = view#buffer#insert (goal_str (succ i)) in + let () = view#buffer#insert (goal_str (succ i) goal.Interface.goal_id) in insert_xml view#buffer (Richpp.richpp_of_pp width goal.Interface.goal_ccl); view#buffer#insert "\n" in diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index d14d156ffc..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 @@ -58,7 +61,7 @@ type abstraction_kind = AbsLambda | AbsPi type proj_flag = int option (** [Some n] = proj of the n-th visible argument *) type prim_token = - | Numeral of NumTok.Signed.t + | Number of NumTok.Signed.t | String of string type instance_expr = Glob_term.glob_level list diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 7075d082ee..efc2a35b65 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -44,13 +44,13 @@ let names_of_local_binders bl = (**********************************************************************) (* Functions on constr_expr *) -(* Note: redundant Numeral representations, such as -0 and +0 (and others), +(* Note: redundant Number representations, such as -0 and +0 (and others), are considered different here. *) let prim_token_eq t1 t2 = match t1, t2 with -| Numeral n1, Numeral n2 -> NumTok.Signed.equal n1 n2 +| Number n1, Number n2 -> NumTok.Signed.equal n1 n2 | String s1, String s2 -> String.equal s1 s2 -| (Numeral _ | String _), _ -> false +| (Number _ | String _), _ -> false let explicitation_eq ex1 ex2 = match ex1, ex2 with | ExplByPos (i1, id1), ExplByPos (i2, id2) -> @@ -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/constrextern.ml b/interp/constrextern.ml index 7bf1c58148..d1bec16a3f 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -357,18 +357,18 @@ let destPatPrim = function { CAst.v = CPatPrim t } -> Some t | _ -> None let make_notation_gen loc ntn mknot mkprim destprim l bl = match snd ntn,List.map destprim l with (* Special case to avoid writing "- 3" for e.g. (Z.opp 3) *) - | "- _", [Some (Numeral p)] when not (NumTok.Signed.is_zero p) -> + | "- _", [Some (Number p)] when not (NumTok.Signed.is_zero p) -> assert (bl=[]); mknot (loc,ntn,([mknot (loc,(InConstrEntry,"( _ )"),l,[])]),[]) | _ -> match decompose_notation_key ntn, l with | (InConstrEntry,[Terminal "-"; Terminal x]), [] -> begin match NumTok.Unsigned.parse_string x with - | Some n -> mkprim (loc, Numeral (NumTok.SMinus,n)) + | Some n -> mkprim (loc, Number (NumTok.SMinus,n)) | None -> mknot (loc,ntn,l,bl) end | (InConstrEntry,[Terminal x]), [] -> begin match NumTok.Unsigned.parse_string x with - | Some n -> mkprim (loc, Numeral (NumTok.SPlus,n)) + | Some n -> mkprim (loc, Number (NumTok.SPlus,n)) | None -> mknot (loc,ntn,l,bl) end | _ -> mknot (loc,ntn,l,bl) @@ -915,7 +915,7 @@ let extern_float f scopes = let hex = !Flags.raw_print || not (get_printing_float ()) in if hex then Float64.to_hex_string f else Float64.to_string f in let n = NumTok.Signed.of_string s in - extern_prim_token_delimiter_if_required (Numeral n) + extern_prim_token_delimiter_if_required (Number n) "float" "float_scope" scopes (**********************************************************************) @@ -1097,7 +1097,7 @@ let rec extern inctx ?impargs scopes vars r = | GInt i -> extern_prim_token_delimiter_if_required - (Numeral (NumTok.Signed.of_int_string (Uint63.to_string i))) + (Number (NumTok.Signed.of_int_string (Uint63.to_string i))) "int63" "int63_scope" (snd scopes) | GFloat f -> extern_float f (snd scopes) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 959b61a3d7..b86ad7175a 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -263,6 +263,13 @@ type intern_env = { binder_block_names: (abstraction_kind option (* None = unknown *) * Id.Set.t) option; } +type pattern_intern_env = { + pat_scopes: Notation_term.subscopes; + (* ids = Some means accept local variables; this is useful for + terms as patterns parsed as pattersn in notations *) + pat_ids: Id.Set.t option; +} + (**********************************************************************) (* Remembering the parsing scope of variables in notations *) @@ -317,6 +324,9 @@ let reset_tmp_scope env = {env with tmp_scope = None} let set_env_scopes env (scopt,subscopes) = {env with tmp_scope = scopt; scopes = subscopes @ env.scopes} +let env_for_pattern env = + {pat_scopes = (env.tmp_scope, env.scopes); pat_ids = Some env.ids} + let mkGProd ?loc (na,bk,t) body = DAst.make ?loc @@ GProd (na, bk, t, body) let mkGLambda ?loc (na,bk,t) body = DAst.make ?loc @@ GLambda (na, bk, t, body) @@ -420,6 +430,40 @@ let binder_status_fun = { slide = on_snd slide_binders; } +(* [test_kind_strict] rules out pattern which refers to global other + than constructors or variables; It is used in instances of notations *) + +let test_kind_pattern_in_notation ?loc = function + | GlobRef.ConstructRef _ -> () + (* We do not accept non constructors to be used as variables in + patterns *) + | GlobRef.ConstRef _ -> + user_err ?loc (str "Found a constant while a pattern was expected.") + | GlobRef.IndRef _ -> + user_err ?loc (str "Found an inductive type while a pattern was expected.") + | GlobRef.VarRef _ -> + (* we accept a section variable name to be used as pattern variable *) + raise Not_found + +let test_kind_ident_in_notation ?loc = function + | GlobRef.ConstructRef _ -> + user_err ?loc (str "Found a constructor while a variable name was expected.") + | GlobRef.ConstRef _ -> + user_err ?loc (str "Found a constant while a variable name was expected.") + | GlobRef.IndRef _ -> + user_err ?loc (str "Found an inductive type while a variable name was expected.") + | GlobRef.VarRef _ -> + (* we accept a section variable name to be used as pattern variable *) + raise Not_found + +(* [test_kind_tolerant] allow global reference names to be used as pattern variables *) + +let test_kind_tolerant ?loc = function + | GlobRef.ConstructRef _ -> () + | GlobRef.ConstRef _ | GlobRef.IndRef _ | GlobRef.VarRef _ -> + (* A non-constructor global reference in a pattern is seen as a variable *) + raise Not_found + (**) let locate_if_hole ?loc na c = match DAst.get c with @@ -539,9 +583,9 @@ let intern_letin_binder intern ntnvars env (({loc;v=na} as locna),def,ty) = (push_name_env ntnvars impls env locna, (na,Explicit,term,ty)) -let intern_cases_pattern_as_binder ?loc ntnvars env p = +let intern_cases_pattern_as_binder ?loc test_kind ntnvars env p = let il,disjpat = - let (il, subst_disjpat) = !intern_cases_pattern_fwd ntnvars (None,env.scopes) p in + let (il, subst_disjpat) = !intern_cases_pattern_fwd test_kind ntnvars (env_for_pattern (reset_tmp_scope env)) p in let substl,disjpat = List.split subst_disjpat in if not (List.for_all (fun subst -> Id.Map.equal Id.equal subst Id.Map.empty) substl) then user_err ?loc (str "Unsupported nested \"as\" clause."); @@ -568,7 +612,7 @@ let intern_local_binder_aux intern ntnvars (env,bl) = function | Some ty -> ty | None -> CAst.make ?loc @@ CHole(None,IntroAnonymous,None) in - let env, ((disjpat,il),id),na = intern_cases_pattern_as_binder ?loc ntnvars env p in + let env, ((disjpat,il),id),na = intern_cases_pattern_as_binder ?loc test_kind_tolerant ntnvars env p in let bk = Default Explicit in let _, bl' = intern_assumption intern ntnvars env [na] bk tyc in let {v=(_,bk,t)} = List.hd bl' in @@ -661,27 +705,21 @@ let is_patvar_store store pat = | PatVar na -> ignore(store na); true | _ -> false -let out_patvar pat = - match pat.v with +let out_patvar = CAst.map_with_loc (fun ?loc -> function | CPatAtom (Some qid) when qualid_is_ident qid -> Name (qualid_basename qid) | CPatAtom None -> Anonymous - | _ -> assert false - -let term_of_name = function - | Name id -> DAst.make (GVar id) - | Anonymous -> - let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in - DAst.make (GHole (Evar_kinds.QuestionMark { Evar_kinds.default_question_mark with Evar_kinds.qm_obligation=st }, IntroAnonymous, None)) + | _ -> assert false) let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renaming,env) = function | Anonymous -> (renaming,env), None, Anonymous | Name id -> let store,get = set_temporary_memory () in + let test_kind = test_kind_tolerant in try (* We instantiate binder name with patterns which may be parsed as terms *) let pat = coerce_to_cases_pattern_expr (fst (Id.Map.find id terms)) in - let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in + let env,((disjpat,ids),id),na = intern_pat test_kind ntnvars env pat in let pat, na = match disjpat with | [pat] when is_patvar_store store pat -> let na = get () in None, na | _ -> Some ((List.map (fun x -> x.v) ids,disjpat),id), na.v in @@ -694,11 +732,11 @@ let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renam if onlyident then (* Do not try to interpret a variable as a constructor *) let na = out_patvar pat in - let env = push_name_env ntnvars [] env (make ?loc:pat.loc na) in - (renaming,env), None, na + let env = push_name_env ntnvars [] env na in + (renaming,env), None, na.v else (* Interpret as a pattern *) - let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in + let env,((disjpat,ids),id),na = intern_pat test_kind ntnvars env pat in let pat, na = match disjpat with | [pat] when is_patvar_store store pat -> let na = get () in None, na @@ -829,22 +867,22 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = let arg = match arg with | None -> None | Some arg -> - let mk_env id (c, (tmp_scope, subscopes)) map = - let nenv = {env with tmp_scope; scopes = subscopes @ env.scopes} in + let mk_env id (c, scopes) map = + let nenv = set_env_scopes env scopes in try let gc = intern nenv c in Id.Map.add id (gc, None) map with Nametab.GlobalizationError _ -> map in - let mk_env' (c, (onlyident,(tmp_scope,subscopes))) = - let nenv = {env with tmp_scope; scopes = subscopes @ env.scopes} in - if onlyident then - let na = out_patvar c in term_of_name na, None - else - let _,((disjpat,_),_),_ = intern_pat ntnvars nenv c in - match disjpat with - | [pat] -> (glob_constr_of_cases_pattern (Global.env()) pat, None) - | _ -> error_cannot_coerce_disjunctive_pattern_term ?loc:c.loc () + let mk_env' (c, (onlyident,scopes)) = + let nenv = set_env_scopes env scopes in + let test_kind = + if onlyident then test_kind_ident_in_notation + else test_kind_pattern_in_notation in + let _,((disjpat,_),_),_ = intern_pat test_kind ntnvars nenv c in + match disjpat with + | [pat] -> (glob_constr_of_cases_pattern (Global.env()) pat, None) + | _ -> error_cannot_coerce_disjunctive_pattern_term ?loc:c.loc () in let terms = Id.Map.fold mk_env terms Id.Map.empty in let binders = Id.Map.map mk_env' binders in @@ -890,20 +928,19 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = (* subst remembers the delimiters stack in the interpretation *) (* of the notations *) try - let (a,(scopt,subscopes)) = Id.Map.find id terms in - intern {env with tmp_scope = scopt; - scopes = subscopes @ env.scopes} a + let (a,scopes) = Id.Map.find id terms in + intern (set_env_scopes env scopes) a with Not_found -> try let pat,(onlyident,scopes) = Id.Map.find id binders in - let env = set_env_scopes env scopes in - if onlyident then - term_of_name (out_patvar pat) - else - let env,((disjpat,ids),id),na = intern_pat ntnvars env pat in - match disjpat with - | [pat] -> glob_constr_of_cases_pattern (Global.env()) pat - | _ -> user_err Pp.(str "Cannot turn a disjunctive pattern into a term.") + let nenv = set_env_scopes env scopes in + let test_kind = + if onlyident then test_kind_ident_in_notation + else test_kind_pattern_in_notation in + let env,((disjpat,ids),id),na = intern_pat test_kind ntnvars nenv pat in + match disjpat with + | [pat] -> glob_constr_of_cases_pattern (Global.env()) pat + | _ -> user_err Pp.(str "Cannot turn a disjunctive pattern into a term.") with Not_found -> try match binderopt with @@ -1570,11 +1607,11 @@ let rec subst_pat_iterator y t = DAst.(map (function | RCPatOr pl -> RCPatOr (List.map (subst_pat_iterator y t) pl))) let is_non_zero c = match c with -| { CAst.v = CPrim (Numeral p) } -> not (NumTok.Signed.is_zero p) +| { CAst.v = CPrim (Number p) } -> not (NumTok.Signed.is_zero p) | _ -> false let is_non_zero_pat c = match c with -| { CAst.v = CPatPrim (Numeral p) } -> not (NumTok.Signed.is_zero p) +| { CAst.v = CPatPrim (Number p) } -> not (NumTok.Signed.is_zero p) | _ -> false let get_asymmetric_patterns = Goptions.declare_bool_option_and_ref @@ -1582,19 +1619,14 @@ let get_asymmetric_patterns = Goptions.declare_bool_option_and_ref ~key:["Asymmetric";"Patterns"] ~value:false -let drop_notations_pattern looked_for genv = +let drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat = (* At toplevel, Constructors and Inductives are accepted, in recursive calls only constructor are allowed *) - let ensure_kind top loc g = - try - if top then looked_for g else - match g with GlobRef.ConstructRef _ -> () | _ -> raise Not_found + let ensure_kind test_kind ?loc g = + try test_kind ?loc g with Not_found -> error_invalid_pattern_notation ?loc () in - let test_kind top = - if top then looked_for else function GlobRef.ConstructRef _ -> () | _ -> raise Not_found - in (* [rcp_of_glob] : from [glob_constr] to [raw_cases_pattern_expr] *) let rec rcp_of_glob scopes x = DAst.(map (function | GVar id -> RCPatAtom (Some (CAst.make ?loc:x.loc id,scopes)) @@ -1611,47 +1643,49 @@ let drop_notations_pattern looked_for genv = end | _ -> CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr."))) x in - let rec drop_syndef top scopes qid pats = + let rec drop_syndef test_kind ?loc scopes qid pats = try + if qualid_is_ident qid && Option.cata (Id.Set.mem (qualid_basename qid)) false env.pat_ids then + raise Not_found; match Nametab.locate_extended qid with | SynDef sp -> let filter (vars,a) = try match a with | NRef g -> (* Convention: do not deactivate implicit arguments and scopes for further arguments *) - test_kind top g; + test_kind ?loc g; let () = assert (List.is_empty vars) in let (_,argscs) = find_remaining_scopes [] pats g in Some (g, [], List.map2 (in_pat_sc scopes) argscs pats) | NApp (NRef g,[]) -> (* special case: Syndef for @Cstr deactivates implicit arguments *) - test_kind top g; + test_kind ?loc g; let () = assert (List.is_empty vars) in let (_,argscs) = find_remaining_scopes [] pats g in Some (g, List.map2 (in_pat_sc scopes) argscs pats, []) | NApp (NRef g,args) -> (* Convention: do not deactivate implicit arguments and scopes for further arguments *) - test_kind top g; + test_kind ?loc g; let nvars = List.length vars in if List.length pats < nvars then error_not_enough_arguments ?loc:qid.loc; let pats1,pats2 = List.chop nvars pats in let subst = split_by_type_pat vars (pats1,[]) in - let idspl1 = List.map (in_not false qid.loc scopes subst []) args in + let idspl1 = List.map (in_not test_kind_inner qid.loc scopes subst []) args in let (_,argscs) = find_remaining_scopes pats1 pats2 g in Some (g, idspl1, List.map2 (in_pat_sc scopes) argscs pats2) | _ -> raise Not_found with Not_found -> None in Syntax_def.search_filtered_syntactic_definition filter sp | TrueGlobal g -> - test_kind top g; + test_kind ?loc g; Dumpglob.add_glob ?loc:qid.loc g; let (_,argscs) = find_remaining_scopes [] pats g in Some (g,[],List.map2 (in_pat_sc scopes) argscs pats) with Not_found -> None - and in_pat top scopes pt = + and in_pat test_kind scopes pt = let open CAst in let loc = pt.loc in match pt.v with - | CPatAlias (p, id) -> DAst.make ?loc @@ RCPatAlias (in_pat top scopes p, id) + | CPatAlias (p, id) -> DAst.make ?loc @@ RCPatAlias (in_pat test_kind scopes p, id) | CPatRecord l -> let sorted_fields = sort_fields ~complete:false loc l (fun _idx fieldname constructor -> CAst.make ?loc @@ CPatAtom None) in @@ -1668,7 +1702,7 @@ let drop_notations_pattern looked_for genv = end | CPatCstr (head, None, pl) -> begin - match drop_syndef top scopes head pl with + match drop_syndef test_kind ?loc scopes head pl with | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) | None -> Loc.raise ?loc (InternalizationError (NotAConstructor head)) end @@ -1682,37 +1716,37 @@ let drop_notations_pattern looked_for genv = in if expl_pl == [] then (* Convention: (@r) deactivates all further implicit arguments and scopes *) - DAst.make ?loc @@ RCPatCstr (g, List.map (in_pat false scopes) pl, []) + DAst.make ?loc @@ RCPatCstr (g, List.map (in_pat test_kind_inner scopes) pl, []) else (* Convention: (@r expl_pl) deactivates implicit arguments in expl_pl and in pl *) (* but not scopes in expl_pl *) let (argscs1,_) = find_remaining_scopes expl_pl pl g in - DAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat false scopes) pl, []) + DAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat test_kind_inner scopes) pl, []) | CPatNotation (_,(InConstrEntry,"- _"),([a],[]),[]) when is_non_zero_pat a -> - let p = match a.CAst.v with CPatPrim (Numeral (_, p)) -> p | _ -> assert false in - let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind false loc) (Numeral (SMinus,p)) scopes in + let p = match a.CAst.v with CPatPrim (Number (_, p)) -> p | _ -> assert false in + let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind test_kind_inner) (Number (SMinus,p)) scopes in rcp_of_glob scopes pat | CPatNotation (_,(InConstrEntry,"( _ )"),([a],[]),[]) -> - in_pat top scopes a + in_pat test_kind scopes a | CPatNotation (_,ntn,fullargs,extrargs) -> let ntn,(terms,termlists) = contract_curly_brackets_pat ntn fullargs in let ((ids',c),df) = Notation.interp_notation ?loc ntn scopes in - let (terms,termlists) = split_by_type_pat ?loc ids' (terms,termlists) in + let subst = split_by_type_pat ?loc ids' (terms,termlists) in Dumpglob.dump_notation_location (patntn_loc ?loc fullargs ntn) ntn df; - in_not top loc scopes (terms,termlists) extrargs c + in_not test_kind loc scopes subst extrargs c | CPatDelimiters (key, e) -> - in_pat top (None,find_delimiters_scope ?loc key::snd scopes) e + in_pat test_kind (None,find_delimiters_scope ?loc key::snd scopes) e | CPatPrim p -> - let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (test_kind false) p scopes in + let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc test_kind_inner p scopes in rcp_of_glob scopes pat | CPatAtom (Some id) -> begin - match drop_syndef top scopes id [] with + match drop_syndef test_kind ?loc scopes id [] with | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr (a, b, c) | None -> DAst.make ?loc @@ RCPatAtom (Some ((make ?loc @@ find_pattern_variable id),scopes)) end | CPatAtom None -> DAst.make ?loc @@ RCPatAtom None - | CPatOr pl -> DAst.make ?loc @@ RCPatOr (List.map (in_pat top scopes) pl) + | CPatOr pl -> DAst.make ?loc @@ RCPatOr (List.map (in_pat test_kind scopes) pl) | CPatCast (_,_) -> (* We raise an error if the pattern contains a cast, due to current restrictions on casts in patterns. Cast in patterns @@ -1725,8 +1759,8 @@ let drop_notations_pattern looked_for genv = This check is here and not in the parser because it would require duplicating the levels of the [pattern] rule. *) CErrors.user_err ?loc (Pp.strbrk "Casts are not supported in this pattern.") - and in_pat_sc scopes x = in_pat false (x,snd scopes) - and in_not top loc scopes (subst,substlist as fullsubst) args = function + and in_pat_sc scopes x = in_pat test_kind_inner (x,snd scopes) + and in_not (test_kind:?loc:Loc.t->'a->'b) loc scopes (subst,substlist as fullsubst) args = function | NVar id -> let () = assert (List.is_empty args) in begin @@ -1734,21 +1768,21 @@ let drop_notations_pattern looked_for genv = (* of the notations *) try let (a,(scopt,subscopes)) = Id.Map.find id subst in - in_pat top (scopt,subscopes@snd scopes) a + in_pat test_kind (scopt,subscopes@snd scopes) a with Not_found -> if Id.equal id ldots_var then DAst.make ?loc @@ RCPatAtom (Some ((make ?loc id),scopes)) else anomaly (str "Unbound pattern notation variable: " ++ Id.print id ++ str ".") end | NRef g -> - ensure_kind top loc g; + ensure_kind test_kind ?loc g; let (_,argscs) = find_remaining_scopes [] args g in DAst.make ?loc @@ RCPatCstr (g, [], List.map2 (in_pat_sc scopes) argscs args) | NApp (NRef g,pl) -> - ensure_kind top loc g; + ensure_kind test_kind ?loc g; let (argscs1,argscs2) = find_remaining_scopes pl args g in - let pl = List.map2 (fun x -> in_not false loc (x,snd scopes) fullsubst []) argscs1 pl in + let pl = List.map2 (fun x -> in_not test_kind_inner loc (x,snd scopes) fullsubst []) argscs1 pl in let pl = add_local_defs_and_check_length loc genv g pl args in - let args = List.map2 (fun x -> in_pat false (x,snd scopes)) argscs2 args in + let args = List.map2 (fun x -> in_pat test_kind_inner (x,snd scopes)) argscs2 args in let pat = if List.length pl = 0 then (* Convention: if notation is @f, encoded as NApp(Nref g,[]), then @@ -1763,10 +1797,10 @@ let drop_notations_pattern looked_for genv = (try (* All elements of the list are in scopes (scopt,subscopes) *) let (l,(scopt,subscopes)) = Id.Map.find x substlist in - let termin = in_not top loc scopes fullsubst [] terminator in + let termin = in_not test_kind_inner loc scopes fullsubst [] terminator in List.fold_right (fun a t -> let nsubst = Id.Map.add y (a, (scopt, subscopes)) subst in - let u = in_not false loc scopes (nsubst, substlist) [] iter in + let u = in_not test_kind_inner loc scopes (nsubst, substlist) [] iter in subst_pat_iterator ldots_var t u) (if revert then List.rev l else l) termin with Not_found -> @@ -1775,7 +1809,7 @@ let drop_notations_pattern looked_for genv = let () = assert (List.is_empty args) in DAst.make ?loc @@ RCPatAtom None | t -> error_invalid_pattern_notation ?loc () - in in_pat true + in in_pat test_kind_top env.pat_scopes pat let rec intern_pat genv ntnvars aliases pat = let intern_cstr_with_all_args loc c with_letin idslpl1 pl2 = @@ -1816,19 +1850,30 @@ let rec intern_pat genv ntnvars aliases pat = check_or_pat_variables loc ids (List.tl idsl); (ids,List.flatten pl') -let intern_cases_pattern genv ntnvars scopes aliases pat = +let intern_cases_pattern test_kind genv ntnvars env aliases pat = intern_pat genv ntnvars aliases - (drop_notations_pattern (function GlobRef.ConstructRef _ -> () | _ -> raise Not_found) genv scopes pat) + (drop_notations_pattern (test_kind,test_kind) genv env pat) let _ = intern_cases_pattern_fwd := - fun ntnvars scopes p -> intern_cases_pattern (Global.env ()) ntnvars scopes empty_alias p - -let intern_ind_pattern genv ntnvars scopes pat = + fun test_kind ntnvars env p -> + intern_cases_pattern test_kind (Global.env ()) ntnvars env empty_alias p + +let intern_ind_pattern genv ntnvars env pat = + let test_kind_top ?loc = function + | GlobRef.IndRef _ -> () + | GlobRef.ConstructRef _ | GlobRef.ConstRef _ | GlobRef.VarRef _ -> + (* A non-inductive global reference at top is an error *) + error_invalid_pattern_notation ?loc () in + let test_kind_inner ?loc = function + | GlobRef.ConstructRef _ -> () + | GlobRef.IndRef _ | GlobRef.ConstRef _ | GlobRef.VarRef _ -> + (* A non-constructor global reference deep in a pattern is seen as a variable *) + raise Not_found in let no_not = try - drop_notations_pattern (function (GlobRef.IndRef _ | GlobRef.ConstructRef _) -> () | _ -> raise Not_found) genv scopes pat - with InternalizationError(NotAConstructor _) as exn -> + drop_notations_pattern (test_kind_top,test_kind_inner) genv env pat + with InternalizationError (NotAConstructor _) as exn -> let _, info = Exninfo.capture exn in error_bad_inductive_type ~info () in @@ -1927,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 @@ -2006,8 +2051,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = GLetIn (na.CAst.v, inc1, int, intern_restart_binders (push_name_env ntnvars (impls_term_list 1 inc1) env na) c2) | CNotation (_,(InConstrEntry,"- _"), ([a],[],[],[])) when is_non_zero a -> - let p = match a.CAst.v with CPrim (Numeral (_, p)) -> p | _ -> assert false in - intern env (CAst.make ?loc @@ CPrim (Numeral (SMinus,p))) + let p = match a.CAst.v with CPrim (Number (_, p)) -> p | _ -> assert false in + intern env (CAst.make ?loc @@ CPrim (Number (SMinus,p))) | CNotation (_,(InConstrEntry,"( _ )"),([a],[],[],[])) -> intern env a | CNotation (_,ntn,args) -> let c = intern_notation intern env ntnvars loc ntn args in @@ -2047,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 @@ -2221,7 +2270,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* Expands a multiple pattern into a disjunction of multiple patterns *) and intern_multiple_pattern env n pl = - let idsl_pll = List.map (intern_cases_pattern globalenv ntnvars (None,env.scopes) empty_alias) pl in + let env = { pat_ids = None; pat_scopes = (None,env.scopes) } in + let idsl_pll = List.map (intern_cases_pattern test_kind_tolerant globalenv ntnvars env empty_alias) pl in let loc = loc_of_multiple_pattern pl in check_number_of_pattern loc n pl; product_of_cases_patterns empty_alias idsl_pll @@ -2262,7 +2312,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let match_td,typ = match t with | Some t -> let with_letin,(ind,ind_ids,alias_subst,l) = - intern_ind_pattern globalenv ntnvars (None,env.scopes) t in + intern_ind_pattern globalenv ntnvars (env_for_pattern (set_type_scope env)) t in let (mib,mip) = Inductive.lookup_mind_specif globalenv ind in let nparams = (List.length (mib.Declarations.mind_params_ctxt)) in (* for "in Vect n", we answer (["n","n"],[(loc,"n")]) @@ -2359,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 @@ -2403,7 +2454,8 @@ let intern_gen kind env sigma let intern_constr env sigma c = intern_gen WithoutTypeConstraint env sigma c let intern_type env sigma c = intern_gen IsType env sigma c let intern_pattern globalenv patt = - intern_cases_pattern globalenv Id.Map.empty (None,[]) empty_alias patt + let env = {pat_ids = None; pat_scopes = (None, [])} in + intern_cases_pattern test_kind_tolerant globalenv Id.Map.empty env empty_alias patt (*********************************************************************) (* Functions to parse and interpret constructions *) @@ -2471,6 +2523,14 @@ let intern_constr_pattern env sigma ?(as_type=false) ?(ltacvars=empty_ltac_sign) ~pattern_mode:true ~ltacvars env sigma c in pattern_of_glob_constr c +let interp_constr_pattern env sigma ?(expected_type=WithoutTypeConstraint) c = + let c = intern_gen expected_type ~pattern_mode:true env sigma c in + let flags = { Pretyping.no_classes_no_fail_inference_flags with expand_evars = false } in + let sigma, c = understand_tcc ~flags env sigma ~expected_type c in + (* FIXME: it is necessary to be unsafe here because of the way we handle + evars in the pretyper. Sometimes they get solved eagerly. *) + pattern_of_constr env sigma (EConstr.Unsafe.to_constr c) + let intern_core kind env sigma ?(pattern_mode=false) ?(ltacvars=empty_ltac_sign) { Genintern.intern_ids = ids; Genintern.notation_variable_status = vl } c = let tmp_scope = scope_of_type_kind env sigma kind in @@ -2565,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 898a3e09c8..0de6c3e89d 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -136,10 +136,16 @@ val interp_type_evars_impls : ?flags:inference_flags -> env -> evar_map -> (** Interprets constr patterns *) +(** Without typing *) val intern_constr_pattern : env -> evar_map -> ?as_type:bool -> ?ltacvars:ltac_sign -> constr_pattern_expr -> patvar list * constr_pattern +(** With typing *) +val interp_constr_pattern : + env -> evar_map -> ?expected_type:typing_constraint -> + constr_pattern_expr -> constr_pattern + (** Raise Not_found if syndef not bound to a name and error if unexisting ref *) val intern_reference : qualid -> GlobRef.t @@ -191,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/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 2853eef5c5..ee07fb6ed1 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -114,8 +114,8 @@ let generalizable_vars_of_glob_constr ?(bound=Id.Set.empty) ?(allowed=Id.Set.emp ungeneralizable loc id) vars; vars -let rec make_fresh ids env x = - if is_freevar ids env x then x else make_fresh ids env (Nameops.increment_subscript x) +let make_fresh ids env x = + Namegen.next_ident_away_from x (fun x -> not (is_freevar ids env x)) let next_name_away_from na avoid = match na with 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 d57c4f3abf..948ebe9640 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -32,7 +32,7 @@ open NumTok fail if a number has no interpretation in the scope (e.g. there is no interpretation for negative numbers in [nat]); interpreters both for terms and patterns can be set; these interpreters are in permanent table - [numeral_interpreter_tab] + [number_interpreter_tab] - a set of ML printers for expressions denoting numbers parsable in this scope - a set of interpretations for infix (more generally distfix) notations @@ -323,7 +323,7 @@ type key = | Oth let key_compare k1 k2 = match k1, k2 with -| RefKey gr1, RefKey gr2 -> GlobRef.Ordered.compare gr1 gr2 +| RefKey gr1, RefKey gr2 -> GlobRef.CanOrd.compare gr1 gr2 | RefKey _, Oth -> -1 | Oth, RefKey _ -> 1 | Oth, Oth -> 0 @@ -341,22 +341,27 @@ type notation_rule = interp_rule * interpretation * notation_applicative_status let notation_rule_eq (rule1,pat1,s1 as x1) (rule2,pat2,s2 as x2) = x1 == x2 || (rule1 = rule2 && interpretation_eq pat1 pat2 && s1 = s2) +let also_cases_notation_rule_eq (also_cases1,rule1) (also_cases2,rule2) = + (* No need in principle to compare also_cases as it is inferred *) + also_cases1 = also_cases2 && notation_rule_eq rule1 rule2 + let keymap_add key interp map = let old = try KeyMap.find key map with Not_found -> [] in (* In case of re-import, no need to keep the previous copy *) - let old = try List.remove_first (notation_rule_eq interp) old with Not_found -> old in + let old = try List.remove_first (also_cases_notation_rule_eq interp) old with Not_found -> old in KeyMap.add key (interp :: old) map let keymap_remove key interp map = let old = try KeyMap.find key map with Not_found -> [] in - KeyMap.add key (List.remove_first (notation_rule_eq interp) old) map + KeyMap.add key (List.remove_first (also_cases_notation_rule_eq interp) old) map let keymap_find key map = try KeyMap.find key map with Not_found -> [] (* Scopes table : interpretation -> scope_name *) -let notations_key_table = ref (KeyMap.empty : notation_rule list KeyMap.t) +(* Boolean = for cases pattern also *) +let notations_key_table = ref (KeyMap.empty : (bool * notation_rule) list KeyMap.t) let glob_prim_constr_key c = match DAst.get c with | GRef (ref, _) -> Some (canonical_gr ref) @@ -446,13 +451,13 @@ module InnerPrimToken = struct let do_interp ?loc interp primtok = match primtok, interp with - | Numeral n, RawNumInterp interp -> interp ?loc n - | Numeral n, BigNumInterp interp -> + | Number n, RawNumInterp interp -> interp ?loc n + | Number n, BigNumInterp interp -> (match NumTok.Signed.to_bigint n with | Some n -> interp ?loc n | None -> raise Not_found) | String s, StringInterp interp -> interp ?loc s - | (Numeral _ | String _), + | (Number _ | String _), (RawNumInterp _ | BigNumInterp _ | StringInterp _) -> raise Not_found type uninterpreter = @@ -466,16 +471,16 @@ module InnerPrimToken = struct | StringUninterp f, StringUninterp f' -> f == f' | _ -> false - let mkNumeral n = - Numeral (NumTok.Signed.of_bigint CDec n) + let mkNumber n = + Number (NumTok.Signed.of_bigint CDec n) let mkString = function | None -> None | Some s -> if Unicode.is_utf8 s then Some (String s) else None let do_uninterp uninterp g = match uninterp with - | RawNumUninterp u -> Option.map (fun (s,n) -> Numeral (s,n)) (u g) - | BigNumUninterp u -> Option.map mkNumeral (u g) + | RawNumUninterp u -> Option.map (fun (s,n) -> Number (s,n)) (u g) + | BigNumUninterp u -> Option.map mkNumber (u g) | StringUninterp u -> mkString (u g) end @@ -495,7 +500,7 @@ let prim_token_uninterpreters = (Hashtbl.create 7 : (prim_token_uid, InnerPrimToken.uninterpreter) Hashtbl.t) (*******************************************************) -(* Numeral notation interpretation *) +(* Number notation interpretation *) type prim_token_notation_error = | UnexpectedTerm of Constr.t | UnexpectedNonOptionTerm of Constr.t @@ -519,21 +524,21 @@ type z_pos_ty = { z_ty : Names.inductive; pos_ty : Names.inductive } -type numeral_ty = +type number_ty = { int : int_ty; decimal : Names.inductive; hexadecimal : Names.inductive; - numeral : Names.inductive } + number : Names.inductive } type target_kind = - | Int of int_ty (* Coq.Init.Numeral.int + uint *) - | UInt of int_ty (* Coq.Init.Numeral.uint *) + | Int of int_ty (* Coq.Init.Number.int + uint *) + | UInt of int_ty (* Coq.Init.Number.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) | Int63 (* Coq.Numbers.Cyclic.Int63.Int63.int *) - | Numeral of numeral_ty (* Coq.Init.Numeral.numeral + uint + int *) + | Number of number_ty (* Coq.Init.Number.number + uint + int *) | DecimalInt of int_ty (* Coq.Init.Decimal.int + uint (deprecated) *) | DecimalUInt of int_ty (* Coq.Init.Decimal.uint (deprecated) *) - | Decimal of numeral_ty (* Coq.Init.Decimal.Decimal + uint + int (deprecated) *) + | Decimal of number_ty (* Coq.Init.Decimal.Decimal + uint + int (deprecated) *) type string_target_kind = | ListByte @@ -542,19 +547,36 @@ type string_target_kind = type option_kind = Option | Direct type 'target conversion_kind = 'target * option_kind +(** A postprocessing translation [to_post] can be done after execution + of the [to_ty] interpreter. The reverse translation is performed + before the [of_ty] uninterpreter. + + [to_post] is an array of [n] lists [l_i] of tuples [(f, t, + args)]. When the head symbol of the translated term matches one of + the [f] in the list [l_0] it is replaced by [t] and its arguments + are translated acording to [args] where [ToPostCopy] means that the + argument is kept unchanged and [ToPostAs k] means that the + argument is recursively translated according to [l_k]. + [ToPostHole] introduces an additional implicit argument hole + (in the reverse translation, the corresponding argument is removed). + [ToPostCheck r] behaves as [ToPostCopy] except in the reverse + translation which fails if the copied term is not [r]. + When [n] is null, no translation is performed. *) +type to_post_arg = ToPostCopy | ToPostAs of int | ToPostHole | ToPostCheck of GlobRef.t type ('target, 'warning) prim_token_notation_obj = { to_kind : 'target conversion_kind; to_ty : GlobRef.t; + to_post : ((GlobRef.t * GlobRef.t * to_post_arg list) list) array; of_kind : 'target conversion_kind; of_ty : GlobRef.t; ty_name : Libnames.qualid; (* for warnings / error messages *) warning : 'warning } -type numeral_notation_obj = (target_kind, numnot_option) prim_token_notation_obj +type number_notation_obj = (target_kind, numnot_option) prim_token_notation_obj type string_notation_obj = (string_target_kind, unit) prim_token_notation_obj module PrimTokenNotation = struct -(** * Code shared between Numeral notation and String notation *) +(** * Code shared between Number notation and String notation *) (** Reduction The constr [c] below isn't necessarily well-typed, since we @@ -588,22 +610,69 @@ exception NotAValidPrimToken to [constr] for the subset that concerns us. Note that if you update [constr_of_glob], you should update the - corresponding numeral notation *and* string notation doc in + corresponding number notation *and* string notation doc in doc/sphinx/user-extensions/syntax-extensions.rst that describes what it means for a term to be ground / to be able to be considered for parsing. *) -let rec constr_of_glob env sigma g = match DAst.get g with - | Glob_term.GRef (GlobRef.ConstructRef c, _) -> - let sigma,c = Evd.fresh_constructor_instance env sigma c in - sigma,mkConstructU c - | Glob_term.GRef (GlobRef.IndRef c, _) -> - let sigma,c = Evd.fresh_inductive_instance env sigma c in - sigma,mkIndU c +let constr_of_globref allow_constant env sigma = function + | GlobRef.ConstructRef c -> + let sigma,c = Evd.fresh_constructor_instance env sigma c in + sigma,mkConstructU c + | GlobRef.IndRef c -> + let sigma,c = Evd.fresh_inductive_instance env sigma c in + sigma,mkIndU c + | GlobRef.ConstRef c when allow_constant -> + let sigma,c = Evd.fresh_constant_instance env sigma c in + sigma,mkConstU c + | _ -> raise NotAValidPrimToken + +let rec constr_of_glob allow_constant to_post post env sigma g = match DAst.get g with + | Glob_term.GRef (r, _) -> + let o = List.find_opt (fun (_,r',_) -> GlobRef.equal r r') post in + begin match o with + | None -> constr_of_globref allow_constant env sigma r + | Some (r, _, a) -> + (* [g] is not a GApp so check that [post] + does not expect any actual argument + (i.e., [a] contains only ToPostHole since they mean "ignore arg") *) + if List.exists ((<>) ToPostHole) a then raise NotAValidPrimToken; + constr_of_globref true env sigma r + end | Glob_term.GApp (gc, gcl) -> - let sigma,c = constr_of_glob env sigma gc in - let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in - sigma,mkApp (c, Array.of_list cl) + let o = match DAst.get gc with + | Glob_term.GRef (r, _) -> List.find_opt (fun (_,r',_) -> GlobRef.equal r r') post + | _ -> None in + begin match o with + | None -> + let sigma,c = constr_of_glob allow_constant to_post post env sigma gc in + let sigma,cl = List.fold_left_map (constr_of_glob allow_constant to_post post env) sigma gcl in + sigma,mkApp (c, Array.of_list cl) + | Some (r, _, a) -> + let sigma,c = constr_of_globref true env sigma r in + let rec aux sigma a gcl = match a, gcl with + | [], [] -> sigma,[] + | ToPostCopy :: a, gc :: gcl -> + let sigma,c = constr_of_glob allow_constant [||] [] env sigma gc in + let sigma,cl = aux sigma a gcl in + sigma, c :: cl + | ToPostCheck r :: a, gc :: gcl -> + let () = match DAst.get gc with + | Glob_term.GRef (r', _) when GlobRef.equal r r' -> () + | _ -> raise NotAValidPrimToken in + let sigma,c = constr_of_glob true [||] [] env sigma gc in + let sigma,cl = aux sigma a gcl in + sigma, c :: cl + | ToPostAs i :: a, gc :: gcl -> + let sigma,c = constr_of_glob allow_constant to_post to_post.(i) env sigma gc in + let sigma,cl = aux sigma a gcl in + sigma, c :: cl + | ToPostHole :: post, _ :: gcl -> aux sigma post gcl + | [], _ :: _ | _ :: _, [] -> raise NotAValidPrimToken + in + let sigma,cl = aux sigma a gcl in + sigma,mkApp (c, Array.of_list cl) + end | Glob_term.GInt i -> sigma, mkInt i | Glob_term.GSort gs -> let sigma,c = Evd.fresh_sort_in_family sigma (Glob_ops.glob_sort_family gs) in @@ -611,6 +680,10 @@ let rec constr_of_glob env sigma g = match DAst.get g with | _ -> raise NotAValidPrimToken +let constr_of_glob to_post env sigma (Glob_term.AnyGlobConstr g) = + let post = match to_post with [||] -> [] | _ -> to_post.(0) in + constr_of_glob false to_post post env sigma g + let rec glob_of_constr token_kind ?loc env sigma c = match Constr.kind c with | App (c, ca) -> let c = glob_of_constr token_kind ?loc env sigma c in @@ -632,9 +705,38 @@ let no_such_prim_token uninterpreted_token_kind ?loc ty = (str ("Cannot interpret this "^uninterpreted_token_kind^" as a value of type ") ++ pr_qualid ty) -let interp_option uninterpreted_token_kind token_kind ty ?loc env sigma c = +let rec postprocess token_kind ?loc ty to_post post g = + let g', gl = match DAst.get g with Glob_term.GApp (g, gl) -> g, gl | _ -> g, [] in + let o = + match DAst.get g' with + | Glob_term.GRef (r, None) -> + List.find_opt (fun (r',_,_) -> GlobRef.equal r r') post + | _ -> None in + match o with None -> g | Some (_, r, a) -> + let rec f n a gl = match a, gl with + | [], [] -> [] + | ToPostHole :: a, gl -> + let e = Evar_kinds.ImplicitArg (r, (n, None), true) in + let h = DAst.make ?loc (Glob_term.GHole (e, Namegen.IntroAnonymous, None)) in + h :: f (n+1) a gl + | (ToPostCopy | ToPostCheck _) :: a, g :: gl -> g :: f (n+1) a gl + | ToPostAs c :: a, g :: gl -> + postprocess token_kind ?loc ty to_post to_post.(c) g :: f (n+1) a gl + | [], _::_ | _::_, [] -> + no_such_prim_token token_kind ?loc ty + in + let gl = f 1 a gl in + let g = DAst.make ?loc (Glob_term.GRef (r, None)) in + DAst.make ?loc (Glob_term.GApp (g, gl)) + +let glob_of_constr token_kind ty ?loc env sigma to_post c = + let g = glob_of_constr token_kind ?loc env sigma c in + match to_post with [||] -> g | _ -> + postprocess token_kind ?loc ty to_post to_post.(0) g + +let interp_option uninterpreted_token_kind token_kind ty ?loc env sigma to_post c = match Constr.kind c with - | App (_Some, [| _; c |]) -> glob_of_constr token_kind ?loc env sigma c + | App (_Some, [| _; c |]) -> glob_of_constr token_kind ty ?loc env sigma to_post c | App (_None, [| _ |]) -> no_such_prim_token uninterpreted_token_kind ?loc ty | x -> Loc.raise ?loc (PrimTokenNotationError(token_kind,env,sigma,UnexpectedNonOptionTerm c)) @@ -643,13 +745,13 @@ let uninterp_option c = | App (_Some, [| _; x |]) -> x | _ -> raise NotAValidPrimToken -let uninterp to_raw o (Glob_term.AnyGlobConstr n) = +let uninterp to_raw o n = let env = Global.env () in let sigma = Evd.from_env env in let sigma,of_ty = Evd.fresh_global env sigma o.of_ty in let of_ty = EConstr.Unsafe.to_constr of_ty in try - let sigma,n = constr_of_glob env sigma n in + let sigma,n = constr_of_glob o.to_post env sigma n in let c = eval_constr_app env sigma of_ty n in let c = if snd o.of_kind == Direct then c else uninterp_option c in Some (to_raw (fst o.of_kind, c)) @@ -670,8 +772,8 @@ let rec int63_of_pos_bigint i = (Uint63.mul (Uint63.of_int 2) (int63_of_pos_bigint quo)) else Uint63.mul (Uint63.of_int 2) (int63_of_pos_bigint quo) -module Numeral = struct -(** * Numeral notation *) +module Numbers = struct +(** * Number notation *) open PrimTokenNotation let warn_large_num = @@ -727,7 +829,7 @@ let coqint_of_rawnum inds c (sign,n) = let pos_neg = match sign with SPlus -> 1 | SMinus -> 2 in mkApp (mkConstruct (ind, pos_neg), [|uint|]) -let coqnumeral_of_rawnum inds c n = +let coqnumber_of_rawnum inds c n = let ind = match c with CDec -> inds.decimal | CHex -> inds.hexadecimal in let i, f, e = NumTok.Signed.to_int_frac_and_exponent n in let i = coqint_of_rawnum inds.int c i in @@ -739,19 +841,19 @@ let coqnumeral_of_rawnum inds c n = mkApp (mkConstruct (ind, 2), [|i; f; e|]) (* (D|Hexad)ecimalExp *) let mkDecHex ind c n = match c with - | CDec -> mkApp (mkConstruct (ind, 1), [|n|]) (* (UInt|Int|)Dec *) - | CHex -> mkApp (mkConstruct (ind, 2), [|n|]) (* (UInt|Int|)Hex *) + | CDec -> mkApp (mkConstruct (ind, 1), [|n|]) (* (UInt|Int|)Decimal *) + | CHex -> mkApp (mkConstruct (ind, 2), [|n|]) (* (UInt|Int|)Hexadecimal *) exception NonDecimal -let decimal_coqnumeral_of_rawnum inds n = +let decimal_coqnumber_of_rawnum inds n = if NumTok.Signed.classify n <> CDec then raise NonDecimal; - coqnumeral_of_rawnum inds CDec n + coqnumber_of_rawnum inds CDec n -let coqnumeral_of_rawnum inds n = +let coqnumber_of_rawnum inds n = let c = NumTok.Signed.classify n in - let n = coqnumeral_of_rawnum inds c n in - mkDecHex inds.numeral c n + let n = coqnumber_of_rawnum inds c n in + mkDecHex inds.number c n let decimal_coquint_of_rawnum inds n = if NumTok.UnsignedNat.classify n <> CDec then raise NonDecimal; @@ -801,7 +903,7 @@ let rawnum_of_coqint cl c = | _ -> raise NotAValidPrimToken) | _ -> raise NotAValidPrimToken -let rawnum_of_coqnumeral cl c = +let rawnum_of_coqnumber cl c = let of_ife i f e = let n = rawnum_of_coqint cl i in let f = try Some (rawnum_of_coquint cl f) with NotAValidPrimToken -> None in @@ -815,17 +917,17 @@ let rawnum_of_coqnumeral cl c = let destDecHex c = match Constr.kind c with | App (c,[|c'|]) -> (match Constr.kind c with - | Construct ((_,1), _) (* (UInt|Int|)Dec *) -> CDec, c' - | Construct ((_,2), _) (* (UInt|Int|)Hex *) -> CHex, c' + | Construct ((_,1), _) (* (UInt|Int|)Decimal *) -> CDec, c' + | Construct ((_,2), _) (* (UInt|Int|)Hexadecimal *) -> CHex, c' | _ -> raise NotAValidPrimToken) | _ -> raise NotAValidPrimToken -let decimal_rawnum_of_coqnumeral c = - rawnum_of_coqnumeral CDec c +let decimal_rawnum_of_coqnumber c = + rawnum_of_coqnumber CDec c -let rawnum_of_coqnumeral c = +let rawnum_of_coqnumber c = let cl, c = destDecHex c in - rawnum_of_coqnumeral cl c + rawnum_of_coqnumber cl c let decimal_rawnum_of_coquint c = rawnum_of_coquint CDec c @@ -947,9 +1049,9 @@ let interp o ?loc n = interp_int63 ?loc (NumTok.SignedNat.to_bigint n) | (Int _ | UInt _ | DecimalInt _ | DecimalUInt _ | Z _ | Int63), _ -> no_such_prim_token "number" ?loc o.ty_name - | Numeral numeral_ty, _ -> coqnumeral_of_rawnum numeral_ty n - | Decimal numeral_ty, _ -> - (try decimal_coqnumeral_of_rawnum numeral_ty n + | Number number_ty, _ -> coqnumber_of_rawnum number_ty n + | Decimal number_ty, _ -> + (try decimal_coqnumber_of_rawnum number_ty n with NonDecimal -> no_such_prim_token "number" ?loc o.ty_name) in let env = Global.env () in @@ -959,12 +1061,13 @@ let interp o ?loc n = match o.warning, snd o.to_kind with | Abstract threshold, Direct when NumTok.Signed.is_bigger_int_than n threshold -> warn_abstract_large_num (o.ty_name,o.to_ty); - glob_of_constr "numeral" ?loc env sigma (mkApp (to_ty,[|c|])) + assert (Array.length o.to_post = 0); + glob_of_constr "number" o.ty_name ?loc env sigma o.to_post (mkApp (to_ty,[|c|])) | _ -> let res = eval_constr_app env sigma to_ty c in match snd o.to_kind with - | Direct -> glob_of_constr "numeral" ?loc env sigma res - | Option -> interp_option "number" "numeral" o.ty_name ?loc env sigma res + | Direct -> glob_of_constr "number" o.ty_name ?loc env sigma o.to_post res + | Option -> interp_option "number" "number" o.ty_name ?loc env sigma o.to_post res let uninterp o n = PrimTokenNotation.uninterp @@ -973,10 +1076,10 @@ let uninterp o n = | (UInt _, c) -> NumTok.Signed.of_nat (rawnum_of_coquint c) | (Z _, c) -> NumTok.Signed.of_bigint CDec (bigint_of_z c) | (Int63, c) -> NumTok.Signed.of_bigint CDec (bigint_of_int63 c) - | (Numeral _, c) -> rawnum_of_coqnumeral c + | (Number _, c) -> rawnum_of_coqnumber c | (DecimalInt _, c) -> NumTok.Signed.of_int (decimal_rawnum_of_coqint c) | (DecimalUInt _, c) -> NumTok.Signed.of_nat (decimal_rawnum_of_coquint c) - | (Decimal _, c) -> decimal_rawnum_of_coqnumeral c + | (Decimal _, c) -> decimal_rawnum_of_coqnumber c end o n end @@ -1009,11 +1112,12 @@ let coqbyte_of_string ?loc byte s = let p = if Int.equal (String.length s) 1 then int_of_char s.[0] else - if Int.equal (String.length s) 3 && is_digit s.[0] && is_digit s.[1] && is_digit s.[2] - then int_of_string s - else + let n = + if Int.equal (String.length s) 3 && is_digit s.[0] && is_digit s.[1] && is_digit s.[2] + then int_of_string s else 256 in + if n < 256 then n else user_err ?loc ~hdr:"coqbyte_of_string" - (str "Expects a single character or a three-digits ascii code.") in + (str "Expects a single character or a three-digit ASCII code.") in coqbyte_of_char_code byte p let coqbyte_of_char byte c = coqbyte_of_char_code byte (Char.code c) @@ -1068,8 +1172,8 @@ let interp o ?loc n = let to_ty = EConstr.Unsafe.to_constr to_ty in let res = eval_constr_app env sigma to_ty c in match snd o.to_kind with - | Direct -> glob_of_constr "string" ?loc env sigma res - | Option -> interp_option "string" "string" o.ty_name ?loc env sigma res + | Direct -> glob_of_constr "string" o.ty_name ?loc env sigma o.to_post res + | Option -> interp_option "string" "string" o.ty_name ?loc env sigma o.to_post res let uninterp o n = PrimTokenNotation.uninterp @@ -1081,21 +1185,21 @@ end (* A [prim_token_infos], which is synchronized with the document state, either contains a unique id pointing to an unsynchronized - prim token function, or a numeral notation object describing how to + prim token function, or a number notation object describing how to interpret and uninterpret. We provide [prim_token_infos] because we expect plugins to provide their own interpretation functions, - rather than going through numeral notations, which are available as + rather than going through number notations, which are available as a vernacular. *) type prim_token_interp_info = Uid of prim_token_uid - | NumeralNotation of numeral_notation_obj + | NumberNotation of number_notation_obj | StringNotation of string_notation_obj type prim_token_infos = { pt_local : bool; (** Is this interpretation local? *) pt_scope : scope_name; (** Concerned scope *) - pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a numeral notation object describing (un)interp functions *) + pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a number notation object describing (un)interp functions *) pt_required : required_module; (** Module that should be loaded first *) pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) pt_in_match : bool (** Is this prim token legal in match patterns ? *) @@ -1119,7 +1223,7 @@ let hashtbl_check_and_set allow_overwrite uid f h eq = | _ -> user_err ~hdr:"prim_token_interpreter" (str "Unique identifier " ++ str uid ++ - str " already used to register a numeral or string (un)interpreter.") + str " already used to register a number or string (un)interpreter.") let register_gen_interpretation allow_overwrite uid (interp, uninterp) = hashtbl_check_and_set @@ -1147,7 +1251,6 @@ let cache_prim_token_interpretation (_,infos) = String.Map.add sc (infos.pt_required,ptii) !prim_token_interp_infos; let add_uninterp r = let l = try GlobRef.Map.find r !prim_token_uninterp_infos with Not_found -> [] in - let l = List.remove_assoc_f String.equal sc l in prim_token_uninterp_infos := GlobRef.Map.add r ((sc,(ptii,infos.pt_in_match)) :: l) !prim_token_uninterp_infos in @@ -1220,7 +1323,7 @@ let check_required_module ?loc sc (sp,d) = (str "Cannot interpret in " ++ str sc ++ str " without requiring first module " ++ str (List.last d) ++ str ".") -(* Look if some notation or numeral printer in [scope] can be used in +(* Look if some notation or number printer in [scope] can be used in the scope stack [scopes], and if yes, using delimiters or not *) let find_with_delimiters = function @@ -1237,7 +1340,7 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function | NotationInScope scope' when String.equal scope scope' -> Some (None,None) | _ -> - (* If the most recently open scope has a notation/numeral printer + (* If the most recently open scope has a notation/number printer but not the expected one then we need delimiters *) if find scope then find_with_delimiters ntn_scope @@ -1333,13 +1436,13 @@ let check_printing_override (scopt,ntn) data parsingdata printingdata = exists) printingdata in parsing_update, exists -let remove_uninterpretation rule (metas,c as pat) = +let remove_uninterpretation rule also_in_cases_pattern (metas,c as pat) = let (key,n) = notation_constr_key c in - notations_key_table := keymap_remove key (rule,pat,n) !notations_key_table + notations_key_table := keymap_remove key (also_in_cases_pattern,(rule,pat,n)) !notations_key_table -let declare_uninterpretation rule (metas,c as pat) = +let declare_uninterpretation ?(also_in_cases_pattern=true) rule (metas,c as pat) = let (key,n) = notation_constr_key c in - notations_key_table := keymap_add key (rule,pat,n) !notations_key_table + notations_key_table := keymap_add key (also_in_cases_pattern,(rule,pat,n)) !notations_key_table let update_notation_data (scopt,ntn) use data table = let (parsingdata,printingdata) = @@ -1375,8 +1478,8 @@ let find_notation ntn sc = | _ -> raise Not_found let notation_of_prim_token = function - | Constrexpr.Numeral (SPlus,n) -> InConstrEntry, NumTok.Unsigned.sprint n - | Constrexpr.Numeral (SMinus,n) -> InConstrEntry, "- "^NumTok.Unsigned.sprint n + | Constrexpr.Number (SPlus,n) -> InConstrEntry, NumTok.Unsigned.sprint n + | Constrexpr.Number (SMinus,n) -> InConstrEntry, "- "^NumTok.Unsigned.sprint n | String _ -> raise Not_found let find_prim_token check_allowed ?loc p sc = @@ -1394,7 +1497,7 @@ let find_prim_token check_allowed ?loc p sc = check_required_module ?loc sc spdir; let interp = match info with | Uid uid -> Hashtbl.find prim_token_interpreters uid - | NumeralNotation o -> InnerPrimToken.RawNumInterp (Numeral.interp o) + | NumberNotation o -> InnerPrimToken.RawNumInterp (Numbers.interp o) | StringNotation o -> InnerPrimToken.StringInterp (Strings.interp o) in let pat = InnerPrimToken.do_interp ?loc interp p in @@ -1411,8 +1514,8 @@ let interp_prim_token_gen ?loc g p local_scopes = let _, info = Exninfo.capture exn in user_err ?loc ~info ~hdr:"interp_prim_token" ((match p with - | Numeral _ -> - str "No interpretation for numeral " ++ pr_notation (notation_of_prim_token p) + | Number _ -> + str "No interpretation for number " ++ pr_notation (notation_of_prim_token p) | String s -> str "No interpretation for string " ++ qs s) ++ str ".") let interp_prim_token ?loc = @@ -1448,14 +1551,17 @@ let interp_notation ?loc ntn local_scopes = (str "Unknown interpretation for notation " ++ pr_notation ntn ++ str ".") let uninterp_notations c = - List.map_append (fun key -> keymap_find key !notations_key_table) + List.map_append (fun key -> List.map snd (keymap_find key !notations_key_table)) (glob_constr_keys c) +let filter_also_for_pattern = + List.map_filter (function (true,x) -> Some x | _ -> None) + let uninterp_cases_pattern_notations c = - keymap_find (cases_pattern_key c) !notations_key_table + filter_also_for_pattern (keymap_find (cases_pattern_key c) !notations_key_table) let uninterp_ind_pattern_notations ind = - keymap_find (RefKey (canonical_gr (GlobRef.IndRef ind))) !notations_key_table + filter_also_for_pattern (keymap_find (RefKey (canonical_gr (GlobRef.IndRef ind))) !notations_key_table) let has_active_parsing_rule_in_scope ntn sc = try @@ -1615,7 +1721,7 @@ type entry_coercion_kind = | IsEntryGlobal of string * int | IsEntryIdent of string * int -let declare_notation (scopt,ntn) pat df ~use coe deprecation = +let declare_notation (scopt,ntn) pat df ~use ~also_in_cases_pattern coe deprecation = (* Register the interpretation *) let scope = match scopt with NotationInScope s -> s | LastLonelyNotation -> default_scope in let sc = find_scope scope in @@ -1630,10 +1736,10 @@ let declare_notation (scopt,ntn) pat df ~use coe deprecation = scope_map := String.Map.add scope sc !scope_map; (* Update the uninterpretation cache *) begin match printing_update with - | Some pat -> remove_uninterpretation (NotationRule (scopt,ntn)) pat + | Some pat -> remove_uninterpretation (NotationRule (scopt,ntn)) also_in_cases_pattern pat | None -> () end; - if not exists && use <> OnlyParsing then declare_uninterpretation (NotationRule (scopt,ntn)) pat; + if not exists && use <> OnlyParsing then declare_uninterpretation ~also_in_cases_pattern (NotationRule (scopt,ntn)) pat; (* Register visibility of lonely notations *) if not exists then begin match scopt with | LastLonelyNotation -> scope_stack := LonelyNotationItem ntn :: !scope_stack @@ -1659,14 +1765,14 @@ let availability_of_prim_token n printer_scope local_scopes = let uid = snd (String.Map.find scope !prim_token_interp_infos) in let open InnerPrimToken in match n, uid with - | Constrexpr.Numeral _, NumeralNotation _ -> true - | _, NumeralNotation _ -> false + | Constrexpr.Number _, NumberNotation _ -> true + | _, NumberNotation _ -> false | String _, StringNotation _ -> true | _, StringNotation _ -> false | _, Uid uid -> let interp = Hashtbl.find prim_token_interpreters uid in match n, interp with - | Constrexpr.Numeral _, (RawNumInterp _ | BigNumInterp _) -> true + | Constrexpr.Number _, (RawNumInterp _ | BigNumInterp _) -> true | String _, StringInterp _ -> true | _ -> false with Not_found -> false @@ -1681,7 +1787,7 @@ let rec find_uninterpretation need_delim def find = function def | OpenScopeItem scope :: scopes -> (try find need_delim scope - with Not_found -> find_uninterpretation need_delim def find scopes) (* TODO: here we should also update the need_delim list with all regular notations in scope [scope] that could shadow a numeral notation *) + with Not_found -> find_uninterpretation need_delim def find scopes) (* TODO: here we should also update the need_delim list with all regular notations in scope [scope] that could shadow a number notation *) | LonelyNotationItem ntn::scopes -> find_uninterpretation (ntn::need_delim) def find scopes @@ -1693,7 +1799,7 @@ let uninterp_prim_token c local_scopes = try let uninterp = match info with | Uid uid -> Hashtbl.find prim_token_uninterpreters uid - | NumeralNotation o -> InnerPrimToken.RawNumUninterp (Numeral.uninterp o) + | NumberNotation o -> InnerPrimToken.RawNumUninterp (Numbers.uninterp o) | StringNotation o -> InnerPrimToken.StringUninterp (Strings.uninterp o) in match InnerPrimToken.do_uninterp uninterp (AnyGlobConstr c) with @@ -1929,12 +2035,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 _ -> ["_"] @@ -2096,23 +2202,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 @@ -2124,7 +2321,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 d744ff41d9..97955bf92e 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -74,7 +74,7 @@ val find_delimiters_scope : ?loc:Loc.t -> delimiters -> scope_name (** {6 Declare and uses back and forth an interpretation of primitive token } *) -(** A numeral interpreter is the pair of an interpreter for **(hexa)decimal** +(** A number interpreter is the pair of an interpreter for **(hexa)decimal** numbers in terms and an optional interpreter in pattern, if non integer or negative numbers are not supported, the interpreter must fail with an appropriate error message *) @@ -84,7 +84,7 @@ type required_module = full_path * string list type rawnum = NumTok.Signed.t (** The unique id string below will be used to refer to a particular - registered interpreter/uninterpreter of numeral or string notation. + registered interpreter/uninterpreter of number or string notation. Using the same uid for different (un)interpreters will fail. If at most one interpretation of prim token is used per scope, then the scope name could be used as unique id. *) @@ -106,7 +106,7 @@ val register_bignumeral_interpretation : val register_string_interpretation : ?allow_overwrite:bool -> prim_token_uid -> string prim_token_interpretation -> unit -(** * Numeral notation *) +(** * Number notation *) type prim_token_notation_error = | UnexpectedTerm of Constr.t @@ -131,21 +131,21 @@ type z_pos_ty = { z_ty : Names.inductive; pos_ty : Names.inductive } -type numeral_ty = +type number_ty = { int : int_ty; decimal : Names.inductive; hexadecimal : Names.inductive; - numeral : Names.inductive } + number : Names.inductive } type target_kind = - | Int of int_ty (* Coq.Init.Numeral.int + uint *) - | UInt of int_ty (* Coq.Init.Numeral.uint *) + | Int of int_ty (* Coq.Init.Number.int + uint *) + | UInt of int_ty (* Coq.Init.Number.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) | Int63 (* Coq.Numbers.Cyclic.Int63.Int63.int *) - | Numeral of numeral_ty (* Coq.Init.Numeral.numeral + uint + int *) + | Number of number_ty (* Coq.Init.Number.number + uint + int *) | DecimalInt of int_ty (* Coq.Init.Decimal.int + uint (deprecated) *) | DecimalUInt of int_ty (* Coq.Init.Decimal.uint (deprecated) *) - | Decimal of numeral_ty (* Coq.Init.Decimal.Decimal + uint + int (deprecated) *) + | Decimal of number_ty (* Coq.Init.Decimal.Decimal + uint + int (deprecated) *) type string_target_kind = | ListByte @@ -154,26 +154,43 @@ type string_target_kind = type option_kind = Option | Direct type 'target conversion_kind = 'target * option_kind +(** A postprocessing translation [to_post] can be done after execution + of the [to_ty] interpreter. The reverse translation is performed + before the [of_ty] uninterpreter. + + [to_post] is an array of [n] lists [l_i] of tuples [(f, t, + args)]. When the head symbol of the translated term matches one of + the [f] in the list [l_0] it is replaced by [t] and its arguments + are translated acording to [args] where [ToPostCopy] means that the + argument is kept unchanged and [ToPostAs k] means that the + argument is recursively translated according to [l_k]. + [ToPostHole] introduces an additional implicit argument hole + (in the reverse translation, the corresponding argument is removed). + [ToPostCheck r] behaves as [ToPostCopy] except in the reverse + translation which fails if the copied term is not [r]. + When [n] is null, no translation is performed. *) +type to_post_arg = ToPostCopy | ToPostAs of int | ToPostHole | ToPostCheck of GlobRef.t type ('target, 'warning) prim_token_notation_obj = { to_kind : 'target conversion_kind; to_ty : GlobRef.t; + to_post : ((GlobRef.t * GlobRef.t * to_post_arg list) list) array; of_kind : 'target conversion_kind; of_ty : GlobRef.t; ty_name : Libnames.qualid; (* for warnings / error messages *) warning : 'warning } -type numeral_notation_obj = (target_kind, numnot_option) prim_token_notation_obj +type number_notation_obj = (target_kind, numnot_option) prim_token_notation_obj type string_notation_obj = (string_target_kind, unit) prim_token_notation_obj type prim_token_interp_info = Uid of prim_token_uid - | NumeralNotation of numeral_notation_obj + | NumberNotation of number_notation_obj | StringNotation of string_notation_obj type prim_token_infos = { pt_local : bool; (** Is this interpretation local? *) pt_scope : scope_name; (** Concerned scope *) - pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a numeral notation object describing (un)interp functions *) + pt_interp_info : prim_token_interp_info; (** Unique id "pointing" to (un)interp functions, OR a number notation object describing (un)interp functions *) pt_required : required_module; (** Module that should be loaded first *) pt_refs : GlobRef.t list; (** Entry points during uninterpretation *) pt_in_match : bool (** Is this prim token legal in match patterns ? *) @@ -234,7 +251,7 @@ type notation_use = | OnlyParsing | ParsingAndPrinting -val declare_uninterpretation : interp_rule -> interpretation -> unit +val declare_uninterpretation : ?also_in_cases_pattern:bool -> interp_rule -> interpretation -> unit type entry_coercion_kind = | IsEntryCoercion of notation_entry_level @@ -243,6 +260,7 @@ type entry_coercion_kind = val declare_notation : notation_with_optional_scope * notation -> interpretation -> notation_location -> use:notation_use -> + also_in_cases_pattern:bool -> entry_coercion_kind option -> Deprecation.t option -> unit @@ -316,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 354809252e..2e3fa0aa0e 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -58,7 +58,7 @@ match t1, t2 with (eq_notation_constr vars) t1 t2 in let eqf (t1, (na1, o1)) (t2, (na2, o2)) = - let eq (i1, n1) (i2, n2) = eq_ind i1 i2 && List.equal Name.equal n1 n2 in + let eq (i1, n1) (i2, n2) = Ind.CanOrd.equal i1 i2 && List.equal Name.equal n1 n2 in (eq_notation_constr vars) t1 t2 && Name.equal na1 na2 && Option.equal eq o1 o2 in Option.equal (eq_notation_constr vars) o1 o2 && @@ -801,7 +801,7 @@ let rec fold_cases_pattern_eq f x p p' = let loc = p.CAst.loc in match DAst.get p, DAst.get p' with | PatVar na, PatVar na' -> let x,na = f x na na' in x, DAst.make ?loc @@ PatVar na - | PatCstr (c,l,na), PatCstr (c',l',na') when eq_constructor c c' -> + | PatCstr (c,l,na), PatCstr (c',l',na') when Construct.CanOrd.equal c c' -> let x,l = fold_cases_pattern_list_eq f x l l' in let x,na = f x na na' in x, DAst.make ?loc @@ PatCstr (c,l,na) @@ -818,7 +818,7 @@ and fold_cases_pattern_list_eq f x pl pl' = match pl, pl' with let rec cases_pattern_eq p1 p2 = match DAst.get p1, DAst.get p2 with | PatVar na1, PatVar na2 -> Name.equal na1 na2 | PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> - eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && + Construct.CanOrd.equal c1 c2 && List.equal cases_pattern_eq pl1 pl2 && Name.equal na1 na2 | _ -> false @@ -941,7 +941,7 @@ let bind_term_as_binding_env alp (terms,termlists,binders,binderlists as sigma) try (* If already bound to a term, unify the binder and the term *) match DAst.get (Id.List.assoc var terms) with - | GVar id' -> + | GVar id' | GRef (GlobRef.VarRef id',None) -> (if not (Id.equal id id') then (fst alp,(id,id')::snd alp) else alp), sigma | t -> @@ -1041,7 +1041,7 @@ let rec match_cases_pattern_binders allow_catchall metas (alp,sigma as acc) pat1 | PatVar na1, PatVar na2 -> match_names metas acc na1 na2 | _, PatVar Anonymous when allow_catchall -> acc | PatCstr (c1,patl1,na1), PatCstr (c2,patl2,na2) - when eq_constructor c1 c2 && Int.equal (List.length patl1) (List.length patl2) -> + when Construct.CanOrd.equal c1 c2 && Int.equal (List.length patl1) (List.length patl2) -> List.fold_left2 (match_cases_pattern_binders false metas) (match_names metas acc na1 na2) patl1 patl2 | _ -> raise No_match @@ -1147,16 +1147,22 @@ let does_not_come_from_already_eta_expanded_var glob = (* checked). *) match DAst.get glob with GVar _ -> false | _ -> true +let is_var_term = function + (* The kind of expressions allowed to be both a term and a binding variable *) + | GVar _ -> true + | GRef (GlobRef.VarRef _,None) -> true + | _ -> false + let rec match_ inner u alp metas sigma a1 a2 = let open CAst in let loc = a1.loc in match DAst.get a1, a2 with (* Matching notation variable *) | r1, NVar id2 when is_term_meta id2 metas -> bind_term_env alp sigma id2 a1 - | GVar _, NVar id2 when is_onlybinding_pattern_like_meta true id2 metas -> bind_binding_as_term_env alp sigma id2 a1 + | r1, NVar id2 when is_var_term r1 && is_onlybinding_pattern_like_meta true id2 metas -> bind_binding_as_term_env alp sigma id2 a1 | r1, NVar id2 when is_onlybinding_pattern_like_meta false id2 metas -> bind_binding_as_term_env alp sigma id2 a1 - | GVar _, NVar id2 when is_onlybinding_strict_meta id2 metas -> raise No_match - | GVar _, NVar id2 when is_onlybinding_meta id2 metas -> bind_binding_as_term_env alp sigma id2 a1 + | r1, NVar id2 when is_var_term r1 && is_onlybinding_strict_meta id2 metas -> raise No_match + | r1, NVar id2 when is_var_term r1 && is_onlybinding_meta id2 metas -> bind_binding_as_term_env alp sigma id2 a1 | r1, NVar id2 when is_bindinglist_meta id2 metas -> bind_term_env alp sigma id2 a1 (* Matching recursive notations for terms *) @@ -1391,11 +1397,11 @@ let rec match_cases_pattern metas (terms,termlists,(),() as sigma) a1 a2 = match DAst.get a1, a2 with | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 a1),(false,0,[]) | PatVar Anonymous, NHole _ -> sigma,(false,0,[]) - | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (GlobRef.ConstructRef r2) when eq_constructor r1 r2 -> + | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (GlobRef.ConstructRef r2) when Construct.CanOrd.equal r1 r2 -> let l = try add_patterns_for_params_remove_local_defs (Global.env ()) r1 largs with Not_found -> raise No_match in sigma,(false,0,l) | PatCstr ((ind,_ as r1),args1,Anonymous), NApp (NRef (GlobRef.ConstructRef r2),l2) - when eq_constructor r1 r2 -> + when Construct.CanOrd.equal r1 r2 -> let l1 = try add_patterns_for_params_remove_local_defs (Global.env()) r1 args1 with Not_found -> raise No_match in let le2 = List.length l2 in if le2 > List.length l1 @@ -1418,10 +1424,10 @@ and match_cases_pattern_no_more_args metas sigma a1 a2 = let match_ind_pattern metas sigma ind pats a2 = match a2 with - | NRef (GlobRef.IndRef r2) when eq_ind ind r2 -> + | NRef (GlobRef.IndRef r2) when Ind.CanOrd.equal ind r2 -> sigma,(false,0,pats) | NApp (NRef (GlobRef.IndRef r2),l2) - when eq_ind ind r2 -> + when Ind.CanOrd.equal ind r2 -> let le2 = List.length l2 in if Int.equal le2 0 (* Special case of a notation for a @Cstr *) || le2 > List.length pats then @@ -1436,9 +1442,8 @@ let reorder_canonically_substitution terms termlists metas = List.fold_right (fun (x,(scl,typ)) (terms',termlists') -> match typ with | NtnTypeConstr -> ((Id.List.assoc x terms, scl)::terms',termlists') - | NtnTypeBinder _ -> assert false | NtnTypeConstrList -> (terms',(Id.List.assoc x termlists,scl)::termlists') - | NtnTypeBinderList -> assert false) + | NtnTypeBinder _ | NtnTypeBinderList -> anomaly (str "Unexpected binder in pattern notation.")) metas ([],[]) let match_notation_constr_cases_pattern c (metas,pat) = diff --git a/interp/numTok.mli b/interp/numTok.mli index bcfe663dd2..386a25f042 100644 --- a/interp/numTok.mli +++ b/interp/numTok.mli @@ -8,20 +8,20 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Numerals in different forms: signed or unsigned, possibly with +(** Numbers in different forms: signed or unsigned, possibly with fractional part and exponent. - Numerals are represented using raw strings of (hexa)decimal + Numbers are represented using raw strings of (hexa)decimal literals and a separate sign flag. Note that this representation is not unique, due to possible multiple leading or trailing zeros, and -0 = +0, for instances. - The reason to keep the numeral exactly as it was parsed is that - specific notations can be declared for specific numerals + The reason to keep the number exactly as it was parsed is that + specific notations can be declared for specific numbers (e.g. [Notation "0" := False], or [Notation "00" := (nil,nil)], or [Notation "2e1" := ...]). Those notations override the generic - interpretation as numeral. So, one has to record the form of the - numeral which exactly matches the notation. *) + interpretation as number. So, one has to record the form of the + number which exactly matches the notation. *) type sign = SPlus | SMinus @@ -44,7 +44,7 @@ sig val sprint : t -> string val print : t -> Pp.t - (** [sprint] and [print] returns the numeral as it was parsed, for printing *) + (** [sprint] and [print] returns the number as it was parsed, for printing *) val classify : t -> num_class @@ -69,7 +69,7 @@ sig val to_bigint : t -> Z.t end -(** {6 Unsigned decimal numerals } *) +(** {6 Unsigned decimal numbers } *) module Unsigned : sig @@ -80,12 +80,12 @@ sig val sprint : t -> string val print : t -> Pp.t - (** [sprint] and [print] returns the numeral as it was parsed, for printing *) + (** [sprint] and [print] returns the number as it was parsed, for printing *) val parse : char Stream.t -> t - (** Parse a positive Coq numeral. + (** Parse a positive Coq number. Precondition: the first char on the stream is already known to be a digit (\[0-9\]). - Precondition: at least two extra chars after the numeral to parse. + Precondition: at least two extra chars after the number to parse. The recognized syntax is: - integer part: \[0-9\]\[0-9_\]* @@ -97,13 +97,13 @@ sig - exponent part: empty or \[pP\]\[+-\]?\[0-9\]\[0-9_\]* *) val parse_string : string -> t option - (** Parse the string as a non negative Coq numeral, if possible *) + (** Parse the string as a non negative Coq number, if possible *) val classify : t -> num_class end -(** {6 Signed decimal numerals } *) +(** {6 Signed decimal numbers } *) module Signed : sig @@ -117,10 +117,10 @@ sig val sprint : t -> string val print : t -> Pp.t - (** [sprint] and [print] returns the numeral as it was parsed, for printing *) + (** [sprint] and [print] returns the number as it was parsed, for printing *) val parse_string : string -> t option - (** Parse the string as a signed Coq numeral, if possible *) + (** Parse the string as a signed Coq number, if possible *) val of_int_string : string -> t (** Convert from a string in the syntax of OCaml's int/int64 *) diff --git a/interp/reserve.ml b/interp/reserve.ml index 4418a32645..1d5af3ff39 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -28,7 +28,7 @@ type key = (** TODO: share code from Notation *) let key_compare k1 k2 = match k1, k2 with -| RefKey gr1, RefKey gr2 -> GlobRef.Ordered.compare gr1 gr2 +| RefKey gr1, RefKey gr2 -> GlobRef.CanOrd.compare gr1 gr2 | RefKey _, Oth -> -1 | Oth, RefKey _ -> 1 | Oth, Oth -> 0 diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index 33d8aa6064..46baa00c74 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -50,6 +50,16 @@ let locate_global_with_alias ?(head=false) qid = user_err ?loc:qid.CAst.loc (pr_qualid qid ++ str " is bound to a notation that does not denote a reference.") +let global_constant_with_alias qid = + try match locate_global_with_alias qid with + | Names.GlobRef.ConstRef c -> c + | ref -> + user_err ?loc:qid.CAst.loc ~hdr:"global_inductive" + (pr_qualid qid ++ spc () ++ str "is not a reference to a constant.") + with Not_found as exn -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid + let global_inductive_with_alias qid = try match locate_global_with_alias qid with | Names.GlobRef.IndRef ind -> ind @@ -60,6 +70,16 @@ let global_inductive_with_alias qid = let _, info = Exninfo.capture exn in Nametab.error_global_not_found ~info qid +let global_constructor_with_alias qid = + try match locate_global_with_alias qid with + | Names.GlobRef.ConstructRef c -> c + | ref -> + user_err ?loc:qid.CAst.loc ~hdr:"global_inductive" + (pr_qualid qid ++ spc () ++ str "is not a constructor of an inductive type.") + with Not_found as exn -> + let _, info = Exninfo.capture exn in + Nametab.error_global_not_found ~info qid + let global_with_alias ?head qid = try locate_global_with_alias ?head qid with Not_found as exn -> @@ -72,9 +92,17 @@ let smart_global ?(head = false) = let open Constrexpr in CAst.with_loc_val (fun | ByNotation (ntn,sc) -> Notation.interp_notation_as_global_reference ?loc ~head (fun _ -> true) ntn sc) -let smart_global_inductive = let open Constrexpr in CAst.with_loc_val (fun ?loc -> function - | AN r -> - global_inductive_with_alias r +let smart_global_kind f dest is = let open Constrexpr in CAst.with_loc_val (fun ?loc -> function + | AN r -> f r | ByNotation (ntn,sc) -> - destIndRef - (Notation.interp_notation_as_global_reference ?loc ~head:false isIndRef ntn sc)) + dest + (Notation.interp_notation_as_global_reference ?loc ~head:false is ntn sc)) + +let smart_global_constant = + smart_global_kind global_constant_with_alias destConstRef isConstRef + +let smart_global_inductive = + smart_global_kind global_inductive_with_alias destIndRef isIndRef + +let smart_global_constructor = + smart_global_kind global_constructor_with_alias destConstructRef isConstructRef diff --git a/interp/smartlocate.mli b/interp/smartlocate.mli index 9b24a62086..26f2a4f36d 100644 --- a/interp/smartlocate.mli +++ b/interp/smartlocate.mli @@ -28,11 +28,23 @@ val global_of_extended_global : extended_global_reference -> GlobRef.t a reference. *) val global_with_alias : ?head:bool -> qualid -> GlobRef.t +(** The same for constants *) +val global_constant_with_alias : qualid -> Constant.t + (** The same for inductive types *) val global_inductive_with_alias : qualid -> inductive +(** The same for constructors of an inductive type *) +val global_constructor_with_alias : qualid -> constructor + (** Locate a reference taking into account notations and "aliases" *) val smart_global : ?head:bool -> qualid Constrexpr.or_by_notation -> GlobRef.t +(** The same for constants *) +val smart_global_constant : qualid Constrexpr.or_by_notation -> Constant.t + (** The same for inductive types *) val smart_global_inductive : qualid Constrexpr.or_by_notation -> inductive + +(** The same for constructors of an inductive type *) +val smart_global_constructor : qualid Constrexpr.or_by_notation -> constructor diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index bd3e234a91..f3ad3546ff 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -22,6 +22,7 @@ type syndef = { syndef_pattern : interpretation; syndef_onlyparsing : bool; syndef_deprecation : Deprecation.t option; + syndef_also_in_cases_pattern : bool; } let syntax_table = @@ -52,7 +53,7 @@ let open_syntax_constant i ((sp,kn),(_local,syndef)) = if not syndef.syndef_onlyparsing then (* Redeclare it to be used as (short) name in case an other (distfix) notation was declared in between *) - Notation.declare_uninterpretation (Notation.SynDefRule kn) pat + Notation.declare_uninterpretation ~also_in_cases_pattern:syndef.syndef_also_in_cases_pattern (Notation.SynDefRule kn) pat end let cache_syntax_constant d = @@ -81,11 +82,12 @@ let in_syntax_constant : (bool * syndef) -> obj = subst_function = subst_syntax_constant; classify_function = classify_syntax_constant } -let declare_syntactic_definition ~local deprecation id ~onlyparsing pat = +let declare_syntactic_definition ~local ?(also_in_cases_pattern=true) deprecation id ~onlyparsing pat = let syndef = { syndef_pattern = pat; syndef_onlyparsing = onlyparsing; syndef_deprecation = deprecation; + syndef_also_in_cases_pattern = also_in_cases_pattern; } in let _ = add_leaf id (in_syntax_constant (local,syndef)) in () diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index 66a3132f2a..31f685152c 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -13,7 +13,7 @@ open Notation_term (** Syntactic definitions. *) -val declare_syntactic_definition : local:bool -> Deprecation.t option -> Id.t -> +val declare_syntactic_definition : local:bool -> ?also_in_cases_pattern:bool -> Deprecation.t option -> Id.t -> onlyparsing:bool -> interpretation -> unit val search_syntactic_definition : ?loc:Loc.t -> KerName.t -> interpretation diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index a23ef8fdca..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; @@ -1165,7 +1159,7 @@ module FNativeEntries = let mkFloat env f = check_float env; - { mark = mark Norm KnownR; term = FFloat f } + { mark = mark Cstr KnownR; term = FFloat f } let mkBool env b = check_bool env; @@ -1328,10 +1322,14 @@ let rec knr info tab m stk = | FFlex(ConstKey (kn,_u as c)) when red_set info.i_flags (fCONST kn) -> (match ref_value_cache info tab (ConstKey c) with | Def v -> kni info tab v stk - | Primitive op when check_native_args op stk -> - let rargs, a, nargs, stk = get_native_args1 op c stk in - kni info tab a (Zprimitive(op,c,rargs,nargs)::stk) - | Undef _ | OpaqueDef _ | Primitive _ -> (set_norm m; (m,stk))) + | Primitive op -> + if check_native_args op stk then + let rargs, a, nargs, stk = get_native_args1 op c stk in + kni info tab a (Zprimitive(op,c,rargs,nargs)::stk) + else + (* Similarly to fix, partially applied primitives are not Norm! *) + (m, stk) + | Undef _ | OpaqueDef _ -> (set_norm m; (m,stk))) | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> (match ref_value_cache info tab (VarKey id) with | Def v -> kni info tab v stk @@ -1531,7 +1529,12 @@ let whd_stack infos tab m stk = match Mark.red_state m.mark with knh infos m stk | Red | Cstr -> let k = kni infos tab m stk in - let () = if infos.i_cache.i_share then ignore (fapp_stack k) in (* to unlock Zupdates! *) + let () = + if infos.i_cache.i_share then + (* to unlock Zupdates! *) + let (m', stk') = k in + if not (m == m' && stk == stk') then ignore (zip m' stk') + in k let create_clos_infos ?univs ?(evars=fun _ -> None) flgs env = diff --git a/kernel/constr.ml b/kernel/constr.ml index 1837a39764..3157ec9f57 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -353,9 +353,9 @@ let isRef c = match kind c with let isRefX x c = let open GlobRef in match x, kind c with - | ConstRef c, Const (c', _) -> Constant.equal c c' - | IndRef i, Ind (i', _) -> eq_ind i i' - | ConstructRef i, Construct (i', _) -> eq_constructor i i' + | ConstRef c, Const (c', _) -> Constant.CanOrd.equal c c' + | IndRef i, Ind (i', _) -> Ind.CanOrd.equal i i' + | ConstructRef i, Construct (i', _) -> Construct.CanOrd.equal i i' | VarRef id, Var id' -> Id.equal id id' | _ -> false @@ -950,14 +950,14 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t let len = Array.length l1 in Int.equal len (Array.length l2) && leq (nargs+len) c1 c2 && Array.equal_norefl (eq 0) l1 l2 - | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && eq 0 c1 c2 + | Proj (p1,c1), Proj (p2,c2) -> Projection.CanOrd.equal p1 p2 && eq 0 c1 c2 | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && List.equal (eq 0) l1 l2 | Const (c1,u1), Const (c2,u2) -> (* The args length currently isn't used but may as well pass it. *) - Constant.equal c1 c2 && leq_universes (Some (GlobRef.ConstRef c1, nargs)) u1 u2 - | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && leq_universes (Some (GlobRef.IndRef c1, nargs)) u1 u2 + Constant.CanOrd.equal c1 c2 && leq_universes (Some (GlobRef.ConstRef c1, nargs)) u1 u2 + | Ind (c1,u1), Ind (c2,u2) -> Ind.CanOrd.equal c1 c2 && leq_universes (Some (GlobRef.IndRef c1, nargs)) u1 u2 | Construct (c1,u1), Construct (c2,u2) -> - eq_constructor c1 c2 && leq_universes (Some (GlobRef.ConstructRef c1, nargs)) u1 u2 + Construct.CanOrd.equal c1 c2 && leq_universes (Some (GlobRef.ConstructRef c1, nargs)) u1 u2 | Case (_,p1,iv1,c1,bl1), Case (_,p2,iv2,c2,bl2) -> eq 0 p1 p2 && eq_invert (eq 0) (leq_universes None) iv1 iv2 && eq 0 c1 c2 && Array.equal (eq 0) bl1 bl2 | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> @@ -1139,9 +1139,9 @@ let constr_ord_int f t1 t2 = | App _, _ -> -1 | _, App _ -> 1 | Const (c1,_u1), Const (c2,_u2) -> Constant.CanOrd.compare c1 c2 | Const _, _ -> -1 | _, Const _ -> 1 - | Ind (ind1, _u1), Ind (ind2, _u2) -> ind_ord ind1 ind2 + | Ind (ind1, _u1), Ind (ind2, _u2) -> Ind.CanOrd.compare ind1 ind2 | Ind _, _ -> -1 | _, Ind _ -> 1 - | Construct (ct1,_u1), Construct (ct2,_u2) -> constructor_ord ct1 ct2 + | Construct (ct1,_u1), Construct (ct2,_u2) -> Construct.CanOrd.compare ct1 ct2 | Construct _, _ -> -1 | _, Construct _ -> 1 | Case (_,p1,iv1,c1,bl1), Case (_,p2,iv2,c2,bl2) -> let c = f p1 p2 in @@ -1158,7 +1158,7 @@ let constr_ord_int f t1 t2 = ((Int.compare =? (Array.compare f)) ==? (Array.compare f)) ln1 ln2 tl1 tl2 bl1 bl2 | CoFix _, _ -> -1 | _, CoFix _ -> 1 - | Proj (p1,c1), Proj (p2,c2) -> (Projection.compare =? f) p1 p2 c1 c2 + | Proj (p1,c1), Proj (p2,c2) -> (Projection.CanOrd.compare =? f) p1 p2 c1 c2 | Proj _, _ -> -1 | _, Proj _ -> 1 | Int i1, Int i2 -> Uint63.compare i1 i2 | Int _, _ -> -1 | _, Int _ -> 1 @@ -1331,11 +1331,11 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = | Ind (ind,u) -> let u', hu = sh_instance u in (Ind (sh_ind ind, u'), - combinesmall 10 (combine (ind_syntactic_hash ind) hu)) + combinesmall 10 (combine (Ind.SyntacticOrd.hash ind) hu)) | Construct (c,u) -> let u', hu = sh_instance u in (Construct (sh_construct c, u'), - combinesmall 11 (combine (constructor_syntactic_hash c) hu)) + combinesmall 11 (combine (Construct.SyntacticOrd.hash c) hu)) | Case (ci,p,iv,c,bl) -> let p, hp = sh_rec p and iv, hiv = sh_invert iv @@ -1442,11 +1442,11 @@ let rec hash t = | Evar (e,l) -> combinesmall 8 (combine (Evar.hash e) (hash_term_list l)) | Const (c,u) -> - combinesmall 9 (combine (Constant.hash c) (Instance.hash u)) + combinesmall 9 (combine (Constant.CanOrd.hash c) (Instance.hash u)) | Ind (ind,u) -> - combinesmall 10 (combine (ind_hash ind) (Instance.hash u)) + combinesmall 10 (combine (Ind.CanOrd.hash ind) (Instance.hash u)) | Construct (c,u) -> - combinesmall 11 (combine (constructor_hash c) (Instance.hash u)) + combinesmall 11 (combine (Construct.CanOrd.hash c) (Instance.hash u)) | Case (_ , p, iv, c, bl) -> combinesmall 12 (combine4 (hash c) (hash p) (hash_invert iv) (hash_term_array bl)) | Fix (_ln ,(_, tl, bl)) -> @@ -1456,7 +1456,7 @@ let rec hash t = | Meta n -> combinesmall 15 n | Rel n -> combinesmall 16 n | Proj (p,c) -> - combinesmall 17 (combine (Projection.hash p) (hash c)) + combinesmall 17 (combine (Projection.CanOrd.hash p) (hash c)) | Int i -> combinesmall 18 (Uint63.hash i) | Float f -> combinesmall 19 (Float64.hash f) | Array(u,t,def,ty) -> @@ -1503,7 +1503,7 @@ struct let h3 = Array.fold_left hash_bool_list 0 info.cstr_tags in combine3 h1 h2 h3 let hash ci = - let h1 = ind_hash ci.ci_ind in + let h1 = Ind.CanOrd.hash ci.ci_ind in let h2 = Int.hash ci.ci_npar in let h3 = Array.fold_left combine 0 ci.ci_cstr_ndecls in let h4 = Array.fold_left combine 0 ci.ci_cstr_nargs in 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/cooking.ml b/kernel/cooking.ml index fdcf44c943..3707a75157 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -38,14 +38,14 @@ struct type t = my_global_reference let equal gr1 gr2 = match gr1, gr2 with | ConstRef c1, ConstRef c2 -> Constant.SyntacticOrd.equal c1 c2 - | IndRef i1, IndRef i2 -> eq_syntactic_ind i1 i2 - | ConstructRef c1, ConstructRef c2 -> eq_syntactic_constructor c1 c2 + | IndRef i1, IndRef i2 -> Ind.SyntacticOrd.equal i1 i2 + | ConstructRef c1, ConstructRef c2 -> Construct.SyntacticOrd.equal c1 c2 | _ -> false open Hashset.Combine let hash = function | ConstRef c -> combinesmall 1 (Constant.SyntacticOrd.hash c) - | IndRef i -> combinesmall 2 (ind_syntactic_hash i) - | ConstructRef c -> combinesmall 3 (constructor_syntactic_hash c) + | IndRef i -> combinesmall 2 (Ind.SyntacticOrd.hash i) + | ConstructRef c -> combinesmall 3 (Construct.SyntacticOrd.hash c) end module RefTable = Hashtbl.Make(RefHash) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index b9f434f179..8de7123fee 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -157,15 +157,15 @@ let hcons_const_body cb = (** {6 Inductive types } *) let eq_nested_type t1 t2 = match t1, t2 with -| NestedInd ind1, NestedInd ind2 -> Names.eq_ind ind1 ind2 +| NestedInd ind1, NestedInd ind2 -> Names.Ind.CanOrd.equal ind1 ind2 | NestedInd _, _ -> false -| NestedPrimitive c1, NestedPrimitive c2 -> Names.Constant.equal c1 c2 +| NestedPrimitive c1, NestedPrimitive c2 -> Names.Constant.CanOrd.equal c1 c2 | NestedPrimitive _, _ -> false let eq_recarg r1 r2 = match r1, r2 with | Norec, Norec -> true | Norec, _ -> false -| Mrec i1, Mrec i2 -> Names.eq_ind i1 i2 +| Mrec i1, Mrec i2 -> Names.Ind.CanOrd.equal i1 i2 | Mrec _, _ -> false | Nested ty1, Nested ty2 -> eq_nested_type ty1 ty2 | Nested _, _ -> false 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 dec9e1deb8..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) @@ -104,7 +103,6 @@ type env = { env_typing_flags : typing_flags; retroknowledge : Retroknowledge.retroknowledge; indirect_pterms : Opaqueproof.opaquetab; - native_symbols : Nativevalues.symbols DPmap.t; } let empty_named_context_val = { @@ -136,7 +134,6 @@ let empty_env = { env_typing_flags = Declareops.safe_flags Conv_oracle.empty; retroknowledge = Retroknowledge.empty; indirect_pterms = Opaqueproof.empty_opaquetab; - native_symbols = DPmap.empty; } @@ -571,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) @@ -829,6 +831,65 @@ let is_type_in_type env r = let set_retroknowledge env r = { env with retroknowledge = r } -let set_native_symbols env native_symbols = { env with native_symbols } -let add_native_symbols dir syms env = - { env with native_symbols = DPmap.add dir syms env.native_symbols } +module type QNameS = +sig + type t + val equal : env -> t -> t -> bool + val compare : env -> t -> t -> int + val hash : env -> t -> int +end + +module QConstant = +struct + type t = Constant.t + let equal _env c1 c2 = Constant.CanOrd.equal c1 c2 + let compare _env c1 c2 = Constant.CanOrd.compare c1 c2 + let hash _env c = Constant.CanOrd.hash c +end + +module QMutInd = +struct + type t = MutInd.t + let equal _env c1 c2 = MutInd.CanOrd.equal c1 c2 + let compare _env c1 c2 = MutInd.CanOrd.compare c1 c2 + let hash _env c = MutInd.CanOrd.hash c +end + +module QInd = +struct + type t = Ind.t + let equal _env c1 c2 = Ind.CanOrd.equal c1 c2 + let compare _env c1 c2 = Ind.CanOrd.compare c1 c2 + let hash _env c = Ind.CanOrd.hash c +end + +module QConstruct = +struct + type t = Construct.t + let equal _env c1 c2 = Construct.CanOrd.equal c1 c2 + let compare _env c1 c2 = Construct.CanOrd.compare c1 c2 + let hash _env c = Construct.CanOrd.hash c +end + +module QProjection = +struct + type t = Projection.t + let equal _env c1 c2 = Projection.CanOrd.equal c1 c2 + let compare _env c1 c2 = Projection.CanOrd.compare c1 c2 + let hash _env c = Projection.CanOrd.hash c + module Repr = + struct + type t = Projection.Repr.t + let equal _env c1 c2 = Projection.Repr.CanOrd.equal c1 c2 + let compare _env c1 c2 = Projection.Repr.CanOrd.compare c1 c2 + let hash _env c = Projection.Repr.CanOrd.hash c + end +end + +module QGlobRef = +struct + type t = GlobRef.t + let equal _env c1 c2 = GlobRef.CanOrd.equal c1 c2 + let compare _env c1 c2 = GlobRef.CanOrd.compare c1 c2 + let hash _env c = GlobRef.CanOrd.hash c +end diff --git a/kernel/environ.mli b/kernel/environ.mli index f443ba38e1..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 @@ -90,7 +89,6 @@ type env = private { env_typing_flags : typing_flags; retroknowledge : Retroknowledge.retroknowledge; indirect_pterms : Opaqueproof.opaquetab; - native_symbols : Nativevalues.symbols DPmap.t; } val oracle : env -> Conv_oracle.oracle @@ -251,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. *) @@ -284,6 +284,32 @@ val template_polymorphic_ind : inductive -> env -> bool val template_polymorphic_variables : inductive -> env -> Univ.Level.t list val template_polymorphic_pind : pinductive -> env -> bool +(** {6 Name quotients} *) + +module type QNameS = +sig + type t + val equal : env -> t -> t -> bool + val compare : env -> t -> t -> int + val hash : env -> t -> int +end + +module QConstant : QNameS with type t = Constant.t + +module QMutInd : QNameS with type t = MutInd.t + +module QInd : QNameS with type t = Ind.t + +module QConstruct : QNameS with type t = Construct.t + +module QProjection : +sig + include QNameS with type t = Projection.t + module Repr : QNameS with type t = Projection.Repr.t +end + +module QGlobRef : QNameS with type t = GlobRef.t + (** {5 Modules } *) val add_modtype : module_type_body -> env -> env @@ -388,6 +414,3 @@ val no_link_info : link_info (** Primitives *) val set_retroknowledge : env -> Retroknowledge.retroknowledge -> env - -val set_native_symbols : env -> Nativevalues.symbols DPmap.t -> env -val add_native_symbols : DirPath.t -> Nativevalues.symbols -> env -> env 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/inductive.ml b/kernel/inductive.ml index d751d9875a..e34b3c0b47 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -404,7 +404,7 @@ let type_case_branches env (pind,largs) pj c = let check_case_info env (indsp,u) r ci = let (mib,mip as spec) = lookup_mind_specif env indsp in if - not (eq_ind indsp ci.ci_ind) || + not (Ind.CanOrd.equal indsp ci.ci_ind) || not (Int.equal mib.mind_nparams ci.ci_npar) || not (Array.equal Int.equal mip.mind_consnrealdecls ci.ci_cstr_ndecls) || not (Array.equal Int.equal mip.mind_consnrealargs ci.ci_cstr_nargs) || @@ -467,12 +467,12 @@ let inter_recarg r1 r2 = match r1, r2 with | Norec, _ -> None | Mrec i1, Mrec i2 | Nested (NestedInd i1), Nested (NestedInd i2) -| Mrec i1, (Nested (NestedInd i2)) -> if Names.eq_ind i1 i2 then Some r1 else None +| Mrec i1, (Nested (NestedInd i2)) -> if Names.Ind.CanOrd.equal i1 i2 then Some r1 else None | Mrec _, _ -> None -| Nested (NestedInd i1), Mrec i2 -> if Names.eq_ind i1 i2 then Some r2 else None +| Nested (NestedInd i1), Mrec i2 -> if Names.Ind.CanOrd.equal i1 i2 then Some r2 else None | Nested (NestedInd _), _ -> None | Nested (NestedPrimitive c1), Nested (NestedPrimitive c2) -> - if Names.Constant.equal c1 c2 then Some r1 else None + if Names.Constant.CanOrd.equal c1 c2 then Some r1 else None | Nested (NestedPrimitive _), _ -> None let inter_wf_paths = Rtree.inter Declareops.eq_recarg inter_recarg Norec @@ -556,7 +556,7 @@ let lookup_subterms env ind = let match_inductive ind ra = match ra with - | Mrec i | Nested (NestedInd i) -> eq_ind ind i + | Mrec i | Nested (NestedInd i) -> Ind.CanOrd.equal ind i | Norec | Nested (NestedPrimitive _) -> false (* In {match c as z in ci y_s return P with |C_i x_s => t end} @@ -644,7 +644,7 @@ let abstract_mind_lc ntyps npars lc = let is_primitive_positive_container env c = match env.retroknowledge.Retroknowledge.retro_array with - | Some c' when Constant.equal c c' -> true + | Some c' when QConstant.equal env c c' -> true | _ -> false (* [get_recargs_approx env tree ind args] builds an approximation of the recargs @@ -667,13 +667,13 @@ let get_recargs_approx env tree ind args = (* When the inferred tree allows it, we consider that we have a potential nested inductive type *) begin match dest_recarg tree with - | Nested (NestedInd kn') | Mrec kn' when eq_ind (fst ind_kn) kn' -> + | Nested (NestedInd kn') | Mrec kn' when Ind.CanOrd.equal (fst ind_kn) kn' -> build_recargs_nested ienv tree (ind_kn, largs) | _ -> mk_norec end | Const (c,_) when is_primitive_positive_container env c -> begin match dest_recarg tree with - | Nested (NestedPrimitive c') when Constant.equal c c' -> + | Nested (NestedPrimitive c') when QConstant.equal env c c' -> build_recargs_nested_primitive ienv tree (c, largs) | _ -> mk_norec end 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 592b5e65f7..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; @@ -447,6 +451,22 @@ module KNset = KNmap.Set (** {6 Kernel pairs } *) +module type EqType = +sig + type t + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int +end + +module type QNameS = +sig + type t + module CanOrd : EqType with type t = t + module UserOrd : EqType with type t = t + module SyntacticOrd : EqType with type t = t +end + (** For constant and inductive names, we use a kernel name couple (kn1,kn2) where kn1 corresponds to the name used at toplevel (i.e. what the user see) and kn2 corresponds to the canonical kernel name i.e. in the environment @@ -529,6 +549,7 @@ module KerPair = struct end module SyntacticOrd = struct + type t = kernel_pair let compare x y = match x, y with | Same knx, Same kny -> KerName.compare knx kny | Dual (knux,kncx), Dual (knuy,kncy) -> @@ -599,100 +620,147 @@ module Mindmap = HMap.Make(MutInd.CanOrd) module Mindset = Mindmap.Set module Mindmap_env = HMap.Make(MutInd.UserOrd) +module Ind = +struct + (** Designation of a (particular) inductive type. *) + type t = MutInd.t (* the name of the inductive type *) + * int (* the position of this inductive type + within the block of mutually-recursive inductive types. + BEWARE: indexing starts from 0. *) + let modpath (mind, _) = MutInd.modpath mind + + module CanOrd = + struct + type nonrec t = t + let equal (m1, i1) (m2, i2) = Int.equal i1 i2 && MutInd.CanOrd.equal m1 m2 + let compare (m1, i1) (m2, i2) = + let c = Int.compare i1 i2 in + if Int.equal c 0 then MutInd.CanOrd.compare m1 m2 else c + let hash (m, i) = + Hashset.Combine.combine (MutInd.CanOrd.hash m) (Int.hash i) + end + + module UserOrd = + struct + type nonrec t = t + let equal (m1, i1) (m2, i2) = + Int.equal i1 i2 && MutInd.UserOrd.equal m1 m2 + let compare (m1, i1) (m2, i2) = + let c = Int.compare i1 i2 in + if Int.equal c 0 then MutInd.UserOrd.compare m1 m2 else c + let hash (m, i) = + Hashset.Combine.combine (MutInd.UserOrd.hash m) (Int.hash i) + end + + module SyntacticOrd = + struct + type nonrec t = t + let equal (m1, i1) (m2, i2) = + Int.equal i1 i2 && MutInd.SyntacticOrd.equal m1 m2 + + let compare (m1, i1) (m2, i2) = + let c = Int.compare i1 i2 in + if Int.equal c 0 then MutInd.SyntacticOrd.compare m1 m2 else c + + let hash (m, i) = + Hashset.Combine.combine (MutInd.SyntacticOrd.hash m) (Int.hash i) + end + +end + +module Construct = +struct + (** Designation of a (particular) constructor of a (particular) inductive type. *) + type t = Ind.t (* designates the inductive type *) + * int (* the index of the constructor + BEWARE: indexing starts from 1. *) + + let modpath (ind, _) = Ind.modpath ind + + module CanOrd = + struct + type nonrec t = t + let equal (ind1, j1) (ind2, j2) = Int.equal j1 j2 && Ind.CanOrd.equal ind1 ind2 + let compare (ind1, j1) (ind2, j2) = + let c = Int.compare j1 j2 in + if Int.equal c 0 then Ind.CanOrd.compare ind1 ind2 else c + let hash (ind, i) = + Hashset.Combine.combine (Ind.CanOrd.hash ind) (Int.hash i) + end + + module UserOrd = + struct + type nonrec t = t + let equal (ind1, j1) (ind2, j2) = + Int.equal j1 j2 && Ind.UserOrd.equal ind1 ind2 + let compare (ind1, j1) (ind2, j2) = + let c = Int.compare j1 j2 in + if Int.equal c 0 then Ind.UserOrd.compare ind1 ind2 else c + let hash (ind, i) = + Hashset.Combine.combine (Ind.UserOrd.hash ind) (Int.hash i) + end + + module SyntacticOrd = + struct + type nonrec t = t + let equal (ind1, j1) (ind2, j2) = + Int.equal j1 j2 && Ind.SyntacticOrd.equal ind1 ind2 + let compare (ind1, j1) (ind2, j2) = + let c = Int.compare j1 j2 in + if Int.equal c 0 then Ind.SyntacticOrd.compare ind1 ind2 else c + let hash (ind, i) = + Hashset.Combine.combine (Ind.SyntacticOrd.hash ind) (Int.hash i) + end + +end + (** Designation of a (particular) inductive type. *) -type inductive = MutInd.t (* the name of the inductive type *) - * int (* the position of this inductive type - within the block of mutually-recursive inductive types. - BEWARE: indexing starts from 0. *) +type inductive = Ind.t (** Designation of a (particular) constructor of a (particular) inductive type. *) -type constructor = inductive (* designates the inductive type *) - * int (* the index of the constructor - BEWARE: indexing starts from 1. *) +type constructor = Construct.t -let ind_modpath (mind,_) = MutInd.modpath mind -let constr_modpath (ind,_) = ind_modpath ind +let ind_modpath = Ind.modpath +let constr_modpath = Construct.modpath let ith_mutual_inductive (mind, _) i = (mind, i) let ith_constructor_of_inductive ind i = (ind, i) let inductive_of_constructor (ind, _i) = ind let index_of_constructor (_ind, i) = i -let eq_ind (m1, i1) (m2, i2) = Int.equal i1 i2 && MutInd.equal m1 m2 -let eq_user_ind (m1, i1) (m2, i2) = - Int.equal i1 i2 && MutInd.UserOrd.equal m1 m2 -let eq_syntactic_ind (m1, i1) (m2, i2) = - Int.equal i1 i2 && MutInd.SyntacticOrd.equal m1 m2 - -let ind_ord (m1, i1) (m2, i2) = - let c = Int.compare i1 i2 in - if Int.equal c 0 then MutInd.CanOrd.compare m1 m2 else c -let ind_user_ord (m1, i1) (m2, i2) = - let c = Int.compare i1 i2 in - if Int.equal c 0 then MutInd.UserOrd.compare m1 m2 else c -let ind_syntactic_ord (m1, i1) (m2, i2) = - let c = Int.compare i1 i2 in - if Int.equal c 0 then MutInd.SyntacticOrd.compare m1 m2 else c - -let ind_hash (m, i) = - Hashset.Combine.combine (MutInd.hash m) (Int.hash i) -let ind_user_hash (m, i) = - Hashset.Combine.combine (MutInd.UserOrd.hash m) (Int.hash i) -let ind_syntactic_hash (m, i) = - Hashset.Combine.combine (MutInd.SyntacticOrd.hash m) (Int.hash i) - -let eq_constructor (ind1, j1) (ind2, j2) = Int.equal j1 j2 && eq_ind ind1 ind2 -let eq_user_constructor (ind1, j1) (ind2, j2) = - Int.equal j1 j2 && eq_user_ind ind1 ind2 -let eq_syntactic_constructor (ind1, j1) (ind2, j2) = - Int.equal j1 j2 && eq_syntactic_ind ind1 ind2 - -let constructor_ord (ind1, j1) (ind2, j2) = - let c = Int.compare j1 j2 in - if Int.equal c 0 then ind_ord ind1 ind2 else c -let constructor_user_ord (ind1, j1) (ind2, j2) = - let c = Int.compare j1 j2 in - if Int.equal c 0 then ind_user_ord ind1 ind2 else c -let constructor_syntactic_ord (ind1, j1) (ind2, j2) = - let c = Int.compare j1 j2 in - if Int.equal c 0 then ind_syntactic_ord ind1 ind2 else c - -let constructor_hash (ind, i) = - Hashset.Combine.combine (ind_hash ind) (Int.hash i) -let constructor_user_hash (ind, i) = - Hashset.Combine.combine (ind_user_hash ind) (Int.hash i) -let constructor_syntactic_hash (ind, i) = - Hashset.Combine.combine (ind_syntactic_hash ind) (Int.hash i) - -module InductiveOrdered = struct - type t = inductive - let compare = ind_ord -end +let eq_ind = Ind.CanOrd.equal +let eq_user_ind = Ind.UserOrd.equal +let eq_syntactic_ind = Ind.SyntacticOrd.equal -module InductiveOrdered_env = struct - type t = inductive - let compare = ind_user_ord -end +let ind_ord = Ind.CanOrd.compare +let ind_user_ord = Ind.UserOrd.compare +let ind_syntactic_ord = Ind.SyntacticOrd.compare -module Indset = Set.Make(InductiveOrdered) -module Indset_env = Set.Make(InductiveOrdered_env) -module Indmap = Map.Make(InductiveOrdered) -module Indmap_env = Map.Make(InductiveOrdered_env) +let ind_hash = Ind.CanOrd.hash +let ind_user_hash = Ind.UserOrd.hash +let ind_syntactic_hash = Ind.SyntacticOrd.hash -module ConstructorOrdered = struct - type t = constructor - let compare = constructor_ord -end +let eq_constructor = Construct.CanOrd.equal +let eq_user_constructor = Construct.UserOrd.equal +let eq_syntactic_constructor = Construct.SyntacticOrd.equal -module ConstructorOrdered_env = struct - type t = constructor - let compare = constructor_user_ord -end +let constructor_ord = Construct.CanOrd.compare +let constructor_user_ord = Construct.UserOrd.compare +let constructor_syntactic_ord = Construct.SyntacticOrd.compare + +let constructor_hash = Construct.CanOrd.hash +let constructor_user_hash = Construct.UserOrd.hash +let constructor_syntactic_hash = Construct.SyntacticOrd.hash + +module Indset = Set.Make(Ind.CanOrd) +module Indset_env = Set.Make(Ind.UserOrd) +module Indmap = Map.Make(Ind.CanOrd) +module Indmap_env = Map.Make(Ind.UserOrd) -module Constrset = Set.Make(ConstructorOrdered) -module Constrset_env = Set.Make(ConstructorOrdered_env) -module Constrmap = Map.Make(ConstructorOrdered) -module Constrmap_env = Map.Make(ConstructorOrdered_env) +module Constrset = Set.Make(Construct.CanOrd) +module Constrset_env = Set.Make(Construct.UserOrd) +module Constrmap = Map.Make(Construct.CanOrd) +module Constrmap_env = Map.Make(Construct.UserOrd) (** {6 Hash-consing of name objects } *) @@ -786,6 +854,8 @@ struct Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) module SyntacticOrd = struct + type nonrec t = t + let compare a b = let c = ind_syntactic_ord a.proj_ind b.proj_ind in if c == 0 then Int.compare a.proj_arg b.proj_arg @@ -798,6 +868,8 @@ struct Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) end module CanOrd = struct + type nonrec t = t + let compare a b = let c = ind_ord a.proj_ind b.proj_ind in if c == 0 then Int.compare a.proj_arg b.proj_arg @@ -810,6 +882,8 @@ struct Hashset.Combine.combinesmall p.proj_arg (ind_hash p.proj_ind) end module UserOrd = struct + type nonrec t = t + let compare a b = let c = ind_user_ord a.proj_ind b.proj_ind in if c == 0 then Int.compare a.proj_arg b.proj_arg @@ -876,6 +950,7 @@ struct let hash (c, b) = (if b then 0 else 1) + Repr.hash c module SyntacticOrd = struct + type nonrec t = t let compare (c, b) (c', b') = if b = b' then Repr.SyntacticOrd.compare c c' else -1 let equal (c, b as x) (c', b' as x') = @@ -883,12 +958,21 @@ struct let hash (c, b) = (if b then 0 else 1) + Repr.SyntacticOrd.hash c end module CanOrd = struct + type nonrec t = t let compare (c, b) (c', b') = if b = b' then Repr.CanOrd.compare c c' else -1 let equal (c, b as x) (c', b' as x') = x == x' || b = b' && Repr.CanOrd.equal c c' let hash (c, b) = (if b then 0 else 1) + Repr.CanOrd.hash c end + module UserOrd = struct + type nonrec t = t + let compare (c, b) (c', b') = + if b = b' then Repr.UserOrd.compare c c' else -1 + let equal (c, b as x) (c', b' as x') = + x == x' || b = b' && Repr.UserOrd.equal c c' + let hash (c, b) = (if b then 0 else 1) + Repr.UserOrd.hash c + end module Self_Hashcons = struct @@ -982,31 +1066,36 @@ module GlobRef = struct (* By default, [global_reference] are ordered on their canonical part *) - module Ordered = struct - open Constant.CanOrd + module CanOrd = struct type t = GlobRefInternal.t let compare gr1 gr2 = - GlobRefInternal.global_ord_gen compare ind_ord constructor_ord gr1 gr2 - let equal gr1 gr2 = GlobRefInternal.global_eq_gen equal eq_ind eq_constructor gr1 gr2 - let hash gr = GlobRefInternal.global_hash_gen hash ind_hash constructor_hash gr + GlobRefInternal.global_ord_gen Constant.CanOrd.compare Ind.CanOrd.compare Construct.CanOrd.compare gr1 gr2 + let equal gr1 gr2 = GlobRefInternal.global_eq_gen Constant.CanOrd.equal Ind.CanOrd.equal Construct.CanOrd.equal gr1 gr2 + let hash gr = GlobRefInternal.global_hash_gen Constant.CanOrd.hash Ind.CanOrd.hash Construct.CanOrd.hash gr end - module Ordered_env = struct - open Constant.UserOrd + module UserOrd = struct + type t = GlobRefInternal.t + let compare gr1 gr2 = + GlobRefInternal.global_ord_gen Constant.UserOrd.compare Ind.UserOrd.compare Construct.UserOrd.compare gr1 gr2 + let equal gr1 gr2 = GlobRefInternal.global_eq_gen Constant.UserOrd.equal Ind.UserOrd.equal Construct.UserOrd.equal gr1 gr2 + let hash gr = GlobRefInternal.global_hash_gen Constant.UserOrd.hash Ind.UserOrd.hash Construct.UserOrd.hash gr + end + + module SyntacticOrd = struct type t = GlobRefInternal.t let compare gr1 gr2 = - GlobRefInternal.global_ord_gen compare ind_user_ord constructor_user_ord gr1 gr2 - let equal gr1 gr2 = - GlobRefInternal.global_eq_gen equal eq_user_ind eq_user_constructor gr1 gr2 - let hash gr = GlobRefInternal.global_hash_gen hash ind_user_hash constructor_user_hash gr + GlobRefInternal.global_ord_gen Constant.SyntacticOrd.compare Ind.SyntacticOrd.compare Construct.SyntacticOrd.compare gr1 gr2 + let equal gr1 gr2 = GlobRefInternal.global_eq_gen Constant.SyntacticOrd.equal Ind.SyntacticOrd.equal Construct.SyntacticOrd.equal gr1 gr2 + let hash gr = GlobRefInternal.global_hash_gen Constant.SyntacticOrd.hash Ind.SyntacticOrd.hash Construct.SyntacticOrd.hash gr end - module Map = HMap.Make(Ordered) + module Map = HMap.Make(CanOrd) module Set = Map.Set (* Alternative sets and maps indexed by the user part of the kernel names *) - module Map_env = HMap.Make(Ordered_env) + module Map_env = HMap.Make(UserOrd) module Set_env = Map_env.Set end diff --git a/kernel/names.mli b/kernel/names.mli index ea137ad1f4..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. @@ -307,6 +310,60 @@ module KNset : CSig.SetS with type elt = KerName.t module KNpred : Predicate.S with type elt = KerName.t module KNmap : Map.ExtS with type key = KerName.t and module Set := KNset +(** {6 Signature for quotiented names} *) + +module type EqType = +sig + type t + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int +end + +module type QNameS = +sig + type t + (** A type of reference that implements an implicit quotient by containing + two different names. The first one is the user name, i.e. what the user + sees when printing. The second one is the canonical name, which is the + actual absolute name of the reference. + + This mechanism is fundamentally tied to the module system of Coq. Functor + application and module inclusion are the typical ways to introduce names + where the canonical and user components differ. In particular, the two + components should be undistinguishable from the point of view of typing, + i.e. from a "kernel" ground. This aliasing only makes sense inside an + environment, but at this point this notion is not even defined so, this + dual name trick is fragile. One has to ensure many invariants when + creating such names, but the kernel is quite lenient when it comes to + checking that these invariants hold. (Read: there are soundness bugs + lurking in the module system.) + + One could enforce the invariants by splitting the names and storing that + information in the environment instead, but unfortunately, this wreaks + havoc in the upper layers. The latter are infamously not stable by + syntactic equality, in particular they might observe the difference + between canonical and user names if not packed together. + + For this reason, it is discouraged to use the canonical-accessing API + in the upper layers, notably the [CanOrd] module below. Instead, one + should use their quotiented versions defined in the [Environ] module. + Eventually all uses to [CanOrd] outside of the kernel should be removed. + + CAVEAT: name sets and maps are still exposing a canonical-accessing API + surreptitiously. *) + + module CanOrd : EqType with type t = t + (** Equality functions over the canonical name. Their use should be + restricted to the kernel. *) + + module UserOrd : EqType with type t = t + (** Equality functions over the user name. *) + + module SyntacticOrd : EqType with type t = t + (** Equality functions using both names, for low-level uses. *) +end + (** {6 Constant Names } *) module Constant: @@ -340,28 +397,12 @@ sig (** Comparisons *) - module CanOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - - module UserOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - - module SyntacticOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end + include QNameS with type t := t - val equal : t -> t -> bool + val equal : t -> t -> bool [@@ocaml.deprecated "Use QConstant.equal"] (** Default comparison, alias for [CanOrd.equal] *) - val hash : t -> int + val hash : t -> int [@@ocaml.deprecated "Use QConstant.hash"] (** Hashing function *) val change_label : t -> Label.t -> t @@ -430,28 +471,12 @@ sig (** Comparisons *) - module CanOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end + include QNameS with type t := t - module UserOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end + val equal : t -> t -> bool [@@ocaml.deprecated "Use QMutInd.equal"] + (** Default comparison, alias for [CanOrd.equal] *) - module SyntacticOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - - val equal : t -> t -> bool - (** Default comparison, alias for [CanOrd.equal] *) - - val hash : t -> int + val hash : t -> int [@@ocaml.deprecated "Use QMutInd.hash"] (** Displaying *) @@ -473,16 +498,35 @@ module Mindset : CSig.SetS with type elt = MutInd.t module Mindmap : Map.ExtS with type key = MutInd.t and module Set := Mindset module Mindmap_env : CMap.ExtS with type key = MutInd.t -(** Designation of a (particular) inductive type. *) -type inductive = MutInd.t (* the name of the inductive type *) - * int (* the position of this inductive type - within the block of mutually-recursive inductive types. - BEWARE: indexing starts from 0. *) +module Ind : +sig + (** Designation of a (particular) inductive type. *) + type t = MutInd.t (* the name of the inductive type *) + * int (* the position of this inductive type + within the block of mutually-recursive inductive types. + BEWARE: indexing starts from 0. *) + val modpath : t -> ModPath.t + + include QNameS with type t := t + +end + +type inductive = Ind.t -(** Designation of a (particular) constructor of a (particular) inductive type. *) -type constructor = inductive (* designates the inductive type *) - * int (* the index of the constructor - BEWARE: indexing starts from 1. *) +module Construct : +sig + (** Designation of a (particular) constructor of a (particular) inductive type. *) + type t = Ind.t (* designates the inductive type *) + * int (* the index of the constructor + BEWARE: indexing starts from 1. *) + + val modpath : t -> ModPath.t + + include QNameS with type t := t + +end + +type constructor = Construct.t module Indset : CSet.S with type elt = inductive module Constrset : CSet.S with type elt = constructor @@ -494,30 +538,51 @@ module Indmap_env : CMap.ExtS with type key = inductive and module Set := Indset module Constrmap_env : CMap.ExtS with type key = constructor and module Set := Constrset_env val ind_modpath : inductive -> ModPath.t +[@@ocaml.deprecated "Use the Ind module"] + val constr_modpath : constructor -> ModPath.t +[@@ocaml.deprecated "Use the Construct module"] val ith_mutual_inductive : inductive -> int -> inductive val ith_constructor_of_inductive : inductive -> int -> constructor val inductive_of_constructor : constructor -> inductive val index_of_constructor : constructor -> int val eq_ind : inductive -> inductive -> bool +[@@ocaml.deprecated "Use the Ind module"] val eq_user_ind : inductive -> inductive -> bool +[@@ocaml.deprecated "Use the Ind module"] val eq_syntactic_ind : inductive -> inductive -> bool +[@@ocaml.deprecated "Use the Ind module"] val ind_ord : inductive -> inductive -> int +[@@ocaml.deprecated "Use the Ind module"] val ind_hash : inductive -> int +[@@ocaml.deprecated "Use the Ind module"] val ind_user_ord : inductive -> inductive -> int +[@@ocaml.deprecated "Use the Ind module"] val ind_user_hash : inductive -> int +[@@ocaml.deprecated "Use the Ind module"] val ind_syntactic_ord : inductive -> inductive -> int +[@@ocaml.deprecated "Use the Ind module"] val ind_syntactic_hash : inductive -> int +[@@ocaml.deprecated "Use the Ind module"] val eq_constructor : constructor -> constructor -> bool +[@@ocaml.deprecated "Use the Construct module"] val eq_user_constructor : constructor -> constructor -> bool +[@@ocaml.deprecated "Use the Construct module"] val eq_syntactic_constructor : constructor -> constructor -> bool +[@@ocaml.deprecated "Use the Construct module"] val constructor_ord : constructor -> constructor -> int +[@@ocaml.deprecated "Use the Construct module"] val constructor_hash : constructor -> int +[@@ocaml.deprecated "Use the Construct module"] val constructor_user_ord : constructor -> constructor -> int +[@@ocaml.deprecated "Use the Construct module"] val constructor_user_hash : constructor -> int +[@@ocaml.deprecated "Use the Construct module"] val constructor_syntactic_ord : constructor -> constructor -> int +[@@ocaml.deprecated "Use the Construct module"] val constructor_syntactic_hash : constructor -> int +[@@ocaml.deprecated "Use the Construct module"] (** {6 Hash-consing } *) @@ -558,21 +623,7 @@ module Projection : sig val make : inductive -> proj_npars:int -> proj_arg:int -> Label.t -> t - module SyntacticOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - module CanOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - module UserOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end + include QNameS with type t := t val constant : t -> Constant.t (** Don't use this if you don't have to. *) @@ -583,9 +634,9 @@ module Projection : sig val arg : t -> int val label : t -> Label.t - val equal : t -> t -> bool - val hash : t -> int - val compare : t -> t -> int + val equal : t -> t -> bool [@@ocaml.deprecated "Use QProjection.equal"] + val hash : t -> int [@@ocaml.deprecated "Use QProjection.hash"] + val compare : t -> t -> int [@@ocaml.deprecated "Use QProjection.compare"] val map : (MutInd.t -> MutInd.t) -> t -> t val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t @@ -602,16 +653,7 @@ module Projection : sig val make : Repr.t -> bool -> t val repr : t -> Repr.t - module SyntacticOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - module CanOrd : sig - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end + include QNameS with type t := t val constant : t -> Constant.t val mind : t -> MutInd.t @@ -623,14 +665,18 @@ module Projection : sig val unfold : t -> t val equal : t -> t -> bool + [@@ocaml.deprecated "Use QProjection.equal"] val hash : t -> int + [@@ocaml.deprecated "Use QProjection.hash"] val hcons : t -> t (** Hashconsing of projections. *) val repr_equal : t -> t -> bool + [@@ocaml.deprecated "Use an explicit projection of Repr"] (** Ignoring the unfolding boolean. *) val compare : t -> t -> int + [@@ocaml.deprecated "Use QProjection.compare"] val map : (MutInd.t -> MutInd.t) -> t -> t val map_npars : (MutInd.t -> int -> MutInd.t * int) -> t -> t @@ -656,19 +702,7 @@ module GlobRef : sig val equal : t -> t -> bool - module Ordered : sig - type nonrec t = t - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end - - module Ordered_env : sig - type nonrec t = t - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int - end + include QNameS with type t := t module Set_env : CSig.SetS with type elt = t module Map_env : Map.ExtS diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index ae070e6f8e..09db29d222 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -65,11 +65,11 @@ type gname = let eq_gname gn1 gn2 = match gn1, gn2 with | Gind (s1, ind1), Gind (s2, ind2) -> - String.equal s1 s2 && eq_ind ind1 ind2 + String.equal s1 s2 && Ind.CanOrd.equal ind1 ind2 | Gconstant (s1, c1), Gconstant (s2, c2) -> - String.equal s1 s2 && Constant.equal c1 c2 + String.equal s1 s2 && Constant.CanOrd.equal c1 c2 | Gproj (s1, ind1, i1), Gproj (s2, ind2, i2) -> - String.equal s1 s2 && eq_ind ind1 ind2 && Int.equal i1 i2 + String.equal s1 s2 && Ind.CanOrd.equal ind1 ind2 && Int.equal i1 i2 | Gcase (None, i1), Gcase (None, i2) -> Int.equal i1 i2 | Gcase (Some l1, i1), Gcase (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2 | Gpred (None, i1), Gpred (None, i2) -> Int.equal i1 i2 @@ -96,9 +96,9 @@ open Hashset.Combine let gname_hash gn = match gn with | Gind (s, ind) -> - combinesmall 1 (combine (String.hash s) (ind_hash ind)) + combinesmall 1 (combine (String.hash s) (Ind.CanOrd.hash ind)) | Gconstant (s, c) -> - combinesmall 2 (combine (String.hash s) (Constant.hash c)) + combinesmall 2 (combine (String.hash s) (Constant.CanOrd.hash c)) | Gcase (l, i) -> combinesmall 3 (combine (Option.hash Label.hash l) (Int.hash i)) | Gpred (l, i) -> combinesmall 4 (combine (Option.hash Label.hash l) (Int.hash i)) | Gfixtype (l, i) -> combinesmall 5 (combine (Option.hash Label.hash l) (Int.hash i)) @@ -107,7 +107,7 @@ let gname_hash gn = match gn with | Ginternal s -> combinesmall 8 (String.hash s) | Grel i -> combinesmall 9 (Int.hash i) | Gnamed id -> combinesmall 10 (Id.hash id) -| Gproj (s, p, i) -> combinesmall 11 (combine (String.hash s) (combine (ind_hash p) i)) +| Gproj (s, p, i) -> combinesmall 11 (combine (String.hash s) (combine (Ind.CanOrd.hash p) i)) let case_ctr = ref (-1) @@ -148,13 +148,13 @@ let eq_symbol sy1 sy2 = | SymbValue v1, SymbValue v2 -> (=) v1 v2 (** FIXME: how is this even valid? *) | SymbSort s1, SymbSort s2 -> Sorts.equal s1 s2 | SymbName n1, SymbName n2 -> Name.equal n1 n2 - | SymbConst kn1, SymbConst kn2 -> Constant.equal kn1 kn2 + | SymbConst kn1, SymbConst kn2 -> Constant.CanOrd.equal kn1 kn2 | SymbMatch sw1, SymbMatch sw2 -> eq_annot_sw sw1 sw2 - | SymbInd ind1, SymbInd ind2 -> eq_ind ind1 ind2 + | SymbInd ind1, SymbInd ind2 -> Ind.CanOrd.equal ind1 ind2 | SymbMeta m1, SymbMeta m2 -> Int.equal m1 m2 | SymbEvar evk1, SymbEvar evk2 -> Evar.equal evk1 evk2 | SymbLevel l1, SymbLevel l2 -> Univ.Level.equal l1 l2 - | SymbProj (i1, k1), SymbProj (i2, k2) -> eq_ind i1 i2 && Int.equal k1 k2 + | SymbProj (i1, k1), SymbProj (i2, k2) -> Ind.CanOrd.equal i1 i2 && Int.equal k1 k2 | _, _ -> false let hash_symbol symb = @@ -162,13 +162,13 @@ let hash_symbol symb = | SymbValue v -> combinesmall 1 (Hashtbl.hash v) (** FIXME *) | SymbSort s -> combinesmall 2 (Sorts.hash s) | SymbName name -> combinesmall 3 (Name.hash name) - | SymbConst c -> combinesmall 4 (Constant.hash c) + | SymbConst c -> combinesmall 4 (Constant.CanOrd.hash c) | SymbMatch sw -> combinesmall 5 (hash_annot_sw sw) - | SymbInd ind -> combinesmall 6 (ind_hash ind) + | SymbInd ind -> combinesmall 6 (Ind.CanOrd.hash ind) | SymbMeta m -> combinesmall 7 m | SymbEvar evk -> combinesmall 8 (Evar.hash evk) | SymbLevel l -> combinesmall 9 (Univ.Level.hash l) - | SymbProj (i, k) -> combinesmall 10 (combine (ind_hash i) k) + | SymbProj (i, k) -> combinesmall 10 (combine (Ind.CanOrd.hash i) k) module HashedTypeSymbol = struct type t = symbol @@ -438,7 +438,7 @@ let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 = eq_mllam_branches gn1 gn2 n env1 env2 br1 br2 | MLconstruct (pf1, ind1, tag1, args1), MLconstruct (pf2, ind2, tag2, args2) -> String.equal pf1 pf2 && - eq_ind ind1 ind2 && + Ind.CanOrd.equal ind1 ind2 && Int.equal tag1 tag2 && Array.equal (eq_mllambda gn1 gn2 n env1 env2) args1 args2 | MLint i1, MLint i2 -> @@ -457,7 +457,7 @@ let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 = Array.equal (eq_mllambda gn1 gn2 n env1 env2) arr1 arr2 | MLisaccu (s1, ind1, ml1), MLisaccu (s2, ind2, ml2) -> - String.equal s1 s2 && eq_ind ind1 ind2 && + String.equal s1 s2 && Ind.CanOrd.equal ind1 ind2 && eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 | (MLlocal _ | MLglobal _ | MLprimitive _ | MLlam _ | MLletrec _ | MLlet _ | MLapp _ | MLif _ | MLmatch _ | MLconstruct _ | MLint _ | MLuint _ | @@ -527,7 +527,7 @@ let rec hash_mllambda gn n env t = combinesmall 9 (hash_mllam_branches gn n env (combine3 hannot hc haccu) br) | MLconstruct (pf, ind, tag, args) -> let hpf = String.hash pf in - let hcs = ind_hash ind in + let hcs = Ind.CanOrd.hash ind in let htag = Int.hash tag in combinesmall 10 (hash_mllambda_array gn n env (combine3 hpf hcs htag) args) | MLint i -> @@ -545,7 +545,7 @@ let rec hash_mllambda gn n env t = | MLarray arr -> combinesmall 15 (hash_mllambda_array gn n env 1 arr) | MLisaccu (s, ind, c) -> - combinesmall 16 (combine (String.hash s) (combine (ind_hash ind) (hash_mllambda gn n env c))) + combinesmall 16 (combine (String.hash s) (combine (Ind.CanOrd.hash ind) (hash_mllambda gn n env c))) | MLfloat f -> combinesmall 17 (Float64.hash f) @@ -689,7 +689,7 @@ let eq_global g1 g2 = eq_mllambda gn1 gn2 (Array.length lns1) env1 env2 t1 t2 | Gopen s1, Gopen s2 -> String.equal s1 s2 | Gtype (ind1, arr1), Gtype (ind2, arr2) -> - eq_ind ind1 ind2 && + Ind.CanOrd.equal ind1 ind2 && Array.equal (fun (tag1,ar1) (tag2,ar2) -> Int.equal tag1 tag2 && Int.equal ar1 ar2) arr1 arr2 | Gcomment s1, Gcomment s2 -> String.equal s1 s2 | _, _ -> false @@ -720,7 +720,7 @@ let hash_global g = let hash_aux acc (tag,ar) = combine3 acc (Int.hash tag) (Int.hash ar) in - combinesmall 6 (combine (ind_hash ind) (Array.fold_left hash_aux 0 arr)) + combinesmall 6 (combine (Ind.CanOrd.hash ind) (Array.fold_left hash_aux 0 arr)) | Gcomment s -> combinesmall 7 (String.hash s) let global_stack = ref ([] : global list) @@ -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 @@ -2192,13 +2184,12 @@ let mk_norm_code env sigma prefix t = [|MLglobal (Ginternal "()")|])) in header::gl, (mind_updates, const_updates) -let mk_library_header dir = - let libname = Format.sprintf "(str_decode \"%s\")" (str_encode dir) in - [Glet(Ginternal "symbols_tbl", - MLapp (MLglobal (Ginternal "get_library_native_symbols"), - [|MLglobal (Ginternal libname)|]))] +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 71317d188b..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 @@ -69,7 +68,7 @@ val compile_mind_field : ModPath.t -> Label.t -> val mk_conv_code : env -> evars -> string -> constr -> constr -> linkable_code val mk_norm_code : env -> evars -> string -> constr -> linkable_code -val mk_library_header : DirPath.t -> global list +val mk_library_header : Nativevalues.symbols -> global list val mod_uid_of_dirpath : DirPath.t -> string diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index fc6afb79d4..d77ee759c6 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -80,17 +80,17 @@ and conv_atom env pb lvl a1 a2 cu = | Arel i1, Arel i2 -> if Int.equal i1 i2 then cu else raise NotConvertible | Aind (ind1,u1), Aind (ind2,u2) -> - if eq_ind ind1 ind2 then convert_instances ~flex:false u1 u2 cu + if Ind.CanOrd.equal ind1 ind2 then convert_instances ~flex:false u1 u2 cu else raise NotConvertible | Aconstant (c1,u1), Aconstant (c2,u2) -> - if Constant.equal c1 c2 then convert_instances ~flex:true u1 u2 cu + if Constant.CanOrd.equal c1 c2 then convert_instances ~flex:true u1 u2 cu else raise NotConvertible | Asort s1, Asort s2 -> sort_cmp_universes env pb s1 s2 cu | Avar id1, Avar id2 -> if Id.equal id1 id2 then cu else raise NotConvertible | Acase(a1,ac1,p1,bs1), Acase(a2,ac2,p2,bs2) -> - if not (eq_ind a1.asw_ind a2.asw_ind) then raise NotConvertible; + if not (Ind.CanOrd.equal a1.asw_ind a2.asw_ind) then raise NotConvertible; let cu = conv_accu env CONV lvl ac1 ac2 cu in let tbl = a1.asw_reloc in let len = Array.length tbl in @@ -124,7 +124,7 @@ and conv_atom env pb lvl a1 a2 cu = let v = mk_rel_accu lvl in conv_val env pb (lvl + 1) (d1 v) (d2 v) cu | Aproj((ind1, i1), ac1), Aproj((ind2, i2), ac2) -> - if not (eq_ind ind1 ind2 && Int.equal i1 i2) then raise NotConvertible + if not (Ind.CanOrd.equal ind1 ind2 && Int.equal i1 i2) then raise NotConvertible else conv_accu env CONV lvl ac1 ac2 cu | Arel _, _ | Aind _, _ | Aconstant _, _ | Asort _, _ | Avar _, _ | Acase _, _ | Afix _, _ | Acofix _, _ | Acofixe _, _ | Aprod _, _ @@ -161,7 +161,7 @@ let native_conv_gen pb sigma env univs t1 t2 = let fn = compile ml_filename code ~profile:false in if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); let t0 = Sys.time () in - call_linker env ~fatal:true ~prefix fn (Some upds); + call_linker ~fatal:true ~prefix fn (Some upds); let t1 = Sys.time () in let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in if !Flags.debug then Feedback.msg_debug (Pp.str time_info); diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 99090f0147..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 *) @@ -433,8 +431,8 @@ module Cache = module ConstrHash = struct type t = constructor - let equal = eq_constructor - let hash = constructor_hash + let equal = Construct.CanOrd.equal + let hash = Construct.CanOrd.hash end module ConstrTable = Hashtbl.Make(ConstrHash) diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 494282d4e1..1e1085d5ff 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -25,7 +25,8 @@ let open_header = ["Nativevalues"; let open_header = List.map mk_open open_header (* Directory where compiled files are stored *) -let output_dir = ref ".coq-native" +let dft_output_dir = ".coq-native" +let output_dir = ref dft_output_dir (* Extension of generated ml files, stored for debugging purposes *) let source_ext = ".native" @@ -92,9 +93,14 @@ let error_native_compiler_failed e = CErrors.user_err msg let call_compiler ?profile:(profile=false) ml_filename = - let load_path = !get_load_paths () in - let load_path = List.map (fun dn -> dn / !output_dir) load_path in - let include_dirs = List.flatten (List.map (fun x -> ["-I"; x]) (get_include_dirs () @ load_path)) in + (* The below path is computed from Require statements, by uniquizing + the paths, see [Library.get_used_load_paths] This is in general + hacky and we should do a bit better once we move loadpath to its + own library *) + let require_load_path = !get_load_paths () in + (* We assume that installed files always go in .coq-native for now *) + let install_load_path = List.map (fun dn -> dn / dft_output_dir) require_load_path in + let include_dirs = List.flatten (List.map (fun x -> ["-I"; x]) (get_include_dirs () @ install_load_path)) in let f = Filename.chop_extension ml_filename in let link_filename = f ^ ".cmo" in let link_filename = Dynlink.adapt_filename link_filename in @@ -139,8 +145,10 @@ let compile fn code ~profile:profile = if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn; r -let compile_library dir code fn = - let header = mk_library_header dir in +type native_library = Nativecode.global list * Nativevalues.symbols + +let compile_library (code, symb) fn = + let header = mk_library_header symb in let fn = fn ^ source_ext in let basename = Filename.basename fn in let dirname = Filename.dirname fn in @@ -154,19 +162,9 @@ let compile_library dir code fn = let _ = call_compiler fn in if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn -let native_symbols = ref Names.DPmap.empty - -let get_library_native_symbols dir = - try Names.DPmap.find dir !native_symbols - with Not_found -> - CErrors.user_err ~hdr:"get_library_native_symbols" - Pp.((str "Linker error in the native compiler. Are you using Require inside a nested Module declaration?") ++ fnl () ++ - (str "This use case is not supported, but disabling the native compiler may help.")) - (* call_linker links dynamically the code for constants in environment or a *) (* conversion test. *) -let call_linker ?(fatal=true) env ~prefix f upds = - native_symbols := env.Environ.native_symbols; +let call_linker ?(fatal=true) ~prefix f upds = rt1 := dummy_value (); rt2 := dummy_value (); if not (Sys.file_exists f) then @@ -185,6 +183,11 @@ let call_linker ?(fatal=true) env ~prefix f upds = else if !Flags.debug then Feedback.msg_debug CErrors.(iprint exn)); match upds with Some upds -> update_locations upds | _ -> () -let link_library env ~prefix ~dirname ~basename = - let f = dirname / !output_dir / basename in - call_linker env ~fatal:false ~prefix f None +let link_library ~prefix ~dirname ~basename = + (* We try both [output_dir] and [.coq-native], unfortunately from + [Require] we don't know if we are loading a library in the build + dir or in the installed layout *) + let install_location = dirname / dft_output_dir / basename in + let build_location = dirname / !output_dir / basename in + let f = if Sys.file_exists build_location then build_location else install_location in + call_linker ~fatal:false ~prefix f None diff --git a/kernel/nativelib.mli b/kernel/nativelib.mli index 29b4d20197..0c0fe3acc9 100644 --- a/kernel/nativelib.mli +++ b/kernel/nativelib.mli @@ -27,27 +27,24 @@ val get_ml_filename : unit -> string * string whether are in byte mode or not; file is expected to be .ml file *) val compile : string -> global list -> profile:bool -> string -(** [compile_library lib code file] is similar to [compile file code] +type native_library = Nativecode.global list * Nativevalues.symbols + +(** [compile_library (code, _) file] is similar to [compile file code] but will perform some extra tweaks to handle [code] as a Coq lib. *) -val compile_library : Names.DirPath.t -> global list -> string -> unit +val compile_library : native_library -> string -> unit val call_linker : ?fatal:bool - -> Environ.env -> prefix:string -> string -> code_location_updates option -> unit val link_library - : Environ.env - -> prefix:string + : prefix:string -> dirname:string -> basename:string -> unit val rt1 : Nativevalues.t ref val rt2 : Nativevalues.t ref - -val get_library_native_symbols : Names.DirPath.t -> Nativevalues.symbols -(** Strictly for usage by code produced by native compute. *) diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 05c98e4b87..bd6241ae67 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -36,13 +36,13 @@ type annot_sw = { (* We compare only what is relevant for generation of ml code *) let eq_annot_sw asw1 asw2 = - eq_ind asw1.asw_ind asw2.asw_ind && + Ind.CanOrd.equal asw1.asw_ind asw2.asw_ind && String.equal asw1.asw_prefix asw2.asw_prefix open Hashset.Combine let hash_annot_sw asw = - combine (ind_hash asw.asw_ind) (String.hash asw.asw_prefix) + combine (Ind.CanOrd.hash asw.asw_ind) (String.hash asw.asw_prefix) type sort_annot = string * int diff --git a/kernel/primred.ml b/kernel/primred.ml index f158cfacea..f0b4d6d362 100644 --- a/kernel/primred.ml +++ b/kernel/primred.ml @@ -12,11 +12,11 @@ type _ action_kind = type exn += IncompatibleDeclarations : 'a action_kind * 'a * 'a -> exn let check_same_types typ c1 c2 = - if not (Constant.equal c1 c2) + if not (Constant.CanOrd.equal c1 c2) then raise (IncompatibleDeclarations (IncompatTypes typ, c1, c2)) let check_same_inds ind i1 i2 = - if not (eq_ind i1 i2) + if not (Ind.CanOrd.equal i1 i2) then raise (IncompatibleDeclarations (IncompatInd ind, i1, i2)) let add_retroknowledge retro action = diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 96bf370342..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.equal cst cst' -> + | 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) @@ -301,9 +302,14 @@ let unfold_ref_with_args infos tab fl v = | Primitive op when check_native_args op v -> let c = match fl with ConstKey c -> c | _ -> assert false in let rargs, a, nargs, v = get_native_args1 op c v in - Some (whd_stack infos tab a (Zupdate a::(Zprimitive(op,c,rargs,nargs)::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,26 +414,30 @@ 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 _ -> - (* else the oracle tells which constant is to be expanded *) - let oracle = CClosure.oracle_of_infos infos.cnv_inf in - let (app1,app2) = - let aux appr1 lft1 fl1 tab1 v1 appr2 lft2 fl2 tab2 v2 = - match unfold_ref_with_args infos.cnv_inf tab1 fl1 v1 with - | Some t1 -> ((lft1, t1), appr2) - | None -> match unfold_ref_with_args infos.cnv_inf tab2 fl2 v2 with - | Some t2 -> (appr1, (lft2, t2)) - | None -> raise NotConvertible - in - if Conv_oracle.oracle_order Univ.out_punivs oracle l2r fl1 fl2 then - aux appr1 lft1 fl1 infos.lft_tab v1 appr2 lft2 fl2 infos.rgt_tab v2 - else - let (app2,app1) = aux appr2 lft2 fl2 infos.rgt_tab v2 appr1 lft1 fl1 infos.lft_tab v1 in - (app1,app2) - in - eqappr cv_pb l2r infos app1 app2 cuniv) + let r1 = unfold_ref_with_args infos.cnv_inf infos.lft_tab fl1 v1 in + let r2 = unfold_ref_with_args infos.cnv_inf infos.rgt_tab fl2 v2 in + match r1, r2 with + | None, None -> raise NotConvertible + | Some t1, Some t2 -> + (* else the oracle tells which constant is to be expanded *) + let oracle = CClosure.oracle_of_infos infos.cnv_inf in + if Conv_oracle.oracle_order Univ.out_punivs oracle l2r fl1 fl2 then + eqappr cv_pb l2r infos (lft1, t1) appr2 cuniv + else + eqappr cv_pb l2r infos appr1 (lft2, t2) cuniv + | Some (t1, v1), None -> + let all = RedFlags.red_add_transparent all (RedFlags.red_transparent (info_flags infos.cnv_inf)) in + let t1 = whd_stack (infos_with_reds infos.cnv_inf all) infos.lft_tab t1 v1 in + eqappr cv_pb l2r infos (lft1, t1) appr2 cuniv + | None, Some (t2, v2) -> + let all = RedFlags.red_add_transparent all (RedFlags.red_transparent (info_flags infos.cnv_inf)) in + let t2 = whd_stack (infos_with_reds infos.cnv_inf all) infos.rgt_tab t2 v2 in + eqappr cv_pb l2r infos appr1 (lft2, t2) cuniv + ) | (FProj (p1,c1), FProj (p2, c2)) -> (* Projections: prefer unfolding to first-order unification, @@ -441,7 +451,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | Some s2 -> eqappr cv_pb l2r infos appr1 (lft2, (c2, (s2 :: v2))) cuniv | None -> - if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) + if Projection.Repr.CanOrd.equal (Projection.repr p1) (Projection.repr p2) && compare_stack_shape v1 v2 then let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in @@ -568,43 +578,37 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* Inductive types: MutInd MutConstruct Fix Cofix *) | (FInd (ind1,u1 as pind1), FInd (ind2,u2 as pind2)) -> - if eq_ind ind1 ind2 then + if Ind.CanOrd.equal ind1 ind2 then if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then let cuniv = convert_instances ~flex:false u1 u2 cuniv in 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)) -> - if Int.equal j1 j2 && eq_ind ind1 ind2 then + if Int.equal j1 j2 && Ind.CanOrd.equal ind1 ind2 then if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then let cuniv = convert_instances ~flex:false u1 u2 cuniv in 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 *) @@ -669,7 +673,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = else raise NotConvertible | FCaseInvert (ci1,p1,_,_,br1,e1), FCaseInvert (ci2,p2,_,_,br2,e2) -> - (if not (eq_ind ci1.ci_ind ci2.ci_ind) then raise NotConvertible); + (if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then raise NotConvertible); let el1 = el_stack lft1 v1 and el2 = el_stack lft2 v2 in let ccnv = ccnv CONV l2r infos el1 el2 in let cuniv = ccnv (mk_clos e1 p1) (mk_clos e2 p2) cuniv in @@ -704,14 +708,14 @@ and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = | (Zlapp a1,Zlapp a2) -> Array.fold_right2 f a1 a2 cu1 | (Zlproj (c1,_l1),Zlproj (c2,_l2)) -> - if not (Projection.Repr.equal c1 c2) then + if not (Projection.Repr.CanOrd.equal c1 c2) then raise NotConvertible else cu1 | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> let cu2 = f fx1 fx2 cu1 in cmp_rec a1 a2 cu2 | (Zlcase(ci1,l1,p1,br1,e1),Zlcase(ci2,l2,p2,br2,e2)) -> - if not (eq_ind ci1.ci_ind ci2.ci_ind) then + if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then raise NotConvertible; let cu2 = f (l1, mk_clos e1 p1) (l2, mk_clos e2 p2) cu1 in convert_branches l2r infos ci1 e1 e2 l1 l2 br1 br2 cu2 diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 3dee3d2b2f..6abd283f6c 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -121,7 +121,6 @@ type compiled_library = { comp_univs : Univ.ContextSet.t; comp_deps : library_info array; comp_enga : engagement; - comp_natsymbs : Nativevalues.symbols } type reimport = compiled_library * Univ.ContextSet.t * vodigest @@ -672,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 @@ -726,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') @@ -881,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 @@ -1139,7 +1138,6 @@ let end_module l restype senv = let mb, cst = build_module_body params restype senv in let senv = push_context_set ~strict:true (Univ.LSet.empty,cst) senv in let newenv = Environ.set_opaque_tables oldsenv.env (Environ.opaque_tables senv.env) in - let newenv = Environ.set_native_symbols newenv senv.env.Environ.native_symbols in let newenv = set_engagement_opt newenv senv.engagement in let newenv = Environ.set_universes (Environ.universes senv.env) newenv in let senv' = propagate_loads { senv with env = newenv } in @@ -1166,7 +1164,6 @@ let end_modtype l senv = let () = check_empty_context senv in let mbids = List.rev_map fst params in let newenv = Environ.set_opaque_tables oldsenv.env (Environ.opaque_tables senv.env) in - let newenv = Environ.set_native_symbols newenv senv.env.Environ.native_symbols in let newenv = set_engagement_opt newenv senv.engagement in let newenv = Environ.set_universes (Environ.universes senv.env) newenv in let senv' = propagate_loads {senv with env=newenv} in @@ -1229,8 +1226,6 @@ let module_of_library lib = lib.comp_mod let univs_of_library lib = lib.comp_univs -type native_library = Nativecode.global list - (** FIXME: MS: remove?*) let current_modpath senv = senv.modpath let current_dirpath senv = Names.ModPath.dp (current_modpath senv) @@ -1272,9 +1267,8 @@ let export ?except ~output_native_objects senv dir = comp_univs = senv.univ; comp_deps = Array.of_list (DPmap.bindings senv.required); comp_enga = Environ.engagement senv.env; - comp_natsymbs = symbols } - in - mp, lib, ast + } in + mp, lib, (ast, symbols) (* cst are the constraints that were computed by the vi2vo step and hence are * not part of the [lib.comp_univs] field (but morally should be) *) @@ -1294,7 +1288,6 @@ let import lib cst vodigest senv = let linkinfo = Nativecode.link_info_of_dirpath lib.comp_name in Modops.add_linked_module mb linkinfo env in - let env = Environ.add_native_symbols lib.comp_name lib.comp_natsymbs env in let sections = Option.map (Section.map_custom (fun custom -> {custom with rev_reimport = (lib,cst,vodigest) :: custom.rev_reimport})) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index b601279e87..6fa9022906 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -191,8 +191,6 @@ val current_dirpath : safe_environment -> DirPath.t type compiled_library -type native_library = Nativecode.global list - val module_of_library : compiled_library -> Declarations.module_body val univs_of_library : compiled_library -> Univ.ContextSet.t @@ -201,7 +199,7 @@ val start_library : DirPath.t -> ModPath.t safe_transformer val export : ?except:Future.UUIDSet.t -> output_native_objects:bool -> safe_environment -> DirPath.t -> - ModPath.t * compiled_library * native_library + ModPath.t * compiled_library * Nativelib.native_library (* Constraints are non empty iff the file is a vi2vo *) val import : compiled_library -> Univ.ContextSet.t -> vodigest -> diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 76a1c190be..1a4c786e43 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -182,7 +182,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 begin let kn2' = kn_of_delta reso2 kn2 in if KerName.equal kn2 kn2' || - MutInd.equal (mind_of_delta_kn reso1 kn1) + MutInd.CanOrd.equal (mind_of_delta_kn reso1 kn1) (subst_mind subst2 (MutInd.make kn2 kn2')) then () else error NotEqualInductiveAliases 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/kernel/typeops.ml b/kernel/typeops.ml index f86c12e1f1..85e24f87b7 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -413,7 +413,7 @@ let type_of_projection env p c ct = try find_rectype env ct with Not_found -> error_case_not_inductive env (make_judge c ct) in - assert(eq_ind (Projection.inductive p) ind); + assert(Ind.CanOrd.equal (Projection.inductive p) ind); let ty = Vars.subst_instance_constr u pty in substl (c :: CList.rev args) ty diff --git a/kernel/vars.ml b/kernel/vars.ml index f7e28b0cfe..a446fa413c 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -348,5 +348,8 @@ let universes_of_constr c = | Array (u,_,_,_) -> let s = LSet.fold LSet.add (Instance.levels u) s in Constr.fold aux s c + | Case (_,_,CaseInvert {univs;args=_},_,_) -> + let s = LSet.fold LSet.add (Instance.levels univs) s in + Constr.fold aux s c | _ -> Constr.fold aux s c in aux LSet.empty c diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 948195797e..1432fb9310 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -95,7 +95,7 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = (* Pp.(msg_debug (str "conv_atom(" ++ pr_atom a1 ++ str ", " ++ pr_atom a2 ++ str ")")) ; *) match a1, a2 with | Aind ((mi,_i) as ind1) , Aind ind2 -> - if eq_ind ind1 ind2 && compare_stack stk1 stk2 then + if Ind.CanOrd.equal ind1 ind2 && compare_stack stk1 stk2 then let ulen = Univ.AUContext.size (Environ.mind_context env mi) in if ulen = 0 then conv_stack env k stk1 stk2 cu @@ -141,7 +141,7 @@ and conv_stack env k stk1 stk2 cu = conv_stack env k stk1 stk2 !rcu else raise NotConvertible | Zproj p1 :: stk1, Zproj p2 :: stk2 -> - if Projection.Repr.equal p1 p2 then conv_stack env k stk1 stk2 cu + if Projection.Repr.CanOrd.equal p1 p2 then conv_stack env k stk1 stk2 cu else raise NotConvertible | [], _ | Zapp _ :: _, _ | Zfix _ :: _, _ | Zswitch _ :: _, _ | Zproj _ :: _, _ -> raise NotConvertible diff --git a/kernel/vmemitcodes.ml b/kernel/vmemitcodes.ml index ec8601edc9..babc57794b 100644 --- a/kernel/vmemitcodes.ml +++ b/kernel/vmemitcodes.ml @@ -36,9 +36,9 @@ let eq_reloc_info r1 r2 = match r1, r2 with | Reloc_annot _, _ -> false | Reloc_const c1, Reloc_const c2 -> eq_structured_constant c1 c2 | Reloc_const _, _ -> false -| Reloc_getglobal c1, Reloc_getglobal c2 -> Constant.equal c1 c2 +| Reloc_getglobal c1, Reloc_getglobal c2 -> Constant.CanOrd.equal c1 c2 | Reloc_getglobal _, _ -> false -| Reloc_proj_name p1, Reloc_proj_name p2 -> Projection.Repr.equal p1 p2 +| Reloc_proj_name p1, Reloc_proj_name p2 -> Projection.Repr.CanOrd.equal p1 p2 | Reloc_proj_name _, _ -> false | Reloc_caml_prim p1, Reloc_caml_prim p2 -> CPrimitives.equal p1 p2 | Reloc_caml_prim _, _ -> false @@ -48,8 +48,8 @@ let hash_reloc_info r = match r with | Reloc_annot sw -> combinesmall 1 (hash_annot_switch sw) | Reloc_const c -> combinesmall 2 (hash_structured_constant c) - | Reloc_getglobal c -> combinesmall 3 (Constant.hash c) - | Reloc_proj_name p -> combinesmall 4 (Projection.Repr.hash p) + | Reloc_getglobal c -> combinesmall 3 (Constant.CanOrd.hash c) + | Reloc_proj_name p -> combinesmall 4 (Projection.Repr.CanOrd.hash p) | Reloc_caml_prim p -> combinesmall 5 (CPrimitives.hash p) module RelocTable = Hashtbl.Make(struct diff --git a/kernel/vmsymtable.ml b/kernel/vmsymtable.ml index 9d80dc578b..ae0fa38571 100644 --- a/kernel/vmsymtable.ml +++ b/kernel/vmsymtable.ml @@ -85,7 +85,7 @@ module AnnotTable = Hashtbl.Make (struct let hash = hash_annot_switch end) -module ProjNameTable = Hashtbl.Make (Projection.Repr) +module ProjNameTable = Hashtbl.Make (Projection.Repr.CanOrd) let str_cst_tbl : int SConstTable.t = SConstTable.create 31 diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 2068133b10..7b4101b9d0 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -96,7 +96,7 @@ let hash_structured_values (v : structured_values) = let eq_structured_constant c1 c2 = match c1, c2 with | Const_sort s1, Const_sort s2 -> Sorts.equal s1 s2 | Const_sort _, _ -> false -| Const_ind i1, Const_ind i2 -> eq_ind i1 i2 +| Const_ind i1, Const_ind i2 -> Ind.CanOrd.equal i1 i2 | Const_ind _, _ -> false | Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2 | Const_b0 _, _ -> false @@ -113,7 +113,7 @@ let hash_structured_constant c = let open Hashset.Combine in match c with | Const_sort s -> combinesmall 1 (Sorts.hash s) - | Const_ind i -> combinesmall 2 (ind_hash i) + | Const_ind i -> combinesmall 2 (Ind.CanOrd.hash i) | Const_b0 t -> combinesmall 3 (Int.hash t) | Const_univ_level l -> combinesmall 4 (Univ.Level.hash l) | Const_val v -> combinesmall 5 (hash_structured_values v) @@ -250,7 +250,7 @@ type id_key = | EvarKey of Evar.t let eq_id_key (k1 : id_key) (k2 : id_key) = match k1, k2 with -| ConstKey c1, ConstKey c2 -> Constant.equal c1 c2 +| ConstKey c1, ConstKey c2 -> Constant.CanOrd.equal c1 c2 | VarKey id1, VarKey id2 -> Id.equal id1 id2 | RelKey n1, RelKey n2 -> Int.equal n1 n2 | EvarKey evk1, EvarKey evk2 -> Evar.equal evk1 evk2 @@ -469,7 +469,7 @@ struct let equal = eq_id_key open Hashset.Combine let hash : t -> tag = function - | ConstKey c -> combinesmall 1 (Constant.hash c) + | ConstKey c -> combinesmall 1 (Constant.CanOrd.hash c) | VarKey id -> combinesmall 2 (Id.hash id) | RelKey i -> combinesmall 3 (Int.hash i) | EvarKey evk -> combinesmall 4 (Evar.hash evk) diff --git a/lib/control.ml b/lib/control.ml index bb42b5727e..95ea3935a7 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -18,10 +18,12 @@ let enable_thread_delay = ref false let check_for_interrupt () = if !interrupt then begin interrupt := false; raise Sys.Break end; - incr steps; - if !enable_thread_delay && !steps = 1000 then begin - Thread.delay 0.001; - steps := 0; + if !enable_thread_delay then begin + incr steps; + if !steps = 1000 then begin + Thread.delay 0.001; + steps := 0; + end end (** This function does not work on windows, sigh... *) diff --git a/lib/genarg.mli b/lib/genarg.mli index 88e9ff13e8..aac43db672 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -11,7 +11,7 @@ (** Generic arguments used by the extension mechanisms of several Coq ASTs. *) (** The route of a generic argument, from parsing to evaluation. -In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc. +In the following diagram, "object" can be ltac_expr, constr, tactic_value, etc. {% \begin{verbatim} %} parsing in_raw out_raw diff --git a/library/coqlib.ml b/library/coqlib.ml index 04a6e159eb..82d1ecacb5 100644 --- a/library/coqlib.ml +++ b/library/coqlib.ml @@ -45,7 +45,7 @@ let has_ref s = CString.Map.mem s !table let check_ind_ref s ind = match CString.Map.find s !table with - | GlobRef.IndRef r -> eq_ind r ind + | GlobRef.IndRef r -> Ind.CanOrd.equal r ind | _ -> false | exception Not_found -> false @@ -84,7 +84,7 @@ let gen_reference_in_modules locstr dirs s = let dirs = List.map make_dir dirs in let qualid = qualid_of_string s in let all = Nametab.locate_all qualid in - let all = List.sort_uniquize GlobRef.Ordered_env.compare all in + let all = List.sort_uniquize GlobRef.UserOrd.compare all in let these = List.filter (has_suffix_in_dirs dirs) all in match these with | [x] -> x diff --git a/library/global.mli b/library/global.mli index 2767594171..5faf0e8bbd 100644 --- a/library/global.mli +++ b/library/global.mli @@ -134,7 +134,7 @@ val body_of_constant_body : Opaqueproof.indirect_accessor -> val start_library : DirPath.t -> ModPath.t val export : ?except:Future.UUIDSet.t -> output_native_objects:bool -> DirPath.t -> - ModPath.t * Safe_typing.compiled_library * Safe_typing.native_library + ModPath.t * Safe_typing.compiled_library * Nativelib.native_library val import : Safe_typing.compiled_library -> Univ.ContextSet.t -> Safe_typing.vodigest -> ModPath.t diff --git a/library/globnames.ml b/library/globnames.ml index bc24fbf096..654349dea0 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -98,14 +98,14 @@ module ExtRefOrdered = struct let equal x y = x == y || match x, y with - | TrueGlobal rx, TrueGlobal ry -> GlobRef.Ordered_env.equal rx ry + | TrueGlobal rx, TrueGlobal ry -> GlobRef.UserOrd.equal rx ry | SynDef knx, SynDef kny -> KerName.equal knx kny | (TrueGlobal _ | SynDef _), _ -> false let compare x y = if x == y then 0 else match x, y with - | TrueGlobal rx, TrueGlobal ry -> GlobRef.Ordered_env.compare rx ry + | TrueGlobal rx, TrueGlobal ry -> GlobRef.UserOrd.compare rx ry | SynDef knx, SynDef kny -> KerName.compare knx kny | TrueGlobal _, SynDef _ -> -1 | SynDef _, TrueGlobal _ -> 1 @@ -113,7 +113,7 @@ module ExtRefOrdered = struct open Hashset.Combine let hash = function - | TrueGlobal gr -> combinesmall 1 (GlobRef.Ordered_env.hash gr) + | TrueGlobal gr -> combinesmall 1 (GlobRef.UserOrd.hash gr) | SynDef kn -> combinesmall 2 (KerName.hash kn) end diff --git a/library/lib.ml b/library/lib.ml index 830777003b..fa0a95d366 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -525,8 +525,8 @@ let init () = let mp_of_global = let open GlobRef in function | VarRef id -> !lib_state.path_prefix.Nametab.obj_mp | ConstRef cst -> Names.Constant.modpath cst - | IndRef ind -> Names.ind_modpath ind - | ConstructRef constr -> Names.constr_modpath constr + | IndRef ind -> Names.Ind.modpath ind + | ConstructRef constr -> Names.Construct.modpath constr let rec dp_of_mp = function |Names.MPfile dp -> dp diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index f485970eec..d8d2f2a2ef 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -823,7 +823,7 @@ let token_text : type c. c Tok.p -> string = function | PKEYWORD t -> "'" ^ t ^ "'" | PIDENT None -> "identifier" | PIDENT (Some t) -> "'" ^ t ^ "'" - | PNUMBER None -> "numeral" + | PNUMBER None -> "number" | PNUMBER (Some n) -> "'" ^ NumTok.Unsigned.sprint n ^ "'" | PSTRING None -> "string" | PSTRING (Some s) -> "STRING \"" ^ s ^ "\"" @@ -916,7 +916,7 @@ let terminal s = if is_ident_not_keyword s then PIDENT (Some s) else PKEYWORD s -(* Precondition: the input is a numeral (c.f. [NumTok.t]) *) -let terminal_numeral s = match NumTok.Unsigned.parse_string s with +(* Precondition: the input is a number (c.f. [NumTok.t]) *) +let terminal_number s = match NumTok.Unsigned.parse_string s with | Some n -> PNUMBER (Some n) - | None -> failwith "numeral token expected." + | None -> failwith "number token expected." diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index ac2c5bcfe2..af4b7ba334 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -49,8 +49,8 @@ val check_keyword : string -> unit (** When string is not an ident, returns a keyword. *) val terminal : string -> string Tok.p -(** Precondition: the input is a numeral (c.f. [NumTok.t]) *) -val terminal_numeral : string -> NumTok.Unsigned.t Tok.p +(** Precondition: the input is a number (c.f. [NumTok.t]) *) +val terminal_number : string -> NumTok.Unsigned.t Tok.p (** The lexer of Coq: *) diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 644493a010..67a061175a 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -80,11 +80,11 @@ let test_array_closing = } GRAMMAR EXTEND Gram - GLOBAL: binder_constr lconstr constr operconstr + GLOBAL: binder_constr lconstr constr term universe_level universe_name sort sort_family - global constr_pattern lconstr_pattern Constr.ident + global constr_pattern cpattern Constr.ident closed_binder open_binders binder binders binders_fixannot - record_declaration typeclass_constraint pattern appl_arg type_cstr; + record_declaration typeclass_constraint pattern arg type_cstr; Constr.ident: [ [ id = Prim.ident -> { id } ] ] ; @@ -97,7 +97,7 @@ GRAMMAR EXTEND Gram constr_pattern: [ [ c = constr -> { c } ] ] ; - lconstr_pattern: + cpattern: [ [ c = lconstr -> { c } ] ] ; sort: @@ -131,65 +131,65 @@ GRAMMAR EXTEND Gram | u = universe_expr -> { [u] } ] ] ; lconstr: - [ [ c = operconstr LEVEL "200" -> { c } ] ] + [ [ c = term LEVEL "200" -> { c } ] ] ; constr: - [ [ c = operconstr LEVEL "8" -> { c } - | "@"; f=global; i = univ_instance -> { CAst.make ~loc @@ CAppExpl((None,f,i),[]) } ] ] + [ [ c = term LEVEL "8" -> { c } + | "@"; f=global; i = univ_annot -> { CAst.make ~loc @@ CAppExpl((None,f,i),[]) } ] ] ; - operconstr: + term: [ "200" RIGHTA [ c = binder_constr -> { c } ] | "100" RIGHTA - [ c1 = operconstr; "<:"; c2 = operconstr LEVEL "200" -> + [ c1 = term; "<:"; c2 = term LEVEL "200" -> { CAst.make ~loc @@ CCast(c1, CastVM c2) } - | c1 = operconstr; "<<:"; c2 = operconstr LEVEL "200" -> + | c1 = term; "<<:"; c2 = term LEVEL "200" -> { CAst.make ~loc @@ CCast(c1, CastNative c2) } - | c1 = operconstr; ":"; c2 = operconstr LEVEL "200" -> + | c1 = term; ":"; c2 = term LEVEL "200" -> { CAst.make ~loc @@ CCast(c1, CastConv c2) } - | c1 = operconstr; ":>" -> + | c1 = term; ":>" -> { CAst.make ~loc @@ CCast(c1, CastCoerce) } ] | "99" RIGHTA [ ] | "90" RIGHTA [ ] | "10" LEFTA - [ f = operconstr; args = LIST1 appl_arg -> { CAst.make ~loc @@ CApp((None,f),args) } - | "@"; f = global; i = univ_instance; args = LIST0 NEXT -> { CAst.make ~loc @@ CAppExpl((None,f,i),args) } + [ f = term; args = LIST1 arg -> { CAst.make ~loc @@ CApp((None,f),args) } + | "@"; f = global; i = univ_annot; args = LIST0 NEXT -> { CAst.make ~loc @@ CAppExpl((None,f,i),args) } | "@"; lid = pattern_ident; args = LIST1 identref -> { let { CAst.loc = locid; v = id } = lid in let args = List.map (fun x -> CAst.make @@ CRef (qualid_of_ident ?loc:x.CAst.loc x.CAst.v, None), None) args in CAst.make ~loc @@ CApp((None, CAst.make ?loc:locid @@ CPatVar id),args) } ] | "9" - [ ".."; c = operconstr LEVEL "0"; ".." -> + [ ".."; c = term LEVEL "0"; ".." -> { CAst.make ~loc @@ CAppExpl ((None, (qualid_of_ident ~loc ldots_var), None),[c]) } ] | "8" [ ] | "1" LEFTA - [ c = operconstr; ".("; f = global; args = LIST0 appl_arg; ")" -> + [ c = term; ".("; f = global; args = LIST0 arg; ")" -> { CAst.make ~loc @@ CApp((Some (List.length args+1), CAst.make @@ CRef (f,None)),args@[c,None]) } - | c = operconstr; ".("; "@"; f = global; - args = LIST0 (operconstr LEVEL "9"); ")" -> + | c = term; ".("; "@"; f = global; + args = LIST0 (term LEVEL "9"); ")" -> { CAst.make ~loc @@ CAppExpl((Some (List.length args+1),f,None),args@[c]) } - | c = operconstr; "%"; key = IDENT -> { CAst.make ~loc @@ CDelimiters (key,c) } ] + | c = term; "%"; key = IDENT -> { CAst.make ~loc @@ CDelimiters (key,c) } ] | "0" [ c = atomic_constr -> { c } - | c = match_constr -> { c } - | "("; c = operconstr LEVEL "200"; ")" -> - { (* Preserve parentheses around numerals so that constrintern does not - collapse -(3) into the numeral -3. *) + | c = term_match -> { c } + | "("; c = term LEVEL "200"; ")" -> + { (* Preserve parentheses around numbers so that constrintern does not + collapse -(3) into the number -3. *) (match c.CAst.v with - | CPrim (Numeral (NumTok.SPlus,n)) -> + | CPrim (Number (NumTok.SPlus,n)) -> CAst.make ~loc @@ CNotation(None,(InConstrEntry,"( _ )"),([c],[],[],[])) | _ -> c) } | "{|"; c = record_declaration; bar_cbrace -> { c } | "{"; c = binder_constr ; "}" -> { CAst.make ~loc @@ CNotation(None,(InConstrEntry,"{ _ }"),([c],[],[],[])) } - | "`{"; c = operconstr LEVEL "200"; "}" -> + | "`{"; c = term LEVEL "200"; "}" -> { CAst.make ~loc @@ CGeneralization (MaxImplicit, None, c) } - | test_array_opening; "["; "|"; ls = array_elems; "|"; def = lconstr; ty = type_cstr; test_array_closing; "|"; "]"; u = univ_instance -> + | test_array_opening; "["; "|"; ls = array_elems; "|"; def = lconstr; ty = type_cstr; test_array_closing; "|"; "]"; u = univ_annot -> { let t = Array.make (List.length ls) def in List.iteri (fun i e -> t.(i) <- e) ls; CAst.make ~loc @@ CArray(u, t, def, ty) } - | "`("; c = operconstr LEVEL "200"; ")" -> + | "`("; c = term LEVEL "200"; ")" -> { CAst.make ~loc @@ CGeneralization (Explicit, None, c) } ] ] ; array_elems: @@ -208,57 +208,57 @@ GRAMMAR EXTEND Gram { (id, mkLambdaCN ~loc bl c) } ] ] ; binder_constr: - [ [ "forall"; bl = open_binders; ","; c = operconstr LEVEL "200" -> + [ [ "forall"; bl = open_binders; ","; c = term LEVEL "200" -> { mkProdCN ~loc bl c } - | "fun"; bl = open_binders; "=>"; c = operconstr LEVEL "200" -> + | "fun"; bl = open_binders; "=>"; c = term LEVEL "200" -> { mkLambdaCN ~loc bl c } | "let"; id=name; bl = binders; ty = let_type_cstr; ":="; - c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> + c1 = term LEVEL "200"; "in"; c2 = term LEVEL "200" -> { let ty,c1 = match ty, c1 with | (_,None), { CAst.v = CCast(c, CastConv t) } -> (Loc.tag ?loc:(constr_loc t) @@ Some t), c (* Tolerance, see G_vernac.def_body *) | _, _ -> ty, c1 in CAst.make ~loc @@ CLetIn(id,mkLambdaCN ?loc:(constr_loc c1) bl c1, Option.map (mkProdCN ?loc:(fst ty) bl) (snd ty), c2) } - | "let"; "fix"; fx = fix_decl; "in"; c = operconstr LEVEL "200" -> + | "let"; "fix"; fx = fix_decl; "in"; c = term LEVEL "200" -> { let {CAst.loc=locf;CAst.v=({CAst.loc=li;CAst.v=id} as lid,_,_,_,_ as dcl)} = fx in let fix = CAst.make ?loc:locf @@ CFix (lid,[dcl]) in CAst.make ~loc @@ CLetIn( CAst.make ?loc:li @@ Name id,fix,None,c) } - | "let"; "cofix"; fx = cofix_decl; "in"; c = operconstr LEVEL "200" -> + | "let"; "cofix"; fx = cofix_body; "in"; c = term LEVEL "200" -> { let {CAst.loc=locf;CAst.v=({CAst.loc=li;CAst.v=id} as lid,_,_,_ as dcl)} = fx in let cofix = CAst.make ?loc:locf @@ CCoFix (lid,[dcl]) in CAst.make ~loc @@ CLetIn( CAst.make ?loc:li @@ Name id,cofix,None,c) } | "let"; lb = ["("; l=LIST0 name SEP ","; ")" -> { l } | "()" -> { [] } ]; - po = return_type; ":="; c1 = operconstr LEVEL "200"; "in"; - c2 = operconstr LEVEL "200" -> + po = as_return_type; ":="; c1 = term LEVEL "200"; "in"; + c2 = term LEVEL "200" -> { CAst.make ~loc @@ CLetTuple (lb,po,c1,c2) } - | "let"; "'"; p = pattern LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; - "in"; c2 = operconstr LEVEL "200" -> + | "let"; "'"; p = pattern LEVEL "200"; ":="; c1 = term LEVEL "200"; + "in"; c2 = term LEVEL "200" -> { CAst.make ~loc @@ CCases (LetPatternStyle, None, [c1, None, None], [CAst.make ~loc ([[p]], c2)]) } - | "let"; "'"; p = pattern LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; - rt = case_type; "in"; c2 = operconstr LEVEL "200" -> + | "let"; "'"; p = pattern LEVEL "200"; ":="; c1 = term LEVEL "200"; + rt = case_type; "in"; c2 = term LEVEL "200" -> { CAst.make ~loc @@ CCases (LetPatternStyle, Some rt, [c1, aliasvar p, None], [CAst.make ~loc ([[p]], c2)]) } | "let"; "'"; p = pattern LEVEL "200"; "in"; t = pattern LEVEL "200"; - ":="; c1 = operconstr LEVEL "200"; rt = case_type; - "in"; c2 = operconstr LEVEL "200" -> + ":="; c1 = term LEVEL "200"; rt = case_type; + "in"; c2 = term LEVEL "200" -> { CAst.make ~loc @@ CCases (LetPatternStyle, Some rt, [c1, aliasvar p, Some t], [CAst.make ~loc ([[p]], c2)]) } - | "if"; c = operconstr LEVEL "200"; po = return_type; - "then"; b1 = operconstr LEVEL "200"; - "else"; b2 = operconstr LEVEL "200" -> + | "if"; c = term LEVEL "200"; po = as_return_type; + "then"; b1 = term LEVEL "200"; + "else"; b2 = term LEVEL "200" -> { CAst.make ~loc @@ CIf (c, po, b1, b2) } | "fix"; c = fix_decls -> { let (id,dcls) = c in CAst.make ~loc @@ CFix (id,dcls) } | "cofix"; c = cofix_decls -> { let (id,dcls) = c in CAst.make ~loc @@ CCoFix (id,dcls) } ] ] ; - appl_arg: + arg: [ [ test_lpar_id_coloneq; "("; id = identref; ":="; c = lconstr; ")" -> { (c,Some (CAst.make ?loc:id.CAst.loc @@ ExplByName id.CAst.v)) } - | c=operconstr LEVEL "9" -> { (c,None) } ] ] + | c=term LEVEL "9" -> { (c,None) } ] ] ; atomic_constr: - [ [ g = global; i = univ_instance -> { CAst.make ~loc @@ CRef (g,i) } + [ [ g = global; i = univ_annot -> { CAst.make ~loc @@ CRef (g,i) } | s = sort -> { CAst.make ~loc @@ CSort s } - | n = NUMBER-> { CAst.make ~loc @@ CPrim (Numeral (NumTok.SPlus,n)) } + | n = NUMBER-> { CAst.make ~loc @@ CPrim (Number (NumTok.SPlus,n)) } | s = string -> { CAst.make ~loc @@ CPrim (String s) } | "_" -> { CAst.make ~loc @@ CHole (None, IntroAnonymous, None) } | "?"; "["; id = identref; "]" -> { CAst.make ~loc @@ CHole (None, IntroIdentifier id.CAst.v, None) } @@ -272,7 +272,7 @@ GRAMMAR EXTEND Gram [ [ "@{"; l = LIST1 inst SEP ";"; "}" -> { l } | -> { [] } ] ] ; - univ_instance: + univ_annot: [ [ "@{"; l = LIST0 universe_level; "}" -> { Some l } | -> { None } ] ] ; @@ -290,34 +290,34 @@ GRAMMAR EXTEND Gram { (id,List.map (fun x -> x.CAst.v) (dcl::dcls)) } ] ] ; cofix_decls: - [ [ dcl = cofix_decl -> { let (id,_,_,_) = dcl.CAst.v in (id,[dcl.CAst.v]) } - | dcl = cofix_decl; "with"; dcls = LIST1 cofix_decl SEP "with"; "for"; id = identref -> + [ [ dcl = cofix_body -> { let (id,_,_,_) = dcl.CAst.v in (id,[dcl.CAst.v]) } + | dcl = cofix_body; "with"; dcls = LIST1 cofix_body SEP "with"; "for"; id = identref -> { (id,List.map (fun x -> x.CAst.v) (dcl::dcls)) } ] ] ; fix_decl: [ [ id = identref; bl = binders_fixannot; ty = type_cstr; ":="; - c = operconstr LEVEL "200" -> + c = term LEVEL "200" -> { CAst.make ~loc (id,snd bl,fst bl,ty,c) } ] ] ; - cofix_decl: + cofix_body: [ [ id = identref; bl = binders; ty = type_cstr; ":="; - c = operconstr LEVEL "200" -> + c = term LEVEL "200" -> { CAst.make ~loc (id,bl,ty,c) } ] ] ; - match_constr: + term_match: [ [ "match"; ci = LIST1 case_item SEP ","; ty = OPT case_type; "with"; br = branches; "end" -> { CAst.make ~loc @@ CCases(RegularStyle,ty,ci,br) } ] ] ; case_item: - [ [ c = operconstr LEVEL "100"; + [ [ c = term LEVEL "100"; ona = OPT ["as"; id = name -> { id } ]; ty = OPT ["in"; t = pattern LEVEL "200" -> { t } ] -> { (c,ona,ty) } ] ] ; case_type: - [ [ "return"; ty = operconstr LEVEL "100" -> { ty } ] ] + [ [ "return"; ty = term LEVEL "100" -> { ty } ] ] ; - return_type: + as_return_type: [ [ a = OPT [ na = OPT["as"; na = name -> { na } ]; ty = case_type -> { (na,ty) } ] -> { match a with @@ -345,7 +345,7 @@ GRAMMAR EXTEND Gram pattern: [ "200" RIGHTA [ ] | "100" RIGHTA - [ p = pattern; ":"; ty = operconstr LEVEL "200" -> + [ p = pattern; ":"; ty = term LEVEL "200" -> { CAst.make ~loc @@ CPatCast (p, ty) } ] | "99" RIGHTA [ ] | "90" RIGHTA [ ] @@ -362,15 +362,15 @@ GRAMMAR EXTEND Gram | "{|"; pat = record_patterns; bar_cbrace -> { CAst.make ~loc @@ CPatRecord pat } | "_" -> { CAst.make ~loc @@ CPatAtom None } | "("; p = pattern LEVEL "200"; ")" -> - { (* Preserve parentheses around numerals so that constrintern does not - collapse -(3) into the numeral -3. *) + { (* Preserve parentheses around numbers so that constrintern does not + collapse -(3) into the number -3. *) match p.CAst.v with - | CPatPrim (Numeral (NumTok.SPlus,n)) -> + | CPatPrim (Number (NumTok.SPlus,n)) -> CAst.make ~loc @@ CPatNotation(None,(InConstrEntry,"( _ )"),([p],[]),[]) | _ -> p } | "("; p = pattern LEVEL "200"; "|" ; pl = LIST1 pattern LEVEL "200" SEP "|"; ")" -> { CAst.make ~loc @@ CPatOr (p::pl) } - | n = NUMBER-> { CAst.make ~loc @@ CPatPrim (Numeral (NumTok.SPlus,n)) } + | n = NUMBER-> { CAst.make ~loc @@ CPatPrim (Number (NumTok.SPlus,n)) } | s = string -> { CAst.make ~loc @@ CPatPrim (String s) } ] ] ; fixannot: @@ -447,12 +447,12 @@ GRAMMAR EXTEND Gram [CLocalPattern (CAst.make ~loc (p, ty))] } ] ] ; typeclass_constraint: - [ [ "!" ; c = operconstr LEVEL "200" -> { (CAst.make ~loc Anonymous), true, c } - | "{"; id = name; "}"; ":" ; expl = [ "!" -> { true } | -> { false } ] ; c = operconstr LEVEL "200" -> + [ [ "!" ; c = term LEVEL "200" -> { (CAst.make ~loc Anonymous), true, c } + | "{"; id = name; "}"; ":" ; expl = [ "!" -> { true } | -> { false } ] ; c = term LEVEL "200" -> { id, expl, c } - | test_name_colon; iid = name; ":" ; expl = [ "!" -> { true } | -> { false } ] ; c = operconstr LEVEL "200" -> + | test_name_colon; iid = name; ":" ; expl = [ "!" -> { true } | -> { false } ] ; c = term LEVEL "200" -> { iid, expl, c } - | c = operconstr LEVEL "200" -> + | c = term LEVEL "200" -> { (CAst.make ~loc Anonymous), false, c } ] ] ; type_cstr: diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 996aa0925c..22b5e70311 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -308,7 +308,8 @@ module Constr = (* Entries that can be referred via the string -> Entry.t table *) let constr = Entry.create "constr" - let operconstr = Entry.create "operconstr" + let term = Entry.create "term" + let operconstr = term let constr_eoi = eoi_entry constr let lconstr = Entry.create "lconstr" let binder_constr = Entry.create "binder_constr" @@ -320,7 +321,8 @@ module Constr = let sort_family = Entry.create "sort_family" let pattern = Entry.create "pattern" let constr_pattern = Entry.create "constr_pattern" - let lconstr_pattern = Entry.create "lconstr_pattern" + let cpattern = Entry.create "cpattern" + let lconstr_pattern = cpattern let closed_binder = Entry.create "closed_binder" let binder = Entry.create "binder" let binders = Entry.create "binders" @@ -328,7 +330,8 @@ module Constr = let binders_fixannot = Entry.create "binders_fixannot" let typeclass_constraint = Entry.create "typeclass_constraint" let record_declaration = Entry.create "record_declaration" - let appl_arg = Entry.create "appl_arg" + let arg = Entry.create "arg" + let appl_arg = arg let type_cstr = Entry.create "type_cstr" end diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 8e60bbf504..ce4c91d51f 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -185,7 +185,9 @@ module Constr : val constr_eoi : constr_expr Entry.t val lconstr : constr_expr Entry.t val binder_constr : constr_expr Entry.t + val term : constr_expr Entry.t val operconstr : constr_expr Entry.t + [@@deprecated "Deprecated in 8.13; use 'term' instead"] val ident : Id.t Entry.t val global : qualid Entry.t val universe_name : Glob_term.glob_sort_name Entry.t @@ -194,7 +196,9 @@ module Constr : val sort_family : Sorts.family Entry.t val pattern : cases_pattern_expr Entry.t val constr_pattern : constr_expr Entry.t + val cpattern : constr_expr Entry.t val lconstr_pattern : constr_expr Entry.t + [@@deprecated "Deprecated in 8.13; use 'cpattern' instead"] val closed_binder : local_binder_expr list Entry.t val binder : local_binder_expr list Entry.t (* closed_binder or variable *) val binders : local_binder_expr list Entry.t (* list of binder *) @@ -202,7 +206,9 @@ module Constr : val binders_fixannot : (local_binder_expr list * recursion_order_expr option) Entry.t val typeclass_constraint : (lname * bool * constr_expr) Entry.t val record_declaration : constr_expr Entry.t + val arg : (constr_expr * explicitation CAst.t option) Entry.t val appl_arg : (constr_expr * explicitation CAst.t option) Entry.t + [@@deprecated "Deprecated in 8.13; use 'arg' instead"] val type_cstr : constr_expr Entry.t end diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 23f8fe04a3..ac2058ba1b 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -115,7 +115,7 @@ module Bool = struct | Case (info, r, _iv, arg, pats) -> let is_bool = let i = info.ci_ind in - Names.eq_ind i (Lazy.force ind) + Names.Ind.CanOrd.equal i (Lazy.force ind) in if is_bool then Ifb ((aux arg), (aux pats.(0)), (aux pats.(1))) diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 6f5c910297..129b220680 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -145,7 +145,7 @@ let rec term_equal t1 t2 = | Appli (t1, u1), Appli (t2, u2) -> term_equal t1 t2 && term_equal u1 u2 | Constructor {ci_constr=(c1,u1); ci_arity=i1; ci_nhyps=j1}, Constructor {ci_constr=(c2,u2); ci_arity=i2; ci_nhyps=j2} -> - Int.equal i1 i2 && Int.equal j1 j2 && eq_constructor c1 c2 (* FIXME check eq? *) + Int.equal i1 i2 && Int.equal j1 j2 && Construct.CanOrd.equal c1 c2 (* FIXME check eq? *) | _ -> false open Hashset.Combine @@ -155,7 +155,7 @@ let rec hash_term = function | Product (s1, s2) -> combine3 2 (Sorts.hash s1) (Sorts.hash s2) | Eps i -> combine 3 (Id.hash i) | Appli (t1, t2) -> combine3 4 (hash_term t1) (hash_term t2) - | Constructor {ci_constr=(c,u); ci_arity=i; ci_nhyps=j} -> combine4 5 (constructor_hash c) i j + | Constructor {ci_constr=(c,u); ci_arity=i; ci_nhyps=j} -> combine4 5 (Construct.CanOrd.hash c) i j type ccpattern = PApp of term * ccpattern list (* arguments are reversed *) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 2dca1d5e49..6869f9c47e 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -741,7 +741,7 @@ and extract_cst_app env sg mle mlt kn args = (* Can we instantiate types variables for this constant ? *) (* In Ocaml, inside the definition of this constant, the answer is no. *) let instantiated = - if lang () == Ocaml && List.mem_f Constant.equal kn !current_fixpoints + if lang () == Ocaml && List.mem_f Constant.CanOrd.equal kn !current_fixpoints then var2var' (snd schema) else instantiation schema in diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index b1ce10985a..21ec80abbc 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -685,7 +685,7 @@ let is_regular_match br = | _ -> raise Impossible in let is_ref i tr = match get_r tr with - | GlobRef.ConstructRef (ind', j) -> eq_ind ind ind' && Int.equal j (i + 1) + | GlobRef.ConstructRef (ind', j) -> Ind.CanOrd.equal ind ind' && Int.equal j (i + 1) | _ -> false in Array.for_all_i is_ref 0 br diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index f8449bcda1..e56d66ca2d 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -32,7 +32,7 @@ module Refset' = GlobRef.Set_env let occur_kn_in_ref kn = let open GlobRef in function | IndRef (kn',_) - | ConstructRef ((kn',_),_) -> MutInd.equal kn kn' + | ConstructRef ((kn',_),_) -> MutInd.CanOrd.equal kn kn' | ConstRef _ | VarRef _ -> false let repr_of_r = let open GlobRef in function diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index 6ddc6ba21e..d6790d008a 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -108,10 +108,6 @@ let pr_firstorder_using_raw _ _ _ = Pptactic.pr_auto_using pr_qualid let pr_firstorder_using_glob _ _ _ = Pptactic.pr_auto_using (Pputils.pr_or_var (fun x -> pr_global (snd x))) let pr_firstorder_using_typed _ _ _ = Pptactic.pr_auto_using pr_global -let warn_deprecated_syntax = - CWarnings.create ~name:"firstorder-deprecated-syntax" ~category:"deprecated" - (fun () -> Pp.strbrk "Deprecated syntax; use \",\" as separator") - } ARGUMENT EXTEND firstorder_using @@ -119,12 +115,7 @@ ARGUMENT EXTEND firstorder_using PRINTED BY { pr_firstorder_using_typed } RAW_PRINTED BY { pr_firstorder_using_raw } GLOB_PRINTED BY { pr_firstorder_using_glob } -| [ "using" reference(a) ] -> { [a] } -| [ "using" reference(a) "," ne_reference_list_sep(l,",") ] -> { a::l } -| [ "using" reference(a) reference(b) reference_list(l) ] -> { - warn_deprecated_syntax (); - a::b::l - } +| [ "using" ne_reference_list_sep(l,",") ] -> { l } | [ ] -> { [] } END diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index f13901c36d..4adad53899 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -38,7 +38,7 @@ let compare_gr id1 id2 = if id1==id2 then 0 else if id1==dummy_id then 1 else if id2==dummy_id then -1 - else GlobRef.Ordered.compare id1 id2 + else GlobRef.CanOrd.compare id1 id2 module OrderedInstance= struct diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index db3631daa4..99c5f85125 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -62,7 +62,7 @@ module Hitem= struct type t = h_item let compare (id1,co1) (id2,co2)= - let c = GlobRef.Ordered.compare id1 id2 in + let c = GlobRef.CanOrd.compare id1 id2 in if c = 0 then let cmp (i1, c1) (i2, c2) = let c = Int.compare i1 i2 in diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index e50c6087bb..73eb943418 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -674,7 +674,7 @@ let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos |Prod _ -> let new_infos = {dyn_infos with info = (f, args)} in build_proof_args env sigma do_finalize new_infos - | Const (c, _) when not (List.mem_f Constant.equal c fnames) -> + | Const (c, _) when not (List.mem_f Constant.CanOrd.equal c fnames) -> let new_infos = {dyn_infos with info = (f, args)} in (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) build_proof_args env sigma do_finalize new_infos diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 1ab747ca09..0ab9ac65d7 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -100,8 +100,8 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match Constr.kind c with - | Ind ((u, _), _) -> MutInd.equal u rel_as_kn - | Construct (((u, _), _), _) -> MutInd.equal u rel_as_kn + | Ind ((u, _), _) -> Environ.QMutInd.equal env u rel_as_kn + | Construct (((u, _), _), _) -> Environ.QMutInd.equal env u rel_as_kn | _ -> false in let get_fun_num c = diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index bbc4df7dde..ca6ae150a7 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -147,19 +147,19 @@ END module Vernac = Pvernac.Vernac_ module Tactic = Pltac -let (wit_function_rec_definition_loc : Vernacexpr.fixpoint_expr Loc.located Genarg.uniform_genarg_type) = - Genarg.create_arg "function_rec_definition_loc" +let (wit_function_fix_definition : Vernacexpr.fixpoint_expr Loc.located Genarg.uniform_genarg_type) = + Genarg.create_arg "function_fix_definition" -let function_rec_definition_loc = - Pcoq.create_generic_entry2 "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) +let function_fix_definition = + Pcoq.create_generic_entry2 "function_fix_definition" (Genarg.rawwit wit_function_fix_definition) } GRAMMAR EXTEND Gram - GLOBAL: function_rec_definition_loc ; + GLOBAL: function_fix_definition ; - function_rec_definition_loc: - [ [ g = Vernac.rec_definition -> { Loc.tag ~loc g } ]] + function_fix_definition: + [ [ g = Vernac.fix_definition -> { Loc.tag ~loc g } ]] ; END @@ -168,7 +168,7 @@ END let () = let raw_printer env sigma _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in - Pptactic.declare_extra_vernac_genarg_pprule wit_function_rec_definition_loc raw_printer + Pptactic.declare_extra_vernac_genarg_pprule wit_function_fix_definition raw_printer let is_proof_termination_interactively_checked recsl = List.exists (function @@ -196,7 +196,7 @@ let is_interactive recsl = } VERNAC COMMAND EXTEND Function STATE CUSTOM -| ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] +| ["Function" ne_function_fix_definition_list_sep(recsl,"with")] => { classify_funind recsl } -> { if is_interactive recsl then diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 012fcee486..314c8abcaf 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -1316,9 +1316,9 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : _ list = let prop_sort = Sorts.InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in + let eq c1 c2 = Environ.QConstant.equal env c1 c2 in List.map - (function - | cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) + (function cst -> List.assoc_f eq (fst cst) this_block_funs_indexes) funs in let ind_list = @@ -2228,7 +2228,8 @@ let build_case_scheme fa = let prop_sort = Sorts.InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in - List.assoc_f Constant.equal funs this_block_funs_indexes + let eq c1 c2 = Environ.QConstant.equal env c1 c2 in + List.assoc_f eq funs this_block_funs_indexes in let ind, sf = let ind = (first_fun_kn, funs_indexes) in diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 6ed61043f9..767a9ec39b 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -332,7 +332,7 @@ let add_pat_variables sigma pat typ env : Environ.env = let constructors = Inductiveops.get_constructors env indf in let constructor : Inductiveops.constructor_summary = List.find - (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) + (fun cs -> Construct.CanOrd.equal c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in let cs_args_types : types list = @@ -402,7 +402,8 @@ let rec pattern_to_term_and_type env typ = let constructors = Inductiveops.get_constructors env indf in let constructor = List.find - (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) + (fun cs -> + Construct.CanOrd.equal (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in let cs_args_types : types list = diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 8e1331ace9..164a446fe3 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -444,7 +444,8 @@ let rec are_unifiable_aux = function match (DAst.get l, DAst.get r) with | PatVar _, _ | _, PatVar _ -> are_unifiable_aux eqs | PatCstr (constructor1, cpl1, _), PatCstr (constructor2, cpl2, _) -> - if not (eq_constructor constructor2 constructor1) then raise NotUnifiable + if not (Construct.CanOrd.equal constructor2 constructor1) then + raise NotUnifiable else let eqs' = try List.combine cpl1 cpl2 @ eqs @@ -464,7 +465,8 @@ let rec eq_cases_pattern_aux = function match (DAst.get l, DAst.get r) with | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs | PatCstr (constructor1, cpl1, _), PatCstr (constructor2, cpl2, _) -> - if not (eq_constructor constructor2 constructor1) then raise NotUnifiable + if not (Construct.CanOrd.equal constructor2 constructor1) then + raise NotUnifiable else let eqs' = try List.combine cpl1 cpl2 @ eqs 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/funind/invfun.ml b/plugins/funind/invfun.ml index 5d631aac84..118a917381 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -27,12 +27,13 @@ open Indfun_common *) let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> + let env = Proofview.Goal.env gl in let sigma = project gl in let typ = pf_get_hyp_typ hid gl in match EConstr.kind sigma typ with | App (i, args) when isInd sigma i -> let ((kn', num) as ind'), u = destInd sigma i in - if MutInd.equal kn kn' then + if Environ.QMutInd.equal env kn kn' then (* We have generated a graph hypothesis so that we must change it if we can *) let info = match find_Function_of_graph ind' with diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index ad4374dba3..ff4a82f864 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -41,7 +41,7 @@ let () = create_generic_quotation "ipattern" Pltac.simple_intropattern wit_simpl let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Stdarg.wit_open_constr let () = let inject (loc, v) = Tacexpr.Tacexp v in - Tacentries.create_ltac_quotation "ltac" inject (Pltac.tactic_expr, Some 5) + Tacentries.create_ltac_quotation "ltac" inject (Pltac.ltac_expr, Some 5) (** Backward-compatible tactic notation entry names *) 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 6cf5d30a95..c2e95c45f9 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -74,22 +74,22 @@ let hint = G_proofs.hint } GRAMMAR EXTEND Gram - GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint + GLOBAL: tactic tacdef_body ltac_expr binder_tactic tactic_value command hint tactic_mode constr_may_eval constr_eval toplevel_selector - operconstr; + term; tactic_then_last: - [ [ "|"; lta = LIST0 (OPT tactic_expr) SEP "|" -> + [ [ "|"; lta = LIST0 (OPT ltac_expr) SEP "|" -> { Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) } | -> { [||] } ] ] ; - tactic_then_gen: - [ [ ta = tactic_expr; "|"; tg = tactic_then_gen -> { let (first,last) = tg in (ta::first, last) } - | ta = tactic_expr; ".."; l = tactic_then_last -> { ([], Some (ta, l)) } + for_each_goal: + [ [ ta = ltac_expr; "|"; tg = for_each_goal -> { let (first,last) = tg in (ta::first, last) } + | ta = ltac_expr; ".."; l = tactic_then_last -> { ([], Some (ta, l)) } | ".."; l = tactic_then_last -> { ([], Some (TacId [], l)) } - | ta = tactic_expr -> { ([ta], None) } - | "|"; tg = tactic_then_gen -> { let (first,last) = tg in (TacId [] :: first, last) } + | ta = ltac_expr -> { ([ta], None) } + | "|"; tg = for_each_goal -> { let (first,last) = tg in (TacId [] :: first, last) } | -> { ([TacId []], None) } ] ] ; @@ -97,13 +97,13 @@ GRAMMAR EXTEND Gram for [TacExtend] *) [ [ "[" ; l = OPT">" -> { if Option.is_empty l then true else false } ] ] ; - tactic_expr: + ltac_expr: [ "5" RIGHTA [ te = binder_tactic -> { te } ] | "4" LEFTA - [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> { TacThen (ta0, ta1) } - | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> { TacThen (ta0,ta1) } - | ta0 = tactic_expr; ";"; l = tactic_then_locality; tg = tactic_then_gen; "]" -> { + [ ta0 = ltac_expr; ";"; ta1 = binder_tactic -> { TacThen (ta0, ta1) } + | ta0 = ltac_expr; ";"; ta1 = ltac_expr -> { TacThen (ta0,ta1) } + | ta0 = ltac_expr; ";"; l = tactic_then_locality; tg = for_each_goal; "]" -> { let (first,tail) = tg in match l , tail with | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) @@ -111,51 +111,51 @@ GRAMMAR EXTEND Gram | false , None -> TacThen (ta0,TacDispatch first) | true , None -> TacThens (ta0,first) } ] | "3" RIGHTA - [ IDENT "try"; ta = tactic_expr -> { TacTry ta } - | IDENT "do"; n = int_or_var; ta = tactic_expr -> { TacDo (n,ta) } - | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> { TacTimeout (n,ta) } - | IDENT "time"; s = OPT string; ta = tactic_expr -> { TacTime (s,ta) } - | IDENT "repeat"; ta = tactic_expr -> { TacRepeat ta } - | IDENT "progress"; ta = tactic_expr -> { TacProgress ta } - | IDENT "once"; ta = tactic_expr -> { TacOnce ta } - | IDENT "exactly_once"; ta = tactic_expr -> { TacExactlyOnce ta } - | IDENT "infoH"; ta = tactic_expr -> { TacShowHyps ta } + [ IDENT "try"; ta = ltac_expr -> { TacTry ta } + | IDENT "do"; n = int_or_var; ta = ltac_expr -> { TacDo (n,ta) } + | IDENT "timeout"; n = int_or_var; ta = ltac_expr -> { TacTimeout (n,ta) } + | IDENT "time"; s = OPT string; ta = ltac_expr -> { TacTime (s,ta) } + | IDENT "repeat"; ta = ltac_expr -> { TacRepeat ta } + | IDENT "progress"; ta = ltac_expr -> { TacProgress ta } + | IDENT "once"; ta = ltac_expr -> { TacOnce ta } + | IDENT "exactly_once"; ta = ltac_expr -> { TacExactlyOnce ta } + | IDENT "infoH"; ta = ltac_expr -> { TacShowHyps ta } (*To do: put Abstract in Refiner*) | IDENT "abstract"; tc = NEXT -> { TacAbstract (tc,None) } | IDENT "abstract"; tc = NEXT; "using"; s = ident -> { TacAbstract (tc,Some s) } - | sel = selector; ta = tactic_expr -> { TacSelect (sel, ta) } ] + | IDENT "only"; sel = selector; ":"; ta = ltac_expr -> { TacSelect (sel, ta) } ] (*End of To do*) | "2" RIGHTA - [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> { TacOr (ta0,ta1) } - | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> { TacOr (ta0,ta1) } - | IDENT "tryif" ; ta = tactic_expr ; - "then" ; tat = tactic_expr ; - "else" ; tae = tactic_expr -> { TacIfThenCatch(ta,tat,tae) } - | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> { TacOrelse (ta0,ta1) } - | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> { TacOrelse (ta0,ta1) } ] + [ ta0 = ltac_expr; "+"; ta1 = binder_tactic -> { TacOr (ta0,ta1) } + | ta0 = ltac_expr; "+"; ta1 = ltac_expr -> { TacOr (ta0,ta1) } + | IDENT "tryif" ; ta = ltac_expr ; + "then" ; tat = ltac_expr ; + "else" ; tae = ltac_expr -> { TacIfThenCatch(ta,tat,tae) } + | ta0 = ltac_expr; "||"; ta1 = binder_tactic -> { TacOrelse (ta0,ta1) } + | ta0 = ltac_expr; "||"; ta1 = ltac_expr -> { TacOrelse (ta0,ta1) } ] | "1" RIGHTA [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> { TacMatchGoal (b,false,mrl) } | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; mrl = match_context_list; "end" -> { TacMatchGoal (b,true,mrl) } - | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> + | b = match_key; c = ltac_expr; "with"; mrl = match_list; "end" -> { TacMatch (b,c,mrl) } - | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + | IDENT "first" ; "["; l = LIST0 ltac_expr SEP "|"; "]" -> { TacFirst l } - | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + | IDENT "solve" ; "["; l = LIST0 ltac_expr SEP "|"; "]" -> { TacSolve l } | IDENT "idtac"; l = LIST0 message_token -> { TacId l } | g=failkw; n = [ n = int_or_var -> { n } | -> { fail_default_value } ]; l = LIST0 message_token -> { TacFail (g,n,l) } | st = simple_tactic -> { st } - | a = tactic_arg -> { TacArg(CAst.make ~loc a) } - | r = reference; la = LIST0 tactic_arg_compat -> + | a = tactic_value -> { TacArg(CAst.make ~loc a) } + | r = reference; la = LIST0 tactic_arg -> { TacArg(CAst.make ~loc @@ TacCall (CAst.make ~loc (r,la))) } ] | "0" - [ "("; a = tactic_expr; ")" -> { a } - | "["; ">"; tg = tactic_then_gen; "]" -> { + [ "("; a = ltac_expr; ")" -> { a } + | "["; ">"; tg = for_each_goal; "]" -> { let (tf,tail) = tg in begin match tail with | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) @@ -166,24 +166,24 @@ GRAMMAR EXTEND Gram failkw: [ [ IDENT "fail" -> { TacLocal } | IDENT "gfail" -> { TacGlobal } ] ] ; - (* binder_tactic: level 5 of tactic_expr *) + (* binder_tactic: level 5 of ltac_expr *) binder_tactic: [ RIGHTA - [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> + [ "fun"; it = LIST1 input_fun ; "=>"; body = ltac_expr LEVEL "5" -> { TacFun (it,body) } | "let"; isrec = [IDENT "rec" -> { true } | -> { false } ]; llc = LIST1 let_clause SEP "with"; "in"; - body = tactic_expr LEVEL "5" -> { TacLetIn (isrec,llc,body) } ] ] + body = ltac_expr LEVEL "5" -> { TacLetIn (isrec,llc,body) } ] ] ; (* Tactic arguments to the right of an application *) - tactic_arg_compat: - [ [ a = tactic_arg -> { a } + tactic_arg: + [ [ a = tactic_value -> { a } | c = Constr.constr -> { (match c with { CAst.v = CRef (r,None) } -> Reference r | c -> ConstrMayEval (ConstrTerm c)) } (* Unambiguous entries: tolerated w/o "ltac:" modifier *) | "()" -> { TacGeneric (None, genarg_of_unit ()) } ] ] ; (* Can be used as argument and at toplevel in tactic expressions. *) - tactic_arg: + tactic_value: [ [ c = constr_eval -> { ConstrMayEval c } | IDENT "fresh"; l = LIST0 fresh_id -> { TacFreshId l } | IDENT "type_term"; c=uconstr -> { TacPretype c } @@ -223,20 +223,20 @@ GRAMMAR EXTEND Gram | l = ident -> { Name.Name l } ] ] ; let_clause: - [ [ idr = identref; ":="; te = tactic_expr -> + [ [ idr = identref; ":="; te = ltac_expr -> { (CAst.map (fun id -> Name id) idr, arg_of_expr te) } - | na = ["_" -> { CAst.make ~loc Anonymous } ]; ":="; te = tactic_expr -> + | na = ["_" -> { CAst.make ~loc Anonymous } ]; ":="; te = ltac_expr -> { (na, arg_of_expr te) } - | idr = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> + | idr = identref; args = LIST1 input_fun; ":="; te = ltac_expr -> { (CAst.map (fun id -> Name id) idr, arg_of_expr (TacFun(args,te))) } ] ] ; match_pattern: [ [ IDENT "context"; oid = OPT Constr.ident; - "["; pc = Constr.lconstr_pattern; "]" -> + "["; pc = Constr.cpattern; "]" -> { Subterm (oid, pc) } - | pc = Constr.lconstr_pattern -> { Term pc } ] ] + | pc = Constr.cpattern -> { Term pc } ] ] ; - match_hyps: + match_hyp: [ [ na = name; ":"; mp = match_pattern -> { Hyp (na, mp) } | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> { Def (na, mpv, mpt) } | na = name; ":="; mpv = match_pattern -> @@ -250,19 +250,19 @@ GRAMMAR EXTEND Gram ] ] ; match_context_rule: - [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "=>"; te = tactic_expr -> { Pat (largs, mp, te) } - | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "]"; "=>"; te = tactic_expr -> { Pat (largs, mp, te) } - | "_"; "=>"; te = tactic_expr -> { All te } ] ] + [ [ largs = LIST0 match_hyp SEP ","; "|-"; mp = match_pattern; + "=>"; te = ltac_expr -> { Pat (largs, mp, te) } + | "["; largs = LIST0 match_hyp SEP ","; "|-"; mp = match_pattern; + "]"; "=>"; te = ltac_expr -> { Pat (largs, mp, te) } + | "_"; "=>"; te = ltac_expr -> { All te } ] ] ; match_context_list: [ [ mrl = LIST1 match_context_rule SEP "|" -> { mrl } | "|"; mrl = LIST1 match_context_rule SEP "|" -> { mrl } ] ] ; match_rule: - [ [ mp = match_pattern; "=>"; te = tactic_expr -> { Pat ([],mp,te) } - | "_"; "=>"; te = tactic_expr -> { All te } ] ] + [ [ mp = match_pattern; "=>"; te = ltac_expr -> { Pat ([],mp,te) } + | "_"; "=>"; te = ltac_expr -> { All te } ] ] ; match_list: [ [ mrl = LIST1 match_rule SEP "|" -> { mrl } @@ -282,13 +282,13 @@ GRAMMAR EXTEND Gram (* Definitions for tactics *) tacdef_body: [ [ name = Constr.global; it=LIST1 input_fun; - redef = ltac_def_kind; body = tactic_expr -> + redef = ltac_def_kind; body = ltac_expr -> { if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body)) else let id = reference_to_id name in Tacexpr.TacticDefinition (id, TacFun (it, body)) } | name = Constr.global; redef = ltac_def_kind; - body = tactic_expr -> + body = ltac_expr -> { if redef then Tacexpr.TacticRedefinition (name, body) else let id = reference_to_id name in @@ -296,7 +296,7 @@ GRAMMAR EXTEND Gram ] ] ; tactic: - [ [ tac = tactic_expr -> { tac } ] ] + [ [ tac = ltac_expr -> { tac } ] ] ; range_selector: @@ -314,15 +314,12 @@ GRAMMAR EXTEND Gram { let open Goal_select in Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l } ] ] ; - selector_body: + selector: [ [ l = range_selector_or_nth -> { l } | test_bracket_ident; "["; id = ident; "]" -> { Goal_select.SelectId id } ] ] ; - selector: - [ [ IDENT "only"; sel = selector_body; ":" -> { sel } ] ] - ; toplevel_selector: - [ [ sel = selector_body; ":" -> { sel } + [ [ sel = selector; ":" -> { sel } | "!"; ":" -> { Goal_select.SelectAlreadyFocused } | IDENT "all"; ":" -> { Goal_select.SelectAll } ] ] ; @@ -332,19 +329,19 @@ 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 ; "=>"; tac = Pltac.tactic -> { Vernacexpr.HintsExtern (n,c, in_tac tac) } ] ] ; - operconstr: LEVEL "0" - [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> + term: LEVEL "0" + [ [ IDENT "ltac"; ":"; "("; tac = Pltac.ltac_expr; ")" -> { let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in CAst.make ~loc @@ CHole (None, IntroAnonymous, Some arg) } ] ] ; @@ -402,7 +399,7 @@ VERNAC { tactic_mode } EXTEND VernacSolve STATE proof { classify_as_proofstep } -> { let g = Option.default (Goal_select.get_default_goal_selector ()) g in let global = match g with Goal_select.SelectAll | Goal_select.SelectList _ -> true | _ -> false in - let t = ComTactic.I (Tacinterp.hide_interp, { Tacinterp.global; ast = t; }) in + let t = Tacinterp.hide_interp { Tacinterp.global; ast = t; } in ComTactic.solve g ~info t ~with_end_tac } END @@ -415,7 +412,7 @@ VERNAC { tactic_mode } EXTEND VernacSolveParallel STATE proof VtProofStep{ proof_block_detection = pbr } } -> { let t, abstract = rm_abstract t in - let t = ComTactic.I (Tacinterp.hide_interp, { Tacinterp.global = true; ast = t; }) in + let t = Tacinterp.hide_interp { Tacinterp.global = true; ast = t; } in ComTactic.solve_parallel ~info t ~abstract ~with_end_tac } END @@ -469,7 +466,7 @@ END VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY | [ "Print" "Ltac" reference(r) ] -> - { Feedback.msg_notice (Tacintern.print_ltac r) } + { Feedback.msg_notice (Tacentries.print_ltac r) } END VERNAC COMMAND EXTEND VernacLocateLtac CLASSIFIED AS QUERY diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index ee94fd565a..a3f03b5bb5 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -67,12 +67,12 @@ END { type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast -type glob_strategy = (glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast +type glob_strategy = (glob_constr_and_expr, Tacexpr.glob_red_expr) strategy_ast let interp_strategy ist gl s = let sigma = project gl in - sigma, strategy_of_ast s -let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s + sigma, strategy_of_ast ist s +let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (Tacintern.intern_red_expr ist) s let subst_strategy s str = str let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>" @@ -80,12 +80,9 @@ let pr_raw_strategy env sigma prc prlc _ (s : raw_strategy) = let prr = Pptactic.pr_red_expr env sigma (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_qualid, prc) in Rewrite.pr_strategy (prc env sigma) prr s let pr_glob_strategy env sigma prc prlc _ (s : glob_strategy) = - let prr = Pptactic.pr_red_expr env sigma - (Ppconstr.pr_constr_expr, - Ppconstr.pr_lconstr_expr, - Pputils.pr_or_by_notation Libnames.pr_qualid, - Ppconstr.pr_constr_expr) - in + let prpat env sigma (_,c,_) = prc env sigma c in + let prcst = Pputils.pr_or_var Pptactic.(pr_and_short_name (pr_evaluable_reference_env env)) in + let prr = Pptactic.pr_red_expr env sigma (prc, prlc, prcst, prpat) in Rewrite.pr_strategy (prc env sigma) prr s } @@ -130,15 +127,15 @@ END { let db_strat db = StratUnary (Topdown, StratHints (false, db)) -let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) +let cl_rewrite_clause_db ist db = cl_rewrite_clause_strat (strategy_of_ast ist (db_strat db)) } TACTIC EXTEND rewrite_strat | [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> { cl_rewrite_clause_strat s (Some id) } | [ "rewrite_strat" rewstrategy(s) ] -> { cl_rewrite_clause_strat s None } -| [ "rewrite_db" preident(db) "in" hyp(id) ] -> { cl_rewrite_clause_db db (Some id) } -| [ "rewrite_db" preident(db) ] -> { cl_rewrite_clause_db db None } +| [ "rewrite_db" preident(db) "in" hyp(id) ] -> { cl_rewrite_clause_db ist db (Some id) } +| [ "rewrite_db" preident(db) ] -> { cl_rewrite_clause_db ist db None } END { diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index c186a83a5c..236de65462 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -121,8 +121,8 @@ let destruction_arg_of_constr (c,lbind as clbind) = match lbind with end | _ -> ElimOnConstr clbind -let mkNumeral n = - Numeral (NumTok.Signed.of_int_string (string_of_int n)) +let mkNumber n = + Number (NumTok.Signed.of_int_string (string_of_int n)) let mkTacCase with_evar = function | [(clear,ElimOnConstr cl),(None,None),None],None -> @@ -130,7 +130,7 @@ let mkTacCase with_evar = function (* Reinterpret numbers as a notation for terms *) | [(clear,ElimOnAnonHyp n),(None,None),None],None -> TacCase (with_evar, - (clear,(CAst.make @@ CPrim (mkNumeral n), + (clear,(CAst.make @@ CPrim (mkNumber n), NoBindings))) (* Reinterpret ident as notations for variables in the context *) (* because we don't know if they are quantified or not *) @@ -291,7 +291,7 @@ GRAMMAR EXTEND Gram ; simple_intropattern: [ [ pat = simple_intropattern_closed; - l = LIST0 ["%"; c = operconstr LEVEL "0" -> { c } ] -> + l = LIST0 ["%"; c = term LEVEL "0" -> { c } ] -> { let {CAst.loc=loc0;v=pat} = pat in let f c pat = let loc1 = Constrexpr_ops.constr_loc c in @@ -320,7 +320,7 @@ GRAMMAR EXTEND Gram with_bindings: [ [ "with"; bl = bindings -> { bl } | -> { NoBindings } ] ] ; - red_flags: + red_flag: [ [ IDENT "beta" -> { [FBeta] } | IDENT "iota" -> { [FMatch;FFix;FCofix] } | IDENT "match" -> { [FMatch] } @@ -337,7 +337,7 @@ GRAMMAR EXTEND Gram ] ] ; strategy_flag: - [ [ s = LIST1 red_flags -> { Redops.make_red_flag (List.flatten s) } + [ [ s = LIST1 red_flag -> { Redops.make_red_flag (List.flatten s) } | d = delta_flag -> { all_with d } ] ] ; @@ -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: @@ -460,7 +465,7 @@ GRAMMAR EXTEND Gram [ [ "as"; id = ident -> { Names.Name.Name id } | -> { Names.Name.Anonymous } ] ] ; by_tactic: - [ [ "by"; tac = tactic_expr LEVEL "3" -> { Some tac } + [ [ "by"; tac = ltac_expr LEVEL "3" -> { Some tac } | -> { None } ] ] ; rewriter : diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml index b7b54143df..94e398fe5d 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -37,8 +37,10 @@ let clause_dft_concl = (* Main entries for ltac *) -let tactic_arg = Entry.create "tactic_arg" -let tactic_expr = Entry.create "tactic_expr" +let tactic_value = Entry.create "tactic_value" +let tactic_arg = tactic_value +let ltac_expr = Entry.create "ltac_expr" +let tactic_expr = ltac_expr let binder_tactic = Entry.create "binder_tactic" let tactic = Entry.create "tactic" diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli index 8565c4b4d6..3a4a081c93 100644 --- a/plugins/ltac/pltac.mli +++ b/plugins/ltac/pltac.mli @@ -31,8 +31,12 @@ val simple_tactic : raw_tactic_expr Entry.t val simple_intropattern : constr_expr intro_pattern_expr CAst.t Entry.t val in_clause : Names.lident Locus.clause_expr Entry.t val clause_dft_concl : Names.lident Locus.clause_expr Entry.t +val tactic_value : raw_tactic_arg Entry.t val tactic_arg : raw_tactic_arg Entry.t + [@@deprecated "Deprecated in 8.13; use 'tactic_value' instead"] +val ltac_expr : raw_tactic_expr Entry.t val tactic_expr : raw_tactic_expr Entry.t + [@@deprecated "Deprecated in 8.13; use 'ltac_expr' instead"] val binder_tactic : raw_tactic_expr Entry.t val tactic : raw_tactic_expr Entry.t val tactic_eoi : raw_tactic_expr Entry.t diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index fe896f9351..edd56ee0f7 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -1135,8 +1135,8 @@ let pr_goal_selector ~toplevel s = pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); pr_lconstr = (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)); pr_pattern = (fun env sigma -> pr_pat_and_constr_expr (pr_glob_constr_env env)); - pr_lpattern = (fun env sigma -> pr_pat_and_constr_expr (pr_lglob_constr_env env)); pr_constant = pr_or_var (pr_and_short_name (pr_evaluable_reference_env env)); + pr_lpattern = (fun env sigma -> pr_pat_and_constr_expr (pr_lglob_constr_env env)); pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant); pr_name = pr_lident; pr_generic = Pputils.pr_glb_generic; @@ -1334,8 +1334,8 @@ let () = ; Genprint.register_print0 wit_constr - (lift_env Ppconstr.pr_lconstr_expr) - (lift_env (fun env sigma (c, _) -> pr_lglob_constr_pptac env sigma c)) + (lift_env Ppconstr.pr_constr_expr) + (lift_env (fun env sigma (c, _) -> pr_glob_constr_pptac env sigma c)) (make_constr_printer Printer.pr_econstr_n_env) ; Genprint.register_print0 diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 6a9fb5c2ea..5e199dad62 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** This module implements pretty-printers for tactic_expr syntactic +(** This module implements pretty-printers for ltac_expr syntactic objects and their subcomponents. *) open Genarg diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index ff24e38577..8196ba6555 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -769,7 +769,7 @@ let get_rew_prf evars r = match r.rew_prf with let poly_subrelation sort = if sort then PropGlobal.subrelation else TypeGlobal.subrelation -let resolve_subrelation env avoid car rel sort prf rel' res = +let resolve_subrelation env car rel sort prf rel' res = if Termops.eq_constr (fst res.rew_evars) rel rel' then res else let evars, app = app_poly_check env res.rew_evars (poly_subrelation sort) [|car; rel; rel'|] in @@ -779,7 +779,7 @@ let resolve_subrelation env avoid car rel sort prf rel' res = rew_prf = RewPrf (rel', appsub); rew_evars = evars } -let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars = +let resolve_morphism env m args args' (b,cstr) evars = let evars, morph_instance, proj, sigargs, m', args, args' = let first = match (Array.findi (fun _ b -> not (Option.is_empty b)) args') with | Some i -> i @@ -843,18 +843,18 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev let proof = applist (proj, List.rev projargs) in let newt = applist (m', List.rev typeargs) in match respars with - [ a, Some r ] -> evars, proof, substl subst a, substl subst r, oldt, fnewt newt + [ a, Some r ] -> evars, proof, substl subst a, substl subst r, newt | _ -> assert(false) -let apply_constraint env avoid car rel prf cstr res = +let apply_constraint env car rel prf cstr res = match snd cstr with | None -> res - | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res + | Some r -> resolve_subrelation env car rel (fst cstr) prf r res -let coerce env avoid cstr res = +let coerce env cstr res = let evars, (rel, prf) = get_rew_prf res.rew_evars res in let res = { res with rew_evars = evars } in - apply_constraint env avoid res.rew_car rel prf cstr res + apply_constraint env res.rew_car rel prf cstr res let apply_rule unify loccs : int pure_strategy = let (nowhere_except_in,occs) = convert_occs loccs in @@ -863,7 +863,7 @@ let apply_rule unify loccs : int pure_strategy = then List.mem occ occs else not (List.mem occ occs) in - { strategy = fun { state = occ ; env ; unfresh ; + { strategy = fun { state = occ ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> let unif = if isEvar (goalevars evars) t then None else unify env evars t in match unif with @@ -874,7 +874,7 @@ let apply_rule unify loccs : int pure_strategy = else if Termops.eq_constr (fst rew.rew_evars) t rew.rew_to then (occ, Identity) else let res = { rew with rew_car = ty } in - let res = Success (coerce env unfresh cstr res) in + let res = Success (coerce env cstr res) in (occ, res) } @@ -968,7 +968,7 @@ let fold_match ?(force=false) env sigma c = let unfold_match env sigma sk app = match EConstr.kind sigma app with - | App (f', args) when Constant.equal (fst (destConst sigma f')) sk -> + | App (f', args) when QConstant.equal env (fst (destConst sigma f')) sk -> let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in let v = EConstr.of_constr v in Reductionops.whd_beta env sigma (mkApp (v, args)) @@ -1017,10 +1017,10 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | None -> false | Some r -> not (is_rew_cast r.rew_prf)) args' then - let evars', prf, car, rel, c1, c2 = - resolve_morphism env unfresh t m args args' (prop, cstr') evars' + let evars', prf, car, rel, c2 = + resolve_morphism env m args args' (prop, cstr') evars' in - let res = { rew_car = ty; rew_from = c1; + let res = { rew_car = ty; rew_from = t; rew_to = c2; rew_prf = RewPrf (rel, prf); rew_evars = evars' } in Success res @@ -1071,7 +1071,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let res = match prf with | RewPrf (rel, prf) -> - Success (apply_constraint env unfresh res.rew_car + Success (apply_constraint env res.rew_car rel prf (prop,cstr) res) | _ -> Success res in state, res @@ -1094,20 +1094,6 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | Fail | Identity -> res in state, res - (* if x' = None && flags.under_lambdas then *) - (* let lam = mkLambda (n, x, b) in *) - (* let lam', occ = aux env lam occ None in *) - (* let res = *) - (* match lam' with *) - (* | None -> None *) - (* | Some (prf, (car, rel, c1, c2)) -> *) - (* Some (resolve_morphism env sigma t *) - (* ~fnewt:unfold_all *) - (* (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *) - (* cstr evars) *) - (* in res, occ *) - (* else *) - | Prod (n, dom, codom) -> let lam = mkLambda (n, dom, codom) in let (evars', app), unfold = @@ -1131,31 +1117,13 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing dependent relations and using projections to get them out. *) - (* | Lambda (n, t, b) when flags.under_lambdas -> *) - (* let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in *) - (* let n'' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n' in *) - (* let n''' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n'' in *) - (* let rel = new_cstr_evar cstr env (mkApp (Lazy.force coq_relation, [|t|])) in *) - (* let env' = Environ.push_rel_context [(n'',None,lift 2 rel);(n'',None,lift 1 t);(n', None, t)] env in *) - (* let b' = s env' avoid b (Typing.type_of env' (goalevars evars) (lift 2 b)) (unlift_cstr env (goalevars evars) cstr) evars in *) - (* (match b' with *) - (* | Some (Some r) -> *) - (* let prf = match r.rew_prf with *) - (* | RewPrf (rel, prf) -> *) - (* let rel = pointwise_or_dep_relation n' t r.rew_car rel in *) - (* let prf = mkLambda (n', t, prf) in *) - (* RewPrf (rel, prf) *) - (* | x -> x *) - (* in *) - (* Some (Some { r with *) - (* rew_prf = prf; *) - (* rew_car = mkProd (n, t, r.rew_car); *) - (* rew_from = mkLambda(n, t, r.rew_from); *) - (* rew_to = mkLambda (n, t, r.rew_to) }) *) - (* | _ -> b') *) | 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 = match n'.binder_name with + | Anonymous -> unfresh + | Name id -> Id.Set.add id unfresh + in let open Context.Rel.Declaration in let env' = EConstr.push_rel (LocalAssum (n', t)) env in let bty = Retyping.get_type_of env' (goalevars evars) b in @@ -1196,7 +1164,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | Success r -> let case = mkCase (ci, lift 1 p, map_invert (lift 1) iv, mkRel 1, Array.map (lift 1) brs) in let res = make_leibniz_proof env case ty r in - state, Success (coerce env unfresh (prop,cstr) res) + state, Success (coerce env (prop,cstr) res) | Fail | Identity -> if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then let evars', eqty = app_poly_sort prop env evars coq_eq [| ty |] in @@ -1237,7 +1205,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = in let res = match res with - | Success r -> Success (coerce env unfresh (prop,cstr) r) + | Success r -> Success (coerce env (prop,cstr) r) | Fail | Identity -> res in state, res | _ -> state, Fail @@ -1671,9 +1639,9 @@ let cl_rewrite_clause l left2right occs clause = let cl_rewrite_clause_strat strat clause = cl_rewrite_clause_strat false strat clause -let apply_glob_constr c l2r occs = (); fun ({ state = () ; env = env } as input) -> +let apply_glob_constr ist c l2r occs = (); fun ({ state = () ; env = env } as input) -> let c sigma = - let (sigma, c) = Pretyping.understand_tcc env sigma c in + let (sigma, c) = Tacinterp.interp_open_constr ist env sigma c in (sigma, (c, NoBindings)) in let flags = general_rewrite_unif_flags () in @@ -1750,12 +1718,12 @@ let rec pr_strategy prc prr = function | StratEval r -> str "eval" ++ spc () ++ prr r | StratFold c -> str "fold" ++ spc () ++ prc c -let rec strategy_of_ast = function +let rec strategy_of_ast ist = function | StratId -> Strategies.id | StratFail -> Strategies.fail | StratRefl -> Strategies.refl | StratUnary (f, s) -> - let s' = strategy_of_ast s in + let s' = strategy_of_ast ist s in let f' = match f with | Subterms -> all_subterms | Subterm -> one_subterm @@ -1769,13 +1737,13 @@ let rec strategy_of_ast = function | Repeat -> Strategies.repeat in f' s' | StratBinary (f, s, t) -> - let s' = strategy_of_ast s in - let t' = strategy_of_ast t in + let s' = strategy_of_ast ist s in + let t' = strategy_of_ast ist t in let f' = match f with | Compose -> Strategies.seq | Choice -> Strategies.choice in f' s' t' - | StratConstr (c, b) -> { strategy = apply_glob_constr (fst c) b AllOccurrences } + | StratConstr (c, b) -> { strategy = apply_glob_constr ist c b AllOccurrences } | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id | StratTerms l -> { strategy = (fun ({ state = () ; env } as input) -> @@ -1784,7 +1752,7 @@ let rec strategy_of_ast = function } | StratEval r -> { strategy = (fun ({ state = () ; env ; evars } as input) -> - let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in + let (sigma,r_interp) = Tacinterp.interp_red_expr ist env (goalevars evars) r in (Strategies.reduce r_interp).strategy { input with evars = (sigma,cstrevars evars) }) } | StratFold c -> Strategies.fold_glob (fst c) diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 60a66dd861..8e0ce183c2 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -62,7 +62,7 @@ type rewrite_result = type strategy -val strategy_of_ast : (glob_constr_and_expr, raw_red_expr) strategy_ast -> strategy +val strategy_of_ast : interp_sign -> (glob_constr_and_expr, glob_red_expr) strategy_ast -> strategy val map_strategy : ('a -> 'b) -> ('c -> 'd) -> ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index ee28229cb7..4c1fe6417e 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -394,8 +394,13 @@ type appl = (* Values for interpretation *) type tacvalue = - | VFun of appl * Tacexpr.ltac_trace * Loc.t option * Val.t Id.Map.t * - Name.t list * Tacexpr.glob_tactic_expr + | VFun of + appl * + Tacexpr.ltac_trace * + Loc.t option * (* when executing a global Ltac function: the location where this function was called *) + Val.t Id.Map.t * (* closure *) + Name.t list * (* binders *) + Tacexpr.glob_tactic_expr (* body *) | VRec of Val.t Id.Map.t ref * Tacexpr.glob_tactic_expr let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index d58a76fe13..29e29044f1 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -31,21 +31,9 @@ type argument = Genarg.ArgT.any Extend.user_symbol (**********************************************************************) (* Interpret entry names of the form "ne_constr_list" as entry keys *) -let coincide s pat off = - let len = String.length pat in - let break = ref true in - let i = ref 0 in - while !break && !i < len do - let c = Char.code s.[off + !i] in - let d = Char.code pat.[!i] in - break := Int.equal c d; - incr i - done; - !break - let atactic n = if n = 5 then Pcoq.Symbol.nterm Pltac.binder_tactic - else Pcoq.Symbol.nterml Pltac.tactic_expr (string_of_int n) + else Pcoq.Symbol.nterml Pltac.ltac_expr (string_of_int n) type entry_name = EntryName : 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, _, 'a) Pcoq.Symbol.t -> entry_name @@ -70,28 +58,37 @@ let check_separator ?loc = function | Some _ -> user_err ?loc (str "Separator is only for arguments with suffix _list_sep.") let rec parse_user_entry ?loc s sep = - let l = String.length s in - if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then - let entry = parse_user_entry ?loc (String.sub s 3 (l-8)) None in + let open CString in + let matches pre suf s = + String.length s > (String.length pre + String.length suf) && + is_prefix pre s && is_suffix suf s + in + let basename pre suf s = + let plen = String.length pre in + String.sub s plen (String.length s - (plen + String.length suf)) + in + let tactic_len = String.length "tactic" in + if matches "ne_" "_list" s then + let entry = parse_user_entry ?loc (basename "ne_" "_list" s) None in check_separator ?loc sep; Ulist1 entry - else if l > 12 && coincide s "ne_" 0 && - coincide s "_list_sep" (l-9) then - let entry = parse_user_entry ?loc (String.sub s 3 (l-12)) None in + else if matches "ne_" "_list_sep" s then + let entry = parse_user_entry ?loc (basename "ne_" "_list_sep" s) None in Ulist1sep (entry, get_separator sep) - else if l > 5 && coincide s "_list" (l-5) then - let entry = parse_user_entry ?loc (String.sub s 0 (l-5)) None in + else if matches "" "_list" s then + let entry = parse_user_entry ?loc (basename "" "_list" s) None in check_separator ?loc sep; Ulist0 entry - else if l > 9 && coincide s "_list_sep" (l-9) then - let entry = parse_user_entry ?loc (String.sub s 0 (l-9)) None in + else if matches "" "_list_sep" s then + let entry = parse_user_entry ?loc (basename "" "_list_sep" s) None in Ulist0sep (entry, get_separator sep) - else if l > 4 && coincide s "_opt" (l-4) then - let entry = parse_user_entry ?loc (String.sub s 0 (l-4)) None in + else if matches "" "_opt" s then + let entry = parse_user_entry ?loc (basename "" "_opt" s) None in check_separator ?loc sep; Uopt entry - else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then - let n = Char.code s.[6] - 48 in + else if String.length s = tactic_len + 1 && is_prefix "tactic" s + && '5' >= s.[tactic_len] && s.[tactic_len] >= '0' then + let n = Char.code s.[tactic_len] - Char.code '0' in check_separator ?loc sep; Uentryl ("tactic", n) else @@ -119,7 +116,7 @@ let get_tactic_entry n = else if Int.equal n 5 then Pltac.binder_tactic, None else if 1<=n && n<5 then - Pltac.tactic_expr, Some (Gramlib.Gramext.Level (string_of_int n)) + Pltac.ltac_expr, Some (Gramlib.Gramext.Level (string_of_int n)) else user_err Pp.(str ("Invalid Tactic Notation level: "^(string_of_int n)^".")) @@ -159,7 +156,7 @@ let rec prod_item_of_symbol lev = function EntryName (Rawwit wit, Pcoq.Symbol.nterm (genarg_grammar wit)) | Extend.Uentryl (s, n) -> let ArgT.Any tag = s in - assert (coincide (ArgT.repr tag) "tactic" 0); + assert (CString.is_suffix "tactic" (ArgT.repr tag)); get_tacentry n lev (** Tactic grammar extensions *) @@ -386,7 +383,7 @@ let add_ml_tactic_notation name ~level ?deprecation prods = in List.iteri iter (List.rev prods); (* We call [extend_atomic_tactic] only for "basic tactics" (the ones - at tactic_expr level 0) *) + at ltac_expr level 0) *) if Int.equal level 0 then extend_atomic_tactic name prods (**********************************************************************) @@ -423,7 +420,7 @@ let create_ltac_quotation name cast (e, l) = in let action _ v _ _ _ loc = cast (Some loc, v) in let gram = (level, assoc, [Pcoq.Production.make rule action]) in - Pcoq.grammar_extend Pltac.tactic_arg {pos=None; data=[gram]} + Pcoq.grammar_extend Pltac.tactic_value {pos=None; data=[gram]} (** Command *) @@ -531,16 +528,40 @@ let print_ltacs () = let locatable_ltac = "Ltac" +let split_ltac_fun = function + | Tacexpr.TacFun (l,t) -> (l,t) + | t -> ([],t) + +let pr_ltac_fun_arg n = spc () ++ Name.print n + +let print_ltac_body qid tac = + let filter mp = + try Some (Nametab.shortest_qualid_of_module mp) + with Not_found -> None + in + let mods = List.map_filter filter tac.Tacenv.tac_redef in + let redefined = match mods with + | [] -> mt () + | mods -> + let redef = prlist_with_sep fnl pr_qualid mods in + fnl () ++ str "Redefined by:" ++ fnl () ++ redef + in + let l,t = split_ltac_fun tac.Tacenv.tac_body in + hv 2 ( + hov 2 (str "Ltac" ++ spc() ++ pr_qualid qid ++ + prlist pr_ltac_fun_arg l ++ spc () ++ str ":=") + ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined + let () = let open Prettyp in - let locate qid = try Some (Tacenv.locate_tactic qid) with Not_found -> None in - let locate_all = Tacenv.locate_extended_all_tactic in - let shortest_qualid = Tacenv.shortest_qualid_of_tactic in - let name kn = str "Ltac" ++ spc () ++ pr_path (Tacenv.path_of_tactic kn) in - let print kn = - let qid = qualid_of_path (Tacenv.path_of_tactic kn) in - Tacintern.print_ltac qid - in + let locate qid = try Some (qid, Tacenv.locate_tactic qid) with Not_found -> None in + let locate_all qid = List.map (fun kn -> (qid,kn)) (Tacenv.locate_extended_all_tactic qid) in + let shortest_qualid (qid,kn) = Tacenv.shortest_qualid_of_tactic kn in + let name (qid,kn) = str "Ltac" ++ spc () ++ pr_path (Tacenv.path_of_tactic kn) in + let print (qid,kn) = + let entries = Tacenv.ltac_entries () in + let tac = KNmap.find kn entries in + print_ltac_body qid tac in let about = name in register_locatable locatable_ltac { locate; @@ -554,14 +575,25 @@ let () = let print_located_tactic qid = Feedback.msg_notice (Prettyp.print_located_other locatable_ltac qid) +let print_ltac id = + try + let kn = Tacenv.locate_tactic id in + let entries = Tacenv.ltac_entries () in + let tac = KNmap.find kn entries in + print_ltac_body id tac + with + Not_found -> + user_err ~hdr:"print_ltac" + (pr_qualid id ++ spc() ++ str "is not a user defined tactic.") + (** Grammar *) let () = let entries = [ - AnyEntry Pltac.tactic_expr; + AnyEntry Pltac.ltac_expr; AnyEntry Pltac.binder_tactic; AnyEntry Pltac.simple_tactic; - AnyEntry Pltac.tactic_arg; + AnyEntry Pltac.tactic_value; ] in register_grammars_by_name "tactic" entries diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index 6ee3ce091b..fc9ab54eba 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -69,6 +69,9 @@ val print_ltacs : unit -> unit val print_located_tactic : Libnames.qualid -> unit (** Display the absolute name of a tactic. *) +val print_ltac : Libnames.qualid -> Pp.t +(** Display the definition of a tactic. *) + (** {5 Low-level registering of tactics} *) type (_, 'a) ml_ty_sig = diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 9c3b05fdf1..47f1d3bf66 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -769,38 +769,6 @@ let glob_tactic_env l env x = (intern_pure_tactic { (Genintern.empty_glob_sign env) with ltacvars }) x -let split_ltac_fun = function - | TacFun (l,t) -> (l,t) - | t -> ([],t) - -let pr_ltac_fun_arg n = spc () ++ Name.print n - -let print_ltac id = - try - let kn = Tacenv.locate_tactic id in - let entries = Tacenv.ltac_entries () in - let tac = KNmap.find kn entries in - let filter mp = - try Some (Nametab.shortest_qualid_of_module mp) - with Not_found -> None - in - let mods = List.map_filter filter tac.Tacenv.tac_redef in - let redefined = match mods with - | [] -> mt () - | mods -> - let redef = prlist_with_sep fnl pr_qualid mods in - fnl () ++ str "Redefined by:" ++ fnl () ++ redef - in - let l,t = split_ltac_fun tac.Tacenv.tac_body in - hv 2 ( - hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++ - prlist pr_ltac_fun_arg l ++ spc () ++ str ":=") - ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined - with - Not_found -> - user_err ~hdr:"print_ltac" - (pr_qualid id ++ spc() ++ str "is not a user defined tactic.") - (** Registering *) let lift intern = (); fun ist x -> (ist, intern ist x) diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli index 22ec15566b..f779aa470c 100644 --- a/plugins/ltac/tacintern.mli +++ b/plugins/ltac/tacintern.mli @@ -55,9 +55,6 @@ val intern_hyp : glob_sign -> lident -> lident val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument -(** printing *) -val print_ltac : Libnames.qualid -> Pp.t - (** Reduction expressions *) val intern_red_expr : glob_sign -> raw_red_expr -> glob_red_expr diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 12bfb4d09e..3d734d3a66 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -153,11 +153,15 @@ let add_extra_loc loc extra = match loc with | None -> extra | Some loc -> TacStore.set extra f_loc loc -let add_loc loc ist = +let extract_loc ist = TacStore.get ist.extra f_loc + +let ensure_loc loc ist = match loc with | None -> ist - | Some loc -> { ist with extra = TacStore.set ist.extra f_loc loc } -let extract_loc ist = TacStore.get ist.extra f_loc + | Some loc -> + match extract_loc ist with + | None -> { ist with extra = TacStore.set ist.extra f_loc loc } + | Some _ -> ist let print_top_val env v = Pptactic.pr_value Pptactic.ltop v @@ -1175,7 +1179,7 @@ and eval_tactic_ist ist tac : unit Proofview.tactic = match tac with | TacFirst l -> Tacticals.New.tclFIRST (List.map (interp_tactic ist) l) | TacSolve l -> Tacticals.New.tclSOLVE (List.map (interp_tactic ist) l) | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac) - | TacArg {CAst.loc} -> Ftactic.run (val_interp (add_loc loc ist) tac) (fun v -> tactic_of_value ist v) + | TacArg {CAst.loc} -> Ftactic.run (val_interp (ensure_loc loc ist) tac) (fun v -> tactic_of_value ist v) | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) (* For extensions *) | TacAlias {loc; v=(s,l)} -> @@ -1254,9 +1258,12 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t = let extra = TacStore.set extra f_trace trace in let ist = { lfun = Id.Map.empty; poly; extra } in let appl = GlbAppl[r,[]] in + (* We call a global ltac reference: add a loc on its executation only if not + already in another global reference *) + let ist = ensure_loc loc ist in Profile_ltac.do_profile "interp_ltac_reference" trace ~count_call:false - (catch_error_tac_loc (* interp *) loc false trace - (val_interp ~appl (add_loc (* exec *) loc ist) (Tacenv.interp_ltac r))) + (catch_error_tac_loc (* loc for interpretation *) loc false trace + (val_interp ~appl ist (Tacenv.interp_ltac r))) and interp_tacarg ist arg : Val.t Ftactic.t = match arg with @@ -1325,7 +1332,7 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = ; extra = TacStore.set ist.extra f_trace [] } in Profile_ltac.do_profile "interp_app" trace ~count_call:false - (catch_error_tac_loc loc false trace (val_interp (add_loc loc ist) body)) >>= fun v -> + (catch_error_tac_loc loc false trace (val_interp (ensure_loc loc ist) body)) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) end begin fun (e, info) -> @@ -1997,7 +2004,7 @@ let interp_tac_gen lfun avoid_ids debug t = let interp t = interp_tac_gen Id.Map.empty Id.Set.empty (get_debug()) t (* MUST be marshallable! *) -type tactic_expr = { +type ltac_expr = { global: bool; ast: Tacexpr.raw_tactic_expr; } @@ -2019,7 +2026,7 @@ let hide_interp {global;ast} = hide_interp (Proofview.Goal.env gl) end -let hide_interp = ComTactic.register_tactic_interpreter "ltac1" hide_interp +let ComTactic.Interpreter hide_interp = ComTactic.register_tactic_interpreter "ltac1" hide_interp (***************************************************************************) (** Register standard arguments *) diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index 01d7306c9d..a74f4592f7 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -77,6 +77,9 @@ val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tac val interp_ltac_constr : interp_sign -> glob_tactic_expr -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic (** Interprets redexp arguments *) +val interp_red_expr : interp_sign -> Environ.env -> Evd.evar_map -> glob_red_expr -> Evd.evar_map * red_expr + +(** Interprets redexp arguments from a raw one *) val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr (** Interprets tactic expressions *) @@ -126,12 +129,12 @@ val interp_tac_gen : value Id.Map.t -> Id.Set.t -> val interp : raw_tactic_expr -> unit Proofview.tactic (** Hides interpretation for pretty-print *) -type tactic_expr = { +type ltac_expr = { global: bool; ast: Tacexpr.raw_tactic_expr; } -val hide_interp : tactic_expr ComTactic.tactic_interpreter +val hide_interp : ltac_expr -> ComTactic.interpretable (** Internals that can be useful for syntax extensions. *) 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/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index d464ec4c06..61f90608b1 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -100,7 +100,7 @@ let rec make_form env sigma atom_env term = | Cast(a,_,_) -> make_form env sigma atom_env a | Ind (ind, _) -> - if Names.eq_ind ind (fst (Lazy.force li_False)) then + if Names.Ind.CanOrd.equal ind (fst (Lazy.force li_False)) then Bot else make_atom atom_env (normalize term) @@ -108,11 +108,11 @@ let rec make_form env sigma atom_env term = begin try let ind, _ = destInd sigma hd in - if Names.eq_ind ind (fst (Lazy.force li_and)) then + if Names.Ind.CanOrd.equal ind (fst (Lazy.force li_and)) then let fa = make_form env sigma atom_env argv.(0) in let fb = make_form env sigma atom_env argv.(1) in Conjunct (fa,fb) - else if Names.eq_ind ind (fst (Lazy.force li_or)) then + else if Names.Ind.CanOrd.equal ind (fst (Lazy.force li_or)) then let fa = make_form env sigma atom_env argv.(0) in let fb = make_form env sigma atom_env argv.(1) in Disjunct (fa,fb) diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 38b26d06b9..a7ebd5f9f5 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -240,7 +240,7 @@ let strip_unfold_term _ ((sigma, t) as p) kt = match EConstr.kind sigma t with let same_proj sigma t1 t2 = match EConstr.kind sigma t1, EConstr.kind sigma t2 with - | Proj(c1,_), Proj(c2, _) -> Projection.equal c1 c2 + | Proj(c1,_), Proj(c2, _) -> Projection.CanOrd.equal c1 c2 | _ -> false let all_ok _ _ = true diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 7b584b5159..ccdf5fa68e 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -100,7 +100,7 @@ ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY { pr_ssrtacarg env sigma } END GRAMMAR EXTEND Gram GLOBAL: ssrtacarg; - ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> { tac } ]]; + ssrtacarg: [[ tac = ltac_expr LEVEL "5" -> { tac } ]]; END (* Copy of ssrtacarg with LEVEL "3", useful for: "under ... do ..." *) @@ -108,7 +108,7 @@ ARGUMENT EXTEND ssrtac3arg TYPED AS tactic PRINTED BY { pr_ssrtacarg env sigma } END GRAMMAR EXTEND Gram GLOBAL: ssrtac3arg; - ssrtac3arg: [[ tac = tactic_expr LEVEL "3" -> { tac } ]]; + ssrtac3arg: [[ tac = ltac_expr LEVEL "3" -> { tac } ]]; END { @@ -350,7 +350,7 @@ let interp_index ist gl idx = | Some c -> let rc = Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) c in begin match Notation.uninterp_prim_token rc (None, []) with - | Constrexpr.Numeral n, _ when NumTok.Signed.is_int n -> + | Constrexpr.Number n, _ when NumTok.Signed.is_int n -> int_of_string (NumTok.Signed.to_string n) | _ -> raise Not_found end @@ -1337,7 +1337,7 @@ ARGUMENT EXTEND ssrbinder TYPED AS (ssrfwdfmt * constr) PRINTED BY { pr_ssrbinde GRAMMAR EXTEND Gram GLOBAL: ssrbinder; ssrbinder: [ - [ ["of" -> { () } | "&" -> { () } ]; c = operconstr LEVEL "99" -> { + [ ["of" -> { () } | "&" -> { () } ]; c = term LEVEL "99" -> { (FwdPose, [BFvar]), CAst.make ~loc @@ CLambdaN ([CLocalAssum ([CAst.make ~loc Anonymous],Default Glob_term.Explicit,c)],mkCHole (Some loc)) } ] ]; @@ -1594,18 +1594,18 @@ GRAMMAR EXTEND Gram | n = Prim.natural -> { ArgArg (check_index ~loc n) } ] ]; ssrswap: [[ IDENT "first" -> { loc, true } | IDENT "last" -> { loc, false } ]]; - ssrorelse: [[ "||"; tac = tactic_expr LEVEL "2" -> { tac } ]]; + ssrorelse: [[ "||"; tac = ltac_expr LEVEL "2" -> { tac } ]]; ssrseqarg: [ [ arg = ssrswap -> { noindex, swaptacarg arg } | i = ssrseqidx; tac = ssrortacarg; def = OPT ssrorelse -> { i, (tac, def) } | i = ssrseqidx; arg = ssrswap -> { i, swaptacarg arg } - | tac = tactic_expr LEVEL "3" -> { noindex, (mk_hint tac, None) } + | tac = ltac_expr LEVEL "3" -> { noindex, (mk_hint tac, None) } ] ]; END { -let tactic_expr = Pltac.tactic_expr +let ltac_expr = Pltac.ltac_expr } @@ -1688,9 +1688,9 @@ let tclintros_expr ?loc tac ipats = } GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; - tactic_expr: LEVEL "1" [ RIGHTA - [ tac = tactic_expr; intros = ssrintros_ne -> { tclintros_expr ~loc tac intros } + GLOBAL: ltac_expr; + ltac_expr: LEVEL "1" [ RIGHTA + [ tac = ltac_expr; intros = ssrintros_ne -> { tclintros_expr ~loc tac intros } ] ]; END @@ -1704,9 +1704,9 @@ END (* (Removing user-specified parentheses is dubious anyway). *) GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; - ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> { CAst.make ~loc (Tacexp tac) } ]]; - tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> { TacArg arg } ]]; + GLOBAL: ltac_expr; + ssrparentacarg: [[ "("; tac = ltac_expr; ")" -> { CAst.make ~loc (Tacexp tac) } ]]; + ltac_expr: LEVEL "0" [[ arg = ssrparentacarg -> { TacArg arg } ]]; END (** The internal "done" and "ssrautoprop" tactics. *) @@ -1741,7 +1741,7 @@ let tclBY tac = Tacticals.New.tclTHEN tac (donetac ~-1) (* The latter two are used in forward-chaining tactics (have, suffice, wlog) *) (* and subgoal reordering tacticals (; first & ; last), respectively. *) -(* Force use of the tactic_expr parsing entry, to rule out tick marks. *) +(* Force use of the ltac_expr parsing entry, to rule out tick marks. *) (** The "by" tactical. *) @@ -1782,12 +1782,12 @@ let ssrdotac_expr ?loc n m tac clauses = } GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; + GLOBAL: ltac_expr; ssrdotac: [ - [ tac = tactic_expr LEVEL "3" -> { mk_hint tac } + [ tac = ltac_expr LEVEL "3" -> { mk_hint tac } | tacs = ssrortacarg -> { tacs } ] ]; - tactic_expr: LEVEL "3" [ RIGHTA + ltac_expr: LEVEL "3" [ RIGHTA [ IDENT "do"; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> { ssrdotac_expr ~loc noindex m tac clauses } | IDENT "do"; tac = ssrortacarg; clauses = ssrclauses -> @@ -1833,20 +1833,20 @@ let tclseq_expr ?loc tac dir arg = } GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; + GLOBAL: ltac_expr; ssr_first: [ [ tac = ssr_first; ipats = ssrintros_ne -> { tclintros_expr ~loc tac ipats } - | "["; tacl = LIST0 tactic_expr SEP "|"; "]" -> { TacFirst tacl } + | "["; tacl = LIST0 ltac_expr SEP "|"; "]" -> { TacFirst tacl } ] ]; ssr_first_else: [ [ tac1 = ssr_first; tac2 = ssrorelse -> { TacOrelse (tac1, tac2) } | tac = ssr_first -> { tac } ]]; - tactic_expr: LEVEL "4" [ LEFTA - [ tac1 = tactic_expr; ";"; IDENT "first"; tac2 = ssr_first_else -> + ltac_expr: LEVEL "4" [ LEFTA + [ tac1 = ltac_expr; ";"; IDENT "first"; tac2 = ssr_first_else -> { TacThen (tac1, tac2) } - | tac = tactic_expr; ";"; IDENT "first"; arg = ssrseqarg -> + | tac = ltac_expr; ";"; IDENT "first"; arg = ssrseqarg -> { tclseq_expr ~loc tac L2R arg } - | tac = tactic_expr; ";"; IDENT "last"; arg = ssrseqarg -> + | tac = ltac_expr; ";"; IDENT "last"; arg = ssrseqarg -> { tclseq_expr ~loc tac R2L arg } ] ]; END @@ -1894,7 +1894,8 @@ let has_occ ((_, occ), _) = occ <> None let gens_sep = function [], [] -> mt | _ -> spc let pr_dgens pr_gen (gensl, clr) = - let prgens s gens = str s ++ pr_list spc pr_gen gens in + let prgens s gens = + if CList.is_empty gens then mt () else str s ++ pr_list spc pr_gen gens in let prdeps deps = prgens ": " deps ++ spc () ++ str "/" in match gensl with | [deps; []] -> prdeps deps ++ pr_clear pr_spc clr @@ -2194,7 +2195,7 @@ END let pr_ssrcongrarg _ _ _ ((n, f), dgens) = (if n <= 0 then mt () else str " " ++ int n) ++ - str " " ++ pr_term f ++ pr_dgens pr_gen dgens + pr_term f ++ pr_dgens pr_gen dgens } @@ -2447,8 +2448,8 @@ END (* The standard TACTIC EXTEND does not work for abstract *) GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; - tactic_expr: LEVEL "3" + GLOBAL: ltac_expr; + ltac_expr: LEVEL "3" [ RIGHTA [ IDENT "abstract"; gens = ssrdgens -> { ssrtac_expr ~loc "abstract" [Tacexpr.TacGeneric (None, Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)] } ]]; diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index e231ab1f87..ab36d4fc7c 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -75,11 +75,14 @@ let pr_hyp (SsrHyp (_, id)) = Id.print id let pr_hyps = pr_list pr_spc pr_hyp let pr_occ = function - | Some (true, occ) -> str "{-" ++ pr_list pr_spc int occ ++ str "}" - | Some (false, occ) -> str "{+" ++ pr_list pr_spc int occ ++ str "}" + | Some (true, occ) -> + if CList.is_empty occ then mt () else str "{-" ++ pr_list pr_spc int occ ++ str "}" + | Some (false, occ) -> + if CList.is_empty occ then mt () else str "{+" ++ pr_list pr_spc int occ ++ str "}" | None -> str "{}" -let pr_clear_ne clr = str "{" ++ pr_hyps clr ++ str "}" +let pr_clear_ne clr = + if CList.is_empty clr then mt () else str "{" ++ pr_hyps clr ++ str "}" let pr_clear sep clr = sep () ++ pr_clear_ne clr let pr_dir = function L2R -> str "->" | R2L -> str "<-" diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 4a907b2795..99cf197b78 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -85,7 +85,7 @@ let mk_pat c (na, t) = (c, na, t) GRAMMAR EXTEND Gram GLOBAL: binder_constr; - ssr_rtype: [[ "return"; t = operconstr LEVEL "100" -> { mk_rtype t } ]]; + ssr_rtype: [[ "return"; t = term LEVEL "100" -> { mk_rtype t } ]]; ssr_mpat: [[ p = pattern -> { [[p]] } ]]; ssr_dpat: [ [ mp = ssr_mpat; "in"; t = pattern; rt = ssr_rtype -> { mp, mk_ctype mp t, rt } @@ -96,9 +96,9 @@ GRAMMAR EXTEND Gram ssr_elsepat: [[ "else" -> { [[CAst.make ~loc @@ CPatAtom None]] } ]]; ssr_else: [[ mp = ssr_elsepat; c = lconstr -> { CAst.make ~loc (mp, c) } ]]; binder_constr: [ - [ "if"; c = operconstr LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> + [ "if"; c = term LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> { let b1, ct, rt = db1 in CAst.make ~loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) } - | "if"; c = operconstr LEVEL "200";"isn't";db1 = ssr_dthen; b2 = ssr_else -> + | "if"; c = term LEVEL "200";"isn't";db1 = ssr_dthen; b2 = ssr_else -> { let b1, ct, rt = db1 in let b1, b2 = let open CAst in let {loc=l1; v=(p1, r1)}, {loc=l2; v=(p2, r2)} = b1, b2 in @@ -119,7 +119,7 @@ END GRAMMAR EXTEND Gram GLOBAL: closed_binder; closed_binder: [ - [ ["of" -> { () } | "&" -> { () } ]; c = operconstr LEVEL "99" -> + [ ["of" -> { () } | "&" -> { () } ]; c = term LEVEL "99" -> { [CLocalAssum ([CAst.make ~loc Anonymous], Default Explicit, c)] } ] ]; END @@ -304,15 +304,6 @@ END { - let warn_search_moved_enabled = ref true - let warn_search_moved = CWarnings.create ~name:"ssr-search-moved" - ~category:"deprecated" ~default:CWarnings.Enabled - (fun () -> - (Pp.strbrk - "SSReflect's Search command has been moved to the \ - ssrsearch module; please Require that module if you \ - still want to use SSReflect's Search command")) - open G_vernac } @@ -322,7 +313,6 @@ GRAMMAR EXTEND Gram query_command: [ [ IDENT "Search"; s = search_query; l = search_queries; "." -> { let (sl,m) = l in - if !warn_search_moved_enabled then warn_search_moved (); fun g -> Vernacexpr.VernacSearch (Vernacexpr.Search (s::sl),g, m) } ] ] diff --git a/plugins/ssr/ssrvernac.mli b/plugins/ssr/ssrvernac.mli index 93339313f0..327a2d4660 100644 --- a/plugins/ssr/ssrvernac.mli +++ b/plugins/ssr/ssrvernac.mli @@ -9,5 +9,3 @@ (************************************************************************) (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) - -val warn_search_moved_enabled : bool ref diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index cdd15acb0d..bd514f15d5 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -463,8 +463,8 @@ let nb_cs_proj_args pc f u = try match kind f with | Prod _ -> na Prod_cs | Sort s -> na (Sort_cs (Sorts.family s)) - | Const (c',_) when Constant.equal c' pc -> nargs_of_proj u.up_f - | Proj (c',_) when Constant.equal (Projection.constant c') pc -> nargs_of_proj u.up_f + | Const (c',_) when Constant.CanOrd.equal c' pc -> nargs_of_proj u.up_f + | Proj (c',_) when Constant.CanOrd.equal (Projection.constant c') pc -> nargs_of_proj u.up_f | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (fst @@ destRef f)) | _ -> -1 with Not_found -> -1 @@ -508,7 +508,7 @@ let filter_upat i0 f n u fpats = let () = if !i0 < np then i0 := n in (u, np) :: fpats let eq_prim_proj c t = match kind t with - | Proj(p,_) -> Constant.equal (Projection.constant p) c + | Proj(p,_) -> Constant.CanOrd.equal (Projection.constant p) c | _ -> false let filter_upat_FO i0 f n u fpats = diff --git a/plugins/ssrsearch/g_search.mlg b/plugins/ssrsearch/g_search.mlg index 5e002e09cc..54fdea0860 100644 --- a/plugins/ssrsearch/g_search.mlg +++ b/plugins/ssrsearch/g_search.mlg @@ -301,10 +301,6 @@ let ssrdisplaysearch gr env t = let pr_res = pr_global gr ++ str ":" ++ spc () ++ pr_lconstr_env env Evd.empty t in Feedback.msg_notice (hov 2 pr_res ++ fnl ()) -(* Remove the warning entirely when this plugin is loaded. *) -let _ = - Ssreflect_plugin.Ssrvernac.warn_search_moved_enabled := false - let deprecated_search = CWarnings.create ~name:"deprecated-ssr-search" diff --git a/plugins/syntax/dune b/plugins/syntax/dune index b395695c8a..f930fc265a 100644 --- a/plugins/syntax/dune +++ b/plugins/syntax/dune @@ -1,22 +1,8 @@ (library - (name numeral_notation_plugin) - (public_name coq.plugins.numeral_notation) - (synopsis "Coq numeral notation plugin") - (modules g_numeral numeral) - (libraries coq.vernac)) - -(library - (name string_notation_plugin) - (public_name coq.plugins.string_notation) - (synopsis "Coq string notation plugin") - (modules g_string string_notation) - (libraries coq.vernac)) - -(library - (name r_syntax_plugin) - (public_name coq.plugins.r_syntax) - (synopsis "Coq syntax plugin: reals") - (modules r_syntax) + (name number_string_notation_plugin) + (public_name coq.plugins.number_string_notation) + (synopsis "Coq number and string notation plugin") + (modules g_number_string string_notation number) (libraries coq.vernac)) (library @@ -33,4 +19,4 @@ (modules float_syntax) (libraries coq.vernac)) -(coq.pp (modules g_numeral g_string)) +(coq.pp (modules g_number_string)) diff --git a/plugins/syntax/g_number_string.mlg b/plugins/syntax/g_number_string.mlg new file mode 100644 index 0000000000..c8badd238d --- /dev/null +++ b/plugins/syntax/g_number_string.mlg @@ -0,0 +1,110 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +DECLARE PLUGIN "number_string_notation_plugin" + +{ + +open Notation +open Number +open String_notation +open Pp +open Names +open Stdarg +open Pcoq.Prim + +let pr_number_after = function + | Nop -> mt () + | Warning n -> str "warning after " ++ NumTok.UnsignedNat.print n + | Abstract n -> str "abstract after " ++ NumTok.UnsignedNat.print n + +let pr_deprecated_number_modifier m = str "(" ++ pr_number_after m ++ str ")" + +let warn_deprecated_numeral_notation = + CWarnings.create ~name:"numeral-notation" ~category:"deprecated" + (fun () -> + strbrk "Numeral Notation is deprecated, please use Number Notation instead.") + +let pr_number_string_mapping (b, n, n') = + if b then + str "[" ++ Libnames.pr_qualid n ++ str "]" ++ spc () ++ str "=>" ++ spc () + ++ Libnames.pr_qualid n' + else + Libnames.pr_qualid n ++ spc () ++ str "=>" ++ spc () + ++ Libnames.pr_qualid n' + +let pr_number_string_via (n, l) = + str "via " ++ Libnames.pr_qualid n ++ str " mapping [" + ++ prlist_with_sep pr_comma pr_number_string_mapping l ++ str "]" + +let pr_number_modifier = function + | After a -> pr_number_after a + | Via nl -> pr_number_string_via nl + +let pr_number_options l = + str "(" ++ prlist_with_sep pr_comma pr_number_modifier l ++ str ")" + +let pr_string_option l = + str "(" ++ pr_number_string_via l ++ str ")" + +} + +VERNAC ARGUMENT EXTEND deprecated_number_modifier + PRINTED BY { pr_deprecated_number_modifier } +| [ ] -> { Nop } +| [ "(" "warning" "after" bignat(waft) ")" ] -> { Warning (NumTok.UnsignedNat.of_string waft) } +| [ "(" "abstract" "after" bignat(n) ")" ] -> { Abstract (NumTok.UnsignedNat.of_string n) } +END + +VERNAC ARGUMENT EXTEND number_string_mapping + PRINTED BY { pr_number_string_mapping } +| [ reference(n) "=>" reference(n') ] -> { false, n, n' } +| [ "[" reference(n) "]" "=>" reference(n') ] -> { true, n, n' } +END + +VERNAC ARGUMENT EXTEND number_string_via + PRINTED BY { pr_number_string_via } +| [ "via" reference(n) "mapping" "[" ne_number_string_mapping_list_sep(l, ",") "]" ] -> { n, l } +END + +VERNAC ARGUMENT EXTEND number_modifier + PRINTED BY { pr_number_modifier } +| [ "warning" "after" bignat(waft) ] -> { After (Warning (NumTok.UnsignedNat.of_string waft)) } +| [ "abstract" "after" bignat(n) ] -> { After (Abstract (NumTok.UnsignedNat.of_string n)) } +| [ number_string_via(v) ] -> { Via v } +END + +VERNAC ARGUMENT EXTEND number_options + PRINTED BY { pr_number_options } +| [ "(" ne_number_modifier_list_sep(l, ",") ")" ] -> { l } +END + +VERNAC ARGUMENT EXTEND string_option + PRINTED BY { pr_string_option } +| [ "(" number_string_via(v) ")" ] -> { v } +END + +VERNAC COMMAND EXTEND NumberNotation CLASSIFIED AS SIDEFF + | #[ locality = Attributes.locality; ] [ "Number" "Notation" reference(ty) reference(f) reference(g) number_options_opt(nl) ":" + ident(sc) ] -> + + { vernac_number_notation (Locality.make_module_locality locality) ty f g (Option.default [] nl) (Id.to_string sc) } + | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" + ident(sc) deprecated_number_modifier(o) ] -> + + { warn_deprecated_numeral_notation (); + vernac_number_notation (Locality.make_module_locality locality) ty f g [After o] (Id.to_string sc) } +END + +VERNAC COMMAND EXTEND StringNotation CLASSIFIED AS SIDEFF + | #[ locality = Attributes.locality; ] [ "String" "Notation" reference(ty) reference(f) reference(g) string_option_opt(o) ":" + ident(sc) ] -> + { vernac_string_notation (Locality.make_module_locality locality) ty f g o (Id.to_string sc) } +END diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg deleted file mode 100644 index c030925ea9..0000000000 --- a/plugins/syntax/g_numeral.mlg +++ /dev/null @@ -1,51 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -DECLARE PLUGIN "numeral_notation_plugin" - -{ - -open Notation -open Numeral -open Pp -open Names -open Stdarg -open Pcoq.Prim - -let pr_numnot_option = function - | Nop -> mt () - | Warning n -> str "(warning after " ++ NumTok.UnsignedNat.print n ++ str ")" - | Abstract n -> str "(abstract after " ++ NumTok.UnsignedNat.print n ++ str ")" - -let warn_deprecated_numeral_notation = - CWarnings.create ~name:"numeral-notation" ~category:"deprecated" - (fun () -> - strbrk "Numeral Notation is deprecated, please use Number Notation instead.") - -} - -VERNAC ARGUMENT EXTEND numnotoption - PRINTED BY { pr_numnot_option } -| [ ] -> { Nop } -| [ "(" "warning" "after" bignat(waft) ")" ] -> { Warning (NumTok.UnsignedNat.of_string waft) } -| [ "(" "abstract" "after" bignat(n) ")" ] -> { Abstract (NumTok.UnsignedNat.of_string n) } -END - -VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] [ "Number" "Notation" reference(ty) reference(f) reference(g) ":" - ident(sc) numnotoption(o) ] -> - - { vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } - | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" - ident(sc) numnotoption(o) ] -> - - { warn_deprecated_numeral_notation (); - vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } -END diff --git a/plugins/syntax/g_string.mlg b/plugins/syntax/g_string.mlg deleted file mode 100644 index 788f9e011d..0000000000 --- a/plugins/syntax/g_string.mlg +++ /dev/null @@ -1,25 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -DECLARE PLUGIN "string_notation_plugin" - -{ - -open String_notation -open Names -open Stdarg - -} - -VERNAC COMMAND EXTEND StringNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" - ident(sc) ] -> - { vernac_string_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) } -END diff --git a/plugins/syntax/int63_syntax.ml b/plugins/syntax/int63_syntax.ml index 5f4db8e800..b14b02f3bb 100644 --- a/plugins/syntax/int63_syntax.ml +++ b/plugins/syntax/int63_syntax.ml @@ -43,6 +43,7 @@ let _ = let id_int63 = Nametab.locate q_id_int63 in let o = { to_kind = Int63, Direct; to_ty = id_int63; + to_post = [||]; of_kind = Int63, Direct; of_ty = id_int63; ty_name = q_int63; @@ -50,7 +51,7 @@ let _ = enable_prim_token_interpretation { pt_local = false; pt_scope = int63_scope; - pt_interp_info = NumeralNotation o; + pt_interp_info = NumberNotation o; pt_required = (int63_path, int63_module); pt_refs = []; pt_in_match = false }) diff --git a/plugins/syntax/number.ml b/plugins/syntax/number.ml new file mode 100644 index 0000000000..89d757a72a --- /dev/null +++ b/plugins/syntax/number.ml @@ -0,0 +1,505 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open Util +open Names +open Libnames +open Constrexpr +open Constrexpr_ops +open Notation + +module CSet = CSet.Make (Constr) +module CMap = CMap.Make (Constr) + +(** * Number notation *) + +type number_string_via = qualid * (bool * qualid * qualid) list +type number_option = + | After of numnot_option + | Via of number_string_via + +let warn_abstract_large_num_no_op = + CWarnings.create ~name:"abstract-large-number-no-op" ~category:"numbers" + (fun f -> + strbrk "The 'abstract after' directive has no effect when " ++ + strbrk "the parsing function (" ++ + Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ") targets an " ++ + strbrk "option type.") + +let get_constructors ind = + let mib,oib = Global.lookup_inductive ind in + let mc = oib.Declarations.mind_consnames in + Array.to_list + (Array.mapi (fun j c -> GlobRef.ConstructRef (ind, j + 1)) mc) + +let qualid_of_ref n = + n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty + +let q_option () = qualid_of_ref "core.option.type" + +let unsafe_locate_ind q = + match Nametab.locate q with + | GlobRef.IndRef i -> i + | _ -> raise Not_found + +let locate_z () = + let zn = "num.Z.type" in + let pn = "num.pos.type" in + if Coqlib.has_ref zn && Coqlib.has_ref pn + then + let q_z = qualid_of_ref zn in + let q_pos = qualid_of_ref pn in + Some ({ + z_ty = unsafe_locate_ind q_z; + pos_ty = unsafe_locate_ind q_pos; + }, mkRefC q_z) + else None + +let locate_number () = + let dint = "num.int.type" in + let duint = "num.uint.type" in + let dec = "num.decimal.type" in + let hint = "num.hexadecimal_int.type" in + let huint = "num.hexadecimal_uint.type" in + let hex = "num.hexadecimal.type" in + let int = "num.num_int.type" in + let uint = "num.num_uint.type" in + let num = "num.number.type" in + if Coqlib.has_ref dint && Coqlib.has_ref duint && Coqlib.has_ref dec + && Coqlib.has_ref hint && Coqlib.has_ref huint && Coqlib.has_ref hex + && Coqlib.has_ref int && Coqlib.has_ref uint && Coqlib.has_ref num + then + let q_dint = qualid_of_ref dint in + let q_duint = qualid_of_ref duint in + let q_dec = qualid_of_ref dec in + let q_hint = qualid_of_ref hint in + let q_huint = qualid_of_ref huint in + let q_hex = qualid_of_ref hex in + let q_int = qualid_of_ref int in + let q_uint = qualid_of_ref uint in + let q_num = qualid_of_ref num in + let int_ty = { + dec_int = unsafe_locate_ind q_dint; + dec_uint = unsafe_locate_ind q_duint; + hex_int = unsafe_locate_ind q_hint; + hex_uint = unsafe_locate_ind q_huint; + int = unsafe_locate_ind q_int; + uint = unsafe_locate_ind q_uint; + } in + let num_ty = { + int = int_ty; + decimal = unsafe_locate_ind q_dec; + hexadecimal = unsafe_locate_ind q_hex; + number = unsafe_locate_ind q_num; + } in + Some (int_ty, mkRefC q_int, mkRefC q_uint, mkRefC q_dint, mkRefC q_duint, + num_ty, mkRefC q_num, mkRefC q_dec) + else None + +let locate_int63 () = + let int63n = "num.int63.type" in + if Coqlib.has_ref int63n + then + let q_int63 = qualid_of_ref int63n in + Some (mkRefC q_int63) + else None + +let has_type env sigma f ty = + let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in + try let _ = Constrintern.interp_constr env sigma c in true + with Pretype_errors.PretypeError _ -> false + +let type_error_to f ty = + CErrors.user_err + (pr_qualid f ++ str " should go from Number.int to " ++ + pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ + fnl () ++ str "Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first).") + +let type_error_of g ty = + CErrors.user_err + (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ + str " to Number.int or (option Number.int)." ++ fnl () ++ + str "Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first).") + +let warn_deprecated_decimal = + CWarnings.create ~name:"decimal-numeral-notation" ~category:"deprecated" + (fun () -> + strbrk "Deprecated Number Notation for Decimal.uint, \ + Decimal.int or Decimal.decimal. Use Number.uint, \ + Number.int or Number.number respectively.") + +let error_params ind = + CErrors.user_err + (str "Wrong number of parameters for inductive" ++ spc () + ++ Printer.pr_global (GlobRef.IndRef ind) ++ str ".") + +let remapping_error ?loc ty ty' ty'' = + CErrors.user_err ?loc + (Printer.pr_global ty + ++ str " was already mapped to" ++ spc () ++ Printer.pr_global ty' + ++ str " and cannot be remapped to" ++ spc () ++ Printer.pr_global ty'' + ++ str ".") + +let error_missing c = + CErrors.user_err + (str "Missing mapping for constructor " ++ Printer.pr_global c ++ str ".") + +let pr_constr env sigma c = + let c = Constrextern.extern_constr env sigma (EConstr.of_constr c) in + Ppconstr.pr_constr_expr env sigma c + +let warn_via_remapping = + CWarnings.create ~name:"via-type-remapping" ~category:"numbers" + (fun (env, sigma, ty, ty', ty'') -> + let constr = pr_constr env sigma in + constr ty ++ str " was already mapped to" ++ spc () ++ constr ty' + ++ str ", mapping it also to" ++ spc () ++ constr ty'' + ++ str " might yield ill typed terms when using the notation.") + +let warn_via_type_mismatch = + CWarnings.create ~name:"via-type-mismatch" ~category:"numbers" + (fun (env, sigma, g, g', exp, actual) -> + let constr = pr_constr env sigma in + str "Type of" ++ spc() ++ Printer.pr_global g + ++ str " seems incompatible with the type of" ++ spc () + ++ Printer.pr_global g' ++ str "." ++ spc () + ++ str "Expected type is: " ++ constr exp ++ spc () + ++ str "instead of " ++ constr actual ++ str "." ++ spc () + ++ str "This might yield ill typed terms when using the notation.") + +let multiple_via_error () = + CErrors.user_err (Pp.str "Multiple 'via' options.") + +let multiple_after_error () = + CErrors.user_err (Pp.str "Multiple 'warning after' or 'abstract after' options.") + +let via_abstract_error () = + CErrors.user_err (Pp.str "'via' and 'abstract' cannot be used together.") + +let locate_global_sort_inductive_or_constant sigma qid = + let locate_sort qid = + match Nametab.locate_extended qid with + | Globnames.TrueGlobal _ -> raise Not_found + | Globnames.SynDef kn -> + match Syntax_def.search_syntactic_definition kn with + | [], Notation_term.NSort r -> + let sigma,c = Evd.fresh_sort_in_family sigma (Glob_ops.glob_sort_family r) in + sigma,Constr.mkSort c + | _ -> raise Not_found in + try locate_sort qid + with Not_found -> + match Smartlocate.global_with_alias qid with + | GlobRef.IndRef i -> sigma, Constr.mkInd i + | _ -> sigma, Constr.mkConst (Smartlocate.global_constant_with_alias qid) + +let locate_global_constructor_inductive_or_constant qid = + let g = Smartlocate.global_with_alias qid in + match g with + | GlobRef.ConstructRef c -> g, Constr.mkConstruct c + | GlobRef.IndRef i -> g, Constr.mkInd i + | _ -> g, Constr.mkConst (Smartlocate.global_constant_with_alias qid) + +(* [get_type env sigma c] retrieves the type of [c] and returns a pair + [l, t] such that [c : l_0 -> ... -> l_n -> t]. *) +let get_type env sigma c = + (* inspired from [compute_implicit_names] in "interp/impargs.ml" *) + let rec aux env acc t = + let t = Reductionops.whd_all env sigma t in + match EConstr.kind sigma t with + | Constr.Prod (na, a, b) -> + let a = Reductionops.whd_all env sigma a in + let rel = Context.Rel.Declaration.LocalAssum (na, a) in + aux (EConstr.push_rel rel env) ((na, a) :: acc) b + | _ -> List.rev acc, t in + let t = Retyping.get_type_of env sigma (EConstr.of_constr c) in + let l, t = aux env [] t in + List.map (fun (na, a) -> na, EConstr.Unsafe.to_constr a) l, + EConstr.Unsafe.to_constr t + +(* [elaborate_to_post_params env sigma ty_ind params] builds the + [to_post] translation (c.f., interp/notation.mli) for the numeral + notation to parse/print type [ty_ind]. This translation is the + identity ([ToPostCopy]) except that it checks ([ToPostCheck]) that + the parameters of the inductive type [ty_ind] match the ones given + in [params]. *) +let elaborate_to_post_params env sigma ty_ind params = + let to_post_for_constructor indc = + let sigma, c = match indc with + | GlobRef.ConstructRef c -> + let sigma,c = Evd.fresh_constructor_instance env sigma c in + sigma, Constr.mkConstructU c + | _ -> assert false in (* c.f. get_constructors *) + let args, t = get_type env sigma c in + let params_indc = match Constr.kind t with + | Constr.App (_, a) -> Array.to_list a | _ -> [] in + let sz = List.length args in + let a = Array.make sz ToPostCopy in + if List.length params <> List.length params_indc then error_params ty_ind; + List.iter2 (fun param param_indc -> + match param, Constr.kind param_indc with + | Some p, Constr.Rel i when i <= sz -> a.(sz - i) <- ToPostCheck p + | _ -> ()) + params params_indc; + indc, indc, Array.to_list a in + let pt_refs = get_constructors ty_ind in + let to_post_0 = List.map to_post_for_constructor pt_refs in + let to_post = + let only_copy (_, _, args) = List.for_all ((=) ToPostCopy) args in + if (List.for_all only_copy to_post_0) then [||] else [|to_post_0|] in + to_post, pt_refs + +(* [elaborate_to_post_via env sigma ty_name ty_ind l] builds the [to_post] + translation (c.f., interp/notation.mli) for the number notation to + parse/print type [ty_name] through the inductive [ty_ind] according + to the pairs [constant, constructor] in the list [l]. *) +let elaborate_to_post_via env sigma ty_name ty_ind l = + let sigma, ty_name = + locate_global_sort_inductive_or_constant sigma ty_name in + let ty_ind = Constr.mkInd ty_ind in + (* Retrieve constants and constructors mappings and their type. + For each constant [cnst] and inductive constructor [indc] in [l], retrieve: + * its location: [lcnst] and [lindc] + * its GlobRef: [cnst] and [indc] + * its type: [tcnst] and [tindc] (decomposed in product by [get_type] above) + * [impls] are the implicit arguments of [cnst] *) + let l = + let read (consider_implicits, cnst, indc) = + let lcnst, lindc = cnst.CAst.loc, indc.CAst.loc in + let cnst, ccnst = locate_global_constructor_inductive_or_constant cnst in + let indc, cindc = + let indc = Smartlocate.global_constructor_with_alias indc in + GlobRef.ConstructRef indc, Constr.mkConstruct indc in + let get_type_wo_params c = + (* ignore parameters of inductive types *) + let rm_params c = match Constr.kind c with + | Constr.App (c, _) when Constr.isInd c -> c + | _ -> c in + let lc, tc = get_type env sigma c in + List.map (fun (n, c) -> n, rm_params c) lc, rm_params tc in + let tcnst, tindc = get_type_wo_params ccnst, get_type_wo_params cindc in + let impls = + if not consider_implicits then [] else + Impargs.(select_stronger_impargs (implicits_of_global cnst)) in + lcnst, cnst, tcnst, lindc, indc, tindc, impls in + List.map read l in + let eq_indc indc (_, _, _, _, indc', _, _) = GlobRef.equal indc indc' in + (* Collect all inductive types involved. + That is [ty_ind] and all final codomains of [tindc] above. *) + let inds = + List.fold_left (fun s (_, _, _, _, _, tindc, _) -> CSet.add (snd tindc) s) + (CSet.singleton ty_ind) l in + (* And for each inductive, retrieve its constructors. *) + let constructors = + CSet.fold (fun ind m -> + let inductive, _ = Constr.destInd ind in + CMap.add ind (get_constructors inductive) m) + inds CMap.empty in + (* Error if one [constructor] in some inductive in [inds] + doesn't appear exactly once in [l] *) + let _ = (* check_for duplicate constructor and error *) + List.fold_left (fun already_seen (_, cnst, _, loc, indc, _, _) -> + try + let cnst' = List.assoc_f GlobRef.equal indc already_seen in + remapping_error ?loc indc cnst' cnst + with Not_found -> (indc, cnst) :: already_seen) + [] l in + let () = (* check for missing constructor and error *) + CMap.iter (fun _ -> + List.iter (fun cstr -> + if not (List.exists (eq_indc cstr) l) then error_missing cstr)) + constructors in + (* Perform some checks on types and warn if they look strange. + These checks are neither sound nor complete, so we only warn. *) + let () = + (* associate inductives to types, and check that this mapping is one to one + and maps [ty_ind] to [ty_name] *) + let ind2ty, ty2ind = + let add loc ckey cval m = + match CMap.find_opt ckey m with + | None -> CMap.add ckey cval m + | Some old_cval -> + if not (Constr.equal old_cval cval) then + warn_via_remapping ?loc (env, sigma, ckey, old_cval, cval); + m in + List.fold_left + (fun (ind2ty, ty2ind) (lcnst, _, (_, tcnst), lindc, _, (_, tindc), _) -> + add lcnst tindc tcnst ind2ty, add lindc tcnst tindc ty2ind) + CMap.(singleton ty_ind ty_name, singleton ty_name ty_ind) l in + (* check that type of constants and constructors mapped in [l] + match modulo [ind2ty] *) + let rm_impls impls (l, t) = + let rec aux impls l = match impls, l with + | Some _ :: impls, _ :: b -> aux impls b + | None :: impls, (n, a) :: b -> (n, a) :: aux impls b + | _ -> l in + aux impls l, t in + let replace m (l, t) = + let apply_m c = try CMap.find c m with Not_found -> c in + List.fold_right (fun (na, a) b -> Constr.mkProd (na, (apply_m a), b)) + l (apply_m t) in + List.iter (fun (_, cnst, tcnst, loc, indc, tindc, impls) -> + let tcnst = rm_impls impls tcnst in + let tcnst' = replace CMap.empty tcnst in + if not (Constr.equal tcnst' (replace ind2ty tindc)) then + let actual = replace CMap.empty tindc in + let expected = replace ty2ind tcnst in + warn_via_type_mismatch ?loc (env, sigma, indc, cnst, expected, actual)) + l in + (* Associate an index to each inductive, starting from 0 for [ty_ind]. *) + let ind2num, num2ind, nb_ind = + CMap.fold (fun ind _ (ind2num, num2ind, i) -> + CMap.add ind i ind2num, Int.Map.add i ind num2ind, i + 1) + (CMap.remove ty_ind constructors) + (CMap.singleton ty_ind 0, Int.Map.singleton 0 ty_ind, 1) in + (* Finally elaborate [to_post] *) + let to_post = + let rec map_prod impls tindc = match impls with + | Some _ :: impls -> ToPostHole :: map_prod impls tindc + | _ -> + match tindc with + | [] -> [] + | (_, a) :: b -> + let t = match CMap.find_opt a ind2num with + | Some i -> ToPostAs i + | None -> ToPostCopy in + let impls = match impls with [] -> [] | _ :: t -> t in + t :: map_prod impls b in + Array.init nb_ind (fun i -> + List.map (fun indc -> + let _, cnst, _, _, _, tindc, impls = List.find (eq_indc indc) l in + indc, cnst, map_prod impls (fst tindc)) + (CMap.find (Int.Map.find i num2ind) constructors)) in + (* and use constants mapped to constructors of [ty_ind] as triggers. *) + let pt_refs = List.map (fun (_, cnst, _) -> cnst) (to_post.(0)) in + to_post, pt_refs + +let locate_global_inductive allow_params qid = + let locate_param_inductive qid = + match Nametab.locate_extended qid with + | Globnames.TrueGlobal _ -> raise Not_found + | Globnames.SynDef kn -> + match Syntax_def.search_syntactic_definition kn with + | [], Notation_term.(NApp (NRef (GlobRef.IndRef i), l)) when allow_params -> + i, + List.map (function + | Notation_term.NRef r -> Some r + | Notation_term.NHole _ -> None + | _ -> raise Not_found) l + | _ -> raise Not_found in + try locate_param_inductive qid + with Not_found -> Smartlocate.global_inductive_with_alias qid, [] + +let vernac_number_notation local ty f g opts scope = + let rec parse_opts = function + | [] -> None, Nop + | h :: opts -> + let via, opts = parse_opts opts in + let via = match h, via with + | Via _, Some _ -> multiple_via_error () + | Via v, None -> Some v + | _ -> via in + let opts = match h, opts with + | After _, (Warning _ | Abstract _) -> multiple_after_error () + | After a, Nop -> a + | _ -> opts in + via, opts in + let via, opts = parse_opts opts in + (match via, opts with Some _, Abstract _ -> via_abstract_error () | _ -> ()); + let env = Global.env () in + let sigma = Evd.from_env env in + let num_ty = locate_number () in + let z_pos_ty = locate_z () in + let int63_ty = locate_int63 () in + let ty_name = ty in + let ty, via = + match via with None -> ty, via | Some (ty', a) -> ty', Some (ty, a) in + let tyc, params = locate_global_inductive (via = None) ty in + let to_ty = Smartlocate.global_with_alias f in + let of_ty = Smartlocate.global_with_alias g in + let cty = mkRefC ty in + let app x y = mkAppC (x,[y]) in + let arrow x y = + mkProdC ([CAst.make Anonymous],Default Glob_term.Explicit, x, y) + in + let opt r = app (mkRefC (q_option ())) r in + (* Check the type of f *) + let to_kind = + match num_ty with + | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma f (arrow cint cty) -> Int int_ty, Direct + | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> Int int_ty, Option + | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint cty) -> UInt int_ty, Direct + | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty, Option + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum cty) -> Number num_ty, Direct + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum (opt cty)) -> Number num_ty, Option + | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint cty) -> DecimalInt int_ty, Direct + | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> DecimalInt int_ty, Option + | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint cty) -> DecimalUInt int_ty, Direct + | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> DecimalUInt int_ty, Option + | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec cty) -> Decimal num_ty, Direct + | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec (opt cty)) -> Decimal num_ty, Option + | _ -> + match z_pos_ty with + | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ cty) -> Z z_pos_ty, Direct + | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ (opt cty)) -> Z z_pos_ty, Option + | _ -> + match int63_ty with + | Some cint63 when has_type env sigma f (arrow cint63 cty) -> Int63, Direct + | Some cint63 when has_type env sigma f (arrow cint63 (opt cty)) -> Int63, Option + | _ -> type_error_to f ty + in + (* Check the type of g *) + let of_kind = + match num_ty with + | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty cint) -> Int int_ty, Direct + | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> Int int_ty, Option + | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty cuint) -> UInt int_ty, Direct + | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty, Option + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty cnum) -> Number num_ty, Direct + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty (opt cnum)) -> Number num_ty, Option + | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty cint) -> DecimalInt int_ty, Direct + | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> DecimalInt int_ty, Option + | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty cuint) -> DecimalUInt int_ty, Direct + | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> DecimalUInt int_ty, Option + | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty cdec) -> Decimal num_ty, Direct + | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty (opt cdec)) -> Decimal num_ty, Option + | _ -> + match z_pos_ty with + | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty cZ) -> Z z_pos_ty, Direct + | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty (opt cZ)) -> Z z_pos_ty, Option + | _ -> + match int63_ty with + | Some cint63 when has_type env sigma g (arrow cty cint63) -> Int63, Direct + | Some cint63 when has_type env sigma g (arrow cty (opt cint63)) -> Int63, Option + | _ -> type_error_of g ty + in + (match to_kind, of_kind with + | ((DecimalInt _ | DecimalUInt _ | Decimal _), _), _ + | _, ((DecimalInt _ | DecimalUInt _ | Decimal _), _) -> + warn_deprecated_decimal () + | _ -> ()); + let to_post, pt_refs = match via with + | None -> elaborate_to_post_params env sigma tyc params + | Some (ty, l) -> elaborate_to_post_via env sigma ty tyc l in + let o = { to_kind; to_ty; to_post; of_kind; of_ty; ty_name; + warning = opts } + in + (match opts, to_kind with + | Abstract _, (_, Option) -> warn_abstract_large_num_no_op o.to_ty + | _ -> ()); + let i = + { pt_local = local; + pt_scope = scope; + pt_interp_info = NumberNotation o; + pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; + pt_refs; + pt_in_match = true } + in + enable_prim_token_interpretation i diff --git a/plugins/syntax/number.mli b/plugins/syntax/number.mli new file mode 100644 index 0000000000..d7d28b29ed --- /dev/null +++ b/plugins/syntax/number.mli @@ -0,0 +1,31 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Libnames +open Vernacexpr +open Notation + +(** * Number notation *) + +type number_string_via = qualid * (bool * qualid * qualid) list +type number_option = + | After of numnot_option + | Via of number_string_via + +val vernac_number_notation : locality_flag -> + qualid -> + qualid -> qualid -> + number_option list -> + Notation_term.scope_name -> unit + +(** These are also used in string notations *) +val locate_global_inductive : bool -> Libnames.qualid -> Names.inductive * Names.GlobRef.t option list +val elaborate_to_post_params : Environ.env -> Evd.evar_map -> Names.inductive -> Names.GlobRef.t option list -> (Names.GlobRef.t * Names.GlobRef.t * Notation.to_post_arg list) list array * Names.GlobRef.t list +val elaborate_to_post_via : Environ.env -> Evd.evar_map -> Libnames.qualid -> Names.inductive -> (bool * Libnames.qualid * Libnames.qualid) list -> (Names.GlobRef.t * Names.GlobRef.t * Notation.to_post_arg list) list array * Names.GlobRef.t list diff --git a/plugins/syntax/number_string_notation_plugin.mlpack b/plugins/syntax/number_string_notation_plugin.mlpack new file mode 100644 index 0000000000..74c32d3a53 --- /dev/null +++ b/plugins/syntax/number_string_notation_plugin.mlpack @@ -0,0 +1,3 @@ +Number +String_notation +G_number_string diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml deleted file mode 100644 index 2db76719b8..0000000000 --- a/plugins/syntax/numeral.ml +++ /dev/null @@ -1,217 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Pp -open Util -open Names -open Libnames -open Constrexpr -open Constrexpr_ops -open Notation - -(** * Numeral notation *) - -let warn_abstract_large_num_no_op = - CWarnings.create ~name:"abstract-large-number-no-op" ~category:"numbers" - (fun f -> - strbrk "The 'abstract after' directive has no effect when " ++ - strbrk "the parsing function (" ++ - Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ") targets an " ++ - strbrk "option type.") - -let get_constructors ind = - let mib,oib = Global.lookup_inductive ind in - let mc = oib.Declarations.mind_consnames in - Array.to_list - (Array.mapi (fun j c -> GlobRef.ConstructRef (ind, j + 1)) mc) - -let qualid_of_ref n = - n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty - -let q_option () = qualid_of_ref "core.option.type" - -let unsafe_locate_ind q = - match Nametab.locate q with - | GlobRef.IndRef i -> i - | _ -> raise Not_found - -let locate_z () = - let zn = "num.Z.type" in - let pn = "num.pos.type" in - if Coqlib.has_ref zn && Coqlib.has_ref pn - then - let q_z = qualid_of_ref zn in - let q_pos = qualid_of_ref pn in - Some ({ - z_ty = unsafe_locate_ind q_z; - pos_ty = unsafe_locate_ind q_pos; - }, mkRefC q_z) - else None - -let locate_numeral () = - let dint = "num.int.type" in - let duint = "num.uint.type" in - let dec = "num.decimal.type" in - let hint = "num.hexadecimal_int.type" in - let huint = "num.hexadecimal_uint.type" in - let hex = "num.hexadecimal.type" in - let int = "num.num_int.type" in - let uint = "num.num_uint.type" in - let num = "num.numeral.type" in - if Coqlib.has_ref dint && Coqlib.has_ref duint && Coqlib.has_ref dec - && Coqlib.has_ref hint && Coqlib.has_ref huint && Coqlib.has_ref hex - && Coqlib.has_ref int && Coqlib.has_ref uint && Coqlib.has_ref num - then - let q_dint = qualid_of_ref dint in - let q_duint = qualid_of_ref duint in - let q_dec = qualid_of_ref dec in - let q_hint = qualid_of_ref hint in - let q_huint = qualid_of_ref huint in - let q_hex = qualid_of_ref hex in - let q_int = qualid_of_ref int in - let q_uint = qualid_of_ref uint in - let q_num = qualid_of_ref num in - let int_ty = { - dec_int = unsafe_locate_ind q_dint; - dec_uint = unsafe_locate_ind q_duint; - hex_int = unsafe_locate_ind q_hint; - hex_uint = unsafe_locate_ind q_huint; - int = unsafe_locate_ind q_int; - uint = unsafe_locate_ind q_uint; - } in - let num_ty = { - int = int_ty; - decimal = unsafe_locate_ind q_dec; - hexadecimal = unsafe_locate_ind q_hex; - numeral = unsafe_locate_ind q_num; - } in - Some (int_ty, mkRefC q_int, mkRefC q_uint, mkRefC q_dint, mkRefC q_duint, - num_ty, mkRefC q_num, mkRefC q_dec) - else None - -let locate_int63 () = - let int63n = "num.int63.type" in - if Coqlib.has_ref int63n - then - let q_int63 = qualid_of_ref int63n in - Some (mkRefC q_int63) - else None - -let has_type env sigma f ty = - let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in - try let _ = Constrintern.interp_constr env sigma c in true - with Pretype_errors.PretypeError _ -> false - -let type_error_to f ty = - CErrors.user_err - (pr_qualid f ++ str " should go from Numeral.int to " ++ - pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ - fnl () ++ str "Instead of Numeral.int, the types Numeral.uint or Z or Int63.int or Numeral.numeral could be used (you may need to require BinNums or Numeral or Int63 first).") - -let type_error_of g ty = - CErrors.user_err - (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ - str " to Numeral.int or (option Numeral.int)." ++ fnl () ++ - str "Instead of Numeral.int, the types Numeral.uint or Z or Int63.int or Numeral.numeral could be used (you may need to require BinNums or Numeral or Int63 first).") - -let warn_deprecated_decimal = - CWarnings.create ~name:"decimal-numeral-notation" ~category:"deprecated" - (fun () -> - strbrk "Deprecated Numeral Notation for Decimal.uint, \ - Decimal.int or Decimal.decimal. Use Numeral.uint, \ - Numeral.int or Numeral.numeral respectively.") - -let vernac_numeral_notation local ty f g scope opts = - let env = Global.env () in - let sigma = Evd.from_env env in - let num_ty = locate_numeral () in - let z_pos_ty = locate_z () in - let int63_ty = locate_int63 () in - let tyc = Smartlocate.global_inductive_with_alias ty in - let to_ty = Smartlocate.global_with_alias f in - let of_ty = Smartlocate.global_with_alias g in - let cty = mkRefC ty in - let app x y = mkAppC (x,[y]) in - let arrow x y = - mkProdC ([CAst.make Anonymous],Default Glob_term.Explicit, x, y) - in - let opt r = app (mkRefC (q_option ())) r in - let constructors = get_constructors tyc in - (* Check the type of f *) - let to_kind = - match num_ty with - | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma f (arrow cint cty) -> Int int_ty, Direct - | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> Int int_ty, Option - | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint cty) -> UInt int_ty, Direct - | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty, Option - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum cty) -> Numeral num_ty, Direct - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum (opt cty)) -> Numeral num_ty, Option - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint cty) -> DecimalInt int_ty, Direct - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> DecimalInt int_ty, Option - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint cty) -> DecimalUInt int_ty, Direct - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> DecimalUInt int_ty, Option - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec cty) -> Decimal num_ty, Direct - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec (opt cty)) -> Decimal num_ty, Option - | _ -> - match z_pos_ty with - | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ cty) -> Z z_pos_ty, Direct - | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ (opt cty)) -> Z z_pos_ty, Option - | _ -> - match int63_ty with - | Some cint63 when has_type env sigma f (arrow cint63 cty) -> Int63, Direct - | Some cint63 when has_type env sigma f (arrow cint63 (opt cty)) -> Int63, Option - | _ -> type_error_to f ty - in - (* Check the type of g *) - let of_kind = - match num_ty with - | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty cint) -> Int int_ty, Direct - | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> Int int_ty, Option - | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty cuint) -> UInt int_ty, Direct - | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty, Option - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty cnum) -> Numeral num_ty, Direct - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty (opt cnum)) -> Numeral num_ty, Option - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty cint) -> DecimalInt int_ty, Direct - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> DecimalInt int_ty, Option - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty cuint) -> DecimalUInt int_ty, Direct - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> DecimalUInt int_ty, Option - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty cdec) -> Decimal num_ty, Direct - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty (opt cdec)) -> Decimal num_ty, Option - | _ -> - match z_pos_ty with - | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty cZ) -> Z z_pos_ty, Direct - | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty (opt cZ)) -> Z z_pos_ty, Option - | _ -> - match int63_ty with - | Some cint63 when has_type env sigma g (arrow cty cint63) -> Int63, Direct - | Some cint63 when has_type env sigma g (arrow cty (opt cint63)) -> Int63, Option - | _ -> type_error_of g ty - in - (match to_kind, of_kind with - | ((DecimalInt _ | DecimalUInt _ | Decimal _), _), _ - | _, ((DecimalInt _ | DecimalUInt _ | Decimal _), _) -> - warn_deprecated_decimal () - | _ -> ()); - let o = { to_kind; to_ty; of_kind; of_ty; - ty_name = ty; - warning = opts } - in - (match opts, to_kind with - | Abstract _, (_, Option) -> warn_abstract_large_num_no_op o.to_ty - | _ -> ()); - let i = - { pt_local = local; - pt_scope = scope; - pt_interp_info = NumeralNotation o; - pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; - pt_refs = constructors; - pt_in_match = true } - in - enable_prim_token_interpretation i diff --git a/plugins/syntax/numeral.mli b/plugins/syntax/numeral.mli deleted file mode 100644 index 99252484b4..0000000000 --- a/plugins/syntax/numeral.mli +++ /dev/null @@ -1,19 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Libnames -open Vernacexpr -open Notation - -(** * Numeral notation *) - -val vernac_numeral_notation : locality_flag -> - qualid -> qualid -> qualid -> - Notation_term.scope_name -> numnot_option -> unit diff --git a/plugins/syntax/numeral_notation_plugin.mlpack b/plugins/syntax/numeral_notation_plugin.mlpack deleted file mode 100644 index f4d9cae3ff..0000000000 --- a/plugins/syntax/numeral_notation_plugin.mlpack +++ /dev/null @@ -1,2 +0,0 @@ -Numeral -G_numeral diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml deleted file mode 100644 index d66b9537b4..0000000000 --- a/plugins/syntax/r_syntax.ml +++ /dev/null @@ -1,214 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Util -open Names -open Glob_term - -(* Poor's man DECLARE PLUGIN *) -let __coq_plugin_name = "r_syntax_plugin" -let () = Mltop.add_known_module __coq_plugin_name - -exception Non_closed_number - -(**********************************************************************) -(* Parsing positive via scopes *) -(**********************************************************************) - -let binnums = ["Coq";"Numbers";"BinNums"] - -let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) - -let is_gr c gr = match DAst.get c with -| GRef (r, _) -> GlobRef.equal r gr -| _ -> false - -let positive_modpath = MPfile (make_dir binnums) - -let positive_kn = MutInd.make2 positive_modpath (Label.make "positive") -let path_of_xI = ((positive_kn,0),1) -let path_of_xO = ((positive_kn,0),2) -let path_of_xH = ((positive_kn,0),3) -let glob_xI = GlobRef.ConstructRef path_of_xI -let glob_xO = GlobRef.ConstructRef path_of_xO -let glob_xH = GlobRef.ConstructRef path_of_xH - -let pos_of_bignat ?loc x = - let ref_xI = DAst.make @@ GRef (glob_xI, None) in - let ref_xH = DAst.make @@ GRef (glob_xH, None) in - let ref_xO = DAst.make @@ GRef (glob_xO, None) in - let rec pos_of x = - match Z.(div_rem x (of_int 2)) with - | (q,rem) when rem = Z.zero -> DAst.make @@ GApp (ref_xO,[pos_of q]) - | (q,_) when not Z.(equal q zero) -> DAst.make @@ GApp (ref_xI,[pos_of q]) - | (q,_) -> ref_xH - in - pos_of x - -(**********************************************************************) -(* Printing positive via scopes *) -(**********************************************************************) - -let rec bignat_of_pos c = match DAst.get c with - | GApp (r, [a]) when is_gr r glob_xO -> Z.mul Z.(of_int 2) (bignat_of_pos a) - | GApp (r, [a]) when is_gr r glob_xI -> Z.add Z.one Z.(mul (of_int 2) (bignat_of_pos a)) - | GRef (a, _) when GlobRef.equal a glob_xH -> Z.one - | _ -> raise Non_closed_number - -(**********************************************************************) -(* Parsing Z via scopes *) -(**********************************************************************) - -let z_kn = MutInd.make2 positive_modpath (Label.make "Z") -let path_of_ZERO = ((z_kn,0),1) -let path_of_POS = ((z_kn,0),2) -let path_of_NEG = ((z_kn,0),3) -let glob_ZERO = GlobRef.ConstructRef path_of_ZERO -let glob_POS = GlobRef.ConstructRef path_of_POS -let glob_NEG = GlobRef.ConstructRef path_of_NEG - -let z_of_int ?loc n = - if not Z.(equal n zero) then - let sgn, n = - if Z.(leq zero n) then glob_POS, n else glob_NEG, Z.neg n in - DAst.make @@ GApp(DAst.make @@ GRef (sgn,None), [pos_of_bignat ?loc n]) - else - DAst.make @@ GRef (glob_ZERO, None) - -(**********************************************************************) -(* Printing Z via scopes *) -(**********************************************************************) - -let bigint_of_z c = match DAst.get c with - | GApp (r,[a]) when is_gr r glob_POS -> bignat_of_pos a - | GApp (r,[a]) when is_gr r glob_NEG -> Z.neg (bignat_of_pos a) - | GRef (a, _) when GlobRef.equal a glob_ZERO -> Z.zero - | _ -> raise Non_closed_number - -(**********************************************************************) -(* Parsing R via scopes *) -(**********************************************************************) - -let rdefinitions = ["Coq";"Reals";"Rdefinitions"] -let r_modpath = MPfile (make_dir rdefinitions) -let r_base_modpath = MPdot (r_modpath, Label.make "RbaseSymbolsImpl") -let r_path = make_path ["Coq";"Reals";"Rdefinitions";"RbaseSymbolsImpl"] "R" - -let glob_IZR = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "IZR") -let glob_Rmult = GlobRef.ConstRef (Constant.make2 r_base_modpath @@ Label.make "Rmult") -let glob_Rdiv = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "Rdiv") - -let binintdef = ["Coq";"ZArith";"BinIntDef"] -let z_modpath = MPdot (MPfile (make_dir binintdef), Label.make "Z") - -let glob_pow_pos = GlobRef.ConstRef (Constant.make2 z_modpath @@ Label.make "pow_pos") - -let r_of_rawnum ?loc n = - let n,e = NumTok.Signed.to_bigint_and_exponent n in - let e,p = NumTok.(match e with EDec e -> e, 10 | EBin e -> e, 2) in - let izr z = - DAst.make @@ GApp (DAst.make @@ GRef(glob_IZR,None), [z]) in - let rmult r r' = - DAst.make @@ GApp (DAst.make @@ GRef(glob_Rmult,None), [r; r']) in - let rdiv r r' = - DAst.make @@ GApp (DAst.make @@ GRef(glob_Rdiv,None), [r; r']) in - let pow p e = - let p = z_of_int ?loc (Z.of_int p) in - let e = pos_of_bignat e in - DAst.make @@ GApp (DAst.make @@ GRef(glob_pow_pos,None), [p; e]) in - let n = - izr (z_of_int ?loc n) in - if Int.equal (Z.sign e) 1 then rmult n (izr (pow p e)) - else if Int.equal (Z.sign e) (-1) then rdiv n (izr (pow p (Z.neg e))) - else n (* e = 0 *) - -(**********************************************************************) -(* Printing R via scopes *) -(**********************************************************************) - -let rawnum_of_r c = - (* print i * 10^e, precondition: e <> 0 *) - let numTok_of_int_exp i e = - (* choose between 123e-2 and 1.23, this is purely heuristic - and doesn't play any soundness role *) - let choose_exponent = - if Int.equal (Z.sign e) 1 then - true (* don't print 12 * 10^2 as 1200 to distinguish them *) - else - let i = Z.to_string i in - let li = if i.[0] = '-' then String.length i - 1 else String.length i in - let e = Z.neg e in - let le = String.length (Z.to_string e) in - Z.(lt (add (of_int li) (of_int le)) e) in - (* print 123 * 10^-2 as 123e-2 *) - let numTok_exponent () = - NumTok.Signed.of_bigint_and_exponent i (NumTok.EDec e) in - (* print 123 * 10^-2 as 1.23, precondition e < 0 *) - let numTok_dot () = - let s, i = - if Z.sign i >= 0 then NumTok.SPlus, Z.to_string i - else NumTok.SMinus, Z.(to_string (neg i)) in - let ni = String.length i in - let e = - (Z.to_int e) in - assert (e > 0); - let i, f = - if e < ni then String.sub i 0 (ni - e), String.sub i (ni - e) e - else "0", String.make (e - ni) '0' ^ i in - let i = s, NumTok.UnsignedNat.of_string i in - let f = NumTok.UnsignedNat.of_string f in - NumTok.Signed.of_int_frac_and_exponent i (Some f) None in - if choose_exponent then numTok_exponent () else numTok_dot () in - match DAst.get c with - | GApp (r, [a]) when is_gr r glob_IZR -> - let n = bigint_of_z a in - NumTok.(Signed.of_bigint CDec n) - | GApp (md, [l; r]) when is_gr md glob_Rmult || is_gr md glob_Rdiv -> - begin match DAst.get l, DAst.get r with - | GApp (i, [l]), GApp (i', [r]) - when is_gr i glob_IZR && is_gr i' glob_IZR -> - begin match DAst.get r with - | GApp (p, [t; e]) when is_gr p glob_pow_pos -> - let t = bigint_of_z t in - if not (Z.(equal t (of_int 10))) then - raise Non_closed_number - else - let i = bigint_of_z l in - let e = bignat_of_pos e in - let e = if is_gr md glob_Rdiv then Z.neg e else e in - numTok_of_int_exp i e - | _ -> raise Non_closed_number - end - | _ -> raise Non_closed_number - end - | _ -> raise Non_closed_number - -let uninterp_r (AnyGlobConstr p) = - try - Some (rawnum_of_r p) - with Non_closed_number -> - None - -open Notation - -let at_declare_ml_module f x = - Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name - -let r_scope = "R_scope" - -let _ = - register_rawnumeral_interpretation r_scope (r_of_rawnum,uninterp_r); - at_declare_ml_module enable_prim_token_interpretation - { pt_local = false; - pt_scope = r_scope; - pt_interp_info = Uid r_scope; - pt_required = (r_path,["Coq";"Reals";"Rdefinitions"]); - pt_refs = [glob_IZR; glob_Rmult; glob_Rdiv]; - pt_in_match = false } diff --git a/plugins/syntax/r_syntax.mli b/plugins/syntax/r_syntax.mli deleted file mode 100644 index b72d544151..0000000000 --- a/plugins/syntax/r_syntax.mli +++ /dev/null @@ -1,9 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) diff --git a/plugins/syntax/r_syntax_plugin.mlpack b/plugins/syntax/r_syntax_plugin.mlpack deleted file mode 100644 index d4ee75ea48..0000000000 --- a/plugins/syntax/r_syntax_plugin.mlpack +++ /dev/null @@ -1 +0,0 @@ -R_syntax diff --git a/plugins/syntax/string_notation.ml b/plugins/syntax/string_notation.ml index e7ed0d8061..774d59dda3 100644 --- a/plugins/syntax/string_notation.ml +++ b/plugins/syntax/string_notation.ml @@ -9,21 +9,15 @@ (************************************************************************) open Pp -open Util open Names open Libnames open Constrexpr open Constrexpr_ops open Notation +open Number (** * String notation *) -let get_constructors ind = - let mib,oib = Global.lookup_inductive ind in - let mc = oib.Declarations.mind_consnames in - Array.to_list - (Array.mapi (fun j c -> GlobRef.ConstructRef (ind, j + 1)) mc) - let qualid_of_ref n = n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty @@ -46,7 +40,7 @@ let type_error_of g ty = (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ str " to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)).") -let vernac_string_notation local ty f g scope = +let vernac_string_notation local ty f g via scope = let env = Global.env () in let sigma = Evd.from_env env in let app x y = mkAppC (x,[y]) in @@ -56,14 +50,16 @@ let vernac_string_notation local ty f g scope = let coption = cref (q_option ()) in let opt r = app coption r in let clist_byte = app clist cbyte in - let tyc = Smartlocate.global_inductive_with_alias ty in + let ty_name = ty in + let ty, via = + match via with None -> ty, via | Some (ty', a) -> ty', Some (ty, a) in + let tyc, params = locate_global_inductive (via = None) ty in let to_ty = Smartlocate.global_with_alias f in let of_ty = Smartlocate.global_with_alias g in let cty = cref ty in let arrow x y = mkProdC ([CAst.make Anonymous],Default Glob_term.Explicit, x, y) in - let constructors = get_constructors tyc in (* Check the type of f *) let to_kind = if has_type env sigma f (arrow clist_byte cty) then ListByte, Direct @@ -80,11 +76,10 @@ let vernac_string_notation local ty f g scope = else if has_type env sigma g (arrow cty (opt cbyte)) then Byte, Option else type_error_of g ty in - let o = { to_kind = to_kind; - to_ty = to_ty; - of_kind = of_kind; - of_ty = of_ty; - ty_name = ty; + let to_post, pt_refs = match via with + | None -> elaborate_to_post_params env sigma tyc params + | Some (ty, l) -> elaborate_to_post_via env sigma ty tyc l in + let o = { to_kind; to_ty; to_post; of_kind; of_ty; ty_name; warning = () } in let i = @@ -92,7 +87,7 @@ let vernac_string_notation local ty f g scope = pt_scope = scope; pt_interp_info = StringNotation o; pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; - pt_refs = constructors; + pt_refs; pt_in_match = true } in enable_prim_token_interpretation i diff --git a/plugins/syntax/string_notation.mli b/plugins/syntax/string_notation.mli index 0d99f98d26..f3c7c969c6 100644 --- a/plugins/syntax/string_notation.mli +++ b/plugins/syntax/string_notation.mli @@ -14,5 +14,7 @@ open Vernacexpr (** * String notation *) val vernac_string_notation : locality_flag -> - qualid -> qualid -> qualid -> + qualid -> + qualid -> qualid -> + Number.number_string_via option -> Notation_term.scope_name -> unit diff --git a/plugins/syntax/string_notation_plugin.mlpack b/plugins/syntax/string_notation_plugin.mlpack deleted file mode 100644 index 6aa081dab4..0000000000 --- a/plugins/syntax/string_notation_plugin.mlpack +++ /dev/null @@ -1,2 +0,0 @@ -String_notation -G_string diff --git a/pretyping/cases.ml b/pretyping/cases.ml index a459229256..a793e217d4 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -128,7 +128,8 @@ type 'a equation = rhs : 'a rhs; alias_stack : Name.t list; eqn_loc : Loc.t option; - used : bool ref } + used : int ref; + catch_all_vars : Id.t CAst.t list ref } type 'a matrix = 'a equation list @@ -297,7 +298,7 @@ let inductive_template env sigma tmloc ind = let ty = EConstr.of_constr ty in let ty' = substl subst ty in let sigma, e = - Evarutil.new_evar env ~src:(hole_source n) ~typeclass_candidate:false sigma ty' + Evarutil.new_evar env ~src:(hole_source n) sigma ty' in (sigma, e::subst,e::evarl,n+1) | LocalDef (na,b,ty) -> @@ -514,7 +515,7 @@ let check_and_adjust_constructor env ind cstrs pat = match DAst.get pat with let loc = pat.CAst.loc in (* Check it is constructor of the right type *) let ind' = inductive_of_constructor cstr in - if eq_ind ind' ind then + if Ind.CanOrd.equal ind' ind then (* Check the constructor has the right number of args *) let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in @@ -543,11 +544,34 @@ let check_all_variables env sigma typ mat = error_bad_pattern ?loc env sigma cstr_sp typ) mat +let set_pattern_catch_all_var ?loc eqn = function + | Name id when not (Id.Set.mem id eqn.rhs.rhs_vars) -> + eqn.catch_all_vars := CAst.make ?loc id :: !(eqn.catch_all_vars) + | _ -> () + +let warn_named_multi_catch_all = + CWarnings.create ~name:"unused-pattern-matching-variable" ~category:"pattern-matching" + (fun id -> + strbrk "Unused variable " ++ Id.print id ++ strbrk " catches more than one case.") + +let wildcard_id = Id.of_string "wildcard'" + +let is_wildcard id = + Id.equal (Id.of_string (Nameops.atompart_of_id id)) wildcard_id + let check_unused_pattern env eqn = - if not !(eqn.used) then - raise_pattern_matching_error ?loc:eqn.eqn_loc (env, Evd.empty, UnusedClause eqn.patterns) + match !(eqn.used) with + | 0 -> raise_pattern_matching_error ?loc:eqn.eqn_loc (env, Evd.empty, UnusedClause eqn.patterns) + | 1 -> () + | _ -> + let warn {CAst.v = id; loc} = + (* Convention: Names starting with `_` and derivatives of Program's + "wildcard'" internal name deactivate the warning *) + if (Id.to_string id).[0] <> '_' && not (is_wildcard id) + then warn_named_multi_catch_all ?loc id in + List.iter warn !(eqn.catch_all_vars) -let set_used_pattern eqn = eqn.used := true +let set_used_pattern eqn = eqn.used := !(eqn.used) + 1 let extract_rhs pb = match pb.mat with @@ -1017,7 +1041,8 @@ let add_assert_false_case pb tomatch = it = None }; alias_stack = Anonymous::aliasnames; eqn_loc = None; - used = ref false } ] + used = ref 0; + catch_all_vars = ref [] } ] let adjust_impossible_cases sigma pb pred tomatch submat = match submat with @@ -1235,6 +1260,7 @@ let group_equations pb ind current cstrs mat = let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in brs.(i-1) <- (args, name, rest) :: brs.(i-1) done; + set_pattern_catch_all_var ?loc:pat.CAst.loc eqn name; if !only_default == None then only_default := Some true | PatCstr (((_,i)),args,name) -> (* This is a regular clause *) @@ -1602,7 +1628,8 @@ let matx_of_eqns env eqns = { patterns = initial_lpat; alias_stack = []; eqn_loc = loc; - used = ref false; + used = ref 0; + catch_all_vars = ref []; rhs = rhs } in List.map build_eqn eqns @@ -1757,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 @@ -1859,7 +1885,8 @@ let build_inversion_problem ~program_mode loc env sigma tms t = { patterns = patl; alias_stack = []; eqn_loc = None; - used = ref false; + used = ref 0; + catch_all_vars = ref []; rhs = { rhs_env = pb_env; (* we assume all vars are used; in practice we discard dependent vars so that the field rhs_vars is normally not used *) @@ -1879,16 +1906,32 @@ let build_inversion_problem ~program_mode loc env sigma tms t = [ { patterns = List.map (fun _ -> DAst.make @@ PatVar Anonymous) patl; alias_stack = []; eqn_loc = None; - used = ref false; + used = ref 0; + catch_all_vars = ref []; rhs = { rhs_env = pb_env; rhs_vars = Id.Set.empty; avoid_ids = avoid0; 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; @@ -1936,7 +1979,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let realnal = match t with | Some {CAst.loc;v=(ind',realnal)} -> - if not (eq_ind ind ind') then + if not (Ind.CanOrd.equal ind ind') then user_err ?loc (str "Wrong inductive type."); if not (Int.equal nrealargs_ctxt (List.length realnal)) then anomaly (Pp.str "Ill-formed 'in' clause in cases."); @@ -2037,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 @@ -2087,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 @@ -2149,7 +2205,7 @@ let constr_of_pat env sigma arsign pat avoid = let name, avoid = match name with Name n -> name, avoid | Anonymous -> - let previd, id = prime avoid (Name (Id.of_string "wildcard")) in + let id = next_ident_away wildcard_id avoid in Name id, Id.Set.add id avoid in let r = Sorts.Relevant in (* TODO relevance *) @@ -2164,7 +2220,7 @@ let constr_of_pat env sigma arsign pat avoid = in let (ind,u), params = dest_ind_family indf in let params = List.map EConstr.of_constr params in - if not (eq_ind ind cind) then error_bad_constructor ?loc env cstr ind; + if not (Ind.CanOrd.equal ind cind) then error_bad_constructor ?loc env cstr ind; let cstrs = get_constructors env indf in let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 8b1ec3aba0..9a986bc14c 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -68,7 +68,8 @@ type 'a equation = rhs : 'a rhs; alias_stack : Name.t list; eqn_loc : Loc.t option; - used : bool ref } + used : int ref; + catch_all_vars : Id.t CAst.t list ref } type 'a matrix = 'a equation list diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index d759f82d35..6e6189796e 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -119,7 +119,7 @@ let disc_subset sigma x = Ind (i,_) -> let len = Array.length l in let sigty = delayed_force sig_typ in - if Int.equal len 2 && eq_ind i (Globnames.destIndRef sigty) + if Int.equal len 2 && Ind.CanOrd.equal i (Globnames.destIndRef sigty) then let (a, b) = pair_of_array l in Some (a, b) @@ -240,10 +240,10 @@ let coerce ?loc env sigma (x : EConstr.constr) (y : EConstr.constr) let sigT = delayed_force sigT_typ in let prod = delayed_force prod_typ in (* Sigma types *) - if Int.equal len (Array.length l') && Int.equal len 2 && eq_ind i i' - && (eq_ind i (destIndRef sigT) || eq_ind i (destIndRef prod)) + if Int.equal len (Array.length l') && Int.equal len 2 && Ind.CanOrd.equal i i' + && (Ind.CanOrd.equal i (destIndRef sigT) || Ind.CanOrd.equal i (destIndRef prod)) then - if eq_ind i (destIndRef sigT) + if Ind.CanOrd.equal i (destIndRef sigT) then begin let (a, pb), (a', pb') = @@ -303,7 +303,7 @@ let coerce ?loc env sigma (x : EConstr.constr) (y : EConstr.constr) papp sigma prod_intro [| a'; b'; x ; y |]) end else - if eq_ind i i' && Int.equal len (Array.length l') then + if Ind.CanOrd.equal i i' && Int.equal len (Array.length l') then (try subco sigma with NoSubtacCoercion -> let sigma, typ = Typing.type_of env sigma c in diff --git a/pretyping/coercionops.ml b/pretyping/coercionops.ml index 0c3eaa1da9..8ddc576d83 100644 --- a/pretyping/coercionops.ml +++ b/pretyping/coercionops.ml @@ -57,7 +57,7 @@ let cl_typ_ord t1 t2 = match t1, t2 with | CL_SECVAR v1, CL_SECVAR v2 -> Id.compare v1 v2 | CL_CONST c1, CL_CONST c2 -> Constant.CanOrd.compare c1 c2 | CL_PROJ c1, CL_PROJ c2 -> Projection.Repr.CanOrd.compare c1 c2 - | CL_IND i1, CL_IND i2 -> ind_ord i1 i2 + | CL_IND i1, CL_IND i2 -> Ind.CanOrd.compare i1 i2 | _ -> pervasives_compare t1 t2 (** OK *) module ClTyp = struct diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 419eeaa92a..a3f1c0b004 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -244,9 +244,9 @@ let matches_core env sigma allow_bound_rels let open GlobRef in match ref, EConstr.kind sigma c with | VarRef id, Var id' -> Names.Id.equal id id' - | ConstRef c, Const (c',_) -> Constant.equal c c' - | IndRef i, Ind (i', _) -> Names.eq_ind i i' - | ConstructRef c, Construct (c',u) -> Names.eq_constructor c c' + | ConstRef c, Const (c',_) -> Environ.QConstant.equal env c c' + | IndRef i, Ind (i', _) -> Names.Ind.CanOrd.equal i i' + | ConstructRef c, Construct (c',u) -> Names.Construct.CanOrd.equal c c' | _, _ -> false in let rec sorec ctx env subst p t = @@ -307,11 +307,11 @@ let matches_core env sigma allow_bound_rels | PApp (c1,arg1), App (c2,arg2) -> (match c1, EConstr.kind sigma c2 with - | PRef (GlobRef.ConstRef r), Proj (pr,c) when not (Constant.equal r (Projection.constant pr)) + | PRef (GlobRef.ConstRef r), Proj (pr,c) when not (Environ.QConstant.equal env r (Projection.constant pr)) || Projection.unfolded pr -> raise PatternMatchingFailure | PProj (pr1,c1), Proj (pr,c) -> - if Projection.equal pr1 pr then + if Environ.QProjection.equal env pr1 pr then try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c) arg1 arg2 with Invalid_argument _ -> raise PatternMatchingFailure else raise PatternMatchingFailure @@ -324,7 +324,7 @@ let matches_core env sigma allow_bound_rels with Invalid_argument _ -> raise PatternMatchingFailure) | PApp (PRef (GlobRef.ConstRef c1), _), Proj (pr, c2) - when Projection.unfolded pr || not (Constant.equal c1 (Projection.constant pr)) -> + when Projection.unfolded pr || not (Environ.QConstant.equal env c1 (Projection.constant pr)) -> raise PatternMatchingFailure | PApp (c, args), Proj (pr, c2) -> @@ -332,7 +332,7 @@ let matches_core env sigma allow_bound_rels sorec ctx env subst p term with Retyping.RetypeError _ -> raise PatternMatchingFailure) - | PProj (p1,c1), Proj (p2,c2) when Projection.equal p1 p2 -> + | PProj (p1,c1), Proj (p2,c2) when Environ.QProjection.equal env p1 p2 -> sorec ctx env subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> @@ -374,7 +374,7 @@ let matches_core env sigma allow_bound_rels | Some ind1 -> (* ppedrot: Something spooky going here. The comparison used to be the generic one, so I may have broken something. *) - if not (eq_ind ind1 ci2.ci_ind) then raise PatternMatchingFailure + if not (Ind.CanOrd.equal ind1 ci2.ci_ind) then raise PatternMatchingFailure in let () = if not ci1.cip_extensible && not (Int.equal (List.length br1) n2) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index a5311e162d..00d4c7b3d8 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -387,7 +387,7 @@ let ise_stack2 no_app env evd f sk1 sk2 = | UnifFailure _ as x -> fail x) | UnifFailure _ as x -> fail x) | Stack.Proj (p1)::q1, Stack.Proj (p2)::q2 -> - if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) + if QProjection.Repr.equal env (Projection.repr p1) (Projection.repr p2) then ise_stack2 true i q1 q2 else fail (UnifFailure (i, NotSameHead)) | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1)::q1, @@ -429,7 +429,7 @@ let exact_ise_stack2 env evd f sk1 sk2 = (fun i -> ise_stack2 i a1 a2)] else UnifFailure (i,NotSameHead) | Stack.Proj (p1)::q1, Stack.Proj (p2)::q2 -> - if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) + if QProjection.Repr.equal env (Projection.repr p1) (Projection.repr p2) then ise_stack2 i q1 q2 else (UnifFailure (i, NotSameHead)) | Stack.App _ :: _, Stack.App _ :: _ -> @@ -566,11 +566,16 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in let compare_heads evd = match EConstr.kind evd term, EConstr.kind evd term' with - | Const (c, u), Const (c', u') when Constant.equal c c' -> - let u = EInstance.kind evd u and u' = EInstance.kind evd u' in - check_strict evd u u' + | Const (c, u), Const (c', u') when QConstant.equal env c c' -> + 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.eq_ind ind ind' -> + | 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 else let u = EInstance.kind evd u and u' = EInstance.kind evd u' in @@ -589,7 +594,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty end | Ind _, Ind _ -> UnifFailure (evd, NotSameHead) | Construct (((mi,ind),ctor as cons), u), Construct (cons', u') - when Names.eq_constructor cons cons' -> + when Names.Construct.CanOrd.equal cons cons' -> if EInstance.is_empty u && EInstance.is_empty u' then Success evd else let u = EInstance.kind evd u and u' = EInstance.kind evd u' in @@ -831,7 +836,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in ise_try evd [f1; f2] - | Proj (p, c), Proj (p', c') when Projection.repr_equal p p' -> + | Proj (p, c), Proj (p', c') when QProjection.Repr.equal env (Projection.repr p) (Projection.repr p') -> let f1 i = ise_and i [(fun i -> evar_conv_x flags env i CONV c c'); @@ -844,7 +849,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty ise_try evd [f1; f2] (* Catch the p.c ~= p c' cases *) - | Proj (p,c), Const (p',u) when Constant.equal (Projection.constant p) p' -> + | Proj (p,c), Const (p',u) when QConstant.equal env (Projection.constant p) p' -> let res = try Some (destApp evd (Retyping.expand_projection env evd p c [])) with Retyping.RetypeError _ -> None @@ -855,7 +860,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty appr2 | None -> UnifFailure (evd,NotSameHead)) - | Const (p,u), Proj (p',c') when Constant.equal p (Projection.constant p') -> + | Const (p,u), Proj (p',c') when QConstant.equal env p (Projection.constant p') -> let res = try Some (destApp evd (Retyping.expand_projection env evd p' c' [])) with Retyping.RetypeError _ -> None @@ -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/evardefine.ml b/pretyping/evardefine.ml index eaf8c65811..13abf47413 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -206,7 +206,7 @@ let is_array_const env sigma c = | Const (cst,_) -> (match env.Environ.retroknowledge.Retroknowledge.retro_array with | None -> false - | Some cst' -> Constant.equal cst cst') + | Some cst' -> Environ.QConstant.equal env cst cst') | _ -> false let split_as_array env sigma0 = function 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/glob_ops.ml b/pretyping/glob_ops.ml index dc5fd80f9e..f42c754ef5 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -91,7 +91,7 @@ let case_style_eq s1 s2 = let open Constr in match s1, s2 with let rec cases_pattern_eq p1 p2 = match DAst.get p1, DAst.get p2 with | PatVar na1, PatVar na2 -> Name.equal na1 na2 | PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> - eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && + Construct.CanOrd.equal c1 c2 && List.equal cases_pattern_eq pl1 pl2 && Name.equal na1 na2 | (PatVar _ | PatCstr _), _ -> false @@ -109,7 +109,7 @@ let matching_var_kind_eq k1 k2 = match k1, k2 with let tomatch_tuple_eq f (c1, p1) (c2, p2) = let eqp {CAst.v=(i1, na1)} {CAst.v=(i2, na2)} = - eq_ind i1 i2 && List.equal Name.equal na1 na2 + Ind.CanOrd.equal i1 i2 && List.equal Name.equal na1 na2 in let eq_pred (n1, o1) (n2, o2) = Name.equal n1 n2 && Option.equal eqp o1 o2 in f c1 c2 && eq_pred p1 p2 @@ -523,6 +523,7 @@ let rec cases_pattern_of_glob_constr env na c = | Anonymous -> PatVar (Name id) end | GHole (_,_,_) -> PatVar na + | GRef (GlobRef.VarRef id,_) -> PatVar (Name id) | GRef (GlobRef.ConstructRef cstr,_) -> PatCstr (cstr,[],na) | GApp (c, l) -> begin match DAst.get c with diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 5be8f9f83c..5ffd919312 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -584,7 +584,7 @@ let build_mutual_induction_scheme env sigma ?(force_mutual=false) = function (List.map (function ((mind',u'),dep',s') -> let (sp',_) = mind' in - if MutInd.equal sp sp' then + if QMutInd.equal env sp sp' then let (mibi',mipi') = lookup_mind_specif env mind' in ((mind',u'),mibi',mipi',dep',s') else diff --git a/pretyping/keys.ml b/pretyping/keys.ml index 7a7099c195..dd3488c1df 100644 --- a/pretyping/keys.ml +++ b/pretyping/keys.ml @@ -34,7 +34,7 @@ module KeyOrdered = struct let hash gr = match gr with - | KGlob gr -> 9 + GlobRef.Ordered.hash gr + | KGlob gr -> 9 + GlobRef.CanOrd.hash gr | KLam -> 0 | KLet -> 1 | KProd -> 2 @@ -49,14 +49,14 @@ module KeyOrdered = struct let compare gr1 gr2 = match gr1, gr2 with - | KGlob gr1, KGlob gr2 -> GlobRef.Ordered.compare gr1 gr2 + | KGlob gr1, KGlob gr2 -> GlobRef.CanOrd.compare gr1 gr2 | _, KGlob _ -> -1 | KGlob _, _ -> 1 | k, k' -> Int.compare (hash k) (hash k') let equal k1 k2 = match k1, k2 with - | KGlob gr1, KGlob gr2 -> GlobRef.Ordered.equal gr1 gr2 + | KGlob gr1, KGlob gr2 -> GlobRef.CanOrd.equal gr1 gr2 | _, KGlob _ -> false | KGlob _, _ -> false | k, k' -> k == k' diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 3f68e3c78f..d06d6e01d1 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -525,7 +525,7 @@ let native_norm env sigma c ty = if print_timing then Feedback.msg_info (Pp.str time_info); let profiler_pid = if profile then start_profiler () else None in let t0 = Unix.gettimeofday () in - Nativelib.call_linker ~fatal:true env ~prefix fn (Some upd); + Nativelib.call_linker ~fatal:true ~prefix fn (Some upd); let t1 = Unix.gettimeofday () in if profile then stop_profiler profiler_pid; let time_info = Format.sprintf "native_compute: Evaluation done in %.5f" (t1 -. t0) in diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 8c3d624f0f..b259945d9e 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -23,7 +23,7 @@ open Environ let case_info_pattern_eq i1 i2 = i1.cip_style == i2.cip_style && - Option.equal eq_ind i1.cip_ind i2.cip_ind && + Option.equal Ind.CanOrd.equal i1.cip_ind i2.cip_ind && Option.equal (List.equal (==)) i1.cip_ind_tags i2.cip_ind_tags && i1.cip_extensible == i2.cip_extensible @@ -59,7 +59,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with | PCoFix (i1,f1), PCoFix (i2,f2) -> Int.equal i1 i2 && rec_declaration_eq f1 f2 | PProj (p1, t1), PProj (p2, t2) -> - Projection.equal p1 p2 && constr_pattern_eq t1 t2 + Projection.CanOrd.equal p1 p2 && constr_pattern_eq t1 t2 | PInt i1, PInt i2 -> Uint63.equal i1 i2 | PFloat f1, PFloat f2 -> @@ -547,7 +547,7 @@ and pats_of_glob_branches loc metas vars ind brs = true, [] (* ends with _ => _ *) | PatCstr((indsp,j),lv,_), _, _ -> let () = match ind with - | Some sp when eq_ind sp indsp -> () + | Some sp when Ind.CanOrd.equal sp indsp -> () | _ -> err ?loc (Pp.str "All constructors must be in the same inductive type.") in diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 268ad2ae56..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' = @@ -813,7 +807,7 @@ struct try let IndType (indf, args) = find_rectype !!env sigma ty in let ((ind',u'),pars) = dest_ind_family indf in - if eq_ind ind ind' then List.map EConstr.of_constr pars + if Ind.CanOrd.equal ind ind' then List.map EConstr.of_constr pars else (* Let the usual code throw an error *) [] with Not_found -> [] else [] diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 9d15e98373..9cf7119709 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -82,7 +82,7 @@ type evaluable_reference = | EvalEvar of EConstr.existential let evaluable_reference_eq sigma r1 r2 = match r1, r2 with -| EvalConst c1, EvalConst c2 -> Constant.equal c1 c2 +| EvalConst c1, EvalConst c2 -> Constant.CanOrd.equal c1 c2 | EvalVar id1, EvalVar id2 -> Id.equal id1 id2 | EvalRel i1, EvalRel i2 -> Int.equal i1 i2 | EvalEvar (e1, ctx1), EvalEvar (e2, ctx2) -> @@ -995,7 +995,7 @@ let whd_simpl_orelse_delta_but_fix env sigma c = | CoFix _ | Fix _ -> s' | Proj (p,t) when (match EConstr.kind sigma constr with - | Const (c', _) -> Constant.equal (Projection.constant p) c' + | Const (c', _) -> Constant.CanOrd.equal (Projection.constant p) c' | _ -> false) -> let npars = Projection.npars p in if List.length stack <= npars then @@ -1101,7 +1101,7 @@ let contextually byhead occs f env sigma t = let match_constr_evaluable_ref sigma c evref = match EConstr.kind sigma c, evref with - | Const (c,u), EvalConstRef c' when Constant.equal c c' -> Some u + | Const (c,u), EvalConstRef c' when Constant.CanOrd.equal c c' -> Some u | Var id, EvalVarRef id' when Id.equal id id' -> Some EInstance.empty | _, _ -> None @@ -1324,7 +1324,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = if isIndRef ref then let ((mind,u),t) = reduce_to_ind_gen allow_product env sigma t in begin match ref with - | GlobRef.IndRef mind' when eq_ind mind mind' -> t + | GlobRef.IndRef mind' when Ind.CanOrd.equal mind mind' -> t | _ -> error_cannot_recognize ref end else diff --git a/pretyping/unification.ml b/pretyping/unification.ml index ccfb508964..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) @@ -547,10 +547,10 @@ let oracle_order env cf1 cf2 = | Some k2 -> match k1, k2 with | IsProj (p, _), IsKey (ConstKey (p',_)) - when Constant.equal (Projection.constant p) p' -> + when Environ.QConstant.equal env (Projection.constant p) p' -> Some (not (Projection.unfolded p)) | IsKey (ConstKey (p,_)), IsProj (p', _) - when Constant.equal p (Projection.constant p') -> + when Environ.QConstant.equal env p (Projection.constant p') -> Some (Projection.unfolded p') | _ -> Some (Conv_oracle.oracle_order (fun x -> x) @@ -687,6 +687,17 @@ let eta_constructor_app env sigma f l1 term = | _ -> assert false) | _ -> assert false +(* If the terms are irrelevant, check that they have the same type. *) +let careful_infer_conv ~pb ~ts env sigma m n = + if Retyping.relevance_of_term env sigma m == Sorts.Irrelevant && + Retyping.relevance_of_term env sigma n == Sorts.Irrelevant + then + let tm = Retyping.get_type_of env sigma m in + let tn = Retyping.get_type_of env sigma n in + Option.bind (infer_conv ~pb:CONV ~ts env sigma tm tn) + (fun sigma -> infer_conv ~pb ~ts env sigma m n) + else infer_conv ~pb ~ts env sigma m n + let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top env cv_pb flags m n = let rec unirec_rec (curenv,nb as curenvnb) pb opt ((sigma,metasubst,evarsubst) as substn : subst0) curm curn = let cM = Evarutil.whd_head_evar sigma curm @@ -758,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 @@ -796,7 +807,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e | _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb opt substn cM (subst1 a c) (* Fast path for projections. *) - | Proj (p1,c1), Proj (p2,c2) when Constant.equal + | Proj (p1,c1), Proj (p2,c2) when Environ.QConstant.equal env (Projection.constant p1) (Projection.constant p2) -> (try unify_same_proj curenvnb cv_pb {opt with at_top = true} substn c1 c2 @@ -844,7 +855,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e | Case (ci1,p1,_,c1,cl1), Case (ci2,p2,_,c2,cl2) -> (try - if not (eq_ind ci1.ci_ind ci2.ci_ind) then error_cannot_unify curenv sigma (cM,cN); + if not (Ind.CanOrd.equal ci1.ci_ind ci2.ci_ind) then error_cannot_unify curenv sigma (cM,cN); let opt' = {opt with at_top = true; with_types = false} in Array.fold_left2 (unirec_rec curenvnb CONV {opt with at_top = true}) (unirec_rec curenvnb CONV opt' @@ -914,7 +925,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e match EConstr.kind sigma c' with | Meta _ -> true | Evar _ -> true - | Const (c, u) -> Constant.equal c (Projection.constant p) + | Const (c, u) -> Environ.QConstant.equal env c (Projection.constant p) | _ -> false in let expand_proj c c' l = @@ -1127,7 +1138,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e None else let ans = match flags.modulo_conv_on_closed_terms with - | Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n + | Some convflags -> careful_infer_conv ~pb:cv_pb ~ts:convflags env sigma m n | _ -> constr_cmp cv_pb env sigma flags m n in match ans with | Some sigma -> ans @@ -1346,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'') = @@ -1365,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/printing/ppconstr.ml b/printing/ppconstr.ml index 8da1d636f0..e312c68b7d 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -77,8 +77,8 @@ let tag_var = tag Tag.variable | LevelSome -> true let prec_of_prim_token = function - | Numeral (NumTok.SPlus,_) -> lposint - | Numeral (NumTok.SMinus,_) -> lnegint + | Number (NumTok.SPlus,_) -> lposint + | Number (NumTok.SMinus,_) -> lnegint | String _ -> latom let print_hunks n pr pr_patt pr_binders (terms, termlists, binders, binderlists) unps = @@ -222,7 +222,7 @@ let tag_var = tag Tag.variable | t -> str " :" ++ pr_sep_com (fun()->brk(1,4)) (pr ltop) t let pr_prim_token = function - | Numeral n -> NumTok.Signed.print n + | Number n -> NumTok.Signed.print n | String s -> qs s let pr_evar pr id l = @@ -681,13 +681,10 @@ let tag_var = tag Tag.variable | CDelimiters (sc,a) -> return (pr_delimiters sc (pr mt (LevelLe ldelim) a), ldelim) | CArray(u, t,def,ty) -> - let pp = ref (str " |"++ spc () ++ pr mt ltop def - ++ pr_opt_type_spc (pr mt) ty ++ str " |]" ++ pr_universe_instance u) in - for i = Array.length t - 1 downto 1 do - pp := str ";" ++ pr mt ltop t.(i) ++ !pp - done; - pp := pr mt ltop t.(0) ++ !pp; - hov 0 (str "[|" ++ !pp), 0 + hov 0 (str "[| " ++ prvect_with_sep (fun () -> str "; ") (pr mt ltop) t ++ + (if not (Array.is_empty t) then str " " else mt()) ++ + str "|" ++ spc() ++ pr mt ltop def ++ pr_opt_type_spc (pr mt) ty ++ + str " |]" ++ pr_universe_instance u), 0 in let loc = constr_loc a in pr_with_comments ?loc diff --git a/printing/printer.ml b/printing/printer.ml index bc26caefbe..ea718526de 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -45,6 +45,8 @@ let should_gname = ~key:["Printing";"Goal";"Names"] ~value:false +let print_goal_names = should_gname (* for export *) + (**********************************************************************) (** Terms *) @@ -884,7 +886,7 @@ struct MutInd.CanOrd.compare m1 m2 | Guarded k1 , Guarded k2 | TypeInType k1, TypeInType k2 -> - GlobRef.Ordered.compare k1 k2 + GlobRef.CanOrd.compare k1 k2 | Constant _, _ -> -1 | _, Constant _ -> 1 | Positive _, _ -> -1 diff --git a/printing/printer.mli b/printing/printer.mli index a25cbebe91..ea388ae57e 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -264,3 +264,6 @@ val pr_goal_by_id : proof:Proof.t -> Id.t -> Pp.t val pr_goal_emacs : proof:Proof.t option -> int -> int -> Pp.t val pr_typing_flags : Declarations.typing_flags -> Pp.t + +(** Tells if flag "Printing Goal Names" is activated *) +val print_goal_names : unit -> bool 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/stm/stm.ml b/stm/stm.ml index 85f889c879..df7e35beb5 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2275,8 +2275,9 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = ), true, true | `MaybeASync (start, nodes, name, delegate) -> (fun () -> reach ~cache:true start; - (* no sections *) - if CList.is_empty (Environ.named_context (Global.env ())) + if CList.is_empty (Environ.named_context (Global.env ())) (* no sections *) + || PG_compat.get_pstate () |> (* #[using] attribute *) + Option.cata (fun x -> Option.has_some (Declare.Proof.get_used_variables x)) false then Util.pi1 (aux (`ASync (start, nodes, name, delegate))) () else Util.pi1 (aux (`Sync (name, `NoPU_NoHint_NoES))) () ), not redefine_qed, true diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index f721e9956b..af0ca22868 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -27,7 +27,7 @@ type term_label = | SortLabel let compare_term_label t1 t2 = match t1, t2 with -| GRLabel gr1, GRLabel gr2 -> GlobRef.Ordered.compare gr1 gr2 +| GRLabel gr1, GRLabel gr2 -> GlobRef.CanOrd.compare gr1 gr2 | _ -> pervasives_compare t1 t2 (** OK *) type 'res lookup_res = 'res Dn.lookup_res = Label of 'res | Nothing | Everything diff --git a/tactics/cbn.ml b/tactics/cbn.ml index 0b13f4763a..31873ea6b0 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -225,8 +225,8 @@ struct let equal_cst_member x y = match x, y with | Cst_const (c1,u1), Cst_const (c2, u2) -> - Constant.equal c1 c2 && Univ.Instance.equal u1 u2 - | Cst_proj p1, Cst_proj p2 -> Projection.repr_equal p1 p2 + Constant.CanOrd.equal c1 c2 && Univ.Instance.equal u1 u2 + | Cst_proj p1, Cst_proj p2 -> Projection.Repr.CanOrd.equal (Projection.repr p1) (Projection.repr p2) | _, _ -> false in let rec equal_rec sk1 sk2 = @@ -239,7 +239,7 @@ struct | Case (_,t1,_,a1,_) :: s1, Case (_,t2,_,a2,_) :: s2 -> f t1 t2 && CArray.equal (fun x y -> f x y) a1 a2 && equal_rec s1 s2 | (Proj (p,_)::s1, Proj(p2,_)::s2) -> - Projection.Repr.equal (Projection.repr p) (Projection.repr p2) + Projection.Repr.CanOrd.equal (Projection.repr p) (Projection.repr p2) && equal_rec s1 s2 | Fix (f1,s1,_) :: s1', Fix (f2,s2,_) :: s2' -> f_fix f1 f2 diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index ed92a85a12..9e66e8668f 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -482,8 +482,7 @@ let make_resolve_hyp env sigma st only_classes pri decl = let keep = not only_classes || is_class in if keep then let id = GlobRef.VarRef id in - let name = PathHints [id] in - (make_resolves env sigma pri ~name ~check:false (IsGlobRef id)) + make_resolves env sigma pri id else [] let make_hints g (modes,st) only_classes sign = 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/elim.ml b/tactics/elim.ml index 49437a2aef..9a55cabc86 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -193,7 +193,7 @@ let head_in indl t gl = let sigma = Tacmach.New.project gl in try let ity,_ = extract_mrectype sigma t in - List.exists (fun i -> eq_ind (fst i) (fst ity)) indl + List.exists (fun i -> Ind.CanOrd.equal (fst i) (fst ity)) indl with Not_found -> false let decompose_these c l = diff --git a/tactics/equality.ml b/tactics/equality.ml index 60e2db4dce..486575d229 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -768,7 +768,7 @@ let find_positions env sigma ~keep_proofs ~no_discr t1 t2 = in (* both sides are fully applied constructors, so either we descend, or we can discriminate here. *) - if eq_constructor sp1 sp2 then + if Construct.CanOrd.equal sp1 sp2 then let nparams = inductive_nparams env ind1 in let params1,rargs1 = List.chop nparams args1 in let _,rargs2 = List.chop nparams args2 in diff --git a/tactics/hints.ml b/tactics/hints.ml index fe3efef7c5..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)); @@ -1347,6 +1357,10 @@ let add_hints ~locality dbnames h = | HintsExternEntry (info, tacexp) -> add_externs info tacexp ~local ~superglobal dbnames +let hint_globref gr = IsGlobRef gr + +let hint_constr (c, diff) = IsConstr (c, diff) + let expand_constructor_hints env sigma lems = List.map_append (fun (evd,lem) -> match EConstr.kind sigma lem with @@ -1365,8 +1379,9 @@ let constructor_hints env sigma eapply lems = List.map_append (fun lem -> make_resolves env sigma (eapply, true) empty_hint_info ~check:true lem) lems -let make_resolves env sigma info ~check ?name hint = - make_resolves env sigma (true, false) info ~check ?name hint +let make_resolves env sigma info hint = + let name = PathHints [hint] in + make_resolves env sigma (true, false) info ~check:false ~name (IsGlobRef hint) let make_local_hint_db env sigma ts eapply lems = let map c = c env sigma in diff --git a/tactics/hints.mli b/tactics/hints.mli index dd22cff10b..54f4716652 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -167,9 +167,7 @@ type hint_db = Hint_db.t type hnf = bool -type hint_term = - | IsGlobRef of GlobRef.t - | IsConstr of constr * Univ.ContextSet.t option [@ocaml.deprecated "Declare a hint constant instead"] +type hint_term type hints_entry = | HintsResolveEntry of (hint_info * hnf * hints_path_atom * hint_term) list @@ -191,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 @@ -199,8 +197,10 @@ val current_pure_db : unit -> hint_db list val add_hints : locality:Goptions.option_locality -> hint_db_name list -> hints_entry -> unit -val prepare_hint : bool (* Check no remaining evars *) -> - env -> evar_map -> evar_map * constr -> (constr * Univ.ContextSet.t) +val hint_globref : GlobRef.t -> hint_term + +val hint_constr : constr * Univ.ContextSet.t option -> hint_term +[@ocaml.deprecated "Declare a hint constant instead"] (** A constr which is Hint'ed will be: - (1) used as an Exact, if it does not start with a product @@ -210,8 +210,7 @@ val prepare_hint : bool (* Check no remaining evars *) -> has missing arguments. *) val make_resolves : - env -> evar_map -> hint_info -> check:bool -> ?name:hints_path_atom -> - hint_term -> hint_entry list + env -> evar_map -> hint_info -> GlobRef.t -> hint_entry list (** [make_resolve_hyp hname htyp]. used to add an hypothesis to the local hint database; 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 a607c09010..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 @@ -540,7 +542,7 @@ let mutual_fix f n rest j = Proofview.Goal.enter begin fun gl -> | (f, n, ar) :: oth -> let open Context.Named.Declaration in let (sp', u') = check_mutind env sigma n ar in - if not (MutInd.equal sp sp') then + if not (QMutInd.equal env sp sp') then error "Fixpoints should be on the same mutual inductive declaration."; if mem_named_context_val f sign then user_err ~hdr:"Logic.prim_refiner" @@ -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/tactics/term_dnet.ml b/tactics/term_dnet.ml index 3bcd235b41..df07dcbca7 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -91,7 +91,7 @@ struct | DArray (t,def,ty) -> DArray(Array.map f t, f def, f ty) let compare_ci ci1 ci2 = - let c = ind_ord ci1.ci_ind ci2.ci_ind in + let c = Ind.CanOrd.compare ci1.ci_ind ci2.ci_ind in if c = 0 then let c = Int.compare ci1.ci_npar ci2.ci_npar in if c = 0 then @@ -107,7 +107,7 @@ struct | DRel, _ -> -1 | _, DRel -> 1 | DSort, DSort -> 0 | DSort, _ -> -1 | _, DSort -> 1 - | DRef gr1, DRef gr2 -> GlobRef.Ordered.compare gr1 gr2 + | DRef gr1, DRef gr2 -> GlobRef.CanOrd.compare gr1 gr2 | DRef _, _ -> -1 | _, DRef _ -> 1 | DCtx (tl1, tr1), DCtx (tl2, tr2) diff --git a/test-suite/Makefile b/test-suite/Makefile index 6c373701cf..279f32c903 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -36,7 +36,8 @@ include ../Makefile.common # Note that this will later need an eval in shell to interpret the quotes ROOT='$(shell cd ..; pwd)' -ifneq ($(wildcard ../_build),) +ifneq ($(wildcard ../_build/default/config/Makefile),) +include ../_build/default/config/Makefile BIN:=$(ROOT)/_build/install/default/bin/ # COQLIB is an env variable so no quotes COQLIB:=$(shell cd ..; pwd)/_build/install/default/lib/coq diff --git a/test-suite/bugs/closed/bug_10972.v b/test-suite/bugs/closed/bug_10972.v new file mode 100644 index 0000000000..945c23c9a4 --- /dev/null +++ b/test-suite/bugs/closed/bug_10972.v @@ -0,0 +1,9 @@ +(* Check rewrite_strat is compatible with Ltac *) +Require Import Coq.Setoids.Setoid. +Module foo. + Definition Foo := True. + Ltac foo := rewrite_strat eval cbv [Foo]. +End foo. +Goal foo.Foo. + foo.foo. +Abort. 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_13078.v b/test-suite/bugs/closed/bug_13078.v new file mode 100644 index 0000000000..ec04408fd1 --- /dev/null +++ b/test-suite/bugs/closed/bug_13078.v @@ -0,0 +1,10 @@ +(* Check that rules with patterns are not registered for cases patterns *) +Module PrintingTest. +Declare Custom Entry test. +Notation "& x" := (Some x) (in custom test at level 0, x pattern). +Check fun x => match x with | None => None | Some tt => Some tt end. +Notation "& x" := (Some x) (at level 0, x pattern). +Check fun x => match x with | None => None | Some tt => Some tt end. +End PrintingTest. + +Fail Notation "x &" := (Some x) (at level 0, x pattern). diff --git a/test-suite/bugs/closed/bug_13129.v b/test-suite/bugs/closed/bug_13129.v new file mode 100644 index 0000000000..632605ecc7 --- /dev/null +++ b/test-suite/bugs/closed/bug_13129.v @@ -0,0 +1,58 @@ +From Coq Require Export Morphisms Setoid . + +Class Equiv A := equiv: relation A. + +Infix "≡" := equiv (at level 70, no associativity). +Infix "≡@{ A }" := (@equiv A _) + (at level 70, only parsing, no associativity). + +Notation "(≡)" := equiv (only parsing). + +(** Unbundled version *) +Class Dist A := dist : nat -> relation A. + +Notation "x ≡{ n }≡ y" := (dist n x y) + (at level 70, n at next level, format "x ≡{ n }≡ y"). +Notation "x ≡{ n }@{ A }≡ y" := (dist (A:=A) n x y) + (at level 70, n at next level, only parsing). + +Notation NonExpansive f := (forall n, Proper (dist n ==> dist n ==> dist n) f). + +Record OfeMixin A `{Equiv A, Dist A} := { + mixin_equiv_dist (x y : A) : x ≡ y <-> forall n, x ≡{n}≡ y; +}. + +(** Bundled version *) +Structure ofeT := OfeT { + ofe_car :> Type; + ofe_equiv : Equiv ofe_car; + ofe_dist : Dist ofe_car; + ofe_mixin : OfeMixin ofe_car +}. +Hint Extern 0 (Equiv _) => eapply (@ofe_equiv _) : typeclass_instances. +Hint Extern 0 (Dist _) => eapply (@ofe_dist _) : typeclass_instances. + +(** Lifting properties from the mixin *) +Section ofe_mixin. + Context {A : ofeT}. + Implicit Types x y : A. + Lemma equiv_dist x y : x ≡ y <-> forall n, x ≡{n}≡ y. + Proof. apply (mixin_equiv_dist _ (ofe_mixin A)). Qed. +End ofe_mixin. + +Axiom _0 : Prop. (* dummy which somehow bothers mangle names *) +Set Mangle Names. + +(** General properties *) +Section ofe. + Context {A : ofeT}. + + Lemma ne_proper_2 {B C : ofeT} (f : A -> B -> C) `{Hf:!NonExpansive f} : + Proper ((≡) ==> (≡) ==> (≡)) f. + Proof. + unfold Proper, respectful. + setoid_rewrite equiv_dist. + intros. + apply Hf;auto. + Qed. +End ofe. diff --git a/test-suite/bugs/closed/bug_13131.v b/test-suite/bugs/closed/bug_13131.v new file mode 100644 index 0000000000..b358ae3ecc --- /dev/null +++ b/test-suite/bugs/closed/bug_13131.v @@ -0,0 +1,6 @@ +Set Mangle Names. + +Class A := {}. + +Lemma foo `{A} : A. +Proof. Fail exact H. assumption. Qed. diff --git a/test-suite/bugs/closed/bug_13162.v b/test-suite/bugs/closed/bug_13162.v new file mode 100644 index 0000000000..eacc8980a9 --- /dev/null +++ b/test-suite/bugs/closed/bug_13162.v @@ -0,0 +1,7 @@ + +Module Type T. End T. +Module F (X:T). End F. +Fail Import F. +(* Error: Anomaly "Uncaught exception Not_found." *) + +Fail Import T. diff --git a/test-suite/bugs/closed/bug_13178.v b/test-suite/bugs/closed/bug_13178.v new file mode 100644 index 0000000000..d9c516c362 --- /dev/null +++ b/test-suite/bugs/closed/bug_13178.v @@ -0,0 +1,3 @@ +Primitive array := #array_type. + +Check [| | 0 |]. diff --git a/test-suite/bugs/closed/bug_13216.v b/test-suite/bugs/closed/bug_13216.v new file mode 100644 index 0000000000..54a28a9c53 --- /dev/null +++ b/test-suite/bugs/closed/bug_13216.v @@ -0,0 +1,4 @@ +Class A. +Declare Instance a:A. +Inductive T `(A) := C. +Definition f x := match x with C _ => 0 end. diff --git a/test-suite/bugs/closed/bug_13276.v b/test-suite/bugs/closed/bug_13276.v new file mode 100644 index 0000000000..15ac7e7b36 --- /dev/null +++ b/test-suite/bugs/closed/bug_13276.v @@ -0,0 +1,9 @@ +From Coq Require Import Floats. +Open Scope float_scope. + +Lemma foo : + let n := opp 0 in sub n 0 = n. +Proof. +cbv. +apply eq_refl. +Qed. 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/bugs/opened/bug_3395.v b/test-suite/bugs/opened/bug_3395.v deleted file mode 100644 index 70b3a48a06..0000000000 --- a/test-suite/bugs/opened/bug_3395.v +++ /dev/null @@ -1,232 +0,0 @@ -Require Import TestSuite.admit. -(* File reduced by coq-bug-finder from originally 10918 lines, then 3649 lines to 3177 lines, then from 3189 lines to 3164 lines, then from 2653 lines to 2496 lines, 2653 lines, then from 1642 lines to 651 lines, then from 736 lines to 473 lines, then from 433 lines to 275 lines, then from 258 lines to 235 lines. *) -Generalizable All Variables. -Set Implicit Arguments. - -Arguments fst {_ _} _. -Arguments snd {_ _} _. - -Axiom cheat : forall {T}, T. - -Reserved Notation "g 'o' f" (at level 40, left associativity). - -Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. -Arguments idpath {A a} , [A] a. -Notation "x = y" := (paths x y) : type_scope. - -Definition symmetry {A : Type} {x y : A} (p : x = y) : y = x - := match p with idpath => idpath end. - -Delimit Scope morphism_scope with morphism. -Delimit Scope category_scope with category. -Delimit Scope object_scope with object. -Record PreCategory (object : Type) := - Build_PreCategory' { - object :> Type := object; - morphism : object -> object -> Type; - identity : forall x, morphism x x; - compose : forall s d d', - morphism d d' - -> morphism s d - -> morphism s d' - where "f 'o' g" := (compose f g); - associativity : forall x1 x2 x3 x4 - (m1 : morphism x1 x2) - (m2 : morphism x2 x3) - (m3 : morphism x3 x4), - (m3 o m2) o m1 = m3 o (m2 o m1); - associativity_sym : forall x1 x2 x3 x4 - (m1 : morphism x1 x2) - (m2 : morphism x2 x3) - (m3 : morphism x3 x4), - m3 o (m2 o m1) = (m3 o m2) o m1; - left_identity : forall a b (f : morphism a b), identity b o f = f; - right_identity : forall a b (f : morphism a b), f o identity a = f; - identity_identity : forall x, identity x o identity x = identity x - }. -Bind Scope category_scope with PreCategory. -Arguments PreCategory {_}. -Arguments identity {_} [!C%category] x%object : rename. - -Arguments compose {_} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. - -Infix "o" := compose : morphism_scope. - -Delimit Scope functor_scope with functor. -Local Open Scope morphism_scope. -Record Functor `(C : @PreCategory objC, D : @PreCategory objD) := - { - object_of :> C -> D; - morphism_of : forall s d, morphism C s d - -> morphism D (object_of s) (object_of d); - composition_of : forall s d d' - (m1 : morphism C s d) (m2: morphism C d d'), - morphism_of _ _ (m2 o m1) - = (morphism_of _ _ m2) o (morphism_of _ _ m1); - identity_of : forall x, morphism_of _ _ (identity x) - = identity (object_of x) - }. -Bind Scope functor_scope with Functor. - -Arguments morphism_of {_} [C%category] {_} [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. - -Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. - -Class IsIsomorphism `{C : @PreCategory objC} {s d} (m : morphism C s d) := - { - morphism_inverse : morphism C d s; - left_inverse : morphism_inverse o m = identity _; - right_inverse : m o morphism_inverse = identity _ - }. - -Definition opposite `(C : @PreCategory objC) : PreCategory - := @Build_PreCategory' - C - (fun s d => morphism C d s) - (identity (C := C)) - (fun _ _ _ m1 m2 => m2 o m1) - (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _ _) - (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _ _) - (fun _ _ => @right_identity _ _ _ _) - (fun _ _ => @left_identity _ _ _ _) - (@identity_identity _ C). - -Notation "C ^op" := (opposite C) (at level 3) : category_scope. - -Definition prod `(C : @PreCategory objC, D : @PreCategory objD) : @PreCategory (objC * objD). - refine (@Build_PreCategory' - (C * D)%type - (fun s d => (morphism C (fst s) (fst d) - * morphism D (snd s) (snd d))%type) - (fun x => (identity (fst x), identity (snd x))) - (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1)) - _ - _ - _ - _ - _); admit. -Defined. -Infix "*" := prod : category_scope. - -Definition compose_functor `(C : @PreCategory objC, D : @PreCategory objD, E : @PreCategory objE) (G : Functor D E) (F : Functor C D) : Functor C E - := Build_Functor - C E - (fun c => G (F c)) - (fun _ _ m => morphism_of G (morphism_of F m)) - cheat - cheat. - -Infix "o" := compose_functor : functor_scope. - -Record NaturalTransformation `(C : @PreCategory objC, D : @PreCategory objD) (F G : Functor C D) := - Build_NaturalTransformation' { - components_of :> forall c, morphism D (F c) (G c); - commutes : forall s d (m : morphism C s d), - components_of d o F _1 m = G _1 m o components_of s; - - commutes_sym : forall s d (m : C.(morphism) s d), - G _1 m o components_of s = components_of d o F _1 m - }. -Definition functor_category `(C : @PreCategory objC, D : @PreCategory objD) : PreCategory - := @Build_PreCategory' (Functor C D) - (@NaturalTransformation _ C _ D) - cheat - cheat - cheat - cheat - cheat - cheat - cheat. - -Definition opposite_functor `(F : @Functor objC C objD D) : Functor C^op D^op - := Build_Functor (C^op) (D^op) - (object_of F) - (fun s d => morphism_of F (s := d) (d := s)) - (fun d' d s m1 m2 => composition_of F s d d' m2 m1) - (identity_of F). - -Definition opposite_invL `(F : @Functor objC C^op objD D) : Functor C D^op - := Build_Functor C (D^op) - (object_of F) - (fun s d => morphism_of F (s := d) (d := s)) - (fun d' d s m1 m2 => composition_of F s d d' m2 m1) - (identity_of F). -Notation "F ^op" := (opposite_functor F) : functor_scope. - -Notation "F ^op'L" := (opposite_invL F) (at level 3) : functor_scope. -Definition fst `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) C - := Build_Functor (C * D) C - (@fst _ _) - (fun _ _ => @fst _ _) - (fun _ _ _ _ _ => idpath) - (fun _ => idpath). - -Definition snd `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) D - := Build_Functor (C * D) D - (@snd _ _) - (fun _ _ => @snd _ _) - (fun _ _ _ _ _ => idpath) - (fun _ => idpath). -Definition prod_functor `(F : @Functor objC C objD D, F' : @Functor objC C objD' D') -: Functor C (D * D') - := Build_Functor - C (D * D') - (fun c => (F c, F' c)) - (fun s d m => (F _1 m, F' _1 m))%morphism - cheat - cheat. -Definition pair `(F : @Functor objC C objD D, F' : @Functor objC' C' objD' D') : Functor (C * C') (D * D') - := (prod_functor (F o fst) (F' o snd))%functor. -Notation cat_of obj := - (@Build_PreCategory' obj - (fun x y => forall _ : x, y) - (fun _ x => x) - (fun _ _ _ f g x => f (g x))%core - (fun _ _ _ _ _ _ _ => idpath) - (fun _ _ _ _ _ _ _ => idpath) - (fun _ _ _ => idpath) - (fun _ _ _ => idpath) - (fun _ => idpath)). - -Definition hom_functor `(C : @PreCategory objC) : Functor (C^op * C) (cat_of Type) - := Build_Functor _ _ cheat cheat cheat cheat. - -Definition induced_hom_natural_transformation `(F : @Functor objC C objD D) -: NaturalTransformation (hom_functor C) (hom_functor D o pair F^op F) - := Build_NaturalTransformation' _ _ cheat cheat cheat. - -Class IsFullyFaithful `(F : @Functor objC C objD D) - := is_fully_faithful - : forall x y : C, - IsIsomorphism (induced_hom_natural_transformation F (x, y)). - -Definition coyoneda `(A : @PreCategory objA) : Functor A^op (@functor_category _ A _ (cat_of Type)) - := cheat. - -Definition yoneda `(A : @PreCategory objA) : Functor A (@functor_category _ A^op _ (cat_of Type)) - := (((coyoneda A^op)^op'L)^op'L)%functor. -Definition coyoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@coyoneda _ A). -Admitted. - -Definition yoneda_embedding_fast `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). -Proof. - intros a b. - pose proof (coyoneda_embedding A^op a b) as CYE. - unfold yoneda. - Time let t := (type of CYE) in - let t' := (eval simpl in t) in pose proof ((fun (x : t) => (x : t')) CYE) as CYE'. (* Finished transaction in 0. secs (0.216013u,0.004s) *) - Fail Timeout 1 let t := match goal with |- ?G => constr:(G) end in - let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). - Time let t := match goal with |- ?G => constr:(G) end in - let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). (* Finished transaction in 0. secs (0.248016u,0.s) *) -Fail Timeout 2 Defined. -Time Defined. (* Finished transaction in 1. secs (0.432027u,0.s) *) - -Definition yoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). -Proof. - intros a b. - pose proof (coyoneda_embedding A^op a b) as CYE. - unfold yoneda; simpl in *. - Fail Timeout 1 exact CYE. - Time exact CYE. (* Finished transaction in 0. secs (0.012001u,0.s) *) -Abort. 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/misc/quotation_token/src/quotation.mlg b/test-suite/misc/quotation_token/src/quotation.mlg index 961b170a0d..ba0bcb1b3c 100644 --- a/test-suite/misc/quotation_token/src/quotation.mlg +++ b/test-suite/misc/quotation_token/src/quotation.mlg @@ -2,9 +2,9 @@ open Pcoq.Constr } GRAMMAR EXTEND Gram - GLOBAL: operconstr; + GLOBAL: term; - operconstr: LEVEL "0" + term: LEVEL "0" [ [ s = QUOTATION "foobar:" -> { CAst.make ~loc Constrexpr.(CSort Glob_term.(UNamed [GProp,0])) } ] ] diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index da2fc90fc3..01564e7f25 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -178,3 +178,6 @@ match N with | _ => Node end : Tree -> Tree +File "stdin", line 253, characters 4-5: +Warning: Unused variable B catches more than one case. +[unused-pattern-matching-variable,pattern-matching] diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 262ec2b677..2d8a8b359c 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -242,3 +242,15 @@ end. Print stray. End Bug11231. + +Module Wish12762. + +Inductive foo := a | b | c. + +Definition bar (f : foo) := + match f with + | a => 0 + | B => 1 + end. + +End Wish12762. diff --git a/test-suite/output/ErrorLocation_13241_1.out b/test-suite/output/ErrorLocation_13241_1.out new file mode 100644 index 0000000000..d899dd5d46 --- /dev/null +++ b/test-suite/output/ErrorLocation_13241_1.out @@ -0,0 +1,3 @@ +File "stdin", line 4, characters 0-1: +Error: No product even after head-reduction. + diff --git a/test-suite/output/ErrorLocation_13241_1.v b/test-suite/output/ErrorLocation_13241_1.v new file mode 100644 index 0000000000..3102b13fb8 --- /dev/null +++ b/test-suite/output/ErrorLocation_13241_1.v @@ -0,0 +1,5 @@ +Ltac a := intro. +Ltac b := a. +Goal True. +b. +Abort. diff --git a/test-suite/output/ErrorLocation_13241_2.out b/test-suite/output/ErrorLocation_13241_2.out new file mode 100644 index 0000000000..d899dd5d46 --- /dev/null +++ b/test-suite/output/ErrorLocation_13241_2.out @@ -0,0 +1,3 @@ +File "stdin", line 4, characters 0-1: +Error: No product even after head-reduction. + diff --git a/test-suite/output/ErrorLocation_13241_2.v b/test-suite/output/ErrorLocation_13241_2.v new file mode 100644 index 0000000000..b82f36ed6f --- /dev/null +++ b/test-suite/output/ErrorLocation_13241_2.v @@ -0,0 +1,5 @@ +Ltac a _ := intro. +Ltac b := a (). +Goal True. +b. +Abort. 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/Notations4.out b/test-suite/output/Notations4.out index a42518822f..a6fd39c29b 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -8,7 +8,7 @@ Entry custom:myconstr is | "4" RIGHTA [ SELF; "*"; NEXT ] | "3" RIGHTA - [ "<"; operconstr LEVEL "10"; ">" ] ] + [ "<"; term LEVEL "10"; ">" ] ] [< b > + < b > * < 2 >] : nat @@ -77,7 +77,7 @@ The command has indeed failed with message: The format is not the same on the right- and left-hand sides of the special token "..". Entry custom:expr is [ "201" RIGHTA - [ "{"; operconstr LEVEL "200"; "}" ] ] + [ "{"; term LEVEL "200"; "}" ] ] fun x : nat => [ x ] : nat -> nat @@ -125,3 +125,57 @@ Warning: Notation "_ :=: _" was already used. [notation-overridden,parsing] : Prop fun x : nat => <{ x; (S x) }> : nat -> nat +exists p : nat, ▢_p (p >= 1) + : Prop +▢_n (n >= 1) + : Prop +The command has indeed failed with message: +Found an inductive type while a variable name was expected. +The command has indeed failed with message: +Found a constructor while a variable name was expected. +The command has indeed failed with message: +Found a constant while a variable name was expected. +exists x y : nat, ▢_(x, y) (x >= 1 /\ y >= 2) + : Prop +▢_n (n >= 1) + : Prop +The command has indeed failed with message: +Found an inductive type while a pattern was expected. +▢_tt (tt = tt) + : Prop +The command has indeed failed with message: +Found a constant while a pattern was expected. +exists x y : nat, ▢_(x, y) (x >= 1 /\ y >= 2) + : Prop +pseudo_force n (fun n : nat => n >= 1) + : Prop +The command has indeed failed with message: +Found an inductive type while a pattern was expected. +▢_tt (tt = tt) + : Prop +The command has indeed failed with message: +Found a constant while a pattern was expected. +exists x y : nat, myforce (x, y) (x >= 1 /\ y >= 2) + : Prop +myforce n (n >= 1) + : Prop +The command has indeed failed with message: +Found an inductive type while a pattern was expected. +myforce tt (tt = tt) + : Prop +The command has indeed failed with message: +Found a constant while a pattern was expected. +id nat + : Set +fun a : bool => id a + : bool -> bool +fun nat : bool => id nat + : bool -> bool +The command has indeed failed with message: +Found an inductive type while a pattern was expected. +!! nat, nat = true + : Prop +!!! nat, nat = true + : Prop +!!!! (nat, id), nat = true /\ id = false + : Prop diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 6dadd8c7fe..0731819bba 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -124,7 +124,7 @@ Check r 2 3. End I. Require Import Coq.Numbers.Cyclic.Int63.Int63. -Module NumeralNotations. +Module NumberNotations. Module Test17. (** Test int63 *) Declare Scope test17_scope. @@ -134,7 +134,7 @@ Module NumeralNotations. Number Notation myint63 of_int to_int : test17_scope. Check let v := 0%test17 in v : myint63. End Test17. -End NumeralNotations. +End NumberNotations. Module K. @@ -313,3 +313,104 @@ Notation "x" := x (in custom com_top at level 90, x custom com at level 90). Check fun x => <{ x ; (S x) }>. End CoercionEntryTransitivity. + +(* Some corner cases *) + +Module P. + +(* Basic rules: + - a section variable be used for itself and as a binding variable + - a global name cannot be used for itself and as a binding variable +*) + + Definition pseudo_force {A} (n:A) (P:A -> Prop) := forall n', n' = n -> P n'. + + Module NotationMixedTermBinderAsIdent. + + Notation "▢_ n P" := (pseudo_force n (fun n => P)) + (at level 0, n ident, P at level 9, format "▢_ n P"). + Check exists p, ▢_p (p >= 1). + Section S. + Variable n:nat. + Check ▢_n (n >= 1). + End S. + Fail Check ▢_nat (nat = bool). + Fail Check ▢_O (O >= 1). + Axiom n:nat. + Fail Check ▢_n (n >= 1). + + End NotationMixedTermBinderAsIdent. + + Module NotationMixedTermBinderAsPattern. + + Notation "▢_ n P" := (pseudo_force n (fun n => P)) + (at level 0, n pattern, P at level 9, format "▢_ n P"). + Check exists x y, ▢_(x,y) (x >= 1 /\ y >= 2). + Section S. + Variable n:nat. + Check ▢_n (n >= 1). + End S. + Fail Check ▢_nat (nat = bool). + Check ▢_tt (tt = tt). + Axiom n:nat. + Fail Check ▢_n (n >= 1). + + End NotationMixedTermBinderAsPattern. + + Module NotationMixedTermBinderAsStrictPattern. + + Notation "▢_ n P" := (pseudo_force n (fun n => P)) + (at level 0, n strict pattern, P at level 9, format "▢_ n P"). + Check exists x y, ▢_(x,y) (x >= 1 /\ y >= 2). + Section S. + Variable n:nat. + Check ▢_n (n >= 1). + End S. + Fail Check ▢_nat (nat = bool). + Check ▢_tt (tt = tt). + Axiom n:nat. + Fail Check ▢_n (n >= 1). + + End NotationMixedTermBinderAsStrictPattern. + + Module AbbreviationMixedTermBinderAsStrictPattern. + + Notation myforce n P := (pseudo_force n (fun n => P)). + Check exists x y, myforce (x,y) (x >= 1 /\ y >= 2). + Section S. + Variable n:nat. + Check myforce n (n >= 1). (* strict hence not used for printing *) + End S. + Fail Check myforce nat (nat = bool). + Check myforce tt (tt = tt). + Axiom n:nat. + Fail Check myforce n (n >= 1). + + End AbbreviationMixedTermBinderAsStrictPattern. + + Module Bug4765Part. + + Notation id x := ((fun y => y) x). + Check id nat. + + Notation id' x := ((fun x => x) x). + Check fun a : bool => id' a. + Check fun nat : bool => id' nat. + Fail Check id' nat. + + End Bug4765Part. + + Module NotationBinderNotMixedWithTerms. + + Notation "!! x , P" := (forall x, P) (at level 200, x pattern). + Check !! nat, nat = true. + + Notation "!!! x , P" := (forall x, P) (at level 200). + Check !!! nat, nat = true. + + Notation "!!!! x , P" := (forall x, P) (at level 200, x strict pattern). + Check !!!! (nat,id), nat = true /\ id = false. + + End NotationBinderNotMixedWithTerms. + +End P. diff --git a/test-suite/output/NumberNotations.out b/test-suite/output/NumberNotations.out index 8065c8d311..60682edec8 100644 --- a/test-suite/output/NumberNotations.out +++ b/test-suite/output/NumberNotations.out @@ -1,9 +1,9 @@ The command has indeed failed with message: -Unexpected term (nat -> nat) while parsing a numeral notation. +Unexpected term (nat -> nat) while parsing a number notation. The command has indeed failed with message: -Unexpected non-option term opaque4 while parsing a numeral notation. +Unexpected non-option term opaque4 while parsing a number notation. The command has indeed failed with message: -Unexpected term (fun (A : Type) (x : A) => x) while parsing a numeral +Unexpected term (fun (A : Type) (x : A) => x) while parsing a number notation. let v := 0%ppp in v : punit : punit @@ -32,7 +32,7 @@ Warning: To avoid stack overflow, large numbers in punit are interpreted as applications of pto_punits. [abstract-large-number,numbers] The command has indeed failed with message: In environment -v := pto_punits (Numeral.UIntDec (Decimal.D1 Decimal.Nil)) : punit +v := pto_punits (Number.UIntDecimal (Decimal.D1 Decimal.Nil)) : punit The term "v" has type "punit@{Set}" while it is expected to have type "punit@{u}". S @@ -61,7 +61,7 @@ The command has indeed failed with message: In environment v := 0 : nat The term "v" has type "nat" while it is expected to have type "wuint". - = {| unwrap := Numeral.UIntDec (Decimal.D0 Decimal.Nil) |} + = {| unwrap := Number.UIntDecimal (Decimal.D0 Decimal.Nil) |} : wuint let v := 0%wuint8' in v : wuint : wuint @@ -82,7 +82,7 @@ function (of_uint) targets an option type. The command has indeed failed with message: The 'abstract after' directive has no effect when the parsing function (of_uint) targets an option type. [abstract-large-number-no-op,numbers] -let v := of_uint (Numeral.UIntDec (Decimal.D1 Decimal.Nil)) in v : unit +let v := of_uint (Number.UIntDecimal (Decimal.D1 Decimal.Nil)) in v : unit : unit let v := 0%test13 in v : unit : unit @@ -234,3 +234,282 @@ let v : ty := Build_ty Type type in v : ty : Prop 1_000 : list nat +0 + : Set +1 + : Set +2 + : Set +3 + : Set +Empty_set + : Set +unit + : Set +sum unit unit + : Set +sum unit (sum unit unit) + : Set +The command has indeed failed with message: +Missing mapping for constructor Isum. +The command has indeed failed with message: +Iunit was already mapped to unit and cannot be remapped to unit. +The command has indeed failed with message: +add is not an inductive type. +The command has indeed failed with message: +add is not a constructor of an inductive type. +The command has indeed failed with message: +Missing mapping for constructor Iempty. +File "stdin", line 574, characters 56-61: +Warning: Type of I'sum seems incompatible with the type of sum. +Expected type is: (I' -> I' -> I') instead of (I -> I' -> I'). +This might yield ill typed terms when using the notation. +[via-type-mismatch,numbers] +File "stdin", line 579, characters 32-33: +Warning: I was already mapped to Set, mapping it also to +nat might yield ill typed terms when using the notation. +[via-type-remapping,numbers] +File "stdin", line 579, characters 37-42: +Warning: Type of Iunit seems incompatible with the type of O. +Expected type is: I instead of I. +This might yield ill typed terms when using the notation. +[via-type-mismatch,numbers] +The command has indeed failed with message: +'via' and 'abstract' cannot be used together. +File "stdin", line 659, characters 21-23: +Warning: Type of I1 seems incompatible with the type of Fin.F1. +Expected type is: (nat -> I) instead of I. +This might yield ill typed terms when using the notation. +[via-type-mismatch,numbers] +File "stdin", line 659, characters 35-37: +Warning: Type of IS seems incompatible with the type of Fin.FS. +Expected type is: (nat -> I -> I) instead of (I -> I). +This might yield ill typed terms when using the notation. +[via-type-mismatch,numbers] +The command has indeed failed with message: +The term "0" has type "forall n : nat, Fin.t (S n)" +while it is expected to have type "nat". +0 + : Fin.t (S ?n) +where +?n : [ |- nat] +1 + : Fin.t (S (S ?n)) +where +?n : [ |- nat] +2 + : Fin.t (S (S (S ?n))) +where +?n : [ |- nat] +3 + : Fin.t (S (S (S (S ?n)))) +where +?n : [ |- nat] +0 : Fin.t 3 + : Fin.t 3 +1 : Fin.t 3 + : Fin.t 3 +2 : Fin.t 3 + : Fin.t 3 +The command has indeed failed with message: +The term "3" has type "Fin.t (S (S (S (S ?n))))" +while it is expected to have type "Fin.t 3". +@Fin.F1 ?n + : Fin.t (S ?n) +where +?n : [ |- nat] +@Fin.FS (S ?n) (@Fin.F1 ?n) + : Fin.t (S (S ?n)) +where +?n : [ |- nat] +@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n)) + : Fin.t (S (S (S ?n))) +where +?n : [ |- nat] +@Fin.FS (S (S (S ?n))) (@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n))) + : Fin.t (S (S (S (S ?n)))) +where +?n : [ |- nat] +@Fin.F1 (S (S O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +@Fin.FS (S (S O)) (@Fin.F1 (S O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +@Fin.FS (S (S O)) (@Fin.FS (S O) (@Fin.F1 O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +The command has indeed failed with message: +The term + "@Fin.FS (S (S (S ?n))) (@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n)))" +has type "Fin.t (S (S (S (S ?n))))" while it is expected to have type + "Fin.t (S (S (S O)))". +0 + : list unit +1 + : list unit +2 + : list unit +2 + : list unit +0 :: 0 :: nil + : list nat +0 + : Ip nat bool +1 + : Ip nat bool +2 + : Ip nat bool +3 + : Ip nat bool +1 + : Ip nat bool +1 + : Ip nat bool +1 + : Ip nat bool +1 + : Ip nat bool +Ip0 nat nat 1 + : Ip nat nat +Ip0 bool bool 1 + : Ip bool bool +Ip1 nat nat 1 + : Ip nat nat +Ip3 1 nat nat + : Ip nat nat +Ip0 nat bool O + : Ip nat bool +Ip1 bool nat (S O) + : Ip nat bool +Ip2 nat (S (S O)) bool + : Ip nat bool +Ip3 (S (S (S O))) nat bool + : Ip nat bool +0 + : 0 = 0 +eq_refl + : 1 = 1 +0 + : 1 = 1 +2 + : extra_list_unit +cons O unit tt (cons O unit tt (nil O unit)) + : extra_list unit +0 + : Set +1 + : Set +2 + : Set +3 + : Set +Empty_set + : Set +unit + : Set +sum unit unit + : Set +sum unit (sum unit unit) + : Set +0 + : Fin.t (S ?n) +where +?n : [ |- nat] +1 + : Fin.t (S (S ?n)) +where +?n : [ |- nat] +2 + : Fin.t (S (S (S ?n))) +where +?n : [ |- nat] +3 + : Fin.t (S (S (S (S ?n)))) +where +?n : [ |- nat] +0 : Fin.t 3 + : Fin.t 3 +1 : Fin.t 3 + : Fin.t 3 +2 : Fin.t 3 + : Fin.t 3 +The command has indeed failed with message: +The term "3" has type "Fin.t (S (S (S (S ?n))))" +while it is expected to have type "Fin.t 3". +@Fin.F1 ?n + : Fin.t (S ?n) +where +?n : [ |- nat] +@Fin.FS (S ?n) (@Fin.F1 ?n) + : Fin.t (S (S ?n)) +where +?n : [ |- nat] +@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n)) + : Fin.t (S (S (S ?n))) +where +?n : [ |- nat] +@Fin.FS (S (S (S ?n))) (@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n))) + : Fin.t (S (S (S (S ?n)))) +where +?n : [ |- nat] +@Fin.F1 (S (S O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +@Fin.FS (S (S O)) (@Fin.F1 (S O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +@Fin.FS (S (S O)) (@Fin.FS (S O) (@Fin.F1 O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +The command has indeed failed with message: +The term + "@Fin.FS (S (S (S ?n))) (@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n)))" +has type "Fin.t (S (S (S (S ?n))))" while it is expected to have type + "Fin.t (S (S (S O)))". +0 + : Fin.t (S ?n) +where +?n : [ |- nat : Set] +1 + : Fin.t (S (S ?n)) +where +?n : [ |- nat : Set] +2 + : Fin.t (S (S (S ?n))) +where +?n : [ |- nat : Set] +3 + : Fin.t (S (S (S (S ?n)))) +where +?n : [ |- nat : Set] +0 : Fin.t 3 + : Fin.t 3 +1 : Fin.t 3 + : Fin.t 3 +2 : Fin.t 3 + : Fin.t 3 +The command has indeed failed with message: +The term "3" has type "Fin.t (S (S (S (S ?n))))" +while it is expected to have type "Fin.t 3". +@Fin.F1 ?n + : Fin.t (S ?n) +where +?n : [ |- nat : Set] +@Fin.FS (S ?n) (@Fin.F1 ?n) + : Fin.t (S (S ?n)) +where +?n : [ |- nat : Set] +@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n)) + : Fin.t (S (S (S ?n))) +where +?n : [ |- nat : Set] +@Fin.FS (S (S (S ?n))) (@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n))) + : Fin.t (S (S (S (S ?n)))) +where +?n : [ |- nat : Set] +@Fin.F1 (S (S O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +@Fin.FS (S (S O)) (@Fin.F1 (S O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +@Fin.FS (S (S O)) (@Fin.FS (S O) (@Fin.F1 O)) : Fin.t (S (S (S O))) + : Fin.t (S (S (S O))) +The command has indeed failed with message: +The term + "@Fin.FS (S (S (S ?n))) (@Fin.FS (S (S ?n)) (@Fin.FS (S ?n) (@Fin.F1 ?n)))" +has type "Fin.t (S (S (S (S ?n))))" while it is expected to have type + "Fin.t (S (S (S O)))". diff --git a/test-suite/output/NumberNotations.v b/test-suite/output/NumberNotations.v index e411005da3..718da13500 100644 --- a/test-suite/output/NumberNotations.v +++ b/test-suite/output/NumberNotations.v @@ -5,17 +5,17 @@ Declare Scope opaque_scope. (* https://github.com/coq/coq/pull/8064#discussion_r202497516 *) Module Test1. Axiom hold : forall {A B C}, A -> B -> C. - Definition opaque3 (x : Numeral.int) : Numeral.int := hold x (fix f (x : nat) : nat := match x with O => O | S n => S (f n) end). - Number Notation Numeral.int opaque3 opaque3 : opaque_scope. + Definition opaque3 (x : Number.int) : Number.int := hold x (fix f (x : nat) : nat := match x with O => O | S n => S (f n) end). + Number Notation Number.int opaque3 opaque3 : opaque_scope. Delimit Scope opaque_scope with opaque. Fail Check 1%opaque. End Test1. (* https://github.com/coq/coq/pull/8064#discussion_r202497990 *) Module Test2. - Axiom opaque4 : option Numeral.int. - Definition opaque6 (x : Numeral.int) : option Numeral.int := opaque4. - Number Notation Numeral.int opaque6 opaque6 : opaque_scope. + Axiom opaque4 : option Number.int. + Definition opaque6 (x : Number.int) : option Number.int := opaque4. + Number Notation Number.int opaque6 opaque6 : opaque_scope. Delimit Scope opaque_scope with opaque. Open Scope opaque_scope. Fail Check 1%opaque. @@ -24,8 +24,8 @@ End Test2. Declare Scope silly_scope. Module Test3. - Inductive silly := SILLY (v : Numeral.uint) (f : forall A, A -> A). - Definition to_silly (v : Numeral.uint) := SILLY v (fun _ x => x). + Inductive silly := SILLY (v : Number.uint) (f : forall A, A -> A). + Definition to_silly (v : Number.uint) := SILLY v (fun _ x => x). Definition of_silly (v : silly) := match v with SILLY v _ => v end. Number Notation silly to_silly of_silly : silly_scope. Delimit Scope silly_scope with silly. @@ -45,15 +45,15 @@ Module Test4. Declare Scope upp. Declare Scope ppps. Polymorphic NonCumulative Inductive punit := ptt. - Polymorphic Definition pto_punit (v : Numeral.uint) : option punit := match Nat.of_num_uint v with O => Some ptt | _ => None end. - Polymorphic Definition pto_punit_all (v : Numeral.uint) : punit := ptt. - Polymorphic Definition pof_punit (v : punit) : Numeral.uint := Nat.to_num_uint 0. - Definition to_punit (v : Numeral.uint) : option punit := match Nat.of_num_uint v with O => Some ptt | _ => None end. - Definition of_punit (v : punit) : Numeral.uint := Nat.to_num_uint 0. - Polymorphic Definition pto_unit (v : Numeral.uint) : option unit := match Nat.of_num_uint v with O => Some tt | _ => None end. - Polymorphic Definition pof_unit (v : unit) : Numeral.uint := Nat.to_num_uint 0. - Definition to_unit (v : Numeral.uint) : option unit := match Nat.of_num_uint v with O => Some tt | _ => None end. - Definition of_unit (v : unit) : Numeral.uint := Nat.to_num_uint 0. + Polymorphic Definition pto_punit (v : Number.uint) : option punit := match Nat.of_num_uint v with O => Some ptt | _ => None end. + Polymorphic Definition pto_punit_all (v : Number.uint) : punit := ptt. + Polymorphic Definition pof_punit (v : punit) : Number.uint := Nat.to_num_uint 0. + Definition to_punit (v : Number.uint) : option punit := match Nat.of_num_uint v with O => Some ptt | _ => None end. + Definition of_punit (v : punit) : Number.uint := Nat.to_num_uint 0. + Polymorphic Definition pto_unit (v : Number.uint) : option unit := match Nat.of_num_uint v with O => Some tt | _ => None end. + Polymorphic Definition pof_unit (v : unit) : Number.uint := Nat.to_num_uint 0. + Definition to_unit (v : Number.uint) : option unit := match Nat.of_num_uint v with O => Some tt | _ => None end. + Definition of_unit (v : unit) : Number.uint := Nat.to_num_uint 0. Number Notation punit to_punit of_punit : pto. Number Notation punit pto_punit of_punit : ppo. Number Notation punit to_punit pof_punit : ptp. @@ -83,7 +83,7 @@ Module Test4. Polymorphic Definition pto_punits := pto_punit_all@{Set}. Polymorphic Definition pof_punits := pof_punit@{Set}. - Number Notation punit pto_punits pof_punits : ppps (abstract after 1). + Number Notation punit pto_punits pof_punits (abstract after 1) : ppps. Delimit Scope ppps with ppps. Universe u. Constraint Set < u. @@ -96,7 +96,7 @@ Module Test5. End Test5. Module Test6. - (* Check that numeral notations on enormous terms don't take forever to print/parse *) + (* Check that number notations on enormous terms don't take forever to print/parse *) (* Ackerman definition from https://stackoverflow.com/a/10303475/377022 *) Fixpoint ack (n m : nat) : nat := match n with @@ -113,15 +113,15 @@ Module Test6. Local Set Primitive Projections. Record > wnat := wrap { unwrap :> nat }. - Definition to_uint (x : wnat) : Numeral.uint := Nat.to_num_uint x. - Definition of_uint (x : Numeral.uint) : wnat := Nat.of_num_uint x. + Definition to_uint (x : wnat) : Number.uint := Nat.to_num_uint x. + Definition of_uint (x : Number.uint) : wnat := Nat.of_num_uint x. Module Export Scopes. Declare Scope wnat_scope. Delimit Scope wnat_scope with wnat. End Scopes. Module Export Notations. Export Scopes. - Number Notation wnat of_uint to_uint : wnat_scope (abstract after 5000). + Number Notation wnat of_uint to_uint (abstract after 5000) : wnat_scope. End Notations. Set Printing Coercions. Check let v := 0%wnat in v : wnat. @@ -138,7 +138,7 @@ End Test6_2. Module Test7. Local Set Primitive Projections. - Record wuint := wrap { unwrap : Numeral.uint }. + Record wuint := wrap { unwrap : Number.uint }. Declare Scope wuint_scope. Delimit Scope wuint_scope with wuint. Number Notation wuint wrap unwrap : wuint_scope. @@ -148,7 +148,7 @@ End Test7. Module Test8. Local Set Primitive Projections. - Record wuint := wrap { unwrap : Numeral.uint }. + Record wuint := wrap { unwrap : Number.uint }. Declare Scope wuint8_scope. Declare Scope wuint8'_scope. Delimit Scope wuint8_scope with wuint8. @@ -177,7 +177,7 @@ Module Test9. Delimit Scope wuint9'_scope with wuint9'. Section with_let. Local Set Primitive Projections. - Record wuint := wrap { unwrap : Numeral.uint }. + Record wuint := wrap { unwrap : Number.uint }. Let wrap' := wrap. Let unwrap' := unwrap. Local Notation wrap'' := wrap. @@ -194,26 +194,26 @@ End Test9. Module Test10. (* Test that it is only a warning to add abstract after to an optional parsing function *) Definition to_uint (v : unit) := Nat.to_num_uint 0. - Definition of_uint (v : Numeral.uint) := match Nat.of_num_uint v with O => Some tt | _ => None end. - Definition of_any_uint (v : Numeral.uint) := tt. + Definition of_uint (v : Number.uint) := match Nat.of_num_uint v with O => Some tt | _ => None end. + Definition of_any_uint (v : Number.uint) := tt. Declare Scope unit_scope. Declare Scope unit2_scope. Delimit Scope unit_scope with unit. Delimit Scope unit2_scope with unit2. - Number Notation unit of_uint to_uint : unit_scope (abstract after 1). + Number Notation unit of_uint to_uint (abstract after 1) : unit_scope. Local Set Warnings Append "+abstract-large-number-no-op". (* Check that there is actually a warning here *) - Fail Number Notation unit of_uint to_uint : unit2_scope (abstract after 1). + Fail Number Notation unit of_uint to_uint (abstract after 1) : unit2_scope. (* Check that there is no warning here *) - Number Notation unit of_any_uint to_uint : unit2_scope (abstract after 1). + Number Notation unit of_any_uint to_uint (abstract after 1) : unit2_scope. End Test10. Module Test12. - (* Test for numeral notations on context variables *) + (* Test for number notations on context variables *) Declare Scope test12_scope. Delimit Scope test12_scope with test12. Section test12. - Context (to_uint : unit -> Numeral.uint) (of_uint : Numeral.uint -> unit). + Context (to_uint : unit -> Number.uint) (of_uint : Number.uint -> unit). Number Notation unit of_uint to_uint : test12_scope. Check let v := 1%test12 in v : unit. @@ -221,15 +221,15 @@ Module Test12. End Test12. Module Test13. - (* Test for numeral notations on notations which do not denote references *) + (* Test for number notations on notations which do not denote references *) Declare Scope test13_scope. Declare Scope test13'_scope. Declare Scope test13''_scope. Delimit Scope test13_scope with test13. Delimit Scope test13'_scope with test13'. Delimit Scope test13''_scope with test13''. - Definition to_uint (x y : unit) : Numeral.uint := Nat.to_num_uint O. - Definition of_uint (x : Numeral.uint) : unit := tt. + Definition to_uint (x y : unit) : Number.uint := Nat.to_num_uint O. + Definition of_uint (x : Number.uint) : unit := tt. Definition to_uint_good := to_uint tt. Notation to_uint' := (to_uint tt). Notation to_uint'' := (to_uint _). @@ -242,7 +242,7 @@ Module Test13. End Test13. Module Test14. - (* Test that numeral notations follow [Import], not [Require], and + (* Test that number notations follow [Import], not [Require], and also test that [Local Number Notation]s do not escape modules nor sections. *) Declare Scope test14_scope. @@ -254,8 +254,8 @@ Module Test14. Delimit Scope test14''_scope with test14''. Delimit Scope test14'''_scope with test14'''. Module Inner. - Definition to_uint (x : unit) : Numeral.uint := Nat.to_num_uint O. - Definition of_uint (x : Numeral.uint) : unit := tt. + Definition to_uint (x : unit) : Number.uint := Nat.to_num_uint O. + Definition of_uint (x : Number.uint) : unit := tt. Local Number Notation unit of_uint to_uint : test14_scope. Global Number Notation unit of_uint to_uint : test14'_scope. Check let v := 0%test14 in v : unit. @@ -267,8 +267,8 @@ Module Test14. Fail Check let v := 0%test14 in v : unit. Check let v := 0%test14' in v : unit. Section InnerSection. - Definition to_uint (x : unit) : Numeral.uint := Nat.to_num_uint O. - Definition of_uint (x : Numeral.uint) : unit := tt. + Definition to_uint (x : unit) : Number.uint := Nat.to_num_uint O. + Definition of_uint (x : Number.uint) : unit := tt. Local Number Notation unit of_uint to_uint : test14''_scope. Fail Global Number Notation unit of_uint to_uint : test14'''_scope. Check let v := 0%test14'' in v : unit. @@ -283,8 +283,8 @@ Module Test15. Declare Scope test15_scope. Delimit Scope test15_scope with test15. Module Inner. - Definition to_uint (x : unit) : Numeral.uint := Nat.to_num_uint O. - Definition of_uint (x : Numeral.uint) : unit := tt. + Definition to_uint (x : unit) : Number.uint := Nat.to_num_uint O. + Definition of_uint (x : Number.uint) : unit := tt. Number Notation unit of_uint to_uint : test15_scope. Check let v := 0%test15 in v : unit. End Inner. @@ -306,8 +306,8 @@ Module Test16. End A. Module F (a : A). Inductive Foo := foo (_ : a.T). - Definition to_uint (x : Foo) : Numeral.uint := Nat.to_num_uint O. - Definition of_uint (x : Numeral.uint) : Foo := foo a.t. + Definition to_uint (x : Foo) : Number.uint := Nat.to_num_uint O. + Definition of_uint (x : Number.uint) : Foo := foo a.t. Global Number Notation Foo of_uint to_uint : test16_scope. Check let v := 0%test16 in v : Foo. End F. @@ -352,8 +352,8 @@ Module Test18. Definition Q_of_nat (x : nat) : Q := {| num := x ; den := 1 ; reduced := transparentify (nat_eq_dec _ _) (gcd_good _) |}. Definition nat_of_Q (x : Q) : option nat := if Nat.eqb x.(den) 1 then Some (x.(num)) else None. - Definition Q_of_uint (x : Numeral.uint) : Q := Q_of_nat (Nat.of_num_uint x). - Definition uint_of_Q (x : Q) : option Numeral.uint + Definition Q_of_uint (x : Number.uint) : Q := Q_of_nat (Nat.of_num_uint x). + Definition uint_of_Q (x : Q) : option Number.uint := option_map Nat.to_num_uint (nat_of_Q x). Number Notation Q Q_of_uint uint_of_Q : Q_scope. @@ -411,7 +411,7 @@ Module Test20. Record > ty := { t : Type ; kt : known_type t }. - Definition ty_of_uint (x : Numeral.uint) : option ty + Definition ty_of_uint (x : Number.uint) : option ty := match Nat.of_num_uint x with | 0 => @Some ty zero | 1 => @Some ty one @@ -421,7 +421,7 @@ Module Test20. | 5 => @Some ty type | _ => None end. - Definition uint_of_ty (x : ty) : Numeral.uint + Definition uint_of_ty (x : ty) : Number.uint := Nat.to_num_uint match kt x with | prop => 3 | set => 4 @@ -487,3 +487,488 @@ Check (-0)%Z. *) End Test22. + +(* Test the via ... mapping ... option *) +Module Test23. + +Inductive sum (A : Set) (B : Set) : Set := pair : A -> B -> sum A B. + +Inductive I := +| Iempty : I +| Iunit : I +| Isum : I -> I -> I. + +Definition of_uint (x : Number.uint) : I := + let fix f n := + match n with + | O => Iempty + | S O => Iunit + | S n => Isum Iunit (f n) + end in + f (Nat.of_num_uint x). + +Definition to_uint (x : I) : Number.uint := + let fix f i := + match i with + | Iempty => O + | Iunit => 1 + | Isum i1 i2 => f i1 + f i2 + end in + Nat.to_num_uint (f x). + +Notation nSet := (Set) (only parsing). (* needed as a reference is expected in Number Notation and Set is syntactically not a reference *) +Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum]) + : type_scope. + +Local Open Scope type_scope. + +Check Empty_set. +Check unit. +Check sum unit unit. +Check sum unit (sum unit unit). +Set Printing All. +Check 0. +Check 1. +Check 2. +Check 3. +Unset Printing All. + +(* Test error messages *) + +(* missing constructor *) +Fail Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit]) + : type_scope. + +(* duplicate constructor *) +Fail Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum, unit => Iunit]) + : type_scope. + +(* not an inductive *) +Fail Number Notation nSet of_uint to_uint (via add + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum]) + : type_scope. + +(* not a constructor *) +Fail Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => add, sum => Isum]) + : type_scope. + +(* put constructors of the wrong inductive ~~> missing constructors *) +Fail Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => O, unit => S]) + : type_scope. + +(* Test warnings *) + +(* wrong type *) +Inductive I' := +| I'empty : I' +| I'unit : I' +| I'sum : I -> I' -> I'. +Definition of_uint' (x : Number.uint) : I' := I'empty. +Definition to_uint' (x : I') : Number.uint := Number.UIntDecimal Decimal.Nil. +Number Notation nSet of_uint' to_uint' (via I' + mapping [Empty_set => I'empty, unit => I'unit, sum => I'sum]) + : type_scope. + +(* wrong type mapping *) +Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, O => Iunit, sum => Isum]) + : type_scope. + +(* incompatibility with abstract (but warning is fine) *) +Fail Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum], + abstract after 12) + : type_scope. +Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum], + warning after 12) + : type_scope. + +(* Test reduction of types when building the notation *) + +Inductive foo := bar : match (true <: bool) with true => nat -> foo | false => True end. + +Definition foo_of_uint (x : Number.uint) : foo := bar (Nat.of_num_uint x). +Definition foo_to_uint (x : foo) : Number.uint := + match x with + | bar x => Nat.to_num_uint x + end. + +Number Notation foo foo_of_uint foo_to_uint (via foo mapping [bar => bar]) + : type_scope. + +Inductive foo' := bar' : let n := nat in n -> foo'. + +Definition foo'_of_uint (x : Number.uint) : foo' := bar' (Nat.of_num_uint x). +Definition foo'_to_uint (x : foo') : Number.uint := + match x with + | bar' x => Nat.to_num_uint x + end. + +Number Notation foo' foo'_of_uint foo'_to_uint (via foo' mapping [bar' => bar']) + : type_scope. + +Inductive foo'' := bar'' : (nat <: Type) -> (foo'' <: Type). + +Definition foo''_of_uint (x : Number.uint) : foo'' := bar'' (Nat.of_num_uint x). +Definition foo''_to_uint (x : foo'') : Number.uint := + match x with + | bar'' x => Nat.to_num_uint x + end. + +Number Notation foo'' foo''_of_uint foo''_to_uint (via foo'' mapping [bar'' => bar'']) + : type_scope. + +End Test23. + +(* Test the via ... mapping ... option with implicit arguments *) +Require Vector. +Module Test24. + +Import Vector. + +Inductive I := +| I1 : I +| IS : I -> I. + +Definition of_uint (x : Number.uint) : I := + let fix f n := + match n with + | O => I1 + | S n => IS (f n) + end in + f (Nat.of_num_uint x). + +Definition to_uint (x : I) : Number.uint := + let fix f i := + match i with + | I1 => O + | IS n => S (f n) + end in + Nat.to_num_uint (f x). + +Local Open Scope type_scope. + +(* ignoring implicit arguments doesn't work *) +Number Notation Fin.t of_uint to_uint (via I + mapping [Fin.F1 => I1, Fin.FS => IS]) + : type_scope. + +Fail Check 1. + +Number Notation Fin.t of_uint to_uint (via I + mapping [[Fin.F1] => I1, [Fin.FS] => IS]) + : type_scope. + +Check Fin.F1. +Check Fin.FS Fin.F1. +Check Fin.FS (Fin.FS Fin.F1). +Check Fin.FS (Fin.FS (Fin.FS Fin.F1)). +Check Fin.F1 : Fin.t 3. +Check Fin.FS Fin.F1 : Fin.t 3. +Check Fin.FS (Fin.FS Fin.F1) : Fin.t 3. +Fail Check Fin.FS (Fin.FS (Fin.FS Fin.F1)) : Fin.t 3. +Set Printing All. +Check 0. +Check 1. +Check 2. +Check 3. +Check 0 : Fin.t 3. +Check 1 : Fin.t 3. +Check 2 : Fin.t 3. +Fail Check 3 : Fin.t 3. +Unset Printing All. + +End Test24. + +(* Test number notations for parameterized inductives *) +Module Test25. + +Definition of_uint (u : Number.uint) : list unit := + let fix f n := + match n with + | O => nil + | S n => cons tt (f n) + end in + f (Nat.of_num_uint u). + +Definition to_uint (l : list unit) : Number.uint := + let fix f n := + match n with + | nil => O + | cons tt l => S (f l) + end in + Nat.to_num_uint (f l). + +Notation listunit := (list unit) (only parsing). +Number Notation listunit of_uint to_uint : nat_scope. + +Check 0. +Check 1. +Check 2. + +Check cons tt (cons tt nil). +Check cons O (cons O nil). (* printer not called on list nat *) + +(* inductive with multiple parameters that are not the first + parameters and not in the same order for each constructor *) +Inductive Ip : Type -> Type -> Type := +| Ip0 : forall T T', nat -> Ip T T' +| Ip1 : forall T' T, nat -> Ip T T' +| Ip2 : forall T, nat -> forall T', Ip T T' +| Ip3 : nat -> forall T T', Ip T T'. + +Definition Ip_of_uint (u : Number.uint) : option (Ip nat bool) := + let f n := + match n with + | O => Some (Ip0 nat bool O) + | S O => Some (Ip1 bool nat (S O)) + | S (S O) => Some (Ip2 nat (S (S O)) bool) + | S (S (S O)) => Some (Ip3 (S (S (S O))) nat bool) + | _ => None + end in + f (Nat.of_num_uint u). + +Definition Ip_to_uint (l : Ip nat bool) : Number.uint := + let f n := + match n with + | Ip0 _ _ n => n + | Ip1 _ _ n => n + | Ip2 _ n _ => n + | Ip3 n _ _ => n + end in + Nat.to_num_uint (f l). + +Notation Ip_nat_bool := (Ip nat bool) (only parsing). +Number Notation Ip_nat_bool Ip_of_uint Ip_to_uint : nat_scope. + +Check 0. +Check 1. +Check 2. +Check 3. +Check Ip0 nat bool (S O). +Check Ip1 bool nat (S O). +Check Ip2 nat (S O) bool. +Check Ip3 (S O) nat bool. +Check Ip0 nat nat (S O). (* not printed *) +Check Ip0 bool bool (S O). (* not printed *) +Check Ip1 nat nat (S O). (* not printed *) +Check Ip3 (S O) nat nat. (* not printed *) +Set Printing All. +Check 0. +Check 1. +Check 2. +Check 3. +Unset Printing All. + +Notation eqO := (eq _ O) (only parsing). +Definition eqO_of_uint (x : Number.uint) : eqO := eq_refl O. +Definition eqO_to_uint (x : O = O) : Number.uint := + match x with + | eq_refl _ => Nat.to_num_uint O + end. +Number Notation eqO eqO_of_uint eqO_to_uint : nat_scope. + +Check 42. +Check eq_refl (S O). (* doesn't match eq _ O, printer not called *) + +Notation eq_ := (eq _ _) (only parsing). +Number Notation eq_ eqO_of_uint eqO_to_uint : nat_scope. + +Check eq_refl (S O). (* matches eq _ _, printer called *) + +Inductive extra_list : Type -> Type := +| nil (n : nat) (v : Type) : extra_list v +| cons (n : nat) (t : Type) (x : t) : extra_list t -> extra_list t. + +Definition extra_list_unit_of_uint (x : Number.uint) : extra_list unit := + let fix f n := + match n with + | O => nil O unit + | S n => cons O unit tt (f n) + end in + f (Nat.of_num_uint x). + +Definition extra_list_unit_to_uint (x : extra_list unit) : Number.uint := + let fix f T (x : extra_list T) := + match x with + | nil _ _ => O + | cons _ T _ x => S (f T x) + end in + Nat.to_num_uint (f unit x). + +Notation extra_list_unit := (extra_list unit). +Number Notation extra_list_unit + extra_list_unit_of_uint extra_list_unit_to_uint : nat_scope. + +Check 2. +Set Printing All. +Check 2. +Unset Printing All. + +End Test25. + +(* Test the via ... mapping ... option with let-binders, beta-redexes, delta-redexes, etc *) +Module Test26. + +Inductive sum (A : Set) (B : Set) : Set := pair : A -> B -> sum A B. + +Inductive I (dummy:=O) := +| Iempty : let v := I in id v +| Iunit : (fun x => x) I +| Isum : let v := I in (fun A B => A -> B) (let v' := v in v') (forall x : match O with O => I | _ => Empty_set end, let dummy2 := x in I). + +Definition of_uint (x : (fun x => let v := I in x) Number.uint) : (fun x => let v := I in x) I := + let fix f n := + match n with + | O => Iempty + | S O => Iunit + | S n => Isum Iunit (f n) + end in + f (Nat.of_num_uint x). + +Definition to_uint (x : (fun x => let v := x in v) I) : match O with O => Number.uint | _ => Empty_set end := + let fix f i := + match i with + | Iempty => O + | Iunit => 1 + | Isum i1 i2 => f i1 + f i2 + end in + Nat.to_num_uint (f x). + +Notation nSet := (Set) (only parsing). (* needed as a reference is expected in Number Notation and Set is syntactically not a reference *) +Number Notation nSet of_uint to_uint (via I + mapping [Empty_set => Iempty, unit => Iunit, sum => Isum]) + : type_scope. + +Local Open Scope type_scope. + +Check Empty_set. +Check unit. +Check sum unit unit. +Check sum unit (sum unit unit). +Set Printing All. +Check 0. +Check 1. +Check 2. +Check 3. +Unset Printing All. +End Test26. + +(* Test the via ... mapping ... option with implicit arguments with let binders, etc *) +Module Test27. + +Module Fin. +Inductive t0 (x:=O) := +with + t (x:=O) : forall y : nat, let z := y in Set := +| F1 (y:=O) {n} : match y with O => t (S n) | _ => Empty_set end +| FS (y:=x) {n} (v:=n+y) (m:=n) : id (match y with O => id (t n) | _ => Empty_set end -> (fun x => x) t (S m)) +with t' (x:=O) := . +End Fin. + +Inductive I (dummy:=O) := +| I1 : I +| IS : let x := I in id x -> I. + +Definition of_uint (x : Number.uint) : I := + let fix f n := + match n with + | O => I1 + | S n => IS (f n) + end in + f (Nat.of_num_uint x). + +Definition to_uint (x : I) : Number.uint := + let fix f i := + match i with + | I1 => O + | IS n => S (f n) + end in + Nat.to_num_uint (f x). + +Local Open Scope type_scope. + +Number Notation Fin.t of_uint to_uint (via I + mapping [[Fin.F1] => I1, [Fin.FS] => IS]) + : type_scope. + +Check Fin.F1. +Check Fin.FS Fin.F1. +Check Fin.FS (Fin.FS Fin.F1). +Check Fin.FS (Fin.FS (Fin.FS Fin.F1)). +Check Fin.F1 : Fin.t 3. +Check Fin.FS Fin.F1 : Fin.t 3. +Check Fin.FS (Fin.FS Fin.F1) : Fin.t 3. +Fail Check Fin.FS (Fin.FS (Fin.FS Fin.F1)) : Fin.t 3. +Set Printing All. +Check 0. +Check 1. +Check 2. +Check 3. +Check 0 : Fin.t 3. +Check 1 : Fin.t 3. +Check 2 : Fin.t 3. +Fail Check 3 : Fin.t 3. +Unset Printing All. + +End Test27. + +Module Test28. +Module Fin. +Inductive t : nat -> Set := +| F1 {n : (nat : Set)} : (t (S n) : Set) +| FS {n : (nat : Set)} : (t n : Set) -> (t (S n) : Set). +End Fin. + +Inductive I := +| I1 : I +| IS : I -> I. + +Definition of_uint (x : Number.uint) : I := + let fix f n := + match n with + | O => I1 + | S n => IS (f n) + end in + f (Nat.of_num_uint x). + +Definition to_uint (x : I) : Number.uint := + let fix f i := + match i with + | I1 => O + | IS n => S (f n) + end in + Nat.to_num_uint (f x). + +Local Open Scope type_scope. + +Number Notation Fin.t of_uint to_uint (via I + mapping [[Fin.F1] => I1, [Fin.FS] => IS]) + : type_scope. + +Check Fin.F1. +Check Fin.FS Fin.F1. +Check Fin.FS (Fin.FS Fin.F1). +Check Fin.FS (Fin.FS (Fin.FS Fin.F1)). +Check Fin.F1 : Fin.t 3. +Check Fin.FS Fin.F1 : Fin.t 3. +Check Fin.FS (Fin.FS Fin.F1) : Fin.t 3. +Fail Check Fin.FS (Fin.FS (Fin.FS Fin.F1)) : Fin.t 3. +Set Printing All. +Check 0. +Check 1. +Check 2. +Check 3. +Check 0 : Fin.t 3. +Check 1 : Fin.t 3. +Check 2 : Fin.t 3. +Fail Check 3 : Fin.t 3. +Unset Printing All. + +End Test28. diff --git a/test-suite/output/QArithSyntax.out b/test-suite/output/QArithSyntax.out index 9b5c076cb4..ced52524f2 100644 --- a/test-suite/output/QArithSyntax.out +++ b/test-suite/output/QArithSyntax.out @@ -1,26 +1,72 @@ eq_refl : 1.02 = 1.02 : 1.02 = 1.02 -eq_refl : 10.2 = 10.2 - : 10.2 = 10.2 -eq_refl : 1020 = 1020 - : 1020 = 1020 -eq_refl : 102 = 102 - : 102 = 102 -eq_refl : 1.02 = 1.02 - : 1.02 = 1.02 -eq_refl : -1e-4 = -1e-4 - : -1e-4 = -1e-4 +1.02e1 + : Q +10.2 + : Q +1.02e3 + : Q +1020 + : Q +1.02e2 + : Q +102 + : Q +eq_refl : 10.2e-1 = 1.02 + : 10.2e-1 = 1.02 +eq_refl : -0.0001 = -0.0001 + : -0.0001 = -0.0001 eq_refl : -0.50 = -0.50 : -0.50 = -0.50 -eq_refl : -26 = -26 - : -26 = -26 -eq_refl : 2860 # 256 = 2860 # 256 - : 2860 # 256 = 2860 # 256 -eq_refl : -6882 = -6882 - : -6882 = -6882 -eq_refl : 2860 # 64 = 2860 # 64 - : 2860 # 64 = 2860 # 64 -eq_refl : 2860 = 2860 - : 2860 = 2860 -eq_refl : -2860 # 1024 = -2860 # 1024 - : -2860 # 1024 = -2860 # 1024 +0 + : Q +0 + : Q +42 + : Q +42 + : Q +1.23 + : Q +0x1.23%xQ + : Q +0.0012 + : Q +42e3 + : Q +42e-3 + : Q +eq_refl : -0x1a = -0x1a + : -0x1a = -0x1a +eq_refl : 0xb.2c = 0xb.2c + : 0xb.2c = 0xb.2c +eq_refl : -0x1ae2 = -0x1ae2 + : -0x1ae2 = -0x1ae2 +0xb.2cp2 + : Q +2860 # 64 + : Q +0xb.2cp8 + : Q +0xb2c + : Q +eq_refl : -0xb.2cp-2 = -2860 # 1024 + : -0xb.2cp-2 = -2860 # 1024 +0x0 + : Q +0x0 + : Q +0x2a + : Q +0x2a + : Q +1.23%Q + : Q +0x1.23 + : Q +0x0.0012 + : Q +0x2ap3 + : Q +0x2ap-3 + : Q diff --git a/test-suite/output/QArithSyntax.v b/test-suite/output/QArithSyntax.v index b5c6222bba..e979abca66 100644 --- a/test-suite/output/QArithSyntax.v +++ b/test-suite/output/QArithSyntax.v @@ -1,15 +1,39 @@ Require Import QArith. Open Scope Q_scope. Check (eq_refl : 1.02 = 102 # 100). -Check (eq_refl : 1.02e1 = 102 # 10). -Check (eq_refl : 1.02e+03 = 1020). -Check (eq_refl : 1.02e+02 = 102 # 1). +Check 1.02e1. +Check 102 # 10. +Check 1.02e+03. +Check 1020. +Check 1.02e+02. +Check 102 # 1. Check (eq_refl : 10.2e-1 = 1.02). Check (eq_refl : -0.0001 = -1 # 10000). Check (eq_refl : -0.50 = - 50 # 100). +Check 0. +Check 000. +Check 42. +Check 0x2a. +Check 1.23. +Check 0x1.23. +Check 0.0012. +Check 42e3. +Check 42e-3. +Open Scope hex_Q_scope. Check (eq_refl : -0x1a = - 26 # 1). Check (eq_refl : 0xb.2c = 2860 # 256). Check (eq_refl : -0x1ae2 = -6882). -Check (eq_refl : 0xb.2cp2 = 2860 # 64). -Check (eq_refl : 0xb.2cp8 = 2860). +Check 0xb.2cp2. +Check 2860 # 64. +Check 0xb.2cp8. +Check 2860. Check (eq_refl : -0xb.2cp-2 = -2860 # 1024). +Check 0x0. +Check 0x00. +Check 42. +Check 0x2a. +Check 1.23. +Check 0x1.23. +Check 0x0.0012. +Check 0x2ap3. +Check 0x2ap-3. diff --git a/test-suite/output/RealSyntax.out b/test-suite/output/RealSyntax.out index a9386b2781..a7b7dabb20 100644 --- a/test-suite/output/RealSyntax.out +++ b/test-suite/output/RealSyntax.out @@ -4,34 +4,81 @@ : R 1.5%R : R -15%R - : R -eq_refl : 1.02 = 1.02 - : 1.02 = 1.02 -eq_refl : 10.2 = 10.2 - : 10.2 = 10.2 -eq_refl : 102e1 = 102e1 - : 102e1 = 102e1 -eq_refl : 102 = 102 - : 102 = 102 -eq_refl : 1.02 = 1.02 - : 1.02 = 1.02 -eq_refl : -1e-4 = -1e-4 - : -1e-4 = -1e-4 -eq_refl : -0.50 = -0.50 - : -0.50 = -0.50 +1.5e1%R + : R +eq_refl : 1.02 = 102e-2 + : 1.02 = 102e-2 +1.02e1 + : R +102e-1 + : R +1.02e3 + : R +102e1 + : R +1.02e2 + : R +102 + : R +10.2e-1 + : R +1.02 + : R +eq_refl : -0.0001 = -1e-4 + : -0.0001 = -1e-4 +eq_refl : -0.50 = -50e-2 + : -0.50 = -50e-2 eq_refl : -26 = -26 : -26 = -26 -eq_refl : 2860 / IZR (BinIntDef.Z.pow_pos 2 8) = 2860 / IZR (Z.pow_pos 2 8) - : 2860 / IZR (BinIntDef.Z.pow_pos 2 8) = 2860 / IZR (Z.pow_pos 2 8) +eq_refl : 0xb.2c%xR = 0xb2cp-8%xR + : 0xb.2c%xR = 0xb2cp-8%xR eq_refl : -6882 = -6882 : -6882 = -6882 -eq_refl : 2860 / IZR (BinIntDef.Z.pow_pos 2 6) = 2860 / IZR (Z.pow_pos 2 6) - : 2860 / IZR (BinIntDef.Z.pow_pos 2 6) = 2860 / IZR (Z.pow_pos 2 6) -eq_refl : 2860 = 2860 - : 2860 = 2860 -eq_refl -: --2860 / IZR (BinIntDef.Z.pow_pos 2 10) = - (2860) / IZR (Z.pow_pos 2 10) - : -2860 / IZR (BinIntDef.Z.pow_pos 2 10) = - - (2860) / IZR (Z.pow_pos 2 10) +0xb.2cp2%xR + : R +0xb2cp-6%xR + : R +0xb.2cp8%xR + : R +2860 + : R +(-0xb.2cp-2)%xR + : R +- 0xb2cp-10%xR + : R +0 + : R +0 + : R +42 + : R +42 + : R +1.23 + : R +0x1.23%xR + : R +0.0012 + : R +42e3 + : R +42e-3 + : R +0x0 + : R +0x0 + : R +0x2a + : R +0x2a + : R +1.23%R + : R +0x1.23 + : R +0x0.0012 + : R +0x2ap3 + : R +0x2ap-3 + : R diff --git a/test-suite/output/RealSyntax.v b/test-suite/output/RealSyntax.v index 69ce3ef5f9..790d5c654f 100644 --- a/test-suite/output/RealSyntax.v +++ b/test-suite/output/RealSyntax.v @@ -8,18 +8,48 @@ Check 1_.5_e1_%R. Open Scope R_scope. Check (eq_refl : 1.02 = IZR 102 / IZR (Z.pow_pos 10 2)). -Check (eq_refl : 1.02e1 = IZR 102 / IZR (Z.pow_pos 10 1)). -Check (eq_refl : 1.02e+03 = IZR 102 * IZR (Z.pow_pos 10 1)). -Check (eq_refl : 1.02e+02 = IZR 102). -Check (eq_refl : 10.2e-1 = 1.02). +Check 1.02e1. +Check IZR 102 / IZR (Z.pow_pos 10 1). +Check 1.02e+03. +Check IZR 102 * IZR (Z.pow_pos 10 1). +Check 1.02e+02. +Check IZR 102. +Check 10.2e-1. +Check 1.02. Check (eq_refl : -0.0001 = IZR (-1) / IZR (Z.pow_pos 10 4)). Check (eq_refl : -0.50 = IZR (-50) / IZR (Z.pow_pos 10 2)). Check (eq_refl : -0x1a = - 26). Check (eq_refl : 0xb.2c = IZR 2860 / IZR (Z.pow_pos 2 8)). Check (eq_refl : -0x1ae2 = -6882). -Check (eq_refl : 0xb.2cp2 = IZR 2860 / IZR (Z.pow_pos 2 6)). -Check (eq_refl : 0xb.2cp8 = 2860). -Check (eq_refl : -0xb.2cp-2 = - IZR 2860 / IZR (Z.pow_pos 2 10)). +Check 0xb.2cp2. +Check IZR 2860 / IZR (Z.pow_pos 2 6). +Check 0xb.2cp8. +Check 2860. +Check -0xb.2cp-2. +Check - (IZR 2860 / IZR (Z.pow_pos 2 10)). +Check 0. +Check 000. +Check 42. +Check 0x2a. +Check 1.23. +Check 0x1.23. +Check 0.0012. +Check 42e3. +Check 42e-3. + +Open Scope hex_R_scope. + +Check 0x0. +Check 0x000. +Check 42. +Check 0x2a. +Check 1.23. +Check 0x1.23. +Check 0x0.0012. +Check 0x2ap3. +Check 0x2ap-3. + +Close Scope hex_R_scope. Require Import Reals. diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index 09feca71e7..0f5fd91d93 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -30,15 +30,15 @@ implb: bool -> bool -> bool Nat.odd: nat -> bool Nat.even: nat -> bool BoolSpec: Prop -> Prop -> bool -> Prop -Numeral.numeral_beq: Numeral.numeral -> Numeral.numeral -> bool +Number.number_beq: Number.number -> Number.number -> bool Nat.eqb: nat -> nat -> bool Nat.testbit: nat -> nat -> bool Decimal.decimal_beq: Decimal.decimal -> Decimal.decimal -> bool -Numeral.uint_beq: Numeral.uint -> Numeral.uint -> bool +Number.uint_beq: Number.uint -> Number.uint -> bool Decimal.uint_beq: Decimal.uint -> Decimal.uint -> bool Hexadecimal.hexadecimal_beq: Hexadecimal.hexadecimal -> Hexadecimal.hexadecimal -> bool -Numeral.int_beq: Numeral.int -> Numeral.int -> bool +Number.int_beq: Number.int -> Number.int -> bool Hexadecimal.uint_beq: Hexadecimal.uint -> Hexadecimal.uint -> bool Nat.ltb: nat -> nat -> bool Nat.leb: nat -> nat -> bool @@ -64,34 +64,34 @@ eq_true_rec: bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b eq_true_sind: forall P : bool -> SProp, P true -> forall b : bool, eq_true b -> P b -Numeral.internal_uint_dec_bl1: - forall x y : Numeral.uint, Numeral.uint_beq x y = true -> x = y +Number.internal_uint_dec_bl1: + forall x y : Number.uint, Number.uint_beq x y = true -> x = y Hexadecimal.internal_hexadecimal_dec_lb: forall x y : Hexadecimal.hexadecimal, x = y -> Hexadecimal.hexadecimal_beq x y = true Hexadecimal.internal_int_dec_lb0: forall x y : Hexadecimal.int, x = y -> Hexadecimal.int_beq x y = true -Numeral.internal_numeral_dec_lb: - forall x y : Numeral.numeral, x = y -> Numeral.numeral_beq x y = true +Number.internal_number_dec_lb: + forall x y : Number.number, x = y -> Number.number_beq x y = true Decimal.internal_decimal_dec_lb: forall x y : Decimal.decimal, x = y -> Decimal.decimal_beq x y = true Hexadecimal.internal_int_dec_bl0: forall x y : Hexadecimal.int, Hexadecimal.int_beq x y = true -> x = y -Numeral.internal_int_dec_lb1: - forall x y : Numeral.int, x = y -> Numeral.int_beq x y = true -Numeral.internal_int_dec_bl1: - forall x y : Numeral.int, Numeral.int_beq x y = true -> x = y +Number.internal_int_dec_lb1: + forall x y : Number.int, x = y -> Number.int_beq x y = true +Number.internal_int_dec_bl1: + forall x y : Number.int, Number.int_beq x y = true -> x = y Hexadecimal.internal_hexadecimal_dec_bl: forall x y : Hexadecimal.hexadecimal, Hexadecimal.hexadecimal_beq x y = true -> x = y -Numeral.internal_uint_dec_lb1: - forall x y : Numeral.uint, x = y -> Numeral.uint_beq x y = true +Number.internal_uint_dec_lb1: + forall x y : Number.uint, x = y -> Number.uint_beq x y = true Decimal.internal_int_dec_bl: forall x y : Decimal.int, Decimal.int_beq x y = true -> x = y Decimal.internal_int_dec_lb: forall x y : Decimal.int, x = y -> Decimal.int_beq x y = true -Numeral.internal_numeral_dec_bl: - forall x y : Numeral.numeral, Numeral.numeral_beq x y = true -> x = y +Number.internal_number_dec_bl: + forall x y : Number.number, Number.number_beq x y = true -> x = y Byte.of_bits: bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) -> Byte.byte @@ -160,21 +160,21 @@ f_equal2_mult: f_equal2_nat: forall (B : Type) (f : nat -> nat -> B) (x1 y1 x2 y2 : nat), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2 -Numeral.internal_numeral_dec_lb: - forall x y : Numeral.numeral, x = y -> Numeral.numeral_beq x y = true -Numeral.internal_int_dec_lb1: - forall x y : Numeral.int, x = y -> Numeral.int_beq x y = true -Numeral.internal_numeral_dec_bl: - forall x y : Numeral.numeral, Numeral.numeral_beq x y = true -> x = y +Number.internal_number_dec_lb: + forall x y : Number.number, x = y -> Number.number_beq x y = true +Number.internal_int_dec_lb1: + forall x y : Number.int, x = y -> Number.int_beq x y = true +Number.internal_number_dec_bl: + forall x y : Number.number, Number.number_beq x y = true -> x = y Hexadecimal.internal_hexadecimal_dec_lb: forall x y : Hexadecimal.hexadecimal, x = y -> Hexadecimal.hexadecimal_beq x y = true -Numeral.internal_int_dec_bl1: - forall x y : Numeral.int, Numeral.int_beq x y = true -> x = y -Numeral.internal_uint_dec_lb1: - forall x y : Numeral.uint, x = y -> Numeral.uint_beq x y = true -Numeral.internal_uint_dec_bl1: - forall x y : Numeral.uint, Numeral.uint_beq x y = true -> x = y +Number.internal_int_dec_bl1: + forall x y : Number.int, Number.int_beq x y = true -> x = y +Number.internal_uint_dec_lb1: + forall x y : Number.uint, x = y -> Number.uint_beq x y = true +Number.internal_uint_dec_bl1: + forall x y : Number.uint, Number.uint_beq x y = true -> x = y Decimal.internal_decimal_dec_lb: forall x y : Decimal.decimal, x = y -> Decimal.decimal_beq x y = true Hexadecimal.internal_hexadecimal_dec_bl: @@ -213,18 +213,18 @@ bool_choice: forall [S : Set] [R1 R2 : S -> Prop], (forall x : S, {R1 x} + {R2 x}) -> {f : S -> bool | forall x : S, f x = true /\ R1 x \/ f x = false /\ R2 x} -Numeral.internal_numeral_dec_lb: - forall x y : Numeral.numeral, x = y -> Numeral.numeral_beq x y = true -Numeral.internal_numeral_dec_bl: - forall x y : Numeral.numeral, Numeral.numeral_beq x y = true -> x = y -Numeral.internal_int_dec_lb1: - forall x y : Numeral.int, x = y -> Numeral.int_beq x y = true -Numeral.internal_int_dec_bl1: - forall x y : Numeral.int, Numeral.int_beq x y = true -> x = y -Numeral.internal_uint_dec_lb1: - forall x y : Numeral.uint, x = y -> Numeral.uint_beq x y = true -Numeral.internal_uint_dec_bl1: - forall x y : Numeral.uint, Numeral.uint_beq x y = true -> x = y +Number.internal_number_dec_lb: + forall x y : Number.number, x = y -> Number.number_beq x y = true +Number.internal_number_dec_bl: + forall x y : Number.number, Number.number_beq x y = true -> x = y +Number.internal_int_dec_lb1: + forall x y : Number.int, x = y -> Number.int_beq x y = true +Number.internal_int_dec_bl1: + forall x y : Number.int, Number.int_beq x y = true -> x = y +Number.internal_uint_dec_lb1: + forall x y : Number.uint, x = y -> Number.uint_beq x y = true +Number.internal_uint_dec_bl1: + forall x y : Number.uint, Number.uint_beq x y = true -> x = y Hexadecimal.internal_hexadecimal_dec_lb: forall x y : Hexadecimal.hexadecimal, x = y -> Hexadecimal.hexadecimal_beq x y = true @@ -306,12 +306,12 @@ nat_rect_plus: (nat_rect (fun _ : nat => A) x (fun _ : nat => f) m) (fun _ : nat => f) n Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat -Numeral.internal_numeral_dec_bl: - forall x y : Numeral.numeral, Numeral.numeral_beq x y = true -> x = y -Numeral.internal_int_dec_bl1: - forall x y : Numeral.int, Numeral.int_beq x y = true -> x = y -Numeral.internal_uint_dec_bl1: - forall x y : Numeral.uint, Numeral.uint_beq x y = true -> x = y +Number.internal_number_dec_bl: + forall x y : Number.number, Number.number_beq x y = true -> x = y +Number.internal_int_dec_bl1: + forall x y : Number.int, Number.int_beq x y = true -> x = y +Number.internal_uint_dec_bl1: + forall x y : Number.uint, Number.uint_beq x y = true -> x = y Hexadecimal.internal_hexadecimal_dec_bl: forall x y : Hexadecimal.hexadecimal, Hexadecimal.hexadecimal_beq x y = true -> x = y @@ -328,12 +328,12 @@ Byte.to_bits_of_bits: forall b : bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))), Byte.to_bits (Byte.of_bits b) = b -Numeral.internal_numeral_dec_lb: - forall x y : Numeral.numeral, x = y -> Numeral.numeral_beq x y = true -Numeral.internal_uint_dec_lb1: - forall x y : Numeral.uint, x = y -> Numeral.uint_beq x y = true -Numeral.internal_int_dec_lb1: - forall x y : Numeral.int, x = y -> Numeral.int_beq x y = true +Number.internal_number_dec_lb: + forall x y : Number.number, x = y -> Number.number_beq x y = true +Number.internal_uint_dec_lb1: + forall x y : Number.uint, x = y -> Number.uint_beq x y = true +Number.internal_int_dec_lb1: + forall x y : Number.int, x = y -> Number.int_beq x y = true Decimal.internal_int_dec_lb: forall x y : Decimal.int, x = y -> Decimal.int_beq x y = true Hexadecimal.internal_hexadecimal_dec_lb: @@ -391,7 +391,7 @@ Nat.lor: nat -> nat -> nat Nat.lxor: nat -> nat -> nat Nat.of_hex_uint: Hexadecimal.uint -> nat Nat.of_uint: Decimal.uint -> nat -Nat.of_num_uint: Numeral.uint -> nat +Nat.of_num_uint: Number.uint -> nat length: forall [A : Type], list A -> nat plus_n_O: forall n : nat, n = n + 0 plus_O_n: forall n : nat, 0 + n = n @@ -458,3 +458,11 @@ reflexive_eq_dom_reflexive: B.b: B.a A.b: A.a F.L: F.P 0 +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 a5ac2cb511..3419d5ac62 100644 --- a/test-suite/output/Search.v +++ b/test-suite/output/Search.v @@ -89,3 +89,16 @@ Module Bug12647. Search F.P. End Bar. End Bug12647. + +Module WithCoercions. + Search headconcl:(_ + _) inside Datatypes. + Coercion Some_nat := @Some nat. + 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/SearchHead.out b/test-suite/output/SearchHead.out index 9554581ebe..2f0d854ac6 100644 --- a/test-suite/output/SearchHead.out +++ b/test-suite/output/SearchHead.out @@ -21,15 +21,15 @@ orb: bool -> bool -> bool implb: bool -> bool -> bool Nat.odd: nat -> bool Nat.even: nat -> bool -Numeral.uint_beq: Numeral.uint -> Numeral.uint -> bool +Number.uint_beq: Number.uint -> Number.uint -> bool Nat.testbit: nat -> nat -> bool Nat.eqb: nat -> nat -> bool Hexadecimal.hexadecimal_beq: Hexadecimal.hexadecimal -> Hexadecimal.hexadecimal -> bool Nat.ltb: nat -> nat -> bool Nat.leb: nat -> nat -> bool -Numeral.numeral_beq: Numeral.numeral -> Numeral.numeral -> bool -Numeral.int_beq: Numeral.int -> Numeral.int -> bool +Number.number_beq: Number.number -> Number.number -> bool +Number.int_beq: Number.int -> Number.int -> bool Hexadecimal.int_beq: Hexadecimal.int -> Hexadecimal.int -> bool Hexadecimal.uint_beq: Hexadecimal.uint -> Hexadecimal.uint -> bool Decimal.decimal_beq: Decimal.decimal -> Decimal.decimal -> bool diff --git a/test-suite/output/SearchPattern.out b/test-suite/output/SearchPattern.out index 80b03e8a0b..d705ec898b 100644 --- a/test-suite/output/SearchPattern.out +++ b/test-suite/output/SearchPattern.out @@ -7,15 +7,15 @@ orb: bool -> bool -> bool implb: bool -> bool -> bool Nat.odd: nat -> bool Nat.even: nat -> bool -Numeral.uint_beq: Numeral.uint -> Numeral.uint -> bool +Number.uint_beq: Number.uint -> Number.uint -> bool Nat.testbit: nat -> nat -> bool Nat.eqb: nat -> nat -> bool Hexadecimal.hexadecimal_beq: Hexadecimal.hexadecimal -> Hexadecimal.hexadecimal -> bool Nat.ltb: nat -> nat -> bool Nat.leb: nat -> nat -> bool -Numeral.numeral_beq: Numeral.numeral -> Numeral.numeral -> bool -Numeral.int_beq: Numeral.int -> Numeral.int -> bool +Number.number_beq: Number.number -> Number.number -> bool +Number.int_beq: Number.int -> Number.int -> bool Hexadecimal.int_beq: Hexadecimal.int -> Hexadecimal.int -> bool Hexadecimal.uint_beq: Hexadecimal.uint -> Hexadecimal.uint -> bool Decimal.decimal_beq: Decimal.decimal -> Decimal.decimal -> bool @@ -50,7 +50,7 @@ Nat.lor: nat -> nat -> nat Nat.gcd: nat -> nat -> nat Hexadecimal.nb_digits: Hexadecimal.uint -> nat Nat.of_hex_uint: Hexadecimal.uint -> nat -Nat.of_num_uint: Numeral.uint -> nat +Nat.of_num_uint: Number.uint -> nat Nat.of_uint: Decimal.uint -> nat Decimal.nb_digits: Decimal.uint -> nat Nat.tail_addmul: nat -> nat -> nat -> nat diff --git a/test-suite/output/Search_bug13298.out b/test-suite/output/Search_bug13298.out new file mode 100644 index 0000000000..18488c790f --- /dev/null +++ b/test-suite/output/Search_bug13298.out @@ -0,0 +1 @@ +snd: forall c : c, fst c = 0 diff --git a/test-suite/output/Search_bug13298.v b/test-suite/output/Search_bug13298.v new file mode 100644 index 0000000000..9a75321c64 --- /dev/null +++ b/test-suite/output/Search_bug13298.v @@ -0,0 +1,3 @@ +Set Primitive Projections. +Record c : Type := { fst : nat; snd : fst = 0 }. +Search concl:fst. diff --git a/test-suite/output/StringSyntax.out b/test-suite/output/StringSyntax.out index e9cf4282dc..68ee7cfeb5 100644 --- a/test-suite/output/StringSyntax.out +++ b/test-suite/output/StringSyntax.out @@ -1051,7 +1051,7 @@ Arguments byte_ind _%function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ "127" : byte The command has indeed failed with message: -Expects a single character or a three-digits ascii code. +Expects a single character or a three-digit ASCII code. "000" : ascii "a" @@ -1059,7 +1059,7 @@ Expects a single character or a three-digits ascii code. "127" : ascii The command has indeed failed with message: -Expects a single character or a three-digits ascii code. +Expects a single character or a three-digit ASCII code. "000" : string "a" @@ -1084,3 +1084,21 @@ Expects a single character or a three-digits ascii code. = ["000"; "001"; "002"; "003"; "004"; "005"; "006"; "007"; "008"; "009"; "010"; "011"; "012"; "013"; "014"; "015"; "016"; "017"; "018"; "019"; "020"; "021"; "022"; "023"; "024"; "025"; "026"; "027"; "028"; "029"; "030"; "031"; " "; "!"; """"; "#"; "$"; "%"; "&"; "'"; "("; ")"; "*"; "+"; ","; "-"; "."; "/"; "0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; ":"; ";"; "<"; "="; ">"; "?"; "@"; "A"; "B"; "C"; "D"; "E"; "F"; "G"; "H"; "I"; "J"; "K"; "L"; "M"; "N"; "O"; "P"; "Q"; "R"; "S"; "T"; "U"; "V"; "W"; "X"; "Y"; "Z"; "["; "\"; "]"; "^"; "_"; "`"; "a"; "b"; "c"; "d"; "e"; "f"; "g"; "h"; "i"; "j"; "k"; "l"; "m"; "n"; "o"; "p"; "q"; "r"; "s"; "t"; "u"; "v"; "w"; "x"; "y"; "z"; "{"; "|"; "}"; "~"; "127"; "128"; "129"; "130"; "131"; "132"; "133"; "134"; "135"; "136"; "137"; "138"; "139"; "140"; "141"; "142"; "143"; "144"; "145"; "146"; "147"; "148"; "149"; "150"; "151"; "152"; "153"; "154"; "155"; "156"; "157"; "158"; "159"; "160"; "161"; "162"; "163"; "164"; "165"; "166"; "167"; "168"; "169"; "170"; "171"; "172"; "173"; "174"; "175"; "176"; "177"; "178"; "179"; "180"; "181"; "182"; "183"; "184"; "185"; "186"; "187"; "188"; "189"; "190"; "191"; "192"; "193"; "194"; "195"; "196"; "197"; "198"; "199"; "200"; "201"; "202"; "203"; "204"; "205"; "206"; "207"; "208"; "209"; "210"; "211"; "212"; "213"; "214"; "215"; "216"; "217"; "218"; "219"; "220"; "221"; "222"; "223"; "224"; "225"; "226"; "227"; "228"; "229"; "230"; "231"; "232"; "233"; "234"; "235"; "236"; "237"; "238"; "239"; "240"; "241"; "242"; "243"; "244"; "245"; "246"; "247"; "248"; "249"; "250"; "251"; "252"; "253"; "254"; "255"] : list ascii +"abc" + : string +"000" + : nat +"001" + : nat +"002" + : nat +"255" + : nat +The command has indeed failed with message: +Expects a single character or a three-digit ASCII code. +"abc" + : string2 +"abc" : string2 + : string2 +"abc" : string1 + : string1 diff --git a/test-suite/output/StringSyntax.v b/test-suite/output/StringSyntax.v index aab6e0bb03..a1ffe69527 100644 --- a/test-suite/output/StringSyntax.v +++ b/test-suite/output/StringSyntax.v @@ -50,3 +50,68 @@ Local Close Scope byte_scope. Local Open Scope char_scope. Compute List.map Ascii.ascii_of_nat (List.seq 0 256). Local Close Scope char_scope. + +(* Test numeral notations for parameterized inductives *) +Module Test2. + +Notation string := (list Byte.byte). +Definition id_string := @id string. + +String Notation string id_string id_string : list_scope. + +Check "abc"%list. + +End Test2. + +(* Test the via ... using ... option *) +Module Test3. + +Inductive I := +| IO : I +| IS : I -> I. + +Definition of_byte (x : Byte.byte) : I := + let fix f n := + match n with + | O => IO + | S n => IS (f n) + end in + f (Byte.to_nat x). + +Definition to_byte (x : I) : option Byte.byte := + let fix f i := + match i with + | IO => O + | IS i => S (f i) + end in + Byte.of_nat (f x). + +String Notation nat of_byte to_byte (via I mapping [O => IO, S => IS]) : nat_scope. + +Check "000". +Check "001". +Check "002". +Check "255". +Fail Check "256". + +End Test3. + +(* Test overlapping string notations *) +Module Test4. + +Notation string1 := (list Byte.byte). +Definition id_string1 := @id string1. + +String Notation string1 id_string1 id_string1 : list_scope. + +Notation string2 := (list Ascii.ascii). +Definition a2b := List.map byte_of_ascii. +Definition b2a := List.map ascii_of_byte. + +String Notation string2 b2a a2b : list_scope. + +Check "abc"%list. +Check ["a";"b";"c"]%char%list : string2. +Check ["a";"b";"c"]%byte%list : string1. + +End Test4. 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/ZSyntax.v b/test-suite/output/ZSyntax.v index 7b2bb00ce0..67c4f85d5c 100644 --- a/test-suite/output/ZSyntax.v +++ b/test-suite/output/ZSyntax.v @@ -18,7 +18,7 @@ Require Import Arith. Check (0 + Z.of_nat 11)%Z. (* Check hexadecimal printing *) -Definition to_num_int n := Numeral.IntHex (Z.to_hex_int n). +Definition to_num_int n := Number.IntHexadecimal (Z.to_hex_int n). Number Notation Z Z.of_num_int to_num_int : Z_scope. Check 42%Z. Check (-42)%Z. diff --git a/test-suite/output/bug_12159.v b/test-suite/output/bug_12159.v index 437b4a68e9..a7366f2d35 100644 --- a/test-suite/output/bug_12159.v +++ b/test-suite/output/bug_12159.v @@ -2,10 +2,10 @@ Declare Scope A. Declare Scope B. Delimit Scope A with A. Delimit Scope B with B. -Definition to_unit (v : Numeral.uint) : option unit +Definition to_unit (v : Number.uint) : option unit := match Nat.of_num_uint v with O => Some tt | _ => None end. -Definition of_unit (v : unit) : Numeral.uint := Nat.to_num_uint 0. -Definition of_unit' (v : unit) : Numeral.uint := Nat.to_num_uint 1. +Definition of_unit (v : unit) : Number.uint := Nat.to_num_uint 0. +Definition of_unit' (v : unit) : Number.uint := Nat.to_num_uint 1. Number Notation unit to_unit of_unit : A. Number Notation unit to_unit of_unit' : B. Definition f x : unit := x. diff --git a/test-suite/output/bug_13004.out b/test-suite/output/bug_13004.out index 2bd7d67535..28bc580202 100644 --- a/test-suite/output/bug_13004.out +++ b/test-suite/output/bug_13004.out @@ -1,2 +1,2 @@ -Ltac bug_13004.t := ltac2:(print (of_string "hi")) -Ltac bug_13004.u := ident:(H) +Ltac t := ltac2:(print (of_string "hi")) +Ltac u := ident:(H) diff --git a/test-suite/output/bug_13238.out b/test-suite/output/bug_13238.out new file mode 100644 index 0000000000..a17d05200d --- /dev/null +++ b/test-suite/output/bug_13238.out @@ -0,0 +1,4 @@ +Ltac t1 x := replace (x x) with (x x) +Ltac t2 x := case : x +Ltac t3 := by move -> +Ltac t4 := congr True diff --git a/test-suite/output/bug_13238.v b/test-suite/output/bug_13238.v new file mode 100644 index 0000000000..9b8063bf13 --- /dev/null +++ b/test-suite/output/bug_13238.v @@ -0,0 +1,13 @@ +Require Import ssreflect. + +Ltac t1 x := replace (x x) with (x x). +Print t1. + +Ltac t2 x := case: x. +Print t2. + +Ltac t3 := by move->. +Print t3. + +Ltac t4 := congr True. +Print t4. diff --git a/test-suite/output/bug_13244.out b/test-suite/output/bug_13244.out new file mode 100644 index 0000000000..8c7d4ac776 --- /dev/null +++ b/test-suite/output/bug_13244.out @@ -0,0 +1,9 @@ +negbT: forall [b : bool], b = false -> ~~ b +contra_notN: forall [P : Prop] [b : bool], (b -> P) -> ~ P -> ~~ b +contraPN: forall [P : Prop] [b : bool], (b -> ~ P) -> P -> ~~ b +contraNN: forall [c b : bool], (c -> b) -> ~~ b -> ~~ c +contraL: forall [c b : bool], (c -> ~~ b) -> b -> ~~ c +contraTN: forall [c b : bool], (c -> ~~ b) -> b -> ~~ c +contra: forall [c b : bool], (c -> b) -> ~~ b -> ~~ c +introN: forall [P : Prop] [b : bool], reflect P b -> ~ P -> ~~ b +contraFN: forall [c b : bool], (c -> b) -> b = false -> ~~ c diff --git a/test-suite/output/bug_13244.v b/test-suite/output/bug_13244.v new file mode 100644 index 0000000000..83eaac1a35 --- /dev/null +++ b/test-suite/output/bug_13244.v @@ -0,0 +1,3 @@ +Require Import ssr.ssrbool. +Set Warnings "-ssr-search-moved". +Search headconcl:(~~ _). 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/bug_13320.out b/test-suite/output/bug_13320.out new file mode 100644 index 0000000000..97efe1da87 --- /dev/null +++ b/test-suite/output/bug_13320.out @@ -0,0 +1,2 @@ +The command has indeed failed with message: +No obligations remaining diff --git a/test-suite/output/bug_13320.v b/test-suite/output/bug_13320.v new file mode 100644 index 0000000000..6f3c51bbe7 --- /dev/null +++ b/test-suite/output/bug_13320.v @@ -0,0 +1,2 @@ +(* Next Obligation should fail normally, not with an anomaly. *) +Fail Next Obligation. 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/output/prim_array.out b/test-suite/output/prim_array.out new file mode 100644 index 0000000000..6c12153ab9 --- /dev/null +++ b/test-suite/output/prim_array.out @@ -0,0 +1,9 @@ +[| | 0 : nat |] + : array nat +[| 1; 2; 3 | 0 : nat |] + : array nat +[| | 0 : nat |]@{Set} + : array@{Set} nat +[| bool; list nat | nat : Set |]@{prim_array.4} + : array@{prim_array.4} Set +(* {prim_array.4} |= Set < prim_array.4 *) diff --git a/test-suite/output/prim_array.v b/test-suite/output/prim_array.v new file mode 100644 index 0000000000..a82f6a16f1 --- /dev/null +++ b/test-suite/output/prim_array.v @@ -0,0 +1,10 @@ +Primitive array := #array_type. + +Check [| | 0 |]. + +Check [| 1; 2; 3 | 0 |]. + +Set Printing Universes. +Check [| | 0 |]. + +Check [| bool; list nat | nat |]. 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/CompatOldOldFlag.v b/test-suite/success/CompatOldOldFlag.v deleted file mode 100644 index f408e95d2e..0000000000 --- a/test-suite/success/CompatOldOldFlag.v +++ /dev/null @@ -1,6 +0,0 @@ -(* -*- coq-prog-args: ("-compat" "8.10") -*- *) -(** Check that the current-minus-three compatibility flag actually requires the relevant modules. *) -Import Coq.Compat.Coq813. -Import Coq.Compat.Coq812. -Import Coq.Compat.Coq811. -Import Coq.Compat.Coq810. 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/NumeralNotationsNoLocal.v b/test-suite/success/NumberNotationsNoLocal.v index fe97f10ddf..e19d06cfa7 100644 --- a/test-suite/success/NumeralNotationsNoLocal.v +++ b/test-suite/success/NumberNotationsNoLocal.v @@ -1,4 +1,4 @@ -(* Test that numeral notations don't work on proof-local variables, especially not ones containing evars *) +(* Test that number notations don't work on proof-local variables, especially not ones containing evars *) Inductive unit11 := tt11. Declare Scope unit11_scope. Delimit Scope unit11_scope with unit11. 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/definition_using.v b/test-suite/success/definition_using.v new file mode 100644 index 0000000000..120e62b145 --- /dev/null +++ b/test-suite/success/definition_using.v @@ -0,0 +1,68 @@ +Require Import Program. +Axiom bogus : Type. + +Section A. +Variable x : bogus. + +#[using="All"] +Definition c1 : bool := true. + +#[using="All"] +Fixpoint c2 n : bool := + match n with + | O => true + | S p => c3 p + end +with c3 n : bool := + match n with + | O => true + | S p => c2 p +end. + +#[using="All"] +Definition c4 : bool. Proof. exact true. Qed. + +#[using="All"] +Fixpoint c5 (n : nat) {struct n} : bool. Proof. destruct n as [|p]. exact true. exact (c5 p). Qed. + +#[using="All", program] +Definition c6 : bool. Proof. exact true. Qed. + +#[using="All", program] +Fixpoint c7 (n : nat) {struct n} : bool := + match n with + | O => true + | S p => c7 p + end. + +End A. + +Check c1 : bogus -> bool. +Check c2 : bogus -> nat -> bool. +Check c3 : bogus -> nat -> bool. +Check c4 : bogus -> bool. +Check c5 : bogus -> nat -> bool. +Check c6 : bogus -> bool. +Check c7 : bogus -> nat -> bool. + +Section B. + +Variable a : bogus. +Variable h : c1 a = true. + +#[using="a*"] +Definition c8 : bogus := a. + +Collection ccc := a h. + +#[using="ccc"] +Definition c9 : bogus := a. + +#[using="ccc - h"] +Definition c10 : bogus := a. + +End B. + +Check c8 : forall a, c1 a = true -> bogus. +Check c9 : forall a, c1 a = true -> bogus. +Check c10: bogus -> bogus. 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/test-suite/success/rewrite_strat.v b/test-suite/success/rewrite_strat.v index a6e59fdda0..98045d1162 100644 --- a/test-suite/success/rewrite_strat.v +++ b/test-suite/success/rewrite_strat.v @@ -51,3 +51,12 @@ Time Qed. (* 0.06 s *) Set Printing All. Set Printing Depth 100000. + +Tactic Notation "my_rewrite_strat" constr(x) := rewrite_strat topdown x. +Tactic Notation "my_rewrite_strat2" uconstr(x) := rewrite_strat topdown x. +Goal (forall x, S x = 0) -> 1=0. +intro H. +my_rewrite_strat H. +Undo. +my_rewrite_strat2 H. +Abort. diff --git a/test-suite/success/sprop_uip.v b/test-suite/success/sprop_uip.v index eae1b75689..c9377727db 100644 --- a/test-suite/success/sprop_uip.v +++ b/test-suite/success/sprop_uip.v @@ -121,6 +121,33 @@ Proof. simpl. Fail check. Abort. +Module HoTTStyle. + (* a small proof which tests destruct in a tricky case *) + + Definition ap {A B} (f:A -> B) {x y} (e : seq x y) : seq (f x) (f y). + Proof. destruct e. reflexivity. Defined. + + Section S. + Context + (A : Type) + (B : Type) + (f : A -> B) + (g : B -> A) + (section : forall a, seq (g (f a)) a) + (retraction : forall b, seq (f (g b)) b). + + Lemma bla (P : B -> Type) (a : A) (F : forall a, P (f a)) + : seq_rect _ (f (g (f a))) (fun a _ => P a) (F (g (f a))) (f a) (retraction (f a)) = F a. + Proof. + lazy. + change (retraction (f a)) with (ap f (section a)). + destruct (section a). + reflexivity. + Qed. + End S. + +End HoTTStyle. + (* check that extraction doesn't fall apart on matches with special reduction *) Require Extraction. diff --git a/test-suite/tools/update-compat/run.sh b/test-suite/tools/update-compat/run.sh index 61273c4f37..7ff5571ffb 100755 --- a/test-suite/tools/update-compat/run.sh +++ b/test-suite/tools/update-compat/run.sh @@ -6,4 +6,4 @@ SCRIPT_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null && pwd )" # we assume that the script lives in test-suite/tools/update-compat/, # and that update-compat.py lives in dev/tools/ cd "${SCRIPT_DIR}/../../.." -dev/tools/update-compat.py --assert-unchanged --master || exit $? +dev/tools/update-compat.py --assert-unchanged --release || exit $? 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 36b9cf06b9..c52edf9994 100644 --- a/theories/Arith/Div2.v +++ b/theories/Arith/Div2.v @@ -31,7 +31,7 @@ Lemma ind_0_1_SS : Proof. intros P H0 H1 H2. fix ind_0_1_SS 1. - destruct n as [|[|n]]. + intros n; destruct n as [|[|n]]. - exact H0. - exact H1. - apply H2, ind_0_1_SS. @@ -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,22 +103,23 @@ Proof. apply Nat.add_shuffle1. Qed. +#[global] Hint Resolve double_S: arith. Lemma even_odd_double n : (even n <-> n = double (div2 n)) /\ (odd n <-> n = S (double (div2 n))). Proof. - revert n. fix even_odd_double 1. destruct n as [|[|n]]. + revert n. fix even_odd_double 1. intros n; destruct n as [|[|n]]. - (* n = 0 *) split; split; auto with arith. inversion 1. - (* n = 1 *) - split; split; auto with arith. inversion_clear 1. inversion H0. + split; split; auto with arith. inversion_clear 1 as [|? H0]. inversion H0. - (* n = (S (S n')) *) destruct (even_odd_double n) as ((Ev,Ev'),(Od,Od')). split; split; simpl div2; rewrite ?double_S. - + inversion_clear 1. inversion_clear H0. auto. + + inversion_clear 1 as [|? H0]. inversion_clear H0. auto. + injection 1. auto with arith. - + inversion_clear 1. inversion_clear H0. auto. + + inversion_clear 1 as [? H0]. inversion_clear H0. auto. + injection 1. auto with arith. Qed. @@ -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/Euclid.v b/theories/Arith/Euclid.v index fdd149e01a..d5f715d843 100644 --- a/theories/Arith/Euclid.v +++ b/theories/Arith/Euclid.v @@ -21,7 +21,7 @@ Inductive diveucl a b : Set := Lemma eucl_dev : forall n, n > 0 -> forall m:nat, diveucl m n. Proof. - induction m as (m,H0) using gt_wf_rec. + intros n H m; induction m as (m,H0) using gt_wf_rec. destruct (le_gt_dec n m) as [Hlebn|Hgtbn]. destruct (H0 (m - n)) as (q,r,Hge0,Heq); auto with arith. apply divex with (S q) r; trivial. @@ -34,7 +34,7 @@ Lemma quotient : n > 0 -> forall m:nat, {q : nat | exists r : nat, m = q * n + r /\ n > r}. Proof. - induction m as (m,H0) using gt_wf_rec. + intros n H m; induction m as (m,H0) using gt_wf_rec. destruct (le_gt_dec n m) as [Hlebn|Hgtbn]. destruct (H0 (m - n)) as (q & Hq); auto with arith; exists (S q). destruct Hq as (r & Heq & Hgt); exists r; split; trivial. @@ -47,7 +47,7 @@ Lemma modulo : n > 0 -> forall m:nat, {r : nat | exists q : nat, m = q * n + r /\ n > r}. Proof. - induction m as (m,H0) using gt_wf_rec. + intros n H m; induction m as (m,H0) using gt_wf_rec. destruct (le_gt_dec n m) as [Hlebn|Hgtbn]. destruct (H0 (m - n)) as (r & Hr); auto with arith; exists r. destruct Hr as (q & Heq & Hgt); exists (S q); split; trivial. diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v index 9c0a6bd96f..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] *) @@ -39,28 +41,28 @@ Hint Constructors odd: arith. Lemma even_equiv : forall n, even n <-> Nat.Even n. Proof. fix even_equiv 1. - destruct n as [|[|n]]; simpl. + intros n; destruct n as [|[|n]]; simpl. - split; [now exists 0 | constructor]. - split. - + inversion_clear 1. inversion_clear H0. + + inversion_clear 1 as [|? H0]. inversion_clear H0. + now rewrite <- Nat.even_spec. - rewrite Nat.Even_succ_succ, <- even_equiv. split. - + inversion_clear 1. now inversion_clear H0. + + inversion_clear 1 as [|? H0]. now inversion_clear H0. + now do 2 constructor. Qed. Lemma odd_equiv : forall n, odd n <-> Nat.Odd n. Proof. fix odd_equiv 1. - destruct n as [|[|n]]; simpl. + intros n; destruct n as [|[|n]]; simpl. - split. + inversion_clear 1. + now rewrite <- Nat.odd_spec. - split; [ now exists 0 | do 2 constructor ]. - rewrite Nat.Odd_succ_succ, <- odd_equiv. split. - + inversion_clear 1. now inversion_clear H0. + + inversion_clear 1 as [? H0]. now inversion_clear H0. + now do 2 constructor. Qed. @@ -68,14 +70,14 @@ Qed. Lemma even_or_odd n : even n \/ odd n. Proof. - induction n. + induction n as [|n IHn]. - auto with arith. - elim IHn; auto with arith. Qed. Lemma even_odd_dec n : {even n} + {odd n}. Proof. - induction n. + induction n as [|n IHn]. - auto with arith. - elim IHn; auto with arith. Defined. @@ -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 bea14480f8..49feda15ea 100644 --- a/theories/Bool/Sumbool.v +++ b/theories/Bool/Sumbool.v @@ -16,21 +16,22 @@ (** A boolean is either [true] or [false], and this is decidable *) Definition sumbool_of_bool : forall b:bool, {b = true} + {b = false}. - destruct b; auto. + intros b; destruct b; auto. Defined. +#[global] Hint Resolve sumbool_of_bool: bool. Definition bool_eq_rec : forall (b:bool) (P:bool -> Set), (b = true -> P true) -> (b = false -> P false) -> P b. - destruct b; auto. + intros b; destruct b; auto. Defined. Definition bool_eq_ind : forall (b:bool) (P:bool -> Prop), (b = true -> P true) -> (b = false -> P false) -> P b. - destruct b; auto. + intros b; destruct b; auto. Defined. @@ -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/Coq810.v b/theories/Compat/Coq810.v deleted file mode 100644 index d559bd96c3..0000000000 --- a/theories/Compat/Coq810.v +++ /dev/null @@ -1,13 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Compatibility file for making Coq act similar to Coq v8.10 *) - -Require Export Coq.Compat.Coq811. 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/FMapPositive.v b/theories/FSets/FMapPositive.v index c3c6c96997..02f408fd85 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -139,8 +139,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. | xH => match m with | Leaf => Leaf - | Node Leaf o Leaf => Leaf - | Node l o r => Node l None r + | Node Leaf _ Leaf => Leaf + | Node l _ r => Node l None r end | xO ii => match m with 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/Byte.v b/theories/Init/Byte.v index 7449b52d76..e03820ef22 100644 --- a/theories/Init/Byte.v +++ b/theories/Init/Byte.v @@ -16,7 +16,7 @@ Require Import Coq.Init.Logic. Require Import Coq.Init.Specif. Require Coq.Init.Nat. -Declare ML Module "string_notation_plugin". +Declare ML Module "number_string_notation_plugin". (** We define an inductive for use with the [String Notation] command which contains all ascii characters. We use 256 constructors for 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/Decimal.v b/theories/Init/Decimal.v index 025264ab01..bb12f9ca3e 100644 --- a/theories/Init/Decimal.v +++ b/theories/Init/Decimal.v @@ -118,6 +118,12 @@ Definition opp (d:int) := | Neg d => Pos d end. +Definition abs (d:int) : uint := + match d with + | Pos d => d + | Neg d => d + end. + (** For conversions with binary numbers, it is easier to operate on little-endian numbers. *) diff --git a/theories/Init/Hexadecimal.v b/theories/Init/Hexadecimal.v index 36f5e5ad1f..7467aa1262 100644 --- a/theories/Init/Hexadecimal.v +++ b/theories/Init/Hexadecimal.v @@ -125,6 +125,12 @@ Definition opp (d:int) := | Neg d => Pos d end. +Definition abs (d:int) : uint := + match d with + | Pos d => d + | Neg d => d + end. + (** For conversions with binary numbers, it is easier to operate on little-endian numbers. *) @@ -173,6 +179,38 @@ Definition nztail_int d := | Neg d => let (r, n) := nztail d in pair (Neg r) n end. +(** [del_head n d] removes [n] digits at beginning of [d] + or returns [zero] if [d] has less than [n] digits. *) + +Fixpoint del_head n d := + match n with + | O => d + | S n => + match d with + | Nil => zero + | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d + | Da d | Db d | Dc d | Dd d | De d | Df d => + del_head n d + end + end. + +Definition del_head_int n d := + match d with + | Pos d => del_head n d + | Neg d => del_head n d + end. + +(** [del_tail n d] removes [n] digits at end of [d] + or returns [zero] if [d] has less than [n] digits. *) + +Definition del_tail n d := rev (del_head n (rev d)). + +Definition del_tail_int n d := + match d with + | Pos d => Pos (del_tail n d) + | Neg d => Neg (del_tail n d) + end. + Module Little. (** Successor of little-endian numbers *) 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/Nat.v b/theories/Init/Nat.v index 7c8cf0b536..9a3a3ec99b 100644 --- a/theories/Init/Nat.v +++ b/theories/Init/Nat.v @@ -9,7 +9,7 @@ (************************************************************************) Require Import Notations Logic Datatypes. -Require Decimal Hexadecimal Numeral. +Require Decimal Hexadecimal Number. Local Open Scope nat_scope. (**********************************************************************) @@ -212,10 +212,10 @@ Fixpoint of_hex_uint_acc (d:Hexadecimal.uint)(acc:nat) := Definition of_hex_uint (d:Hexadecimal.uint) := of_hex_uint_acc d O. -Definition of_num_uint (d:Numeral.uint) := +Definition of_num_uint (d:Number.uint) := match d with - | Numeral.UIntDec d => of_uint d - | Numeral.UIntHex d => of_hex_uint d + | Number.UIntDecimal d => of_uint d + | Number.UIntHexadecimal d => of_hex_uint d end. Fixpoint to_little_uint n acc := @@ -236,9 +236,9 @@ Fixpoint to_little_hex_uint n acc := Definition to_hex_uint n := Hexadecimal.rev (to_little_hex_uint n Hexadecimal.zero). -Definition to_num_uint n := Numeral.UIntDec (to_uint n). +Definition to_num_uint n := Number.UIntDecimal (to_uint n). -Definition to_num_hex_uint n := Numeral.UIntHex (to_hex_uint n). +Definition to_num_hex_uint n := Number.UIntHexadecimal (to_hex_uint n). Definition of_int (d:Decimal.int) : option nat := match Decimal.norm d with @@ -252,17 +252,17 @@ Definition of_hex_int (d:Hexadecimal.int) : option nat := | _ => None end. -Definition of_num_int (d:Numeral.int) : option nat := +Definition of_num_int (d:Number.int) : option nat := match d with - | Numeral.IntDec d => of_int d - | Numeral.IntHex d => of_hex_int d + | Number.IntDecimal d => of_int d + | Number.IntHexadecimal d => of_hex_int d end. Definition to_int n := Decimal.Pos (to_uint n). Definition to_hex_int n := Hexadecimal.Pos (to_hex_uint n). -Definition to_num_int n := Numeral.IntDec (to_int n). +Definition to_num_int n := Number.IntDecimal (to_int n). (** ** Euclidean division *) diff --git a/theories/Init/Number.v b/theories/Init/Number.v new file mode 100644 index 0000000000..eb9cc856ac --- /dev/null +++ b/theories/Init/Number.v @@ -0,0 +1,45 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * Decimal or Hexadecimal numbers *) + +Require Import Decimal Hexadecimal. + +Variant uint := UIntDecimal (u:Decimal.uint) | UIntHexadecimal (u:Hexadecimal.uint). +#[deprecated(since="8.13",note="Use UintDecimal instead.")] +Notation UIntDec := UIntDecimal (only parsing). +#[deprecated(since="8.13",note="Use UintHexadecimal instead.")] +Notation UIntHex := UIntHexadecimal (only parsing). + +Variant int := IntDecimal (i:Decimal.int) | IntHexadecimal (i:Hexadecimal.int). +#[deprecated(since="8.13",note="Use IntDecimal instead.")] +Notation IntDec := IntDecimal (only parsing). +#[deprecated(since="8.13",note="Use IntHexadecimal instead.")] +Notation IntHex := IntHexadecimal (only parsing). + +Variant number := Decimal (d:Decimal.decimal) | Hexadecimal (h:Hexadecimal.hexadecimal). +#[deprecated(since="8.13",note="Use Decimal instead.")] +Notation Dec := Decimal (only parsing). +#[deprecated(since="8.13",note="Use Hexadecimal instead.")] +Notation Hex := Hexadecimal (only parsing). + +Scheme Equality for uint. +Scheme Equality for int. +Scheme Equality for number. + +Register uint as num.num_uint.type. +Register int as num.num_int.type. +Register number as num.number.type. + +(** Pseudo-conversion functions used when declaring + Number Notations on [uint] and [int]. *) + +Definition uint_of_uint (i:uint) := i. +Definition int_of_int (i:int) := i. diff --git a/theories/Init/Numeral.v b/theories/Init/Numeral.v index 179547d0b3..50fa312e7e 100644 --- a/theories/Init/Numeral.v +++ b/theories/Init/Numeral.v @@ -8,26 +8,47 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** * Decimal or Hexadecimal numbers *) - -Require Import Decimal Hexadecimal. - -Variant uint := UIntDec (u:Decimal.uint) | UIntHex (u:Hexadecimal.uint). - -Variant int := IntDec (i:Decimal.int) | IntHex (i:Hexadecimal.int). - -Variant numeral := Dec (d:Decimal.decimal) | Hex (h:Hexadecimal.hexadecimal). - -Scheme Equality for uint. -Scheme Equality for int. -Scheme Equality for numeral. - -Register uint as num.num_uint.type. -Register int as num.num_int.type. -Register numeral as num.numeral.type. - -(** Pseudo-conversion functions used when declaring - Number Notations on [uint] and [int]. *) - -Definition uint_of_uint (i:uint) := i. -Definition int_of_int (i:int) := i. +(** * Deprecated: use Number.v instead *) + +Require Import Decimal Hexadecimal Number. + +#[deprecated(since="8.13",note="Use Number.uint instead.")] +Notation uint := uint (only parsing). +#[deprecated(since="8.13",note="Use Number.UintDecimal instead.")] +Notation UIntDec := UIntDecimal (only parsing). +#[deprecated(since="8.13",note="Use Number.UintHexadecimal instead.")] +Notation UIntHex := UIntHexadecimal (only parsing). + +#[deprecated(since="8.13",note="Use Number.int instead.")] +Notation int := int (only parsing). +#[deprecated(since="8.13",note="Use Number.IntDecimal instead.")] +Notation IntDec := IntDecimal (only parsing). +#[deprecated(since="8.13",note="Use Number.IntHexadecimal instead.")] +Notation IntHex := IntHexadecimal (only parsing). + +#[deprecated(since="8.13",note="Use Number.numeral instead.")] +Notation numeral := number (only parsing). +#[deprecated(since="8.13",note="Use Number.Decimal instead.")] +Notation Dec := Decimal (only parsing). +#[deprecated(since="8.13",note="Use Number.Hexadecimal instead.")] +Notation Hex := Hexadecimal (only parsing). + +#[deprecated(since="8.13",note="Use Number.uint_beq instead.")] +Notation uint_beq := uint_beq (only parsing). +#[deprecated(since="8.13",note="Use Number.uint_eq_dec instead.")] +Notation uint_eq_dec := uint_eq_dec (only parsing). +#[deprecated(since="8.13",note="Use Number.int_beq instead.")] +Notation int_beq := int_beq (only parsing). +#[deprecated(since="8.13",note="Use Number.int_eq_dec instead.")] +Notation int_eq_dec := int_eq_dec (only parsing). +#[deprecated(since="8.13",note="Use Number.numeral_beq instead.")] +Notation numeral_beq := number_beq (only parsing). +#[deprecated(since="8.13",note="Use Number.numeral_eq_dec instead.")] +Notation numeral_eq_dec := number_eq_dec (only parsing). + +Register number as num.numeral.type. + +#[deprecated(since="8.13",note="Use Number.uint_of_uint instead.")] +Notation uint_of_uint := uint_of_uint (only parsing). +#[deprecated(since="8.13",note="Use Number.int_of_int instead.")] +Notation int_of_int := int_of_int (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/Prelude.v b/theories/Init/Prelude.v index 0fe3d5491e..9f8a054b5c 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -17,6 +17,7 @@ Require Coq.Init.Byte. Require Coq.Init.Decimal. Require Coq.Init.Hexadecimal. Require Coq.Init.Numeral. +Require Coq.Init.Number. Require Coq.Init.Nat. Require Export Peano. Require Export Coq.Init.Wf. @@ -29,28 +30,26 @@ Require Export Coq.Init.Tauto. *) Declare ML Module "cc_plugin". Declare ML Module "ground_plugin". -Declare ML Module "numeral_notation_plugin". -Declare ML Module "string_notation_plugin". (* Parsing / printing of hexadecimal numbers *) Arguments Nat.of_hex_uint d%hex_uint_scope. Arguments Nat.of_hex_int d%hex_int_scope. -Number Notation Numeral.uint Numeral.uint_of_uint Numeral.uint_of_uint +Number Notation Number.uint Number.uint_of_uint Number.uint_of_uint : hex_uint_scope. -Number Notation Numeral.int Numeral.int_of_int Numeral.int_of_int +Number Notation Number.int Number.int_of_int Number.int_of_int : hex_int_scope. (* Parsing / printing of decimal numbers *) Arguments Nat.of_uint d%dec_uint_scope. Arguments Nat.of_int d%dec_int_scope. -Number Notation Numeral.uint Numeral.uint_of_uint Numeral.uint_of_uint +Number Notation Number.uint Number.uint_of_uint Number.uint_of_uint : dec_uint_scope. -Number Notation Numeral.int Numeral.int_of_int Numeral.int_of_int +Number Notation Number.int Number.int_of_int Number.int_of_int : dec_int_scope. (* Parsing / printing of [nat] numbers *) -Number Notation nat Nat.of_num_uint Nat.to_num_hex_uint : hex_nat_scope (abstract after 5001). -Number Notation nat Nat.of_num_uint Nat.to_num_uint : nat_scope (abstract after 5001). +Number Notation nat Nat.of_num_uint Nat.to_num_hex_uint (abstract after 5001) : hex_nat_scope. +Number Notation nat Nat.of_num_uint Nat.to_num_uint (abstract after 5001) : nat_scope. (* Printing/Parsing of bytes *) Export Byte.ByteSyntaxNotations. 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/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v index 222e76c3e7..e57e5fe856 100644 --- a/theories/NArith/BinNatDef.v +++ b/theories/NArith/BinNatDef.v @@ -390,10 +390,10 @@ Definition of_uint (d:Decimal.uint) := Pos.of_uint d. Definition of_hex_uint (d:Hexadecimal.uint) := Pos.of_hex_uint d. -Definition of_num_uint (d:Numeral.uint) := +Definition of_num_uint (d:Number.uint) := match d with - | Numeral.UIntDec d => of_uint d - | Numeral.UIntHex d => of_hex_uint d + | Number.UIntDecimal d => of_uint d + | Number.UIntHexadecimal d => of_hex_uint d end. Definition of_int (d:Decimal.int) := @@ -408,10 +408,10 @@ Definition of_hex_int (d:Hexadecimal.int) := | Hexadecimal.Neg _ => None end. -Definition of_num_int (d:Numeral.int) := +Definition of_num_int (d:Number.int) := match d with - | Numeral.IntDec d => of_int d - | Numeral.IntHex d => of_hex_int d + | Number.IntDecimal d => of_int d + | Number.IntHexadecimal d => of_hex_int d end. Definition to_uint n := @@ -426,13 +426,13 @@ Definition to_hex_uint n := | pos p => Pos.to_hex_uint p end. -Definition to_num_uint n := Numeral.UIntDec (to_uint n). +Definition to_num_uint n := Number.UIntDecimal (to_uint n). Definition to_int n := Decimal.Pos (to_uint n). Definition to_hex_int n := Hexadecimal.Pos (to_hex_uint n). -Definition to_num_int n := Numeral.IntDec (to_int n). +Definition to_num_int n := Number.IntDecimal (to_int n). Number Notation N of_num_uint to_num_uint : N_scope. diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v index 8280b7d01f..adeb527c1c 100644 --- a/theories/NArith/Ndigits.v +++ b/theories/NArith/Ndigits.v @@ -36,13 +36,13 @@ Notation Nxor_nilpotent := N.lxor_nilpotent (only parsing). Lemma Ptestbit_Pbit : forall p n, Pos.testbit p (N.of_nat n) = Pos.testbit_nat p n. Proof. - induction p as [p IH|p IH| ]; intros [|n]; simpl; trivial; + intro p; induction p as [p IH|p IH| ]; intros [|n]; simpl; trivial; rewrite <- IH; f_equal; rewrite (pred_Sn n) at 2; now rewrite Nat2N.inj_pred. Qed. Lemma Ntestbit_Nbit : forall a n, N.testbit a (N.of_nat n) = N.testbit_nat a n. Proof. - destruct a. trivial. apply Ptestbit_Pbit. + intro a; destruct a. trivial. apply Ptestbit_Pbit. Qed. Lemma Pbit_Ptestbit : @@ -54,7 +54,7 @@ Qed. Lemma Nbit_Ntestbit : forall a n, N.testbit_nat a (N.to_nat n) = N.testbit a n. Proof. - destruct a. trivial. apply Pbit_Ptestbit. + intro a; destruct a. trivial. apply Pbit_Ptestbit. Qed. (** Equivalence of shifts, index in [N] or [nat] *) @@ -104,7 +104,7 @@ Qed. Lemma Nshiftr_nat_spec : forall a n m, N.testbit_nat (N.shiftr_nat a n) m = N.testbit_nat a (m+n). Proof. - induction n; intros m. + intros a n; induction n as [|n IHn]; intros m. now rewrite <- plus_n_O. simpl. rewrite <- plus_n_Sm, <- plus_Sn_m, <- IHn. destruct (N.shiftr_nat a n) as [|[p|p|]]; simpl; trivial. @@ -113,7 +113,7 @@ Qed. Lemma Nshiftl_nat_spec_high : forall a n m, (n<=m)%nat -> N.testbit_nat (N.shiftl_nat a n) m = N.testbit_nat a (m-n). Proof. - induction n; intros m H. + intros a n; induction n as [|n IHn]; intros m H. - now rewrite Nat.sub_0_r. - destruct m. + inversion H. @@ -125,9 +125,9 @@ Qed. Lemma Nshiftl_nat_spec_low : forall a n m, (m<n)%nat -> N.testbit_nat (N.shiftl_nat a n) m = false. Proof. - induction n; intros m H. inversion H. + intros a n; induction n as [|n IHn]; intros m H. inversion H. rewrite Nshiftl_nat_S. - destruct m. + destruct m as [|m]. - destruct (N.shiftl_nat a n); trivial. - apply Lt.lt_S_n in H. specialize (IHn m H). @@ -147,13 +147,13 @@ Lemma Pshiftl_nat_N : forall p n, Npos (Pos.shiftl_nat p n) = N.shiftl_nat (Npos p) n. Proof. unfold Pos.shiftl_nat, N.shiftl_nat. - induction n; simpl; auto. now rewrite <- IHn. + intros p n; induction n as [|n IHn]; simpl; auto. now rewrite <- IHn. Qed. Lemma Pshiftl_nat_plus : forall n m p, Pos.shiftl_nat p (m + n) = Pos.shiftl_nat (Pos.shiftl_nat p n) m. Proof. - induction m; simpl; intros. reflexivity. + intros n m; induction m; simpl; intros. reflexivity. now f_equal. Qed. @@ -221,13 +221,13 @@ Local Notation Step H := (fun n => H (S n)). Lemma Pbit_faithful_0 : forall p, ~(Pos.testbit_nat p == (fun _ => false)). Proof. - induction p as [p IHp|p IHp| ]; intros H; try discriminate (H O). + intros p; induction p as [p IHp|p IHp| ]; intros H; try discriminate (H O). apply (IHp (Step H)). Qed. Lemma Pbit_faithful : forall p p', Pos.testbit_nat p == Pos.testbit_nat p' -> p = p'. Proof. - induction p as [p IHp|p IHp| ]; intros [p'|p'|] H; trivial; + intros p; induction p as [p IHp|p IHp| ]; intros [p'|p'|] H; trivial; try discriminate (H O). f_equal. apply (IHp _ (Step H)). destruct (Pbit_faithful_0 _ (Step H)). @@ -260,25 +260,25 @@ Definition Neven (n:N) := N.odd n = false. Lemma Nbit0_correct : forall n:N, N.testbit_nat n 0 = N.odd n. Proof. - destruct n; trivial. + intros n; destruct n as [|p]; trivial. destruct p; trivial. Qed. Lemma Ndouble_bit0 : forall n:N, N.odd (N.double n) = false. Proof. - destruct n; trivial. + intros n; destruct n; trivial. Qed. Lemma Ndouble_plus_one_bit0 : forall n:N, N.odd (N.succ_double n) = true. Proof. - destruct n; trivial. + intros n; destruct n; trivial. Qed. Lemma Ndiv2_double : forall n:N, Neven n -> N.double (N.div2 n) = n. Proof. - destruct n. trivial. destruct p. intro H. discriminate H. + intros n; destruct n as [|p]. trivial. destruct p. intro H. discriminate H. intros. reflexivity. intro H. discriminate H. Qed. @@ -286,7 +286,7 @@ Qed. Lemma Ndiv2_double_plus_one : forall n:N, Nodd n -> N.succ_double (N.div2 n) = n. Proof. - destruct n. intro. discriminate H. + intros n; destruct n as [|p]. intro H. discriminate H. destruct p. intros. reflexivity. intro H. discriminate H. intro. reflexivity. @@ -295,21 +295,21 @@ Qed. Lemma Ndiv2_correct : forall (a:N) (n:nat), N.testbit_nat (N.div2 a) n = N.testbit_nat a (S n). Proof. - destruct a; trivial. + intros a; destruct a as [|p]; trivial. destruct p; trivial. Qed. Lemma Nxor_bit0 : forall a a':N, N.odd (N.lxor a a') = xorb (N.odd a) (N.odd a'). Proof. - intros. rewrite <- Nbit0_correct, (Nxor_semantics a a' O). + intros a a'. rewrite <- Nbit0_correct, (Nxor_semantics a a' O). rewrite Nbit0_correct, Nbit0_correct. reflexivity. Qed. Lemma Nxor_div2 : forall a a':N, N.div2 (N.lxor a a') = N.lxor (N.div2 a) (N.div2 a'). Proof. - intros. apply Nbit_faithful. unfold eqf. intro. + intros a a'. apply Nbit_faithful. unfold eqf. intro n. rewrite (Nxor_semantics (N.div2 a) (N.div2 a') n), Ndiv2_correct, (Nxor_semantics a a' (S n)). rewrite 2! Ndiv2_correct. reflexivity. @@ -319,7 +319,7 @@ Lemma Nneg_bit0 : forall a a':N, N.odd (N.lxor a a') = true -> N.odd a = negb (N.odd a'). Proof. - intros. + intros a a' H. rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc, xorb_nilpotent, xorb_false. reflexivity. @@ -328,21 +328,21 @@ Qed. Lemma Nneg_bit0_1 : forall a a':N, N.lxor a a' = Npos 1 -> N.odd a = negb (N.odd a'). Proof. - intros. apply Nneg_bit0. rewrite H. reflexivity. + intros a a' H. apply Nneg_bit0. rewrite H. reflexivity. Qed. Lemma Nneg_bit0_2 : forall (a a':N) (p:positive), N.lxor a a' = Npos (xI p) -> N.odd a = negb (N.odd a'). Proof. - intros. apply Nneg_bit0. rewrite H. reflexivity. + intros a a' p H. apply Nneg_bit0. rewrite H. reflexivity. Qed. Lemma Nsame_bit0 : forall (a a':N) (p:positive), N.lxor a a' = Npos (xO p) -> N.odd a = N.odd a'. Proof. - intros. rewrite <- (xorb_false (N.odd a)). + intros a a' p H. rewrite <- (xorb_false (N.odd a)). assert (H0: N.odd (Npos (xO p)) = false) by reflexivity. rewrite <- H0, <- H, Nxor_bit0, <- xorb_assoc, xorb_nilpotent, false_xorb. reflexivity. @@ -366,7 +366,7 @@ Lemma Nbit0_less : forall a a', N.odd a = false -> N.odd a' = true -> Nless a a' = true. Proof. - intros. destruct (N.discr (N.lxor a a')) as [(p,H2)|H1]. unfold Nless. + intros a a' H H0. destruct (N.discr (N.lxor a a')) as [(p,H2)|H1]. unfold Nless. rewrite H2. destruct p. simpl. rewrite H, H0. reflexivity. assert (H1: N.odd (N.lxor a a') = false) by (rewrite H2; reflexivity). rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1. @@ -379,7 +379,7 @@ Lemma Nbit0_gt : forall a a', N.odd a = true -> N.odd a' = false -> Nless a a' = false. Proof. - intros. destruct (N.discr (N.lxor a a')) as [(p,H2)|H1]. unfold Nless. + intros a a' H H0. destruct (N.discr (N.lxor a a')) as [(p,H2)|H1]. unfold Nless. rewrite H2. destruct p. simpl. rewrite H, H0. reflexivity. assert (H1: N.odd (N.lxor a a') = false) by (rewrite H2; reflexivity). rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1. @@ -390,13 +390,13 @@ Qed. Lemma Nless_not_refl : forall a, Nless a a = false. Proof. - intro. unfold Nless. rewrite (N.lxor_nilpotent a). reflexivity. + intro a. unfold Nless. rewrite (N.lxor_nilpotent a). reflexivity. Qed. Lemma Nless_def_1 : forall a a', Nless (N.double a) (N.double a') = Nless a a'. Proof. - destruct a; destruct a'. reflexivity. + intros a a'; destruct a as [|p]; destruct a' as [|p0]. reflexivity. trivial. unfold Nless. simpl. destruct p; trivial. unfold Nless. simpl. destruct (Pos.lxor p p0). reflexivity. @@ -407,7 +407,7 @@ Lemma Nless_def_2 : forall a a', Nless (N.succ_double a) (N.succ_double a') = Nless a a'. Proof. - destruct a; destruct a'. reflexivity. + intros a a'; destruct a as [|p]; destruct a' as [|p0]. reflexivity. trivial. unfold Nless. simpl. destruct p; trivial. unfold Nless. simpl. destruct (Pos.lxor p p0). reflexivity. @@ -430,20 +430,20 @@ Qed. Lemma Nless_z : forall a, Nless a N0 = false. Proof. - induction a. reflexivity. + intros a; induction a as [|p]. reflexivity. unfold Nless. rewrite (N.lxor_0_r (Npos p)). induction p; trivial. Qed. Lemma N0_less_1 : forall a, Nless N0 a = true -> {p : positive | a = Npos p}. Proof. - destruct a. discriminate. + intros a; destruct a as [|p]. discriminate. intros. exists p. reflexivity. Qed. Lemma N0_less_2 : forall a, Nless N0 a = false -> a = N0. Proof. - induction a as [|p]; intro H. trivial. + intros a; induction a as [|p]; intro H. trivial. exfalso. induction p as [|p IHp|]; discriminate || simpl; auto using IHp. Qed. @@ -451,14 +451,14 @@ Lemma Nless_trans : forall a a' a'', Nless a a' = true -> Nless a' a'' = true -> Nless a a'' = true. Proof. - induction a as [|a IHa|a IHa] using N.binary_ind; intros a' a'' H H0. + intros a; induction a as [|a IHa|a IHa] using N.binary_ind; intros a' a'' H H0. - case_eq (Nless N0 a'') ; intros Heqn. + trivial. + rewrite (N0_less_2 a'' Heqn), (Nless_z a') in H0. discriminate H0. - induction a' as [|a' _|a' _] using N.binary_ind. + rewrite (Nless_z (N.double a)) in H. discriminate H. + rewrite (Nless_def_1 a a') in H. - induction a'' using N.binary_ind. + induction a'' as [|a'' _|a'' _] using N.binary_ind. * rewrite (Nless_z (N.double a')) in H0. discriminate H0. * rewrite (Nless_def_1 a' a'') in H0. rewrite (Nless_def_1 a a''). exact (IHa _ _ H H0). @@ -470,7 +470,7 @@ Proof. - induction a' as [|a' _|a' _] using N.binary_ind. + rewrite (Nless_z (N.succ_double a)) in H. discriminate H. + rewrite (Nless_def_4 a a') in H. discriminate H. - + induction a'' using N.binary_ind. + + induction a'' as [|a'' _|a'' _] using N.binary_ind. * rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0. * rewrite (Nless_def_4 a' a'') in H0. discriminate H0. * rewrite (Nless_def_2 a' a'') in H0. rewrite (Nless_def_2 a a') in H. @@ -480,7 +480,7 @@ Qed. Lemma Nless_total : forall a a', {Nless a a' = true} + {Nless a' a = true} + {a = a'}. Proof. - induction a using N.binary_rec; intro a'. + intro a; induction a as [|a IHa|a IHa] using N.binary_rec; intro a'. - case_eq (Nless N0 a') ; intros Heqb. + left. left. auto. + right. rewrite (N0_less_2 a' Heqb). reflexivity. @@ -553,9 +553,9 @@ Definition ByteV2N {n : nat} : ByteVector n -> N := Lemma Bv2N_N2Bv : forall n, Bv2N _ (N2Bv n) = n. Proof. -destruct n. +intro n; destruct n as [|p]. simpl; auto. -induction p; simpl in *; auto; rewrite IHp; simpl; auto. +induction p as [p IHp|p IHp|]; simpl in *; auto; rewrite IHp; simpl; auto. Qed. (** The opposite composition is not so simple: if the considered @@ -564,7 +564,7 @@ Qed. Lemma Bv2N_Nsize : forall n (bv:Bvector n), N.size_nat (Bv2N n bv) <= n. Proof. -induction bv; intros. +intros n bv; induction bv as [|h n bv]; intros. auto. simpl. destruct h; @@ -579,16 +579,16 @@ Lemma Bv2N_Nsize_1 : forall n (bv:Bvector (S n)), Bsign _ bv = true <-> N.size_nat (Bv2N _ bv) = (S n). Proof. -apply Vector.rectS ; intros ; simpl. +apply Vector.rectS ; intros a ; simpl. destruct a ; compute ; split ; intros x ; now inversion x. - destruct a, (Bv2N (S n) v) ; + intros n v IH; destruct a, (Bv2N (S n) v) ; simpl ;intuition ; try discriminate. Qed. Lemma Bv2N_upper_bound (n : nat) (bv : Bvector n) : (Bv2N bv < N.shiftl_nat 1 n)%N. Proof with simpl; auto. - induction bv... + induction bv as [|h]... - constructor. - destruct h. + apply N.succ_double_lt... @@ -621,7 +621,7 @@ Fixpoint N2Bv_gen (n:nat)(a:N) : Bvector n := Lemma N2Bv_N2Bv_gen : forall (a:N), N2Bv a = N2Bv_gen (N.size_nat a) a. Proof. -destruct a; simpl. +intro a; destruct a as [|p]; simpl. auto. induction p; simpl; intros; auto; congruence. Qed. @@ -632,7 +632,7 @@ Qed. Lemma N2Bv_N2Bv_gen_above : forall (a:N)(k:nat), N2Bv_gen (N.size_nat a + k) a = Vector.append (N2Bv a) (Bvect_false k). Proof. -destruct a; simpl. +intros a k; destruct a as [|p]; simpl. destruct k; simpl; auto. induction p; simpl; intros;unfold Bcons; f_equal; auto. Qed. @@ -642,7 +642,7 @@ Qed. Lemma N2Bv_Bv2N : forall n (bv:Bvector n), N2Bv_gen n (Bv2N n bv) = bv. Proof. -induction bv; intros. +intros n bv; induction bv as [|h n bv IHbv]; intros. auto. simpl. generalize IHbv; clear IHbv. @@ -658,7 +658,7 @@ Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)), N.odd (Bv2N _ bv) = Blow _ bv. Proof. apply Vector.caseS. -intros. +intros h n t. unfold Blow. simpl. destruct (Bv2N n t); simpl; @@ -670,9 +670,9 @@ Notation Bnth := (@Vector.nth_order bool). Lemma Bnth_Nbit : forall n (bv:Bvector n) p (H:p<n), Bnth bv H = N.testbit_nat (Bv2N _ bv) p. Proof. -induction bv; intros. +intros n bv; induction bv as [|h n bv IHbv]; intros p H. inversion H. -destruct p ; simpl. +destruct p as [|p]; simpl. destruct (Bv2N n bv); destruct h; simpl in *; auto. specialize IHbv with p (Lt.lt_S_n _ _ H). simpl in * ; destruct (Bv2N n bv); destruct h; simpl in *; auto. @@ -680,9 +680,9 @@ Qed. Lemma Nbit_Nsize : forall n p, N.size_nat n <= p -> N.testbit_nat n p = false. Proof. -destruct n as [|n]. +intro n; destruct n as [|n]. simpl; auto. -induction n; simpl in *; intros; destruct p; auto with arith. +induction n; simpl in *; intros p H; destruct p; auto with arith. inversion H. inversion H. Qed. @@ -690,9 +690,9 @@ Qed. Lemma Nbit_Bth: forall n p (H:p < N.size_nat n), N.testbit_nat n p = Bnth (N2Bv n) H. Proof. -destruct n as [|n]. -inversion H. -induction n ; destruct p ; unfold Vector.nth_order in *; simpl in * ; auto. +intro n; destruct n as [|n]. +intros p H; inversion H. +induction n ; intro p; destruct p ; unfold Vector.nth_order in *; simpl in * ; auto. intros H ; destruct (Lt.lt_n_O _ (Lt.lt_S_n _ _ H)). Qed. @@ -701,8 +701,9 @@ Qed. Lemma Nxor_BVxor : forall n (bv bv' : Bvector n), Bv2N _ (BVxor _ bv bv') = N.lxor (Bv2N _ bv) (Bv2N _ bv'). Proof. -apply Vector.rect2 ; intros. +apply Vector.rect2. now simpl. +intros n v1 v2 H a b. simpl. destruct a, b, (Bv2N n v1), (Bv2N n v2); simpl in *; rewrite H ; now simpl. Qed. @@ -710,8 +711,8 @@ Qed. Lemma Nand_BVand : forall n (bv bv' : Bvector n), Bv2N _ (BVand _ bv bv') = N.land (Bv2N _ bv) (Bv2N _ bv'). Proof. -refine (@Vector.rect2 _ _ _ _ _); simpl; intros; auto. -rewrite H. +refine (@Vector.rect2 _ _ _ _ _); simpl; auto. +intros n v1 v2 H a b; rewrite H. destruct a, b, (Bv2N n v1), (Bv2N n v2); simpl; auto. Qed. @@ -719,15 +720,15 @@ Qed. Lemma N2Bv_sized_Nsize (n : N) : N2Bv_sized (N.size_nat n) n = N2Bv n. Proof with simpl; auto. - destruct n... - induction p... + destruct n as [|p]... + induction p as [p IHp|p IHp|]... all: rewrite IHp... Qed. Lemma N2Bv_sized_Bv2N (n : nat) (v : Bvector n) : N2Bv_sized n (Bv2N n v) = v. Proof with simpl; auto. - induction v... + induction v as [|h n v IHv]... destruct h; unfold N2Bv_sized; destruct (Bv2N n v) as [|[]]; @@ -737,6 +738,6 @@ Qed. Lemma N2Bv_N2Bv_sized_above (a : N) (k : nat) : N2Bv_sized (N.size_nat a + k) a = N2Bv a ++ Bvect_false k. Proof with auto. - destruct a... + destruct a as [|p]... induction p; simpl; f_equal... Qed. diff --git a/theories/Numbers/AltBinNotations.v b/theories/Numbers/AltBinNotations.v index 7c846571a7..c203c178f5 100644 --- a/theories/Numbers/AltBinNotations.v +++ b/theories/Numbers/AltBinNotations.v @@ -17,7 +17,7 @@ the [Decimal.int] representation. When working with numbers with thousands of digits and more, conversion from/to [Decimal.int] can become significantly slow. If that becomes a problem for your - development, this file provides some alternative [Numeral + development, this file provides some alternative [Number Notation] commands that use [Z] as bridge type. To enable these commands, just be sure to [Require] this file after other files defining numeral notations. 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/DecimalFacts.v b/theories/Numbers/DecimalFacts.v index dd361562ba..87a9f704cd 100644 --- a/theories/Numbers/DecimalFacts.v +++ b/theories/Numbers/DecimalFacts.v @@ -10,175 +10,425 @@ (** * DecimalFacts : some facts about Decimal numbers *) -Require Import Decimal Arith. +Require Import Decimal Arith ZArith. + +Variant digits := d0 | d1 | d2 | d3 | d4 | d5 | d6 | d7 | d8 | d9. + +Fixpoint to_list (u : uint) : list digits := + match u with + | Nil => nil + | D0 u => cons d0 (to_list u) + | D1 u => cons d1 (to_list u) + | D2 u => cons d2 (to_list u) + | D3 u => cons d3 (to_list u) + | D4 u => cons d4 (to_list u) + | D5 u => cons d5 (to_list u) + | D6 u => cons d6 (to_list u) + | D7 u => cons d7 (to_list u) + | D8 u => cons d8 (to_list u) + | D9 u => cons d9 (to_list u) + end. -Lemma uint_dec (d d' : uint) : { d = d' } + { d <> d' }. -Proof. - decide equality. -Defined. +Fixpoint of_list (l : list digits) : uint := + match l with + | nil => Nil + | cons d0 l => D0 (of_list l) + | cons d1 l => D1 (of_list l) + | cons d2 l => D2 (of_list l) + | cons d3 l => D3 (of_list l) + | cons d4 l => D4 (of_list l) + | cons d5 l => D5 (of_list l) + | cons d6 l => D6 (of_list l) + | cons d7 l => D7 (of_list l) + | cons d8 l => D8 (of_list l) + | cons d9 l => D9 (of_list l) + end. -Lemma rev_revapp d d' : - rev (revapp d d') = revapp d' d. +Lemma of_list_to_list u : of_list (to_list u) = u. +Proof. now induction u; [|simpl; rewrite IHu..]. Qed. + +Lemma to_list_of_list l : to_list (of_list l) = l. +Proof. now induction l as [|h t IHl]; [|case h; simpl; rewrite IHl]. Qed. + +Lemma to_list_inj u u' : to_list u = to_list u' -> u = u'. Proof. - revert d'. induction d; simpl; intros; now rewrite ?IHd. + now intro H; rewrite <-(of_list_to_list u), <-(of_list_to_list u'), H. Qed. -Lemma rev_rev d : rev (rev d) = d. +Lemma of_list_inj u u' : of_list u = of_list u' -> u = u'. Proof. - apply rev_revapp. + now intro H; rewrite <-(to_list_of_list u), <-(to_list_of_list u'), H. Qed. -Lemma revapp_rev_nil d : revapp (rev d) Nil = d. -Proof. now fold (rev (rev d)); rewrite rev_rev. Qed. +Lemma nb_digits_spec u : nb_digits u = length (to_list u). +Proof. now induction u; [|simpl; rewrite IHu..]. Qed. -Lemma app_nil_r d : app d Nil = d. -Proof. now unfold app; rewrite revapp_rev_nil. Qed. +Fixpoint lnzhead l := + match l with + | nil => nil + | cons d l' => + match d with + | d0 => lnzhead l' + | _ => l + end + end. -Lemma app_int_nil_r d : app_int d Nil = d. -Proof. now case d; intro d'; simpl; rewrite app_nil_r. Qed. +Lemma nzhead_spec u : to_list (nzhead u) = lnzhead (to_list u). +Proof. now induction u; [|simpl; rewrite IHu|..]. Qed. + +Definition lzero := cons d0 nil. + +Definition lunorm l := + match lnzhead l with + | nil => lzero + | d => d + end. + +Lemma unorm_spec u : to_list (unorm u) = lunorm (to_list u). +Proof. now unfold unorm, lunorm; rewrite <-nzhead_spec; case (nzhead u). Qed. -Lemma revapp_revapp_1 d d' d'' : - nb_digits d <= 1 -> - revapp (revapp d d') d'' = revapp d' (revapp d d''). +Lemma revapp_spec d d' : + to_list (revapp d d') = List.rev_append (to_list d) (to_list d'). +Proof. now revert d'; induction d; intro d'; [|simpl; rewrite IHd..]. Qed. + +Lemma rev_spec d : to_list (rev d) = List.rev (to_list d). +Proof. now unfold rev; rewrite revapp_spec, List.rev_alt; simpl. Qed. + +Lemma app_spec d d' : + to_list (app d d') = Datatypes.app (to_list d) (to_list d'). Proof. - now case d; clear d; intro d; - [|case d; clear d; intro d; - [|simpl; case nb_digits; [|intros n]; intros Hn; exfalso; - [apply (Nat.nle_succ_diag_l _ Hn)| - apply (Nat.nle_succ_0 _ (le_S_n _ _ Hn))]..]..]. + unfold app. + now rewrite revapp_spec, List.rev_append_rev, rev_spec, List.rev_involutive. Qed. -Lemma nb_digits_pos d : d <> Nil -> 0 < nb_digits d. -Proof. now case d; [|intros d' _; apply Nat.lt_0_succ..]. Qed. +Definition lnztail l := + let fix aux l_rev := + match l_rev with + | cons d0 l_rev => let (r, n) := aux l_rev in pair r (S n) + | _ => pair l_rev O + end in + let (r, n) := aux (List.rev l) in pair (List.rev r) n. -Lemma nb_digits_revapp d d' : - nb_digits (revapp d d') = nb_digits d + nb_digits d'. +Lemma nztail_spec d : + let (r, n) := nztail d in + let (r', n') := lnztail (to_list d) in + to_list r = r' /\ n = n'. Proof. - now revert d'; induction d; [|intro d'; simpl; rewrite IHd; simpl..]. + unfold nztail, lnztail. + set (f := fix aux d_rev := match d_rev with + | D0 d_rev => let (r, n) := aux d_rev in (r, S n) + | _ => (d_rev, 0) end). + set (f' := fix aux (l_rev : list digits) : list digits * nat := + match l_rev with + | cons d0 l_rev => let (r, n) := aux l_rev in (r, S n) + | _ => (l_rev, 0) + end). + rewrite <-(of_list_to_list (rev d)), rev_spec. + induction (List.rev _) as [|h t IHl]; [now simpl|]. + case h; simpl; [|now rewrite rev_spec; simpl; rewrite to_list_of_list..]. + now revert IHl; case f; intros r n; case f'; intros r' n' [-> ->]. Qed. -Lemma nb_digits_rev u : nb_digits (rev u) = nb_digits u. -Proof. now unfold rev; rewrite nb_digits_revapp. Qed. +Lemma del_head_spec_0 d : del_head 0 d = d. +Proof. now simpl. Qed. -Lemma nb_digits_nzhead u : nb_digits (nzhead u) <= nb_digits u. -Proof. now induction u; [|apply le_S|..]. Qed. +Lemma del_head_spec_small n d : + n <= length (to_list d) -> to_list (del_head n d) = List.skipn n (to_list d). +Proof. + revert d; induction n as [|n IHn]; intro d; [now simpl|]. + now case d; [|intros d' H; apply IHn, le_S_n..]. +Qed. -Lemma del_head_nb_digits (u:uint) : del_head (nb_digits u) u = Nil. -Proof. now induction u. Qed. +Lemma del_head_spec_large n d : length (to_list d) < n -> del_head n d = zero. +Proof. + revert d; induction n; intro d; [now case d|]. + now case d; [|intro d'; simpl; intro H; rewrite (IHn _ (lt_S_n _ _ H))..]. +Qed. -Lemma nb_digits_del_head n u : - n <= nb_digits u -> nb_digits (del_head n u) = nb_digits u - n. +Lemma nb_digits_0 d : nb_digits d = 0 -> d = Nil. Proof. - revert u; induction n; intros u; [now rewrite Nat.sub_0_r|]. - now case u; clear u; intro u; [|intro Hn; apply IHn, le_S_n..]. + rewrite nb_digits_spec, <-(of_list_to_list d). + now case (to_list d) as [|h t]; [|rewrite to_list_of_list]. Qed. +Lemma nb_digits_n0 d : nb_digits d <> 0 -> d <> Nil. +Proof. now case d; [|intros u _..]. Qed. + Lemma nb_digits_iter_D0 n d : nb_digits (Nat.iter n D0 d) = n + nb_digits d. Proof. now induction n; simpl; [|rewrite IHn]. Qed. -Fixpoint nth n u := - match n with - | O => - match u with - | Nil => Nil - | D0 d => D0 Nil - | D1 d => D1 Nil - | D2 d => D2 Nil - | D3 d => D3 Nil - | D4 d => D4 Nil - | D5 d => D5 Nil - | D6 d => D6 Nil - | D7 d => D7 Nil - | D8 d => D8 Nil - | D9 d => D9 Nil - end - | S n => - match u with - | Nil => Nil - | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => - nth n d - end - end. +Lemma length_lnzhead l : length (lnzhead l) <= length l. +Proof. now induction l as [|h t IHl]; [|case h; [apply le_S|..]]. Qed. + +Lemma nb_digits_nzhead u : nb_digits (nzhead u) <= nb_digits u. +Proof. now induction u; [|apply le_S|..]. Qed. + +Lemma unorm_nzhead u : nzhead u <> Nil -> unorm u = nzhead u. +Proof. now unfold unorm; case nzhead. Qed. -Lemma nb_digits_nth n u : nb_digits (nth n u) <= 1. +Lemma nb_digits_unorm u : u <> Nil -> nb_digits (unorm u) <= nb_digits u. Proof. - revert u; induction n. - - now intro u; case u; [apply Nat.le_0_1|..]. - - intro u; case u; [apply Nat.le_0_1|intro u'; apply IHn..]. + intro Hu; case (uint_eq_dec (nzhead u) Nil). + { unfold unorm; intros ->; simpl. + now revert Hu; case u; [|intros u' _; apply le_n_S, Nat.le_0_l..]. } + intro H; rewrite (unorm_nzhead _ H); apply nb_digits_nzhead. Qed. -Lemma del_head_nth n u : - n < nb_digits u -> - del_head n u = revapp (nth n u) (del_head (S n) u). -Proof. - revert u; induction n; intro u; [now case u|]. - now case u; [|intro u'; intro H; apply IHn, le_S_n..]. -Qed. - -Lemma nth_revapp_r n d d' : - nb_digits d <= n -> - nth n (revapp d d') = nth (n - nb_digits d) d'. -Proof. - revert d d'; induction n; intro d. - - now case d; intro d'; - [case d'|intros d'' H; exfalso; revert H; apply Nat.nle_succ_0..]. - - now induction d; - [intro d'; case d'| - intros d' H; - simpl revapp; rewrite IHd; [|now apply le_Sn_le]; - rewrite Nat.sub_succ_l; [|now apply le_S_n]; - simpl; rewrite <-(IHn _ _ (le_S_n _ _ H))..]. -Qed. - -Lemma nth_revapp_l n d d' : - n < nb_digits d -> - nth n (revapp d d') = nth (nb_digits d - n - 1) d. -Proof. - revert d d'; induction n; intro d. - - rewrite Nat.sub_0_r. - now induction d; - [|intros d' _; simpl revapp; - revert IHd; case d; clear d; [|intro d..]; intro IHd; - [|rewrite IHd; [simpl nb_digits; rewrite (Nat.sub_succ_l _ (S _))|]; - [|apply le_n_S, Nat.le_0_l..]..]..]. - - now induction d; - [|intros d' H; - simpl revapp; simpl nb_digits; - simpl in H; generalize (lt_S_n _ _ H); clear H; intro H; - case (le_lt_eq_dec _ _ H); clear H; intro H; - [rewrite (IHd _ H), Nat.sub_succ_l; - [rewrite Nat.sub_succ_l; [|apply Nat.le_add_le_sub_r]| - apply le_Sn_le]| - rewrite nth_revapp_r; rewrite <-H; - [rewrite Nat.sub_succ, Nat.sub_succ_l; [rewrite !Nat.sub_diag|]|]]..]. -Qed. - -Lemma app_del_tail_head (u:uint) n : - n <= nb_digits u -> - app (del_tail n u) (del_head (nb_digits u - n) u) = u. -Proof. - unfold app, del_tail; rewrite rev_rev. - induction n. - - intros _; rewrite Nat.sub_0_r, del_head_nb_digits; simpl. - now rewrite revapp_rev_nil. - - intro Hn. - rewrite (del_head_nth (_ - _)); - [|now apply Nat.sub_lt; [|apply Nat.lt_0_succ]]. - rewrite Nat.sub_succ_r, <-Nat.sub_1_r. - rewrite <-(nth_revapp_l _ _ Nil Hn); fold (rev u). - rewrite <-revapp_revapp_1; [|now apply nb_digits_nth]. - rewrite <-(del_head_nth _ _); [|now rewrite nb_digits_rev]. - rewrite Nat.sub_1_r, Nat.succ_pred_pos; [|now apply Nat.lt_add_lt_sub_r]. - apply (IHn (le_Sn_le _ _ Hn)). +Lemma nb_digits_rev d : nb_digits (rev d) = nb_digits d. +Proof. now rewrite !nb_digits_spec, rev_spec, List.rev_length. Qed. + +Lemma nb_digits_del_head_sub d n : + n <= nb_digits d -> + nb_digits (del_head (nb_digits d - n) d) = n. +Proof. + rewrite !nb_digits_spec; intro Hn. + rewrite del_head_spec_small; [|now apply Nat.le_sub_l]. + rewrite List.skipn_length, <-(Nat2Z.id (_ - _)). + rewrite Nat2Z.inj_sub; [|now apply Nat.le_sub_l]. + rewrite (Nat2Z.inj_sub _ _ Hn). + rewrite Z.sub_sub_distr, Z.sub_diag; apply Nat2Z.id. +Qed. + +Lemma unorm_D0 u : unorm (D0 u) = unorm u. +Proof. reflexivity. Qed. + +Lemma app_nil_l d : app Nil d = d. +Proof. now simpl. Qed. + +Lemma app_nil_r d : app d Nil = d. +Proof. now apply to_list_inj; rewrite app_spec, List.app_nil_r. Qed. + +Lemma abs_app_int d d' : abs (app_int d d') = app (abs d) d'. +Proof. now case d. Qed. + +Lemma abs_norm d : abs (norm d) = unorm (abs d). +Proof. now case d as [u|u]; [|simpl; unfold unorm; case nzhead]. Qed. + +Lemma iter_D0_nzhead d : + Nat.iter (nb_digits d - nb_digits (nzhead d)) D0 (nzhead d) = d. +Proof. + induction d; [now simpl| |now rewrite Nat.sub_diag..]. + simpl nzhead; simpl nb_digits. + rewrite (Nat.sub_succ_l _ _ (nb_digits_nzhead _)). + now rewrite <-IHd at 4. +Qed. + +Lemma iter_D0_unorm d : + d <> Nil -> + Nat.iter (nb_digits d - nb_digits (unorm d)) D0 (unorm d) = d. +Proof. + case (uint_eq_dec (nzhead d) Nil); intro Hn. + { unfold unorm; rewrite Hn; simpl; intro H. + revert H Hn; induction d; [now simpl|intros _|now intros _..]. + case (uint_eq_dec d Nil); simpl; intros H Hn; [now rewrite H|]. + rewrite Nat.sub_0_r, (le_plus_minus 1 (nb_digits d)). + { now simpl; rewrite IHd. } + revert H; case d; [now simpl|intros u _; apply le_n_S, Nat.le_0_l..]. } + intros _; rewrite (unorm_nzhead _ Hn); apply iter_D0_nzhead. +Qed. + +Lemma nzhead_app_l d d' : + nb_digits d' < nb_digits (nzhead (app d d')) -> + nzhead (app d d') = app (nzhead d) d'. +Proof. + intro Hl; apply to_list_inj; revert Hl. + rewrite !nb_digits_spec, app_spec, !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]. + { now simpl; intro H; exfalso; revert H; apply le_not_lt, length_lnzhead. } + rewrite <-List.app_comm_cons. + now case h; [simpl; intro Hl; apply IHl|..]. +Qed. + +Lemma nzhead_app_r d d' : + nb_digits (nzhead (app d d')) <= nb_digits d' -> + nzhead (app d d') = nzhead d'. +Proof. + intro Hl; apply to_list_inj; revert Hl. + rewrite !nb_digits_spec, !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]; [now simpl|]. + rewrite <-List.app_comm_cons. + now case h; [| simpl; rewrite List.app_length; intro Hl; exfalso; revert Hl; + apply le_not_lt, le_plus_r..]. +Qed. + +Lemma nzhead_app_nil_r d d' : nzhead (app d d') = Nil -> nzhead d' = Nil. +Proof. +now intro H; generalize H; rewrite nzhead_app_r; [|rewrite H; apply Nat.le_0_l]. +Qed. + +Lemma nzhead_app_nil d d' : + nb_digits (nzhead (app d d')) <= nb_digits d' -> nzhead d = Nil. +Proof. + intro H; apply to_list_inj; revert H. + rewrite !nb_digits_spec, !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]; [now simpl|]. + now case h; [now simpl|..]; + simpl;intro H; exfalso; revert H; apply le_not_lt; + rewrite List.app_length; apply le_plus_r. +Qed. + +Lemma nzhead_app_nil_l d d' : nzhead (app d d') = Nil -> nzhead d = Nil. +Proof. + intro H; apply to_list_inj; generalize (f_equal to_list H); clear H. + rewrite !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]; [now simpl|]. + now rewrite <-List.app_comm_cons; case h. +Qed. + +Lemma unorm_app_zero d d' : + nb_digits (unorm (app d d')) <= nb_digits d' -> unorm d = zero. +Proof. + unfold unorm. + case (uint_eq_dec (nzhead (app d d')) Nil). + { now intro Hn; rewrite Hn, (nzhead_app_nil_l _ _ Hn). } + intro H; fold (unorm (app d d')); rewrite (unorm_nzhead _ H); intro H'. + case (uint_eq_dec (nzhead d) Nil); [now intros->|]. + intro H''; fold (unorm d); rewrite (unorm_nzhead _ H''). + exfalso; apply H''; revert H'; apply nzhead_app_nil. +Qed. + +Lemma app_int_nil_r d : app_int d Nil = d. +Proof. + now case d; intro d'; simpl; + rewrite <-(of_list_to_list (app _ _)), app_spec; + rewrite List.app_nil_r, of_list_to_list. +Qed. + +Lemma unorm_app_l d d' : + nb_digits d' < nb_digits (unorm (app d d')) -> + unorm (app d d') = app (unorm d) d'. +Proof. + case (uint_eq_dec d' Nil); [now intros->; rewrite !app_nil_r|intro Hd']. + case (uint_eq_dec (nzhead (app d d')) Nil). + { unfold unorm; intros->; simpl; intro H; exfalso; revert H; apply le_not_lt. + now revert Hd'; case d'; [|intros d'' _; apply le_n_S, Peano.le_0_n..]. } + intro Ha; rewrite (unorm_nzhead _ Ha). + intro Hn; generalize Hn; rewrite (nzhead_app_l _ _ Hn). + rewrite !nb_digits_spec, app_spec, List.app_length. + case (uint_eq_dec (nzhead d) Nil). + { intros->; simpl; intro H; exfalso; revert H; apply Nat.lt_irrefl. } + now intro H; rewrite (unorm_nzhead _ H). +Qed. + +Lemma unorm_app_r d d' : + nb_digits (unorm (app d d')) <= nb_digits d' -> + unorm (app d d') = unorm d'. +Proof. + case (uint_eq_dec (nzhead (app d d')) Nil). + { now unfold unorm; intro H; rewrite H, (nzhead_app_nil_r _ _ H). } + intro Ha; rewrite (unorm_nzhead _ Ha). + case (uint_eq_dec (nzhead d') Nil). + { now intros H H'; exfalso; apply Ha; rewrite nzhead_app_r. } + intro Hd'; rewrite (unorm_nzhead _ Hd'); apply nzhead_app_r. +Qed. + +Lemma norm_app_int d d' : + nb_digits d' < nb_digits (unorm (app (abs d) d')) -> + norm (app_int d d') = app_int (norm d) d'. +Proof. + case (uint_eq_dec d' Nil); [now intros->; rewrite !app_int_nil_r|intro Hd']. + case d as [d|d]; [now simpl; intro H; apply f_equal, unorm_app_l|]. + simpl; unfold unorm. + case (uint_eq_dec (nzhead (app d d')) Nil). + { intros->; simpl; intro H; exfalso; revert H; apply le_not_lt. + now revert Hd'; case d'; [|intros d'' _; apply le_n_S, Peano.le_0_n..]. } + set (m := match nzhead _ with Nil => _ | _ => _ end). + intro Ha. + replace m with (nzhead (app d d')). + 2:{ now unfold m; revert Ha; case nzhead. } + intro Hn; generalize Hn; rewrite (nzhead_app_l _ _ Hn). + case (uint_eq_dec (app (nzhead d) d') Nil). + { intros->; simpl; intro H; exfalso; revert H; apply le_not_lt, Nat.le_0_l. } + clear m; set (m := match app _ _ with Nil => _ | _ => _ end). + intro Ha'. + replace m with (Neg (app (nzhead d) d')); [|now unfold m; revert Ha'; case app]. + case (uint_eq_dec (nzhead d) Nil). + { intros->; simpl; intro H; exfalso; revert H; apply Nat.lt_irrefl. } + clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). + intro Hd. + now replace m with (Neg (nzhead d)); [|unfold m; revert Hd; case nzhead]. +Qed. + +Lemma del_head_nb_digits d : del_head (nb_digits d) d = Nil. +Proof. + apply to_list_inj. + rewrite nb_digits_spec, del_head_spec_small; [|now simpl]. + now rewrite List.skipn_all. +Qed. + +Lemma del_tail_nb_digits d : del_tail (nb_digits d) d = Nil. +Proof. now unfold del_tail; rewrite <-nb_digits_rev, del_head_nb_digits. Qed. + +Lemma del_head_app n d d' : + n <= nb_digits d -> del_head n (app d d') = app (del_head n d) d'. +Proof. + rewrite nb_digits_spec; intro Hn. + apply to_list_inj. + rewrite del_head_spec_small. + 2:{ now rewrite app_spec, List.app_length; apply le_plus_trans. } + rewrite !app_spec, (del_head_spec_small _ _ Hn). + rewrite List.skipn_app. + now rewrite (proj2 (Nat.sub_0_le _ _) Hn). +Qed. + +Lemma del_tail_app n d d' : + n <= nb_digits d' -> del_tail n (app d d') = app d (del_tail n d'). +Proof. + rewrite nb_digits_spec; intro Hn. + unfold del_tail. + rewrite <-(of_list_to_list (rev (app d d'))), rev_spec, app_spec. + rewrite List.rev_app_distr, <-!rev_spec, <-app_spec, of_list_to_list. + rewrite del_head_app; [|now rewrite nb_digits_spec, rev_spec, List.rev_length]. + apply to_list_inj. + rewrite rev_spec, !app_spec, !rev_spec. + now rewrite List.rev_app_distr, List.rev_involutive. +Qed. + +Lemma del_tail_app_int n d d' : + n <= nb_digits d' -> del_tail_int n (app_int d d') = app_int d (del_tail n d'). +Proof. now case d as [d|d]; simpl; intro H; rewrite del_tail_app. Qed. + +Lemma app_del_tail_head n (d:uint) : + n <= nb_digits d -> app (del_tail n d) (del_head (nb_digits d - n) d) = d. +Proof. + rewrite nb_digits_spec; intro Hn; unfold del_tail. + rewrite <-(of_list_to_list (app _ _)), app_spec, rev_spec. + rewrite del_head_spec_small; [|now rewrite rev_spec, List.rev_length]. + rewrite del_head_spec_small; [|now apply Nat.le_sub_l]. + rewrite rev_spec. + set (n' := _ - n). + assert (Hn' : n = length (to_list d) - n'). + { now apply plus_minus; rewrite Nat.add_comm; symmetry; apply le_plus_minus_r. } + now rewrite Hn', <-List.firstn_skipn_rev, List.firstn_skipn, of_list_to_list. Qed. Lemma app_int_del_tail_head n (d:int) : - let ad := match d with Pos d | Neg d => d end in - n <= nb_digits ad -> - app_int (del_tail_int n d) (del_head (nb_digits ad - n) ad) = d. + n <= nb_digits (abs d) -> + app_int (del_tail_int n d) (del_head (nb_digits (abs d) - n) (abs d)) = d. Proof. now case d; clear d; simpl; intros u Hu; rewrite app_del_tail_head. Qed. +Lemma del_head_app_int_exact i f : + nb_digits f < nb_digits (unorm (app (abs i) f)) -> + del_head (nb_digits (unorm (app (abs i) f)) - nb_digits f) (unorm (app (abs i) f)) = f. +Proof. + simpl; intro Hnb; generalize Hnb; rewrite (unorm_app_l _ _ Hnb); clear Hnb. + replace (_ - _) with (nb_digits (unorm (abs i))). + - now rewrite del_head_app; [rewrite del_head_nb_digits|]. + - rewrite !nb_digits_spec, app_spec, List.app_length. + now rewrite Nat.add_comm, minus_plus. +Qed. + +Lemma del_tail_app_int_exact i f : + nb_digits f < nb_digits (unorm (app (abs i) f)) -> + del_tail_int (nb_digits f) (norm (app_int i f)) = norm i. +Proof. + simpl; intro Hnb. + rewrite (norm_app_int _ _ Hnb). + rewrite del_tail_app_int; [|now simpl]. + now rewrite del_tail_nb_digits, app_int_nil_r. +Qed. + (** Normalization on little-endian numbers *) Fixpoint nztail d := @@ -224,10 +474,13 @@ Proof. apply nzhead_revapp. Qed. +Lemma rev_rev d : rev (rev d) = d. +Proof. now apply to_list_inj; rewrite !rev_spec, List.rev_involutive. Qed. + Lemma rev_nztail_rev d : rev (nztail (rev d)) = nzhead d. Proof. - destruct (uint_dec (nztail (rev d)) Nil) as [H|H]. + destruct (uint_eq_dec (nztail (rev d)) Nil) as [H|H]. - rewrite H. unfold rev; simpl. rewrite <- (rev_rev d). symmetry. now apply nzhead_revapp_0. @@ -278,21 +531,9 @@ Proof. unfold unorm. now destruct nzhead. Qed. -Lemma unorm_D0 u : unorm (D0 u) = unorm u. -Proof. reflexivity. Qed. - Lemma unorm_iter_D0 n u : unorm (Nat.iter n D0 u) = unorm u. Proof. now induction n. Qed. -Lemma nb_digits_unorm u : - u <> Nil -> nb_digits (unorm u) <= nb_digits u. -Proof. - case u; clear u; [now simpl|intro u..]; [|now simpl..]. - intros _; unfold unorm. - case_eq (nzhead (D0 u)); [|now intros u' <-; apply nb_digits_nzhead..]. - intros _; apply le_n_S, Nat.le_0_l. -Qed. - Lemma del_head_nonnil n u : n < nb_digits u -> del_head n u <> Nil. Proof. @@ -311,73 +552,78 @@ Proof. now apply del_head_nonnil. Qed. -Lemma nzhead_invol d : nzhead (nzhead d) = nzhead d. +Lemma nzhead_involutive d : nzhead (nzhead d) = nzhead d. Proof. now induction d. Qed. +#[deprecated(since="8.13",note="Use nzhead_involutive instead.")] +Notation nzhead_invol := nzhead_involutive (only parsing). -Lemma nztail_invol d : nztail (nztail d) = nztail d. +Lemma nztail_involutive d : nztail (nztail d) = nztail d. Proof. rewrite <-(rev_rev (nztail _)), <-(rev_rev (nztail d)), <-(rev_rev d). - now rewrite !rev_nztail_rev, nzhead_invol. + now rewrite !rev_nztail_rev, nzhead_involutive. Qed. +#[deprecated(since="8.13",note="Use nztail_involutive instead.")] +Notation nztail_invol := nztail_involutive (only parsing). -Lemma unorm_invol d : unorm (unorm d) = unorm d. +Lemma unorm_involutive d : unorm (unorm d) = unorm d. Proof. unfold unorm. destruct (nzhead d) eqn:E; trivial. destruct (nzhead_nonzero _ _ E). Qed. +#[deprecated(since="8.13",note="Use unorm_involutive instead.")] +Notation unorm_invol := unorm_involutive (only parsing). -Lemma norm_invol d : norm (norm d) = norm d. +Lemma norm_involutive d : norm (norm d) = norm d. Proof. unfold norm. destruct d. - - f_equal. apply unorm_invol. + - f_equal. apply unorm_involutive. - destruct (nzhead d) eqn:E; auto. destruct (nzhead_nonzero _ _ E). Qed. +#[deprecated(since="8.13",note="Use norm_involutive instead.")] +Notation norm_invol := norm_involutive (only parsing). + +Lemma lnzhead_neq_d0_head l l' : ~(lnzhead l = cons d0 l'). +Proof. now induction l as [|h t Il]; [|case h]. Qed. + +Lemma lnzhead_head_nd0 h t : h <> d0 -> lnzhead (cons h t) = cons h t. +Proof. now case h. Qed. Lemma nzhead_del_tail_nzhead_eq n u : nzhead u = u -> n < nb_digits u -> nzhead (del_tail n u) = del_tail n u. Proof. + rewrite nb_digits_spec, <-List.rev_length. intros Hu Hn. - assert (Hhd : forall u, - nzhead u = u <-> match nth 0 u with D0 _ => False | _ => True end). - { clear n u Hu Hn; intro u. - case u; clear u; [|intro u..]; [now simpl| |now simpl..]; simpl. - split; [|now simpl]. - apply nzhead_nonzero. } - assert (Hhd' : nth 0 (del_tail n u) = nth 0 u). - { rewrite <-(app_del_tail_head _ _ (le_Sn_le _ _ Hn)) at 2. - unfold app. - rewrite nth_revapp_l. - - rewrite <-(nth_revapp_l _ _ Nil). - + now fold (rev (rev (del_tail n u))); rewrite rev_rev. - + unfold del_tail; rewrite rev_rev. - rewrite nb_digits_del_head; rewrite nb_digits_rev. - * now rewrite <-Nat.lt_add_lt_sub_r. - * now apply Nat.lt_le_incl. - - unfold del_tail; rewrite rev_rev. - rewrite nb_digits_del_head; rewrite nb_digits_rev. - + now rewrite <-Nat.lt_add_lt_sub_r. - + now apply Nat.lt_le_incl. } - revert Hu; rewrite Hhd; intro Hu. - now rewrite Hhd, Hhd'. + apply to_list_inj; unfold del_tail. + rewrite nzhead_spec, rev_spec. + rewrite del_head_spec_small; [|now rewrite rev_spec; apply Nat.lt_le_incl]. + rewrite rev_spec. + rewrite List.skipn_rev, List.rev_involutive. + generalize (f_equal to_list Hu) Hn; rewrite nzhead_spec; intro Hu'. + case (to_list u) as [|h t]. + { simpl; intro H; exfalso; revert H; apply le_not_lt, Peano.le_0_n. } + intro Hn'; generalize (Nat.sub_gt _ _ Hn'); rewrite List.rev_length. + case (_ - _); [now simpl|]; intros n' _. + rewrite List.firstn_cons, lnzhead_head_nd0; [now simpl|]. + intro Hh; revert Hu'; rewrite Hh; apply lnzhead_neq_d0_head. Qed. Lemma nzhead_del_tail_nzhead n u : n < nb_digits (nzhead u) -> nzhead (del_tail n (nzhead u)) = del_tail n (nzhead u). -Proof. apply nzhead_del_tail_nzhead_eq, nzhead_invol. Qed. +Proof. apply nzhead_del_tail_nzhead_eq, nzhead_involutive. Qed. Lemma unorm_del_tail_unorm n u : n < nb_digits (unorm u) -> unorm (del_tail n (unorm u)) = del_tail n (unorm u). Proof. - case (uint_dec (nzhead u) Nil). + case (uint_eq_dec (nzhead u) Nil). - unfold unorm; intros->; case n; [now simpl|]; intro n'. now simpl; intro H; exfalso; generalize (lt_S_n _ _ H). - unfold unorm. @@ -396,7 +642,7 @@ Lemma norm_del_tail_int_norm n d : Proof. case d; clear d; intros u; simpl. - now intro H; simpl; rewrite unorm_del_tail_unorm. - - case (uint_dec (nzhead u) Nil); intro Hu. + - case (uint_eq_dec (nzhead u) Nil); intro Hu. + now rewrite Hu; case n; [|intros n' Hn'; generalize (lt_S_n _ _ Hn')]. + set (m := match nzhead u with Nil => Pos zero | _ => _ end). replace m with (Neg (nzhead u)); [|now unfold m; revert Hu; case nzhead]. @@ -418,7 +664,7 @@ Proof. generalize (nzhead_revapp d d'). generalize (nzhead_revapp_0 (nztail d) d'). generalize (nzhead_revapp (nztail d) d'). - rewrite nztail_invol. + rewrite nztail_involutive. now case nztail; [intros _ H _ H'; rewrite (H eq_refl), (H' eq_refl) |intros d'' H _ H' _; rewrite H; [rewrite H'|]..]. @@ -455,5 +701,10 @@ Proof. |rewrite H'; unfold r; clear m r H']; unfold norm; rewrite rev_rev, <-Hd''; - rewrite nzhead_revapp; rewrite nztail_invol; [|rewrite Hd'']..]. + rewrite nzhead_revapp; rewrite nztail_involutive; [|rewrite Hd'']..]. +Qed. + +Lemma unorm_app_l_nil d d' : nzhead d = Nil -> unorm (app d d') = unorm d'. +Proof. + now unfold unorm; rewrite <-nzhead_app_nzhead; intros->; rewrite app_nil_l. Qed. diff --git a/theories/Numbers/DecimalN.v b/theories/Numbers/DecimalN.v index 8bc5c38fb5..a5dd97f24b 100644 --- a/theories/Numbers/DecimalN.v +++ b/theories/Numbers/DecimalN.v @@ -74,7 +74,7 @@ Proof. destruct (norm d) eqn:Hd; intros [= <-]. unfold N.to_int. rewrite Unsigned.to_of. f_equal. revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_invol. + - intros [= <-]. apply unorm_involutive. - destruct (nzhead d); now intros [= <-]. Qed. @@ -93,7 +93,7 @@ Qed. Lemma of_int_norm d : N.of_int (norm d) = N.of_int d. Proof. - unfold N.of_int. now rewrite norm_invol. + unfold N.of_int. now rewrite norm_involutive. Qed. Lemma of_inj_pos d d' : diff --git a/theories/Numbers/DecimalNat.v b/theories/Numbers/DecimalNat.v index 1962ac5d9d..4fee40caa2 100644 --- a/theories/Numbers/DecimalNat.v +++ b/theories/Numbers/DecimalNat.v @@ -270,7 +270,7 @@ Proof. destruct (norm d) eqn:Hd; intros [= <-]. unfold Nat.to_int. rewrite Unsigned.to_of. f_equal. revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_invol. + - intros [= <-]. apply unorm_involutive. - destruct (nzhead d); now intros [= <-]. Qed. @@ -289,7 +289,7 @@ Qed. Lemma of_int_norm d : Nat.of_int (norm d) = Nat.of_int d. Proof. - unfold Nat.of_int. now rewrite norm_invol. + unfold Nat.of_int. now rewrite norm_involutive. Qed. Lemma of_inj_pos d d' : diff --git a/theories/Numbers/DecimalQ.v b/theories/Numbers/DecimalQ.v index c51cced024..2027813eec 100644 --- a/theories/Numbers/DecimalQ.v +++ b/theories/Numbers/DecimalQ.v @@ -15,455 +15,413 @@ Require Import Decimal DecimalFacts DecimalPos DecimalN DecimalZ QArith. -Lemma of_to (q:Q) : forall d, to_decimal q = Some d -> of_decimal d = q. +Lemma of_IQmake_to_decimal num den : + match IQmake_to_decimal num den with + | None => True + | Some (DecimalExp _ _ _) => False + | Some (Decimal i f) => of_decimal (Decimal i f) = IQmake (IZ_of_Z num) den + end. Proof. - cut (match to_decimal q with None => True | Some d => of_decimal d = q end). - { now case to_decimal; [intros d <- d' Hd'; injection Hd'; intros ->|]. } - destruct q as (num, den). - unfold to_decimal; simpl. - generalize (DecimalPos.Unsigned.nztail_to_uint den). - case Decimal.nztail; intros u n. - case u; clear u; [intros; exact I|intros; exact I|intro u|intros; exact I..]. - case u; clear u; [|intros; exact I..]. - unfold Pos.of_uint, Pos.of_uint_acc; rewrite N.mul_1_l. - case n. - - unfold of_decimal, app_int, app, Z.to_int; simpl. - intro H; inversion H as (H1); clear H H1. - case num; [reflexivity|intro pnum; fold (rev (rev (Pos.to_uint pnum)))..]. - + rewrite rev_rev; simpl. - now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. - + rewrite rev_rev; simpl. - now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. - - clear n; intros n H. - injection H; clear H; intros ->. - case Nat.ltb. - + unfold of_decimal. - rewrite of_to. - apply f_equal2; [|now simpl]. - unfold app_int, app, Z.to_int; simpl. - now case num; - [|intro pnum; fold (rev (rev (Pos.to_uint pnum))); - rewrite rev_rev; unfold Z.of_int, Z.of_uint; - rewrite DecimalPos.Unsigned.of_to..]. - + unfold of_decimal; case Nat.ltb_spec; intro Hn; simpl. - * rewrite nb_digits_del_head; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply le_Sn_le]. - rewrite Z.sub_sub_distr, Z.sub_diag; simpl. - rewrite <-(of_to num) at 4. - now revert Hn; case Z.to_int; clear num; intros pnum Hn; simpl; - (rewrite app_del_tail_head; [|now apply le_Sn_le]). - * revert Hn. - set (anum := match Z.to_int num with Pos i => i | _ => _ end). - intro Hn. - assert (H : exists l, nb_digits anum = S l). - { exists (Nat.pred (nb_digits anum)); apply S_pred_pos. - now unfold anum; case num; - [apply Nat.lt_0_1| - intro pnum; apply nb_digits_pos, Unsigned.to_uint_nonnil..]. } - destruct H as (l, Hl); rewrite Hl. - assert (H : forall n d, (nb_digits (Nat.iter n D0 d) = n + nb_digits d)%nat). - { now intros n'; induction n'; intro d; [|simpl; rewrite IHn']. } - rewrite H, Hl. - rewrite Nat.add_succ_r, Nat.sub_add; [|now apply le_S_n; rewrite <-Hl]. - assert (H' : forall n d, Pos.of_uint (Nat.iter n D0 d) = Pos.of_uint d). - { now intro n'; induction n'; intro d; [|simpl; rewrite IHn']. } - now unfold anum; case num; simpl; [|intro pnum..]; - unfold app, Z.of_uint; simpl; - rewrite H', ?DecimalPos.Unsigned.of_to. + unfold IQmake_to_decimal. + generalize (Unsigned.nztail_to_uint den). + case Decimal.nztail; intros den' e_den'. + case den'; [now simpl|now simpl| |now simpl..]; clear den'; intro den'. + case den'; [ |now simpl..]; clear den'. + case e_den' as [|e_den']; simpl; intro H; injection H; clear H; intros->. + { now unfold of_decimal; simpl; rewrite app_int_nil_r, DecimalZ.of_to. } + replace (10 ^ _)%positive with (Nat.iter (S e_den') (Pos.mul 10) 1%positive). + 2:{ induction e_den' as [|n IHn]; [now simpl| ]. + now rewrite SuccNat2Pos.inj_succ, Pos.pow_succ_r, <-IHn. } + case Nat.ltb_spec; intro He_den'. + - unfold of_decimal; simpl. + rewrite app_int_del_tail_head; [|now apply Nat.lt_le_incl]. + rewrite DecimalZ.of_to. + now rewrite nb_digits_del_head_sub; [|now apply Nat.lt_le_incl]. + - unfold of_decimal; simpl. + rewrite nb_digits_iter_D0. + apply f_equal2. + + apply f_equal, DecimalZ.to_int_inj. + rewrite DecimalZ.to_of. + rewrite <-(DecimalZ.of_to num), DecimalZ.to_of. + case (Z.to_int num); clear He_den' num; intro num; simpl. + * unfold app; simpl. + now rewrite unorm_D0, unorm_iter_D0, unorm_involutive. + * case (uint_eq_dec (nzhead num) Nil); [|intro Hn]. + { intros->; simpl; unfold app; simpl. + now rewrite unorm_D0, unorm_iter_D0. } + replace (match nzhead num with Nil => _ | _ => _ end) + with (Neg (nzhead num)); [|now revert Hn; case nzhead]. + simpl. + rewrite nzhead_iter_D0, nzhead_involutive. + now revert Hn; case nzhead. + + revert He_den'; case nb_digits as [|n]; [now simpl; rewrite Nat.add_0_r|]. + intro Hn. + rewrite Nat.add_succ_r, Nat.add_comm. + now rewrite <-le_plus_minus; [|apply le_S_n]. Qed. -(* normalize without fractional part, for instance norme 12.3e-1 is 123e-2 *) -Definition dnorme (d:decimal) : decimal := - let '(i, f, e) := - match d with - | Decimal i f => (i, f, Pos Nil) - | DecimalExp i f e => (i, f, e) - end in - let i := norm (app_int i f) in - let e := norm (Z.to_int (Z.of_int e - Z.of_nat (nb_digits f))) in - match e with - | Pos zero => Decimal i Nil - | _ => DecimalExp i Nil e +Lemma IZ_of_Z_IZ_to_Z z z' : IZ_to_Z z = Some z' -> IZ_of_Z z' = z. +Proof. now case z as [| |p|p]; [|intro H; injection H; intros<-..]. Qed. + +Lemma of_IQmake_to_decimal' num den : + match IQmake_to_decimal' num den with + | None => True + | Some (DecimalExp _ _ _) => False + | Some (Decimal i f) => of_decimal (Decimal i f) = IQmake num den end. +Proof. + unfold IQmake_to_decimal'. + case_eq (IZ_to_Z num); [intros num' Hnum'|now simpl]. + generalize (of_IQmake_to_decimal num' den). + case IQmake_to_decimal as [d|]; [|now simpl]. + case d as [i f|]; [|now simpl]. + now rewrite (IZ_of_Z_IZ_to_Z _ _ Hnum'). +Qed. + +Lemma of_to (q:IQ) : forall d, to_decimal q = Some d -> of_decimal d = q. +Proof. + intro d. + case q as [num den|q q'|q q']; simpl. + - generalize (of_IQmake_to_decimal' num den). + case IQmake_to_decimal' as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + now intros H H'; injection H'; clear H'; intros <-. + - case q as [num den| |]; [|now simpl..]. + case q' as [num' den'| |]; [|now simpl..]. + case num' as [z p| | |]; [|now simpl..]. + case (Z.eq_dec z 10); [intros->|]. + 2:{ case z; [now simpl| |now simpl]; intro pz'. + case pz'; [intros d0..| ]; [now simpl| |now simpl]. + case d0; [intros d1..| ]; [ |now simpl..]. + case d1; [intros d2..| ]; [now simpl| |now simpl]. + now case d2. } + case (Pos.eq_dec den' 1%positive); [intros->|now case den']. + generalize (of_IQmake_to_decimal' num den). + case IQmake_to_decimal' as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros <-; clear num den. + intros H; injection H; clear H; intros<-. + unfold of_decimal; simpl. + now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. + - case q as [num den| |]; [|now simpl..]. + case q' as [num' den'| |]; [|now simpl..]. + case num' as [z p| | |]; [|now simpl..]. + case (Z.eq_dec z 10); [intros->|]. + 2:{ case z; [now simpl| |now simpl]; intro pz'. + case pz'; [intros d0..| ]; [now simpl| |now simpl]. + case d0; [intros d1..| ]; [ |now simpl..]. + case d1; [intros d2..| ]; [now simpl| |now simpl]. + now case d2. } + case (Pos.eq_dec den' 1%positive); [intros->|now case den']. + generalize (of_IQmake_to_decimal' num den). + case IQmake_to_decimal' as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros <-; clear num den. + intros H; injection H; clear H; intros<-. + unfold of_decimal; simpl. + now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. +Qed. -(* normalize without exponent part, for instance norme 12.3e-1 is 1.23 *) -Definition dnormf (d:decimal) : decimal := - match dnorme d with - | Decimal i _ => Decimal i Nil - | DecimalExp i _ e => - match Z.of_int e with - | Z0 => Decimal i Nil - | Zpos e => Decimal (norm (app_int i (Pos.iter D0 Nil e))) Nil - | Zneg e => - let ne := Pos.to_nat e in - let ai := match i with Pos d | Neg d => d end in - let ni := nb_digits ai in - if ne <? ni then - Decimal (del_tail_int ne i) (del_head (ni - ne) ai) - else - let z := match i with Pos _ => Pos zero | Neg _ => Neg zero end in - Decimal z (Nat.iter (ne - ni) D0 ai) +Definition dnorm (d:decimal) : decimal := + let norm_i i f := + match i with + | Pos i => Pos (unorm i) + | Neg i => match nzhead (app i f) with Nil => Pos zero | _ => Neg (unorm i) end + end in + match d with + | Decimal i f => Decimal (norm_i i f) f + | DecimalExp i f e => + match norm e with + | Pos zero => Decimal (norm_i i f) f + | e => DecimalExp (norm_i i f) f e end end. -Lemma dnorme_spec d : - match dnorme d with - | Decimal i Nil => i = norm i - | DecimalExp i Nil e => i = norm i /\ e = norm e /\ e <> Pos zero - | _ => False +Lemma dnorm_spec_i d : + let (i, f) := + match d with Decimal i f => (i, f) | DecimalExp i f _ => (i, f) end in + let i' := match dnorm d with Decimal i _ => i | DecimalExp i _ _ => i end in + match i with + | Pos i => i' = Pos (unorm i) + | Neg i => + (i' = Neg (unorm i) /\ (nzhead i <> Nil \/ nzhead f <> Nil)) + \/ (i' = Pos zero /\ (nzhead i = Nil /\ nzhead f = Nil)) end. Proof. - case d; clear d; intros i f; [|intro e]; unfold dnorme; simpl. - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); [intros->|intro Hne']. - + now rewrite norm_invol. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - replace m with r; [now unfold r; rewrite !norm_invol|]. - unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); [intros->|intro Hne']. - + now rewrite norm_invol. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - replace m with r; [now unfold r; rewrite !norm_invol|]. - unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. + case d as [i f|i f e]; case i as [i|i]. + - now simpl. + - simpl; case (uint_eq_dec (nzhead (app i f)) Nil); intro Ha. + + rewrite Ha; right; split; [now simpl|split]. + * now unfold unorm; rewrite (nzhead_app_nil_l _ _ Ha). + * now unfold unorm; rewrite (nzhead_app_nil_r _ _ Ha). + + left; split; [now revert Ha; case nzhead|]. + case (uint_eq_dec (nzhead i) Nil). + * intro Hi; right; intro Hf; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + * now intro H; left. + - simpl; case (norm e); clear e; intro e; [|now simpl]. + now case e; clear e; [|intro e..]; [|case e|..]. + - simpl. + set (m := match nzhead _ with Nil => _ | _ => _ end). + set (m' := match _ with Decimal _ _ => _ | _ => _ end). + replace m' with m. + 2:{ unfold m'; case (norm e); clear m' e; intro e; [|now simpl]. + now case e; clear e; [|intro e..]; [|case e|..]. } + unfold m; case (uint_eq_dec (nzhead (app i f)) Nil); intro Ha. + + rewrite Ha; right; split; [now simpl|split]. + * now unfold unorm; rewrite (nzhead_app_nil_l _ _ Ha). + * now unfold unorm; rewrite (nzhead_app_nil_r _ _ Ha). + + left; split; [now revert Ha; case nzhead|]. + case (uint_eq_dec (nzhead i) Nil). + * intro Hi; right; intro Hf; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + * now intro H; left. +Qed. + +Lemma dnorm_spec_f d : + let f := match d with Decimal _ f => f | DecimalExp _ f _ => f end in + let f' := match dnorm d with Decimal _ f => f | DecimalExp _ f _ => f end in + f' = f. +Proof. + case d as [i f|i f e]; [now simpl|]. + simpl; case (int_eq_dec (norm e) (Pos zero)); [now intros->|intro He]. + set (i' := match i with Pos _ => _ | _ => _ end). + set (m := match norm e with Pos Nil => _ | _ => _ end). + replace m with (DecimalExp i' f (norm e)); [now simpl|]. + unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. Qed. -Lemma dnormf_spec d : - match dnormf d with - | Decimal i f => i = Neg zero \/ i = norm i - | _ => False +Lemma dnorm_spec_e d : + match d, dnorm d with + | Decimal _ _, Decimal _ _ => True + | DecimalExp _ _ e, Decimal _ _ => norm e = Pos zero + | DecimalExp _ _ e, DecimalExp _ _ e' => e' = norm e /\ e' <> Pos zero + | Decimal _ _, DecimalExp _ _ _ => False end. Proof. - case d; clear d; intros i f; [|intro e]; unfold dnormf, dnorme; simpl. - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); [intros->|intro Hne']. - + now right; rewrite norm_invol. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. } - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - case_eq (Z.of_int e'); [|intros pe'..]; intro Hpe'; - [now right; rewrite norm_invol..|]. - case Nat.ltb_spec. - * now intro H; rewrite (norm_del_tail_int_norm _ _ H); right. - * now intros _; case norm; intros _; [right|left]. - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); [intros->|intro Hne']. - + now right; rewrite norm_invol. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. } - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - case_eq (Z.of_int e'); [|intros pe'..]; intro Hpe'; - [now right; rewrite norm_invol..|]. - case Nat.ltb_spec. - * now intro H; rewrite (norm_del_tail_int_norm _ _ H); right. - * now intros _; case norm; intros _; [right|left]. + case d as [i f|i f e]; [now simpl|]. + simpl; case (int_eq_dec (norm e) (Pos zero)); [now intros->|intro He]. + set (i' := match i with Pos _ => _ | _ => _ end). + set (m := match norm e with Pos Nil => _ | _ => _ end). + replace m with (DecimalExp i' f (norm e)); [now simpl|]. + unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. Qed. -Lemma dnorme_invol d : dnorme (dnorme d) = dnorme d. +Lemma dnorm_involutive d : dnorm (dnorm d) = dnorm d. Proof. - case d; clear d; intros i f; [|intro e]; unfold dnorme; simpl. - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); intro Hne'. - + rewrite Hne'; simpl; rewrite app_int_nil_r, norm_invol. - revert Hne'. - rewrite <-to_of. - change (Pos zero) with (Z.to_int 0). - intro H; generalize (to_int_inj _ _ H); clear H. - unfold e'; rewrite DecimalZ.of_to. - now case f; [rewrite app_int_nil_r|..]. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. } - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - unfold nb_digits, Z.of_nat; rewrite Z.sub_0_r, to_of, norm_invol. - rewrite app_int_nil_r, norm_invol. - set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); intro Hne'. - + rewrite Hne'; simpl; rewrite app_int_nil_r, norm_invol. - revert Hne'. - rewrite <-to_of. - change (Pos zero) with (Z.to_int 0). - intro H; generalize (to_int_inj _ _ H); clear H. - unfold e'; rewrite DecimalZ.of_to. - now case f; [rewrite app_int_nil_r|..]. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. } - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - unfold nb_digits, Z.of_nat; rewrite Z.sub_0_r, to_of, norm_invol. - rewrite app_int_nil_r, norm_invol. - set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. + case d as [i f|i f e]; case i as [i|i]. + - now simpl; rewrite unorm_involutive. + - simpl; case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. + set (m := match nzhead _ with Nil =>_ | _ => _ end). + replace m with (Neg (unorm i)). + 2:{ now unfold m; revert Ha; case nzhead. } + case (uint_eq_dec (nzhead i) Nil); intro Hi. + + unfold unorm; rewrite Hi; simpl. + case (uint_eq_dec (nzhead f) Nil). + * intro Hf; exfalso; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + * now case nzhead. + + rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. + now revert Ha; case nzhead. + - simpl; case (int_eq_dec (norm e) (Pos zero)); intro He. + + now rewrite He; simpl; rewrite unorm_involutive. + + set (m := match norm e with Pos Nil => _ | _ => _ end). + replace m with (DecimalExp (Pos (unorm i)) f (norm e)). + 2:{ unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. } + simpl; rewrite norm_involutive, unorm_involutive. + revert He; case (norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. + - simpl; case (int_eq_dec (norm e) (Pos zero)); intro He. + + rewrite He; simpl. + case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. + set (m := match nzhead _ with Nil =>_ | _ => _ end). + replace m with (Neg (unorm i)). + 2:{ now unfold m; revert Ha; case nzhead. } + case (uint_eq_dec (nzhead i) Nil); intro Hi. + * unfold unorm; rewrite Hi; simpl. + case (uint_eq_dec (nzhead f) Nil). + -- intro Hf; exfalso; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + -- now case nzhead. + * rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. + now revert Ha; case nzhead. + + set (m := match norm e with Pos Nil => _ | _ => _ end). + pose (i' := match nzhead (app i f) with Nil => Pos zero | _ => Neg (unorm i) end). + replace m with (DecimalExp i' f (norm e)). + 2:{ unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. } + simpl; rewrite norm_involutive. + set (i'' := match i' with Pos _ => _ | _ => _ end). + clear m; set (m := match norm e with Pos Nil => _ | _ => _ end). + replace m with (DecimalExp i'' f (norm e)). + 2:{ unfold m; revert He; case (norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. } + unfold i'', i'. + case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. + fold i'; replace i' with (Neg (unorm i)). + 2:{ now unfold i'; revert Ha; case nzhead. } + case (uint_eq_dec (nzhead i) Nil); intro Hi. + * unfold unorm; rewrite Hi; simpl. + case (uint_eq_dec (nzhead f) Nil). + -- intro Hf; exfalso; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + -- now case nzhead. + * rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. + now revert Ha; case nzhead. Qed. -Lemma dnormf_invol d : dnormf (dnormf d) = dnormf d. +Lemma IZ_to_Z_IZ_of_Z z : IZ_to_Z (IZ_of_Z z) = Some z. +Proof. now case z. Qed. + +Lemma dnorm_i_exact i f : + (nb_digits f < nb_digits (unorm (app (abs i) f)))%nat -> + match i with + | Pos i => Pos (unorm i) + | Neg i => + match nzhead (app i f) with + | Nil => Pos zero + | _ => Neg (unorm i) + end + end = norm i. Proof. - case d; clear d; intros i f; [|intro e]; unfold dnormf, dnorme; simpl. - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); intro Hne'. - + rewrite Hne'; simpl; rewrite app_int_nil_r, norm_invol. - revert Hne'. - rewrite <-to_of. - change (Pos zero) with (Z.to_int 0). - intro H; generalize (to_int_inj _ _ H); clear H. - unfold e'; rewrite DecimalZ.of_to. - now case f; [rewrite app_int_nil_r|..]. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. } - rewrite of_int_norm. - case_eq (Z.of_int e'); [|intro pe'..]; intro Hnpe'; - [now simpl; rewrite app_int_nil_r, norm_invol..|]. - case Nat.ltb_spec; intro Hpe'. - * rewrite nb_digits_del_head; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply Nat.lt_le_incl]. - simpl. - rewrite Z.sub_sub_distr, Z.sub_diag, Z.add_0_l. - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - rewrite positive_nat_Z; simpl. - unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - rewrite app_int_del_tail_head; [|now apply Nat.lt_le_incl]. - now rewrite norm_invol, (proj2 (Nat.ltb_lt _ _) Hpe'). - * simpl. - rewrite nb_digits_iter_D0. - rewrite (Nat.sub_add _ _ Hpe'). - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - rewrite positive_nat_Z; simpl. - unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - revert Hpe'. - set (i' := norm (app_int i f)). - case_eq i'; intros u Hu Hpe'. - ++ simpl; unfold app; simpl. - rewrite unorm_D0, unorm_iter_D0. - assert (Hu' : unorm u = u). - { generalize (f_equal norm Hu). - unfold i'; rewrite norm_invol; fold i'. - now simpl; rewrite Hu; intro H; injection H. } - now rewrite Hu', (proj2 (Nat.ltb_ge _ _) Hpe'). - ++ simpl; rewrite nzhead_iter_D0. - assert (Hu' : nzhead u = u). - { generalize (f_equal norm Hu). - unfold i'; rewrite norm_invol; fold i'. - now rewrite Hu; simpl; case (nzhead u); [|intros u' H; injection H..]. } - rewrite Hu'. - assert (Hu'' : u <> Nil). - { intro H; revert Hu; rewrite H; unfold i'. - now case app_int; intro u'; [|simpl; case nzhead]. } - set (m := match u with Nil => Pos zero | _ => _ end). - assert (H : m = Neg u); [|rewrite H; clear m H]. - { now revert Hu''; unfold m; case u. } - now rewrite (proj2 (Nat.ltb_ge _ _) Hpe'). - - set (e' := Z.to_int _). - case (int_eq_dec (norm e') (Pos zero)); intro Hne'. - + rewrite Hne'; simpl; rewrite app_int_nil_r, norm_invol. - revert Hne'. - rewrite <-to_of. - change (Pos zero) with (Z.to_int 0). - intro H; generalize (to_int_inj _ _ H); clear H. - unfold e'; rewrite DecimalZ.of_to. - now case f; [rewrite app_int_nil_r|..]. - + set (r := DecimalExp _ _ _). - set (m := match norm e' with Pos zero => _ | _ => _ end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { unfold m; revert Hne'; case (norm e'); intro e''; [|now simpl]. - now case e''; [|intro e'''; case e'''..]. } - rewrite of_int_norm. - case_eq (Z.of_int e'); [|intro pe'..]; intro Hnpe'; - [now simpl; rewrite app_int_nil_r, norm_invol..|]. - case Nat.ltb_spec; intro Hpe'. - * rewrite nb_digits_del_head; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply Nat.lt_le_incl]. - simpl. - rewrite Z.sub_sub_distr, Z.sub_diag, Z.add_0_l. - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - rewrite positive_nat_Z; simpl. - unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - rewrite app_int_del_tail_head; [|now apply Nat.lt_le_incl]. - now rewrite norm_invol, (proj2 (Nat.ltb_lt _ _) Hpe'). - * simpl. - rewrite nb_digits_iter_D0. - rewrite (Nat.sub_add _ _ Hpe'). - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - rewrite positive_nat_Z; simpl. - unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - revert Hpe'. - set (i' := norm (app_int i f)). - case_eq i'; intros u Hu Hpe'. - ++ simpl; unfold app; simpl. - rewrite unorm_D0, unorm_iter_D0. - assert (Hu' : unorm u = u). - { generalize (f_equal norm Hu). - unfold i'; rewrite norm_invol; fold i'. - now simpl; rewrite Hu; intro H; injection H. } - now rewrite Hu', (proj2 (Nat.ltb_ge _ _) Hpe'). - ++ simpl; rewrite nzhead_iter_D0. - assert (Hu' : nzhead u = u). - { generalize (f_equal norm Hu). - unfold i'; rewrite norm_invol; fold i'. - now rewrite Hu; simpl; case (nzhead u); [|intros u' H; injection H..]. } - rewrite Hu'. - assert (Hu'' : u <> Nil). - { intro H; revert Hu; rewrite H; unfold i'. - now case app_int; intro u'; [|simpl; case nzhead]. } - set (m := match u with Nil => Pos zero | _ => _ end). - assert (H : m = Neg u); [|rewrite H; clear m H]. - { now revert Hu''; unfold m; case u. } - now rewrite (proj2 (Nat.ltb_ge _ _) Hpe'). + case i as [ni|ni]; [now simpl|]; simpl. + case (uint_eq_dec (nzhead (app ni f)) Nil); intro Ha. + { now rewrite Ha, (nzhead_app_nil_l _ _ Ha). } + rewrite (unorm_nzhead _ Ha). + set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (Neg (unorm ni)); [|now unfold m; revert Ha; case nzhead]. + case (uint_eq_dec (nzhead ni) Nil); intro Hni. + { rewrite <-nzhead_app_nzhead, Hni, app_nil_l. + intro H; exfalso; revert H; apply le_not_lt, nb_digits_nzhead. } + clear m; set (m := match nzhead ni with Nil => _ | _ => _ end). + replace m with (Neg (nzhead ni)); [|now unfold m; revert Hni; case nzhead]. + now rewrite (unorm_nzhead _ Hni). +Qed. + +Lemma dnorm_i_exact' i f : + (nb_digits (unorm (app (abs i) f)) <= nb_digits f)%nat -> + match i with + | Pos i => Pos (unorm i) + | Neg i => + match nzhead (app i f) with + | Nil => Pos zero + | _ => Neg (unorm i) + end + end = + match norm (app_int i f) with + | Pos _ => Pos zero + | Neg _ => Neg zero + end. +Proof. + case i as [ni|ni]; simpl. + { now intro Hnb; rewrite (unorm_app_zero _ _ Hnb). } + unfold unorm. + case (uint_eq_dec (nzhead (app ni f)) Nil); intro Hn. + { now rewrite Hn. } + set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (nzhead (app ni f)). + 2:{ now unfold m; revert Hn; case nzhead. } + clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (Neg (unorm ni)). + 2:{ now unfold m, unorm; revert Hn; case nzhead. } + clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (Neg (nzhead (app ni f))). + 2:{ now unfold m; revert Hn; case nzhead. } + rewrite <-(unorm_nzhead _ Hn). + now intro H; rewrite (unorm_app_zero _ _ H). Qed. -Lemma to_of (d:decimal) : - to_decimal (of_decimal d) = Some (dnorme d) - \/ to_decimal (of_decimal d) = Some (dnormf d). +Lemma to_of (d:decimal) : to_decimal (of_decimal d) = Some (dnorm d). Proof. - unfold to_decimal. - pose (t10 := fun y => ((y + y~0~0)~0)%positive). - assert (H : exists e_den, - Decimal.nztail (Pos.to_uint (Qden (of_decimal d))) = (D1 Nil, e_den)). - { assert (H : forall p, - Decimal.nztail (Pos.to_uint (Pos.iter t10 1%positive p)) - = (D1 Nil, Pos.to_nat p)). - { intro p; rewrite Pos2Nat.inj_iter. - fold (Nat.iter (Pos.to_nat p) t10 1%positive). - induction (Pos.to_nat p); [now simpl|]. - rewrite DecimalPos.Unsigned.nat_iter_S. - unfold Pos.to_uint. - change (Pos.to_little_uint _) - with (Unsigned.to_lu (10 * N.pos (Nat.iter n t10 1%positive))). - rewrite Unsigned.to_ldec_tenfold. - revert IHn; unfold Pos.to_uint. - unfold Decimal.nztail; rewrite !rev_rev; simpl. - set (f'' := _ (Pos.to_little_uint _)). - now case f''; intros r n' H; inversion H. } - case d; intros i f; [|intro e]; unfold of_decimal; simpl. - - case (- Z.of_nat _)%Z; [|intro p..]; simpl; [now exists O..|]. - exists (Pos.to_nat p); apply H. - - case (_ - _)%Z; [|intros p..]; simpl; [now exists O..|]. - exists (Pos.to_nat p); apply H. } - generalize (DecimalPos.Unsigned.nztail_to_uint (Qden (of_decimal d))). - destruct H as (e, He); rewrite He; clear He; simpl. - assert (Hn1 : forall p, N.pos (Pos.iter t10 1%positive p) = 1%N -> False). - { intro p. - rewrite Pos2Nat.inj_iter. - case_eq (Pos.to_nat p); [|now simpl]. - intro H; exfalso; apply (lt_irrefl O). - rewrite <-H at 2; apply Pos2Nat.is_pos. } - assert (Ht10inj : forall n m, t10 n = t10 m -> n = m). - { intros n m H; generalize (f_equal Z.pos H); clear H. - change (Z.pos (t10 n)) with (Z.mul 10 (Z.pos n)). - change (Z.pos (t10 m)) with (Z.mul 10 (Z.pos m)). - rewrite Z.mul_comm, (Z.mul_comm 10). - intro H; generalize (f_equal (fun z => Z.div z 10) H); clear H. - now rewrite !Z.div_mul; [|now simpl..]; intro H; inversion H. } - assert (Hinj : forall n m, - Nat.iter n t10 1%positive = Nat.iter m t10 1%positive -> n = m). - { induction n; [now intro m; case m|]. - intro m; case m; [now simpl|]; clear m; intro m. - rewrite !Unsigned.nat_iter_S. - intro H; generalize (Ht10inj _ _ H); clear H; intro H. - now rewrite (IHn _ H). } - case e; clear e; [|intro e]; simpl; unfold of_decimal, dnormf, dnorme. - - case d; clear d; intros i f; [|intro e]; simpl. - + intro H; left; revert H. - generalize (nb_digits_pos f). - case f; - [|now clear f; intro f; intros H1 H2; exfalso; revert H1 H2; - case nb_digits; simpl; - [intros H _; apply (lt_irrefl O), H|intros n _; apply Hn1]..]. - now intros _ _; simpl; rewrite to_of. - + intro H; right; revert H. - rewrite <-to_of, DecimalZ.of_to. - set (emf := (_ - _)%Z). - case_eq emf; [|intro pemf..]. - * now simpl; rewrite to_of. - * set (r := DecimalExp _ _ _). - set (m := match _ with Pos _ => _ | _ => r end). - assert (H : m = r). - { unfold m, Z.to_int. - generalize (Unsigned.to_uint_nonzero pemf). - now case Pos.to_uint; [|intro u; case u..]. } - rewrite H; unfold r; clear H m r. - rewrite DecimalZ.of_to. - simpl Qnum. - intros Hpemf _. - apply f_equal; apply f_equal2; [|reflexivity]. - rewrite !Pos2Nat.inj_iter. - set (n := _ pemf). - fold (Nat.iter n (Z.mul 10) (Z.of_int (app_int i f))). - fold (Nat.iter n D0 Nil). - rewrite <-of_int_iter_D0, to_of. - now rewrite norm_app_int_norm; [|induction n]. - * simpl Qden; intros _ H; exfalso; revert H; apply Hn1. - - case d; clear d; intros i f; [|intro e']; simpl. - + case_eq (nb_digits f); [|intros nf' Hnf']; - [now simpl; intros _ H; exfalso; symmetry in H; revert H; apply Hn1|]. - unfold Z.of_nat, Z.opp. - simpl Qden. - intro H; injection H; clear H; unfold Pos.pow. - rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (SuccNat2Pos.inj _ _ ((Pos2Nat.inj _ _ H))); clear H. - intro He; rewrite <-He; clear e He. - simpl Qnum. - case Nat.ltb; [left|right]. - * now rewrite <-to_of, DecimalZ.of_to, to_of. - * rewrite to_of. - set (nif := norm _). - set (anif := match nif with Pos i0 => i0 | _ => _ end). - set (r := DecimalExp nif Nil _). - set (m := match _ with Pos _ => _ | _ => r end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { now unfold m; rewrite <-to_of, DecimalZ.of_to. } - rewrite <-to_of, !DecimalZ.of_to. - fold anif. - now rewrite SuccNat2Pos.id_succ. - + set (nemf := (_ - _)%Z); intro H. - assert (H' : exists pnemf, nemf = Z.neg pnemf); [|revert H]. - { revert H; case nemf; [|intro pnemf..]; [..|now intros _; exists pnemf]; - simpl Qden; intro H; exfalso; symmetry in H; revert H; apply Hn1. } - destruct H' as (pnemf,Hpnemf); rewrite Hpnemf. - simpl Qden. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H. - intro H; revert Hpnemf; rewrite H; clear pnemf H; intro Hnemf. - simpl Qnum. - case Nat.ltb; [left|right]. - * now rewrite <-to_of, DecimalZ.of_to, to_of. - * rewrite to_of. - set (nif := norm _). - set (anif := match nif with Pos i0 => i0 | _ => _ end). - set (r := DecimalExp nif Nil _). - set (m := match _ with Pos _ => _ | _ => r end). - assert (H : m = r); [|rewrite H; unfold m, r; clear m r H]. - { now unfold m; rewrite <-to_of, DecimalZ.of_to. } - rewrite <-to_of, !DecimalZ.of_to. - fold anif. - now rewrite SuccNat2Pos.id_succ. + case d as [i f|i f e]. + - unfold of_decimal; simpl; unfold IQmake_to_decimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_decimal; simpl. + change (fun _ : positive => _) with (Pos.mul 10). + rewrite nztail_to_uint_pow10, to_of. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + + rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + + rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + * rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + * rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. + - unfold of_decimal; simpl. + rewrite <-to_of. + case (Z.of_int e); clear e; [|intro e..]; simpl. + + unfold IQmake_to_decimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_decimal; simpl. + change (fun _ : positive => _) with (Pos.mul 10). + rewrite nztail_to_uint_pow10, to_of. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + * rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + -- rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + -- rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. + + unfold IQmake_to_decimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_decimal; simpl. + change (fun _ : positive => _) with (Pos.mul 10). + rewrite nztail_to_uint_pow10, to_of. + generalize (Unsigned.to_uint_nonzero e); intro He. + set (dnorm_i := match i with Pos _ => _ | _ => _ end). + set (m := match Pos.to_uint e with Nil => _ | _ => _ end). + replace m with (DecimalExp dnorm_i f (Pos (Pos.to_uint e))). + 2:{ now unfold m; revert He; case (Pos.to_uint e); [|intro u; case u|..]. } + clear m; unfold dnorm_i. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + * rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + -- rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + -- rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. + + unfold IQmake_to_decimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_decimal; simpl. + change (fun _ : positive => _) with (Pos.mul 10). + rewrite nztail_to_uint_pow10, to_of. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + * rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + -- rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + -- rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. Qed. (** Some consequences *) @@ -478,84 +436,24 @@ Proof. now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). Qed. -Lemma to_decimal_surj d : - exists q, to_decimal q = Some (dnorme d) \/ to_decimal q = Some (dnormf d). +Lemma to_decimal_surj d : exists q, to_decimal q = Some (dnorm d). Proof. exists (of_decimal d). apply to_of. Qed. -Lemma of_decimal_dnorme d : of_decimal (dnorme d) = of_decimal d. +Lemma of_decimal_dnorm d : of_decimal (dnorm d) = of_decimal d. +Proof. now apply to_decimal_inj; rewrite !to_of; [|rewrite dnorm_involutive]. Qed. + +Lemma of_inj d d' : of_decimal d = of_decimal d' -> dnorm d = dnorm d'. Proof. - unfold of_decimal, dnorme. - destruct d. - - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - case_eq (nb_digits f); [|intro nf]; intro Hnf. - + now simpl; rewrite app_int_nil_r, <-DecimalZ.to_of, DecimalZ.of_to. - + simpl; rewrite Z.sub_0_r. - unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - rewrite app_int_nil_r. - now rewrite <-DecimalZ.to_of, DecimalZ.of_to. - - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - set (emf := (_ - _)%Z). - case_eq emf; [|intro pemf..]; intro Hemf. - + now simpl; rewrite app_int_nil_r, <-DecimalZ.to_of, DecimalZ.of_to. - + simpl. - set (r := DecimalExp _ Nil _). - set (m := match Pos.to_uint pemf with zero => _ | _ => r end). - assert (H : m = r); [|rewrite H; unfold r; clear m r H]. - { generalize (Unsigned.to_uint_nonzero pemf). - now unfold m; case Pos.to_uint; [|intro u; case u|..]. } - simpl; rewrite Z.sub_0_r. - unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - rewrite app_int_nil_r. - now rewrite <-DecimalZ.to_of, DecimalZ.of_to. - + simpl. - unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. - rewrite app_int_nil_r. - now rewrite <-DecimalZ.to_of, DecimalZ.of_to. + intro H. + apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) + (Some (dnorm d)) (Some (dnorm d'))). + now rewrite <- !to_of, H. Qed. -Lemma of_decimal_dnormf d : of_decimal (dnormf d) = of_decimal d. +Lemma of_iff d d' : of_decimal d = of_decimal d' <-> dnorm d = dnorm d'. Proof. - rewrite <-(of_decimal_dnorme d). - unfold of_decimal, dnormf. - assert (H : match dnorme d with Decimal _ f | DecimalExp _ f _ => f end = Nil). - { now unfold dnorme; destruct d; - (case norm; intro d; [case d; [|intro u; case u|..]|]). } - revert H; generalize (dnorme d); clear d; intro d. - destruct d; intro H; rewrite H; clear H; [now simpl|]. - case (Z.of_int e); clear e; [|intro e..]. - - now simpl. - - simpl. - rewrite app_int_nil_r. - apply f_equal2; [|reflexivity]. - rewrite app_int_nil_r. - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - rewrite !Pos2Nat.inj_iter. - fold (Nat.iter (Pos.to_nat e) D0 Nil). - now rewrite of_int_iter_D0. - - simpl. - set (ai := match i with Pos _ => _ | _ => _ end). - rewrite app_int_nil_r. - case Nat.ltb_spec; intro Hei; simpl. - + rewrite nb_digits_del_head; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply Nat.le_sub_l]. - rewrite Nat2Z.inj_sub; [|now apply le_Sn_le]. - rewrite Z.sub_sub_distr, Z.sub_diag; simpl. - rewrite positive_nat_Z; simpl. - now revert Hei; unfold ai; case i; clear i ai; intros i Hei; simpl; - (rewrite app_del_tail_head; [|now apply le_Sn_le]). - + set (n := nb_digits _). - assert (H : (n = Pos.to_nat e - nb_digits ai + nb_digits ai)%nat). - { unfold n; induction (_ - _)%nat; [now simpl|]. - now rewrite Unsigned.nat_iter_S; simpl; rewrite IHn0. } - rewrite H; clear n H. - rewrite Nat2Z.inj_add, (Nat2Z.inj_sub _ _ Hei). - rewrite <-Z.sub_sub_distr, Z.sub_diag, Z.sub_0_r. - rewrite positive_nat_Z; simpl. - rewrite <-(DecimalZ.of_to (Z.of_int (app_int _ _))), DecimalZ.to_of. - rewrite <-(DecimalZ.of_to (Z.of_int i)), DecimalZ.to_of. - apply f_equal2; [|reflexivity]; apply f_equal. - now unfold ai; case i; clear i ai Hei; intro i; - (induction (_ - _)%nat; [|rewrite <-IHn]). + split. apply of_inj. intros E. rewrite <- of_decimal_dnorm, E. + apply of_decimal_dnorm. Qed. diff --git a/theories/Numbers/DecimalR.v b/theories/Numbers/DecimalR.v new file mode 100644 index 0000000000..9b65a7dc20 --- /dev/null +++ b/theories/Numbers/DecimalR.v @@ -0,0 +1,312 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * DecimalR + + Proofs that conversions between decimal numbers and [R] + are bijections. *) + +Require Import Decimal DecimalFacts DecimalPos DecimalZ DecimalQ Rdefinitions. + +Lemma of_IQmake_to_decimal num den : + match IQmake_to_decimal num den with + | None => True + | Some (DecimalExp _ _ _) => False + | Some (Decimal i f) => + of_decimal (Decimal i f) = IRQ (QArith_base.Qmake num den) + end. +Proof. + unfold IQmake_to_decimal. + case (Pos.eq_dec den 1); [now intros->|intro Hden]. + assert (Hf : match QArith_base.IQmake_to_decimal num den with + | Some (Decimal i f) => f <> Nil + | _ => True + end). + { unfold QArith_base.IQmake_to_decimal; simpl. + generalize (Unsigned.nztail_to_uint den). + case Decimal.nztail as [den' e_den']. + case den'; [now simpl|now simpl| |now simpl..]; clear den'; intro den'. + case den'; [ |now simpl..]; clear den'. + case e_den' as [|e_den']; [now simpl; intros H _; apply Hden; injection H|]. + intros _. + case Nat.ltb_spec; intro He_den'. + - apply del_head_nonnil. + revert He_den'; case nb_digits as [|n]; [now simpl|]. + now intro H; simpl; apply le_lt_n_Sm, Nat.le_sub_l. + - apply nb_digits_n0. + now rewrite nb_digits_iter_D0, Nat.sub_add. } + replace (match den with 1%positive => _ | _ => _ end) + with (QArith_base.IQmake_to_decimal num den); [|now revert Hden; case den]. + generalize (of_IQmake_to_decimal num den). + case QArith_base.IQmake_to_decimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + unfold of_decimal; simpl. + intro H; injection H; clear H; intros <-. + intro H; generalize (f_equal QArith_base.IZ_to_Z H); clear H. + rewrite !IZ_to_Z_IZ_of_Z; intro H; injection H; clear H; intros<-. + now revert Hf; case f. +Qed. + +Lemma of_to (q:IR) : forall d, to_decimal q = Some d -> of_decimal d = q. +Proof. + intro d. + case q as [z|q|r r'|r r']; simpl. + - case z as [z p| |p|p]. + + now simpl. + + now simpl; intro H; injection H; clear H; intros<-. + + simpl; intro H; injection H; clear H; intros<-. + now unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to. + + simpl; intro H; injection H; clear H; intros<-. + now unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to. + - case q as [num den]. + generalize (of_IQmake_to_decimal num den). + case IQmake_to_decimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + now intros H H'; injection H'; intros<-. + - case r as [z|q| |]; [|case q as[num den]|now simpl..]; + (case r' as [z'| | |]; [|now simpl..]); + (case z' as [p e| | |]; [|now simpl..]). + + case (Z.eq_dec p 10); [intros->|intro Hp]. + 2:{ revert Hp; case p; [now simpl|intro d0..]; + (case d0; [intro d1..|]; [now simpl| |now simpl]; + case d1; [intro d2..|]; [|now simpl..]; + case d2; [intro d3..|]; [now simpl| |now simpl]; + now case d3). } + case z as [| |p|p]; [now simpl|..]; intro H; injection H; intros<-. + * now unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to. + * unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to; simpl. + now rewrite Unsigned.of_to. + * unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to; simpl. + now rewrite Unsigned.of_to. + + case (Z.eq_dec p 10); [intros->|intro Hp]. + 2:{ revert Hp; case p; [now simpl|intro d0..]; + (case d0; [intro d1..|]; [now simpl| |now simpl]; + case d1; [intro d2..|]; [|now simpl..]; + case d2; [intro d3..|]; [now simpl| |now simpl]; + now case d3). } + generalize (of_IQmake_to_decimal num den). + case IQmake_to_decimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros H H'; injection H'; clear H'; intros<-. + unfold of_decimal; simpl. + change (match f with Nil => _ | _ => _ end) with (of_decimal (Decimal i f)). + rewrite H; clear H. + now unfold Z.of_uint; rewrite Unsigned.of_to. + - case r as [z|q| |]; [|case q as[num den]|now simpl..]; + (case r' as [z'| | |]; [|now simpl..]); + (case z' as [p e| | |]; [|now simpl..]). + + case (Z.eq_dec p 10); [intros->|intro Hp]. + 2:{ revert Hp; case p; [now simpl|intro d0..]; + (case d0; [intro d1..|]; [now simpl| |now simpl]; + case d1; [intro d2..|]; [|now simpl..]; + case d2; [intro d3..|]; [now simpl| |now simpl]; + now case d3). } + case z as [| |p|p]; [now simpl|..]; intro H; injection H; intros<-. + * now unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to. + * unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to; simpl. + now rewrite Unsigned.of_to. + * unfold of_decimal; simpl; unfold Z.of_uint; rewrite Unsigned.of_to; simpl. + now rewrite Unsigned.of_to. + + case (Z.eq_dec p 10); [intros->|intro Hp]. + 2:{ revert Hp; case p; [now simpl|intro d0..]; + (case d0; [intro d1..|]; [now simpl| |now simpl]; + case d1; [intro d2..|]; [|now simpl..]; + case d2; [intro d3..|]; [now simpl| |now simpl]; + now case d3). } + generalize (of_IQmake_to_decimal num den). + case IQmake_to_decimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros H H'; injection H'; clear H'; intros<-. + unfold of_decimal; simpl. + change (match f with Nil => _ | _ => _ end) with (of_decimal (Decimal i f)). + rewrite H; clear H. + now unfold Z.of_uint; rewrite Unsigned.of_to. +Qed. + +Lemma to_of (d:decimal) : to_decimal (of_decimal d) = Some (dnorm d). +Proof. + case d as [i f|i f e]. + - unfold of_decimal; simpl. + case (uint_eq_dec f Nil); intro Hf. + + rewrite Hf; clear f Hf. + unfold to_decimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, DecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + + set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_decimal; simpl. + unfold IQmake_to_decimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_decimal (Z.of_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_decimal, n; simpl. + rewrite nztail_to_uint_pow10. + clear r; set (r := if _ <? _ then Some (Decimal _ _) else Some _). + clear m; set (m := match nb_digits f with 0 => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite DecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + * rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + * rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. + - unfold of_decimal; simpl. + rewrite <-(DecimalZ.to_of e). + case (Z.of_int e); clear e; [|intro e..]; simpl. + + case (uint_eq_dec f Nil); intro Hf. + * rewrite Hf; clear f Hf. + unfold to_decimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, DecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + * set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_decimal; simpl. + unfold IQmake_to_decimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_decimal (Z.of_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_decimal, n; simpl. + rewrite nztail_to_uint_pow10. + clear r; set (r := if _ <? _ then Some (Decimal _ _) else Some _). + clear m; set (m := match nb_digits f with 0 => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite DecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + -- rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + -- rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. + + set (i' := match i with Pos _ => _ | _ => _ end). + set (m := match Pos.to_uint e with Nil => _ | _ => _ end). + replace m with (DecimalExp i' f (Pos (Pos.to_uint e))). + 2:{ unfold m; generalize (Unsigned.to_uint_nonzero e). + now case Pos.to_uint; [|intro u; case u|..]. } + unfold i'; clear i' m. + case (uint_eq_dec f Nil); intro Hf. + * rewrite Hf; clear f Hf. + unfold to_decimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, DecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + * set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_decimal; simpl. + unfold IQmake_to_decimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_decimal (Z.of_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_decimal, n; simpl. + rewrite nztail_to_uint_pow10. + clear r; set (r := if _ <? _ then Some (Decimal _ _) else Some _). + clear m; set (m := match nb_digits f with 0 => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite DecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + -- rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + -- rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. + + case (uint_eq_dec f Nil); intro Hf. + * rewrite Hf; clear f Hf. + unfold to_decimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, DecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + * set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_decimal; simpl. + unfold IQmake_to_decimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_decimal (Z.of_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_decimal, n; simpl. + rewrite nztail_to_uint_pow10. + clear r; set (r := if _ <? _ then Some (Decimal _ _) else Some _). + clear m; set (m := match nb_digits f with 0 => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite DecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + -- rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + -- rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. +Qed. + +(** Some consequences *) + +Lemma to_decimal_inj q q' : + to_decimal q <> None -> to_decimal q = to_decimal q' -> q = q'. +Proof. + intros Hnone EQ. + generalize (of_to q) (of_to q'). + rewrite <-EQ. + revert Hnone; case to_decimal; [|now simpl]. + now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). +Qed. + +Lemma to_decimal_surj d : exists q, to_decimal q = Some (dnorm d). +Proof. + exists (of_decimal d). apply to_of. +Qed. + +Lemma of_decimal_dnorm d : of_decimal (dnorm d) = of_decimal d. +Proof. now apply to_decimal_inj; rewrite !to_of; [|rewrite dnorm_involutive]. Qed. + +Lemma of_inj d d' : of_decimal d = of_decimal d' -> dnorm d = dnorm d'. +Proof. + intro H. + apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) + (Some (dnorm d)) (Some (dnorm d'))). + now rewrite <- !to_of, H. +Qed. + +Lemma of_iff d d' : of_decimal d = of_decimal d' <-> dnorm d = dnorm d'. +Proof. + split. apply of_inj. intros E. rewrite <- of_decimal_dnorm, E. + apply of_decimal_dnorm. +Qed. diff --git a/theories/Numbers/DecimalZ.v b/theories/Numbers/DecimalZ.v index 69d8073fc7..faaf8a3932 100644 --- a/theories/Numbers/DecimalZ.v +++ b/theories/Numbers/DecimalZ.v @@ -79,9 +79,11 @@ Qed. Lemma of_uint_iter_D0 d n : Z.of_uint (app d (Nat.iter n D0 Nil)) = Nat.iter n (Z.mul 10) (Z.of_uint d). Proof. - unfold Z.of_uint. - unfold app; rewrite <-rev_revapp. - rewrite Unsigned.of_lu_rev, Unsigned.of_lu_revapp. + rewrite <-(rev_rev (app _ _)), <-(of_list_to_list (rev (app _ _))). + rewrite rev_spec, app_spec, List.rev_app_distr. + rewrite <-!rev_spec, <-app_spec, of_list_to_list. + unfold Z.of_uint; rewrite Unsigned.of_lu_rev. + unfold app; rewrite Unsigned.of_lu_revapp, !rev_rev. rewrite <-!Unsigned.of_lu_rev, !rev_rev. assert (H' : Pos.of_uint (Nat.iter n D0 Nil) = 0%N). { now induction n; [|rewrite Unsigned.nat_iter_S]. } @@ -100,3 +102,22 @@ Proof. - rewrite of_uint_iter_D0; induction n; [now simpl|]. rewrite !Unsigned.nat_iter_S, <-IHn; ring. Qed. + +Lemma nztail_to_uint_pow10 n : + Decimal.nztail (Pos.to_uint (Nat.iter n (Pos.mul 10) 1%positive)) + = (D1 Nil, n). +Proof. + case n as [|n]; [now simpl|]. + rewrite <-(Nat2Pos.id (S n)); [|now simpl]. + generalize (Pos.of_nat (S n)); clear n; intro p. + induction (Pos.to_nat p); [now simpl|]. + rewrite Unsigned.nat_iter_S. + unfold Pos.to_uint. + change (Pos.to_little_uint _) + with (Unsigned.to_lu (10 * N.pos (Nat.iter n (Pos.mul 10) 1%positive))). + rewrite Unsigned.to_ldec_tenfold. + revert IHn; unfold Pos.to_uint. + unfold Decimal.nztail; rewrite !rev_rev; simpl. + set (f'' := _ (Pos.to_little_uint _)). + now case f''; intros r n' H; inversion H. +Qed. diff --git a/theories/Numbers/HexadecimalFacts.v b/theories/Numbers/HexadecimalFacts.v index 7328b2303d..c624b4e6b9 100644 --- a/theories/Numbers/HexadecimalFacts.v +++ b/theories/Numbers/HexadecimalFacts.v @@ -10,136 +10,437 @@ (** * HexadecimalFacts : some facts about Hexadecimal numbers *) -Require Import Hexadecimal Arith. +Require Import Hexadecimal Arith ZArith. + +Variant digits := + | d0 | d1 | d2 | d3 | d4 | d5 | d6 | d7 | d8 | d9 + | da | db | dc | dd | de | df. + +Fixpoint to_list (u : uint) : list digits := + match u with + | Nil => nil + | D0 u => cons d0 (to_list u) + | D1 u => cons d1 (to_list u) + | D2 u => cons d2 (to_list u) + | D3 u => cons d3 (to_list u) + | D4 u => cons d4 (to_list u) + | D5 u => cons d5 (to_list u) + | D6 u => cons d6 (to_list u) + | D7 u => cons d7 (to_list u) + | D8 u => cons d8 (to_list u) + | D9 u => cons d9 (to_list u) + | Da u => cons da (to_list u) + | Db u => cons db (to_list u) + | Dc u => cons dc (to_list u) + | Dd u => cons dd (to_list u) + | De u => cons de (to_list u) + | Df u => cons df (to_list u) + end. + +Fixpoint of_list (l : list digits) : uint := + match l with + | nil => Nil + | cons d0 l => D0 (of_list l) + | cons d1 l => D1 (of_list l) + | cons d2 l => D2 (of_list l) + | cons d3 l => D3 (of_list l) + | cons d4 l => D4 (of_list l) + | cons d5 l => D5 (of_list l) + | cons d6 l => D6 (of_list l) + | cons d7 l => D7 (of_list l) + | cons d8 l => D8 (of_list l) + | cons d9 l => D9 (of_list l) + | cons da l => Da (of_list l) + | cons db l => Db (of_list l) + | cons dc l => Dc (of_list l) + | cons dd l => Dd (of_list l) + | cons de l => De (of_list l) + | cons df l => Df (of_list l) + end. -Scheme Equality for uint. +Lemma of_list_to_list u : of_list (to_list u) = u. +Proof. now induction u; [|simpl; rewrite IHu..]. Qed. -Scheme Equality for int. +Lemma to_list_of_list l : to_list (of_list l) = l. +Proof. now induction l as [|h t IHl]; [|case h; simpl; rewrite IHl]. Qed. -Lemma rev_revapp d d' : - rev (revapp d d') = revapp d' d. +Lemma to_list_inj u u' : to_list u = to_list u' -> u = u'. Proof. - revert d'. induction d; simpl; intros; now rewrite ?IHd. + now intro H; rewrite <-(of_list_to_list u), <-(of_list_to_list u'), H. Qed. -Lemma rev_rev d : rev (rev d) = d. +Lemma of_list_inj u u' : of_list u = of_list u' -> u = u'. Proof. - apply rev_revapp. + now intro H; rewrite <-(to_list_of_list u), <-(to_list_of_list u'), H. Qed. -Lemma revapp_rev_nil d : revapp (rev d) Nil = d. -Proof. now fold (rev (rev d)); rewrite rev_rev. Qed. +Lemma nb_digits_spec u : nb_digits u = length (to_list u). +Proof. now induction u; [|simpl; rewrite IHu..]. Qed. -Lemma app_nil_r d : app d Nil = d. -Proof. now unfold app; rewrite revapp_rev_nil. Qed. +Fixpoint lnzhead l := + match l with + | nil => nil + | cons d l' => + match d with + | d0 => lnzhead l' + | _ => l + end + end. -Lemma app_int_nil_r d : app_int d Nil = d. -Proof. now case d; intro d'; simpl; rewrite app_nil_r. Qed. +Lemma nzhead_spec u : to_list (nzhead u) = lnzhead (to_list u). +Proof. now induction u; [|simpl; rewrite IHu|..]. Qed. + +Definition lzero := cons d0 nil. + +Definition lunorm l := + match lnzhead l with + | nil => lzero + | d => d + end. + +Lemma unorm_spec u : to_list (unorm u) = lunorm (to_list u). +Proof. now unfold unorm, lunorm; rewrite <-nzhead_spec; case (nzhead u). Qed. + +Lemma revapp_spec d d' : + to_list (revapp d d') = List.rev_append (to_list d) (to_list d'). +Proof. now revert d'; induction d; intro d'; [|simpl; rewrite IHd..]. Qed. + +Lemma rev_spec d : to_list (rev d) = List.rev (to_list d). +Proof. now unfold rev; rewrite revapp_spec, List.rev_alt; simpl. Qed. + +Lemma app_spec d d' : + to_list (app d d') = Datatypes.app (to_list d) (to_list d'). +Proof. + unfold app. + now rewrite revapp_spec, List.rev_append_rev, rev_spec, List.rev_involutive. +Qed. -Lemma revapp_revapp_1 d d' d'' : - nb_digits d <= 1 -> - revapp (revapp d d') d'' = revapp d' (revapp d d''). +Definition lnztail l := + let fix aux l_rev := + match l_rev with + | cons d0 l_rev => let (r, n) := aux l_rev in pair r (S n) + | _ => pair l_rev O + end in + let (r, n) := aux (List.rev l) in pair (List.rev r) n. + +Lemma nztail_spec d : + let (r, n) := nztail d in + let (r', n') := lnztail (to_list d) in + to_list r = r' /\ n = n'. Proof. - now case d; clear d; intro d; - [|case d; clear d; intro d; - [|simpl; case nb_digits; [|intros n]; intros Hn; exfalso; - [apply (Nat.nle_succ_diag_l _ Hn)| - apply (Nat.nle_succ_0 _ (le_S_n _ _ Hn))]..]..]. + unfold nztail, lnztail. + set (f := fix aux d_rev := match d_rev with + | D0 d_rev => let (r, n) := aux d_rev in (r, S n) + | _ => (d_rev, 0) end). + set (f' := fix aux (l_rev : list digits) : list digits * nat := + match l_rev with + | cons d0 l_rev => let (r, n) := aux l_rev in (r, S n) + | _ => (l_rev, 0) + end). + rewrite <-(of_list_to_list (rev d)), rev_spec. + induction (List.rev _) as [|h t IHl]; [now simpl|]. + case h; simpl; [|now rewrite rev_spec; simpl; rewrite to_list_of_list..]. + now revert IHl; case f; intros r n; case f'; intros r' n' [-> ->]. Qed. -Lemma nb_digits_pos d : d <> Nil -> 0 < nb_digits d. -Proof. now case d; [|intros d' _; apply Nat.lt_0_succ..]. Qed. +Lemma del_head_spec_0 d : del_head 0 d = d. +Proof. now simpl. Qed. -Lemma nb_digits_revapp d d' : - nb_digits (revapp d d') = nb_digits d + nb_digits d'. +Lemma del_head_spec_small n d : + n <= length (to_list d) -> to_list (del_head n d) = List.skipn n (to_list d). Proof. - now revert d'; induction d; [|intro d'; simpl; rewrite IHd; simpl..]. + revert d; induction n as [|n IHn]; intro d; [now simpl|]. + now case d; [|intros d' H; apply IHn, le_S_n..]. Qed. -Lemma nb_digits_rev u : nb_digits (rev u) = nb_digits u. -Proof. now unfold rev; rewrite nb_digits_revapp. Qed. +Lemma del_head_spec_large n d : length (to_list d) < n -> del_head n d = zero. +Proof. + revert d; induction n; intro d; [now case d|]. + now case d; [|intro d'; simpl; intro H; rewrite (IHn _ (lt_S_n _ _ H))..]. +Qed. -Lemma nb_digits_nzhead u : nb_digits (nzhead u) <= nb_digits u. -Proof. now induction u; [|apply le_S|..]. Qed. +Lemma nb_digits_0 d : nb_digits d = 0 -> d = Nil. +Proof. + rewrite nb_digits_spec, <-(of_list_to_list d). + now case (to_list d) as [|h t]; [|rewrite to_list_of_list]. +Qed. + +Lemma nb_digits_n0 d : nb_digits d <> 0 -> d <> Nil. +Proof. now case d; [|intros u _..]. Qed. Lemma nb_digits_iter_D0 n d : nb_digits (Nat.iter n D0 d) = n + nb_digits d. Proof. now induction n; simpl; [|rewrite IHn]. Qed. -Fixpoint nth n u := - match n with - | O => - match u with - | Nil => Nil - | D0 d => D0 Nil - | D1 d => D1 Nil - | D2 d => D2 Nil - | D3 d => D3 Nil - | D4 d => D4 Nil - | D5 d => D5 Nil - | D6 d => D6 Nil - | D7 d => D7 Nil - | D8 d => D8 Nil - | D9 d => D9 Nil - | Da d => Da Nil - | Db d => Db Nil - | Dc d => Dc Nil - | Dd d => Dd Nil - | De d => De Nil - | Df d => Df Nil - end - | S n => - match u with - | Nil => Nil - | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d - | Da d | Db d | Dc d | Dd d | De d | Df d => - nth n d - end - end. +Lemma length_lnzhead l : length (lnzhead l) <= length l. +Proof. now induction l as [|h t IHl]; [|case h; [apply le_S|..]]. Qed. + +Lemma nb_digits_nzhead u : nb_digits (nzhead u) <= nb_digits u. +Proof. now induction u; [|apply le_S|..]. Qed. -Lemma nb_digits_nth n u : nb_digits (nth n u) <= 1. -Proof. - revert u; induction n. - - now intro u; case u; [apply Nat.le_0_1|..]. - - intro u; case u; [apply Nat.le_0_1|intro u'; apply IHn..]. -Qed. - -Lemma nth_revapp_r n d d' : - nb_digits d <= n -> - nth n (revapp d d') = nth (n - nb_digits d) d'. -Proof. - revert d d'; induction n; intro d. - - now case d; intro d'; - [case d'|intros d'' H; exfalso; revert H; apply Nat.nle_succ_0..]. - - now induction d; - [intro d'; case d'| - intros d' H; - simpl revapp; rewrite IHd; [|now apply le_Sn_le]; - rewrite Nat.sub_succ_l; [|now apply le_S_n]; - simpl; rewrite <-(IHn _ _ (le_S_n _ _ H))..]. -Qed. - -Lemma nth_revapp_l n d d' : - n < nb_digits d -> - nth n (revapp d d') = nth (nb_digits d - n - 1) d. -Proof. - revert d d'; induction n; intro d. - - rewrite Nat.sub_0_r. - now induction d; - [|intros d' _; simpl revapp; - revert IHd; case d; clear d; [|intro d..]; intro IHd; - [|rewrite IHd; [simpl nb_digits; rewrite (Nat.sub_succ_l _ (S _))|]; - [|apply le_n_S, Nat.le_0_l..]..]..]. - - now induction d; - [|intros d' H; - simpl revapp; simpl nb_digits; - simpl in H; generalize (lt_S_n _ _ H); clear H; intro H; - case (le_lt_eq_dec _ _ H); clear H; intro H; - [rewrite (IHd _ H), Nat.sub_succ_l; - [rewrite Nat.sub_succ_l; [|apply Nat.le_add_le_sub_r]| - apply le_Sn_le]| - rewrite nth_revapp_r; rewrite <-H; - [rewrite Nat.sub_succ, Nat.sub_succ_l; [rewrite !Nat.sub_diag|]|]]..]. +Lemma unorm_nzhead u : nzhead u <> Nil -> unorm u = nzhead u. +Proof. now unfold unorm; case nzhead. Qed. + +Lemma nb_digits_unorm u : u <> Nil -> nb_digits (unorm u) <= nb_digits u. +Proof. + intro Hu; case (uint_eq_dec (nzhead u) Nil). + { unfold unorm; intros ->; simpl. + now revert Hu; case u; [|intros u' _; apply le_n_S, Nat.le_0_l..]. } + intro H; rewrite (unorm_nzhead _ H); apply nb_digits_nzhead. +Qed. + +Lemma nb_digits_rev d : nb_digits (rev d) = nb_digits d. +Proof. now rewrite !nb_digits_spec, rev_spec, List.rev_length. Qed. + +Lemma nb_digits_del_head_sub d n : + n <= nb_digits d -> + nb_digits (del_head (nb_digits d - n) d) = n. +Proof. + rewrite !nb_digits_spec; intro Hn. + rewrite del_head_spec_small; [|now apply Nat.le_sub_l]. + rewrite List.skipn_length, <-(Nat2Z.id (_ - _)). + rewrite Nat2Z.inj_sub; [|now apply Nat.le_sub_l]. + rewrite (Nat2Z.inj_sub _ _ Hn). + rewrite Z.sub_sub_distr, Z.sub_diag; apply Nat2Z.id. +Qed. + +Lemma unorm_D0 u : unorm (D0 u) = unorm u. +Proof. reflexivity. Qed. + +Lemma app_nil_l d : app Nil d = d. +Proof. now simpl. Qed. + +Lemma app_nil_r d : app d Nil = d. +Proof. now apply to_list_inj; rewrite app_spec, List.app_nil_r. Qed. + +Lemma abs_app_int d d' : abs (app_int d d') = app (abs d) d'. +Proof. now case d. Qed. + +Lemma abs_norm d : abs (norm d) = unorm (abs d). +Proof. now case d as [u|u]; [|simpl; unfold unorm; case nzhead]. Qed. + +Lemma iter_D0_nzhead d : + Nat.iter (nb_digits d - nb_digits (nzhead d)) D0 (nzhead d) = d. +Proof. + induction d; [now simpl| |now rewrite Nat.sub_diag..]. + simpl nzhead; simpl nb_digits. + rewrite (Nat.sub_succ_l _ _ (nb_digits_nzhead _)). + now rewrite <-IHd at 4. +Qed. + +Lemma iter_D0_unorm d : + d <> Nil -> + Nat.iter (nb_digits d - nb_digits (unorm d)) D0 (unorm d) = d. +Proof. + case (uint_eq_dec (nzhead d) Nil); intro Hn. + { unfold unorm; rewrite Hn; simpl; intro H. + revert H Hn; induction d; [now simpl|intros _|now intros _..]. + case (uint_eq_dec d Nil); simpl; intros H Hn; [now rewrite H|]. + rewrite Nat.sub_0_r, (le_plus_minus 1 (nb_digits d)). + { now simpl; rewrite IHd. } + revert H; case d; [now simpl|intros u _; apply le_n_S, Nat.le_0_l..]. } + intros _; rewrite (unorm_nzhead _ Hn); apply iter_D0_nzhead. +Qed. + +Lemma nzhead_app_l d d' : + nb_digits d' < nb_digits (nzhead (app d d')) -> + nzhead (app d d') = app (nzhead d) d'. +Proof. + intro Hl; apply to_list_inj; revert Hl. + rewrite !nb_digits_spec, app_spec, !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]. + { now simpl; intro H; exfalso; revert H; apply le_not_lt, length_lnzhead. } + rewrite <-List.app_comm_cons. + now case h; [simpl; intro Hl; apply IHl|..]. +Qed. + +Lemma nzhead_app_r d d' : + nb_digits (nzhead (app d d')) <= nb_digits d' -> + nzhead (app d d') = nzhead d'. +Proof. + intro Hl; apply to_list_inj; revert Hl. + rewrite !nb_digits_spec, !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]; [now simpl|]. + rewrite <-List.app_comm_cons. + now case h; [| simpl; rewrite List.app_length; intro Hl; exfalso; revert Hl; + apply le_not_lt, le_plus_r..]. +Qed. + +Lemma nzhead_app_nil_r d d' : nzhead (app d d') = Nil -> nzhead d' = Nil. +Proof. +now intro H; generalize H; rewrite nzhead_app_r; [|rewrite H; apply Nat.le_0_l]. +Qed. + +Lemma nzhead_app_nil d d' : + nb_digits (nzhead (app d d')) <= nb_digits d' -> nzhead d = Nil. +Proof. + intro H; apply to_list_inj; revert H. + rewrite !nb_digits_spec, !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]; [now simpl|]. + now case h; [now simpl|..]; + simpl;intro H; exfalso; revert H; apply le_not_lt; + rewrite List.app_length; apply le_plus_r. +Qed. + +Lemma nzhead_app_nil_l d d' : nzhead (app d d') = Nil -> nzhead d = Nil. +Proof. + intro H; apply to_list_inj; generalize (f_equal to_list H); clear H. + rewrite !nzhead_spec, app_spec. + induction (to_list d) as [|h t IHl]; [now simpl|]. + now rewrite <-List.app_comm_cons; case h. +Qed. + +Lemma unorm_app_zero d d' : + nb_digits (unorm (app d d')) <= nb_digits d' -> unorm d = zero. +Proof. + unfold unorm. + case (uint_eq_dec (nzhead (app d d')) Nil). + { now intro Hn; rewrite Hn, (nzhead_app_nil_l _ _ Hn). } + intro H; fold (unorm (app d d')); rewrite (unorm_nzhead _ H); intro H'. + case (uint_eq_dec (nzhead d) Nil); [now intros->|]. + intro H''; fold (unorm d); rewrite (unorm_nzhead _ H''). + exfalso; apply H''; revert H'; apply nzhead_app_nil. +Qed. + +Lemma app_int_nil_r d : app_int d Nil = d. +Proof. + now case d; intro d'; simpl; + rewrite <-(of_list_to_list (app _ _)), app_spec; + rewrite List.app_nil_r, of_list_to_list. +Qed. + +Lemma unorm_app_l d d' : + nb_digits d' < nb_digits (unorm (app d d')) -> + unorm (app d d') = app (unorm d) d'. +Proof. + case (uint_eq_dec d' Nil); [now intros->; rewrite !app_nil_r|intro Hd']. + case (uint_eq_dec (nzhead (app d d')) Nil). + { unfold unorm; intros->; simpl; intro H; exfalso; revert H; apply le_not_lt. + now revert Hd'; case d'; [|intros d'' _; apply le_n_S, Peano.le_0_n..]. } + intro Ha; rewrite (unorm_nzhead _ Ha). + intro Hn; generalize Hn; rewrite (nzhead_app_l _ _ Hn). + rewrite !nb_digits_spec, app_spec, List.app_length. + case (uint_eq_dec (nzhead d) Nil). + { intros->; simpl; intro H; exfalso; revert H; apply Nat.lt_irrefl. } + now intro H; rewrite (unorm_nzhead _ H). +Qed. + +Lemma unorm_app_r d d' : + nb_digits (unorm (app d d')) <= nb_digits d' -> + unorm (app d d') = unorm d'. +Proof. + case (uint_eq_dec (nzhead (app d d')) Nil). + { now unfold unorm; intro H; rewrite H, (nzhead_app_nil_r _ _ H). } + intro Ha; rewrite (unorm_nzhead _ Ha). + case (uint_eq_dec (nzhead d') Nil). + { now intros H H'; exfalso; apply Ha; rewrite nzhead_app_r. } + intro Hd'; rewrite (unorm_nzhead _ Hd'); apply nzhead_app_r. +Qed. + +Lemma norm_app_int d d' : + nb_digits d' < nb_digits (unorm (app (abs d) d')) -> + norm (app_int d d') = app_int (norm d) d'. +Proof. + case (uint_eq_dec d' Nil); [now intros->; rewrite !app_int_nil_r|intro Hd']. + case d as [d|d]; [now simpl; intro H; apply f_equal, unorm_app_l|]. + simpl; unfold unorm. + case (uint_eq_dec (nzhead (app d d')) Nil). + { intros->; simpl; intro H; exfalso; revert H; apply le_not_lt. + now revert Hd'; case d'; [|intros d'' _; apply le_n_S, Peano.le_0_n..]. } + set (m := match nzhead _ with Nil => _ | _ => _ end). + intro Ha. + replace m with (nzhead (app d d')). + 2:{ now unfold m; revert Ha; case nzhead. } + intro Hn; generalize Hn; rewrite (nzhead_app_l _ _ Hn). + case (uint_eq_dec (app (nzhead d) d') Nil). + { intros->; simpl; intro H; exfalso; revert H; apply le_not_lt, Nat.le_0_l. } + clear m; set (m := match app _ _ with Nil => _ | _ => _ end). + intro Ha'. + replace m with (Neg (app (nzhead d) d')); [|now unfold m; revert Ha'; case app]. + case (uint_eq_dec (nzhead d) Nil). + { intros->; simpl; intro H; exfalso; revert H; apply Nat.lt_irrefl. } + clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). + intro Hd. + now replace m with (Neg (nzhead d)); [|unfold m; revert Hd; case nzhead]. +Qed. + +Lemma del_head_nb_digits d : del_head (nb_digits d) d = Nil. +Proof. + apply to_list_inj. + rewrite nb_digits_spec, del_head_spec_small; [|now simpl]. + now rewrite List.skipn_all. +Qed. + +Lemma del_tail_nb_digits d : del_tail (nb_digits d) d = Nil. +Proof. now unfold del_tail; rewrite <-nb_digits_rev, del_head_nb_digits. Qed. + +Lemma del_head_app n d d' : + n <= nb_digits d -> del_head n (app d d') = app (del_head n d) d'. +Proof. + rewrite nb_digits_spec; intro Hn. + apply to_list_inj. + rewrite del_head_spec_small. + 2:{ now rewrite app_spec, List.app_length; apply le_plus_trans. } + rewrite !app_spec, (del_head_spec_small _ _ Hn). + rewrite List.skipn_app. + now rewrite (proj2 (Nat.sub_0_le _ _) Hn). +Qed. + +Lemma del_tail_app n d d' : + n <= nb_digits d' -> del_tail n (app d d') = app d (del_tail n d'). +Proof. + rewrite nb_digits_spec; intro Hn. + unfold del_tail. + rewrite <-(of_list_to_list (rev (app d d'))), rev_spec, app_spec. + rewrite List.rev_app_distr, <-!rev_spec, <-app_spec, of_list_to_list. + rewrite del_head_app; [|now rewrite nb_digits_spec, rev_spec, List.rev_length]. + apply to_list_inj. + rewrite rev_spec, !app_spec, !rev_spec. + now rewrite List.rev_app_distr, List.rev_involutive. +Qed. + +Lemma del_tail_app_int n d d' : + n <= nb_digits d' -> del_tail_int n (app_int d d') = app_int d (del_tail n d'). +Proof. now case d as [d|d]; simpl; intro H; rewrite del_tail_app. Qed. + +Lemma app_del_tail_head n (d:uint) : + n <= nb_digits d -> app (del_tail n d) (del_head (nb_digits d - n) d) = d. +Proof. + rewrite nb_digits_spec; intro Hn; unfold del_tail. + rewrite <-(of_list_to_list (app _ _)), app_spec, rev_spec. + rewrite del_head_spec_small; [|now rewrite rev_spec, List.rev_length]. + rewrite del_head_spec_small; [|now apply Nat.le_sub_l]. + rewrite rev_spec. + set (n' := _ - n). + assert (Hn' : n = length (to_list d) - n'). + { now apply plus_minus; rewrite Nat.add_comm; symmetry; apply le_plus_minus_r. } + now rewrite Hn', <-List.firstn_skipn_rev, List.firstn_skipn, of_list_to_list. +Qed. + +Lemma app_int_del_tail_head n (d:int) : + n <= nb_digits (abs d) -> + app_int (del_tail_int n d) (del_head (nb_digits (abs d) - n) (abs d)) = d. +Proof. now case d; clear d; simpl; intros u Hu; rewrite app_del_tail_head. Qed. + +Lemma del_head_app_int_exact i f : + nb_digits f < nb_digits (unorm (app (abs i) f)) -> + del_head (nb_digits (unorm (app (abs i) f)) - nb_digits f) (unorm (app (abs i) f)) = f. +Proof. + simpl; intro Hnb; generalize Hnb; rewrite (unorm_app_l _ _ Hnb); clear Hnb. + replace (_ - _) with (nb_digits (unorm (abs i))). + - now rewrite del_head_app; [rewrite del_head_nb_digits|]. + - rewrite !nb_digits_spec, app_spec, List.app_length. + now rewrite Nat.add_comm, minus_plus. +Qed. + +Lemma del_tail_app_int_exact i f : + nb_digits f < nb_digits (unorm (app (abs i) f)) -> + del_tail_int (nb_digits f) (norm (app_int i f)) = norm i. +Proof. + simpl; intro Hnb. + rewrite (norm_app_int _ _ Hnb). + rewrite del_tail_app_int; [|now simpl]. + now rewrite del_tail_nb_digits, app_int_nil_r. Qed. (** Normalization on little-endian numbers *) @@ -193,6 +494,9 @@ Proof. apply nzhead_revapp. Qed. +Lemma rev_rev d : rev (rev d) = d. +Proof. now apply to_list_inj; rewrite !rev_spec, List.rev_involutive. Qed. + Lemma rev_nztail_rev d : rev (nztail (rev d)) = nzhead d. Proof. @@ -247,47 +551,128 @@ Proof. unfold unorm. now destruct nzhead. Qed. -Lemma unorm_D0 u : unorm (D0 u) = unorm u. -Proof. reflexivity. Qed. - Lemma unorm_iter_D0 n u : unorm (Nat.iter n D0 u) = unorm u. Proof. now induction n. Qed. -Lemma nb_digits_unorm u : - u <> Nil -> nb_digits (unorm u) <= nb_digits u. +Lemma del_head_nonnil n u : + n < nb_digits u -> del_head n u <> Nil. Proof. - case u; clear u; [now simpl|intro u..]; [|now simpl..]. - intros _; unfold unorm. - case_eq (nzhead (D0 u)); [|now intros u' <-; apply nb_digits_nzhead..]. - intros _; apply le_n_S, Nat.le_0_l. + now revert n; induction u; intro n; + [|case n; [|intro n'; simpl; intro H; apply IHu, lt_S_n]..]. Qed. -Lemma nzhead_invol d : nzhead (nzhead d) = nzhead d. +Lemma del_tail_nonnil n u : + n < nb_digits u -> del_tail n u <> Nil. +Proof. + unfold del_tail. + rewrite <-nb_digits_rev. + generalize (rev u); clear u; intro u. + intros Hu H. + generalize (rev_nil_inv _ H); clear H. + now apply del_head_nonnil. +Qed. + +Lemma nzhead_involutive d : nzhead (nzhead d) = nzhead d. Proof. now induction d. Qed. +#[deprecated(since="8.13",note="Use nzhead_involutive instead.")] +Notation nzhead_invol := nzhead_involutive (only parsing). -Lemma nztail_invol d : nztail (nztail d) = nztail d. +Lemma nztail_involutive d : nztail (nztail d) = nztail d. Proof. rewrite <-(rev_rev (nztail _)), <-(rev_rev (nztail d)), <-(rev_rev d). - now rewrite !rev_nztail_rev, nzhead_invol. + now rewrite !rev_nztail_rev, nzhead_involutive. Qed. +#[deprecated(since="8.13",note="Use nztail_involutive instead.")] +Notation nztail_invol := nztail_involutive (only parsing). -Lemma unorm_invol d : unorm (unorm d) = unorm d. +Lemma unorm_involutive d : unorm (unorm d) = unorm d. Proof. unfold unorm. destruct (nzhead d) eqn:E; trivial. destruct (nzhead_nonzero _ _ E). Qed. +#[deprecated(since="8.13",note="Use unorm_involutive instead.")] +Notation unorm_invol := unorm_involutive (only parsing). -Lemma norm_invol d : norm (norm d) = norm d. +Lemma norm_involutive d : norm (norm d) = norm d. Proof. unfold norm. destruct d. - - f_equal. apply unorm_invol. + - f_equal. apply unorm_involutive. - destruct (nzhead d) eqn:E; auto. destruct (nzhead_nonzero _ _ E). Qed. +#[deprecated(since="8.13",note="Use norm_involutive instead.")] +Notation norm_invol := norm_involutive (only parsing). + +Lemma lnzhead_neq_d0_head l l' : ~(lnzhead l = cons d0 l'). +Proof. now induction l as [|h t Il]; [|case h]. Qed. + +Lemma lnzhead_head_nd0 h t : h <> d0 -> lnzhead (cons h t) = cons h t. +Proof. now case h. Qed. + +Lemma nzhead_del_tail_nzhead_eq n u : + nzhead u = u -> + n < nb_digits u -> + nzhead (del_tail n u) = del_tail n u. +Proof. + rewrite nb_digits_spec, <-List.rev_length. + intros Hu Hn. + apply to_list_inj; unfold del_tail. + rewrite nzhead_spec, rev_spec. + rewrite del_head_spec_small; [|now rewrite rev_spec; apply Nat.lt_le_incl]. + rewrite rev_spec. + rewrite List.skipn_rev, List.rev_involutive. + generalize (f_equal to_list Hu) Hn; rewrite nzhead_spec; intro Hu'. + case (to_list u) as [|h t]. + { simpl; intro H; exfalso; revert H; apply le_not_lt, Peano.le_0_n. } + intro Hn'; generalize (Nat.sub_gt _ _ Hn'); rewrite List.rev_length. + case (_ - _); [now simpl|]; intros n' _. + rewrite List.firstn_cons, lnzhead_head_nd0; [now simpl|]. + intro Hh; revert Hu'; rewrite Hh; apply lnzhead_neq_d0_head. +Qed. + +Lemma nzhead_del_tail_nzhead n u : + n < nb_digits (nzhead u) -> + nzhead (del_tail n (nzhead u)) = del_tail n (nzhead u). +Proof. apply nzhead_del_tail_nzhead_eq, nzhead_involutive. Qed. + +Lemma unorm_del_tail_unorm n u : + n < nb_digits (unorm u) -> + unorm (del_tail n (unorm u)) = del_tail n (unorm u). +Proof. + case (uint_eq_dec (nzhead u) Nil). + - unfold unorm; intros->; case n; [now simpl|]; intro n'. + now simpl; intro H; exfalso; generalize (lt_S_n _ _ H). + - unfold unorm. + set (m := match nzhead u with Nil => zero | _ => _ end). + intros H. + replace m with (nzhead u). + + intros H'. + rewrite (nzhead_del_tail_nzhead _ _ H'). + now generalize (del_tail_nonnil _ _ H'); case del_tail. + + now unfold m; revert H; case nzhead. +Qed. + +Lemma norm_del_tail_int_norm n d : + n < nb_digits (match norm d with Pos d | Neg d => d end) -> + norm (del_tail_int n (norm d)) = del_tail_int n (norm d). +Proof. + case d; clear d; intros u; simpl. + - now intro H; simpl; rewrite unorm_del_tail_unorm. + - case (uint_eq_dec (nzhead u) Nil); intro Hu. + + now rewrite Hu; case n; [|intros n' Hn'; generalize (lt_S_n _ _ Hn')]. + + set (m := match nzhead u with Nil => Pos zero | _ => _ end). + replace m with (Neg (nzhead u)); [|now unfold m; revert Hu; case nzhead]. + unfold del_tail_int. + clear m Hu. + simpl. + intro H; generalize (del_tail_nonnil _ _ H). + rewrite (nzhead_del_tail_nzhead _ _ H). + now case del_tail. +Qed. Lemma nzhead_app_nzhead d d' : nzhead (app (nzhead d) d') = nzhead (app d d'). @@ -299,7 +684,7 @@ Proof. generalize (nzhead_revapp d d'). generalize (nzhead_revapp_0 (nztail d) d'). generalize (nzhead_revapp (nztail d) d'). - rewrite nztail_invol. + rewrite nztail_involutive. now case nztail; [intros _ H _ H'; rewrite (H eq_refl), (H' eq_refl) |intros d'' H _ H' _; rewrite H; [rewrite H'|]..]. @@ -336,5 +721,5 @@ Proof. |rewrite H'; unfold r; clear m r H']; unfold norm; rewrite rev_rev, <-Hd''; - rewrite nzhead_revapp; rewrite nztail_invol; [|rewrite Hd'']..]. + rewrite nzhead_revapp; rewrite nztail_involutive; [|rewrite Hd'']..]. Qed. diff --git a/theories/Numbers/HexadecimalN.v b/theories/Numbers/HexadecimalN.v index f333e2b7f6..93ba82d14a 100644 --- a/theories/Numbers/HexadecimalN.v +++ b/theories/Numbers/HexadecimalN.v @@ -74,7 +74,7 @@ Proof. destruct (norm d) eqn:Hd; intros [= <-]. unfold N.to_hex_int. rewrite Unsigned.to_of. f_equal. revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_invol. + - intros [= <-]. apply unorm_involutive. - destruct (nzhead d); now intros [= <-]. Qed. @@ -93,7 +93,7 @@ Qed. Lemma of_int_norm d : N.of_hex_int (norm d) = N.of_hex_int d. Proof. - unfold N.of_hex_int. now rewrite norm_invol. + unfold N.of_hex_int. now rewrite norm_involutive. Qed. Lemma of_inj_pos d d' : diff --git a/theories/Numbers/HexadecimalNat.v b/theories/Numbers/HexadecimalNat.v index b05184e821..94a14b90bd 100644 --- a/theories/Numbers/HexadecimalNat.v +++ b/theories/Numbers/HexadecimalNat.v @@ -289,7 +289,7 @@ Proof. destruct (norm d) eqn:Hd; intros [= <-]. unfold Nat.to_hex_int. rewrite Unsigned.to_of. f_equal. revert Hd; destruct d; simpl. - - intros [= <-]. apply unorm_invol. + - intros [= <-]. apply unorm_involutive. - destruct (nzhead d); now intros [= <-]. Qed. @@ -308,7 +308,7 @@ Qed. Lemma of_int_norm d : Nat.of_hex_int (norm d) = Nat.of_hex_int d. Proof. - unfold Nat.of_hex_int. now rewrite norm_invol. + unfold Nat.of_hex_int. now rewrite norm_involutive. Qed. Lemma of_inj_pos d d' : diff --git a/theories/Numbers/HexadecimalQ.v b/theories/Numbers/HexadecimalQ.v index 9bf43ceb88..a32019767c 100644 --- a/theories/Numbers/HexadecimalQ.v +++ b/theories/Numbers/HexadecimalQ.v @@ -16,442 +16,412 @@ Require Import Decimal DecimalFacts DecimalPos DecimalN DecimalZ. Require Import Hexadecimal HexadecimalFacts HexadecimalPos HexadecimalN HexadecimalZ QArith. -Lemma of_to (q:Q) : forall d, to_hexadecimal q = Some d -> of_hexadecimal d = q. +Lemma of_IQmake_to_hexadecimal num den : + match IQmake_to_hexadecimal num den with + | None => True + | Some (HexadecimalExp _ _ _) => False + | Some (Hexadecimal i f) => of_hexadecimal (Hexadecimal i f) = IQmake (IZ_of_Z num) den + end. +Proof. + unfold IQmake_to_hexadecimal. + generalize (Unsigned.nztail_to_hex_uint den). + case Hexadecimal.nztail; intros den' e_den'. + case den'; [now simpl|now simpl| |now simpl..]; clear den'; intro den'. + case den'; [ |now simpl..]; clear den'. + case e_den' as [|e_den']; simpl; intro H; injection H; clear H; intros->. + { now unfold of_hexadecimal; simpl; rewrite app_int_nil_r, HexadecimalZ.of_to. } + replace (16 ^ _)%positive with (Nat.iter (S e_den') (Pos.mul 16) 1%positive). + 2:{ induction e_den' as [|n IHn]; [now simpl| ]. + now rewrite SuccNat2Pos.inj_succ, Pos.pow_succ_r, <-IHn. } + case Nat.ltb_spec; intro He_den'. + - unfold of_hexadecimal; simpl. + rewrite app_int_del_tail_head; [|now apply Nat.lt_le_incl]. + rewrite HexadecimalZ.of_to. + now rewrite nb_digits_del_head_sub; [|now apply Nat.lt_le_incl]. + - unfold of_hexadecimal; simpl. + rewrite nb_digits_iter_D0. + apply f_equal2. + + apply f_equal, HexadecimalZ.to_int_inj. + rewrite HexadecimalZ.to_of. + rewrite <-(HexadecimalZ.of_to num), HexadecimalZ.to_of. + case (Z.to_hex_int num); clear He_den' num; intro num; simpl. + * unfold app; simpl. + now rewrite unorm_D0, unorm_iter_D0, unorm_involutive. + * case (uint_eq_dec (nzhead num) Nil); [|intro Hn]. + { intros->; simpl; unfold app; simpl. + now rewrite unorm_D0, unorm_iter_D0. } + replace (match nzhead num with Nil => _ | _ => _ end) + with (Neg (nzhead num)); [|now revert Hn; case nzhead]. + simpl. + rewrite nzhead_iter_D0, nzhead_involutive. + now revert Hn; case nzhead. + + revert He_den'; case nb_digits as [|n]; [now simpl; rewrite Nat.add_0_r|]. + intro Hn. + rewrite Nat.add_succ_r, Nat.add_comm. + now rewrite <-le_plus_minus; [|apply le_S_n]. +Qed. + +Lemma IZ_of_Z_IZ_to_Z z z' : IZ_to_Z z = Some z' -> IZ_of_Z z' = z. +Proof. now case z as [| |p|p]; [|intro H; injection H; intros<-..]. Qed. + +Lemma of_IQmake_to_hexadecimal' num den : + match IQmake_to_hexadecimal' num den with + | None => True + | Some (HexadecimalExp _ _ _) => False + | Some (Hexadecimal i f) => of_hexadecimal (Hexadecimal i f) = IQmake num den + end. +Proof. + unfold IQmake_to_hexadecimal'. + case_eq (IZ_to_Z num); [intros num' Hnum'|now simpl]. + generalize (of_IQmake_to_hexadecimal num' den). + case IQmake_to_hexadecimal as [d|]; [|now simpl]. + case d as [i f|]; [|now simpl]. + now rewrite (IZ_of_Z_IZ_to_Z _ _ Hnum'). +Qed. + +Lemma of_to (q:IQ) : forall d, to_hexadecimal q = Some d -> of_hexadecimal d = q. Proof. - cut (match to_hexadecimal q with None => True | Some d => of_hexadecimal d = q end). - { now case to_hexadecimal; [intros d <- d' Hd'; injection Hd'; intros ->|]. } - destruct q as (num, den). - unfold to_hexadecimal; simpl Qnum; simpl Qden. - generalize (HexadecimalPos.Unsigned.nztail_to_hex_uint den). - case Hexadecimal.nztail; intros u n. - change 16%N with (2^4)%N; rewrite <-N.pow_mul_r. - change 4%N with (N.of_nat 4); rewrite <-Nnat.Nat2N.inj_mul. - change 4%Z with (Z.of_nat 4); rewrite <-Nat2Z.inj_mul. - case u; clear u; try (intros; exact I); [| | |]; intro u; - (case u; clear u; [|intros; exact I..]). - - unfold Pos.of_hex_uint, Pos.of_hex_uint_acc; rewrite N.mul_1_l. - case n. - + unfold of_hexadecimal, app_int, app, Z.to_hex_int; simpl. - intro H; inversion H as (H1); clear H H1. - case num; [reflexivity|intro pnum; fold (rev (rev (Pos.to_hex_uint pnum)))..]. - * rewrite rev_rev; simpl. - now unfold Z.of_hex_uint; rewrite HexadecimalPos.Unsigned.of_to. - * rewrite rev_rev; simpl. - now unfold Z.of_hex_uint; rewrite HexadecimalPos.Unsigned.of_to. - + clear n; intros n. - intro H; injection H; intros ->; clear H. - unfold of_hexadecimal. - rewrite DecimalZ.of_to. - simpl nb_digits; rewrite Nat2Z.inj_0, Z.mul_0_r, Z.sub_0_r. - now apply f_equal2; [rewrite app_int_nil_r, of_to|]. - - unfold Pos.of_hex_uint, Pos.of_hex_uint_acc. - rewrite <-N.pow_succ_r', <-Nnat.Nat2N.inj_succ. - intro H; injection H; intros ->; clear H. - fold (4 * n)%nat. - change 1%Z with (Z.of_nat 1); rewrite <-Znat.Nat2Z.inj_add. - unfold of_hexadecimal. - rewrite DecimalZ.of_to. - simpl nb_digits; rewrite Nat2Z.inj_0, Z.mul_0_r, Z.sub_0_r. - now apply f_equal2; [rewrite app_int_nil_r, of_to|]. - - change 2%Z with (Z.of_nat 2); rewrite <-Znat.Nat2Z.inj_add. - unfold Pos.of_hex_uint, Pos.of_hex_uint_acc. - change 4%N with (2^2)%N; rewrite <-N.pow_add_r. - change 2%N with (N.of_nat 2); rewrite <-Nnat.Nat2N.inj_add. - intro H; injection H; intros ->; clear H. - fold (4 * n)%nat. - unfold of_hexadecimal. - rewrite DecimalZ.of_to. - simpl nb_digits; rewrite Nat2Z.inj_0, Z.mul_0_r, Z.sub_0_r. - now apply f_equal2; [rewrite app_int_nil_r, of_to|]. - - change 3%Z with (Z.of_nat 3); rewrite <-Znat.Nat2Z.inj_add. - unfold Pos.of_hex_uint, Pos.of_hex_uint_acc. - change 8%N with (2^3)%N; rewrite <-N.pow_add_r. - change 3%N with (N.of_nat 3); rewrite <-Nnat.Nat2N.inj_add. - intro H; injection H; intros ->; clear H. - fold (4 * n)%nat. - unfold of_hexadecimal. - rewrite DecimalZ.of_to. - simpl nb_digits; rewrite Nat2Z.inj_0, Z.mul_0_r, Z.sub_0_r. - now apply f_equal2; [rewrite app_int_nil_r, of_to|]. + intro d. + case q as [num den|q q'|q q']; simpl. + - generalize (of_IQmake_to_hexadecimal' num den). + case IQmake_to_hexadecimal' as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + now intros H H'; injection H'; clear H'; intros <-. + - case q as [num den| |]; [|now simpl..]. + case q' as [num' den'| |]; [|now simpl..]. + case num' as [z p| | |]; [|now simpl..]. + case (Z.eq_dec z 2); [intros->|]. + 2:{ case z; [now simpl| |now simpl]; intro pz'. + case pz'; [intros d0..| ]; [now simpl| |now simpl]. + now case d0. } + case (Pos.eq_dec den' 1%positive); [intros->|now case den']. + generalize (of_IQmake_to_hexadecimal' num den). + case IQmake_to_hexadecimal' as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros <-; clear num den. + intros H; injection H; clear H; intros<-. + unfold of_hexadecimal; simpl. + now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. + - case q as [num den| |]; [|now simpl..]. + case q' as [num' den'| |]; [|now simpl..]. + case num' as [z p| | |]; [|now simpl..]. + case (Z.eq_dec z 2); [intros->|]. + 2:{ case z; [now simpl| |now simpl]; intro pz'. + case pz'; [intros d0..| ]; [now simpl| |now simpl]. + now case d0. } + case (Pos.eq_dec den' 1%positive); [intros->|now case den']. + generalize (of_IQmake_to_hexadecimal' num den). + case IQmake_to_hexadecimal' as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros <-; clear num den. + intros H; injection H; clear H; intros<-. + unfold of_hexadecimal; simpl. + now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. Qed. -(* normalize without fractional part, for instance norme 0x1.2p-1 is 0x12e-5 *) -Definition hnorme (d:hexadecimal) : hexadecimal := - let '(i, f, e) := - match d with - | Hexadecimal i f => (i, f, Decimal.Pos Decimal.Nil) - | HexadecimalExp i f e => (i, f, e) + +Definition dnorm (d:hexadecimal) : hexadecimal := + let norm_i i f := + match i with + | Pos i => Pos (unorm i) + | Neg i => match nzhead (app i f) with Nil => Pos zero | _ => Neg (unorm i) end end in - let i := norm (app_int i f) in - let e := (Z.of_int e - 4 * Z.of_nat (nb_digits f))%Z in - match e with - | Z0 => Hexadecimal i Nil - | Zpos e => Hexadecimal (Pos.iter double i e) Nil - | Zneg _ => HexadecimalExp i Nil (Decimal.norm (Z.to_int e)) + match d with + | Hexadecimal i f => Hexadecimal (norm_i i f) f + | HexadecimalExp i f e => + match Decimal.norm e with + | Decimal.Pos Decimal.zero => Hexadecimal (norm_i i f) f + | e => HexadecimalExp (norm_i i f) f e + end end. -Lemma hnorme_spec d : - match hnorme d with - | Hexadecimal i Nil => i = norm i - | HexadecimalExp i Nil e => - i = norm i /\ e = Decimal.norm e /\ e <> Decimal.Pos Decimal.zero - | _ => False +Lemma dnorm_spec_i d : + let (i, f) := + match d with Hexadecimal i f => (i, f) | HexadecimalExp i f _ => (i, f) end in + let i' := match dnorm d with Hexadecimal i _ => i | HexadecimalExp i _ _ => i end in + match i with + | Pos i => i' = Pos (unorm i) + | Neg i => + (i' = Neg (unorm i) /\ (nzhead i <> Nil \/ nzhead f <> Nil)) + \/ (i' = Pos zero /\ (nzhead i = Nil /\ nzhead f = Nil)) end. Proof. - case d; clear d; intros i f; [|intro e]; unfold hnorme; simpl. - - case_eq (nb_digits f); [now simpl; rewrite norm_invol|]; intros nf Hnf. - split; [now simpl; rewrite norm_invol|]. - unfold Z.of_nat. - now rewrite <-!DecimalZ.to_of, !DecimalZ.of_to. - - set (e' := (_ - _)%Z). - case_eq e'; [|intro pe'..]; intro He'. - + now rewrite norm_invol. - + rewrite Pos2Nat.inj_iter. - set (ne' := Pos.to_nat pe'). - fold (Nat.iter ne' double (norm (app_int i f))). - induction ne'; [now simpl; rewrite norm_invol|]. - now rewrite Unsigned.nat_iter_S, <-double_norm, IHne', norm_invol. - + split; [now rewrite norm_invol|]. - split; [now rewrite DecimalFacts.norm_invol|]. - rewrite <-DecimalZ.to_of, DecimalZ.of_to. - change (Decimal.Pos _) with (Z.to_int 0). - now intro H; generalize (DecimalZ.to_int_inj _ _ H). + case d as [i f|i f e]; case i as [i|i]. + - now simpl. + - simpl; case (uint_eq_dec (nzhead (app i f)) Nil); intro Ha. + + rewrite Ha; right; split; [now simpl|split]. + * now unfold unorm; rewrite (nzhead_app_nil_l _ _ Ha). + * now unfold unorm; rewrite (nzhead_app_nil_r _ _ Ha). + + left; split; [now revert Ha; case nzhead|]. + case (uint_eq_dec (nzhead i) Nil). + * intro Hi; right; intro Hf; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + * now intro H; left. + - simpl; case (Decimal.norm e); clear e; intro e; [|now simpl]. + now case e; clear e; [|intro e..]; [|case e|..]. + - simpl. + set (m := match nzhead _ with Nil => _ | _ => _ end). + set (m' := match _ with Hexadecimal _ _ => _ | _ => _ end). + replace m' with m. + 2:{ unfold m'; case (Decimal.norm e); clear m' e; intro e; [|now simpl]. + now case e; clear e; [|intro e..]; [|case e|..]. } + unfold m; case (uint_eq_dec (nzhead (app i f)) Nil); intro Ha. + + rewrite Ha; right; split; [now simpl|split]. + * now unfold unorm; rewrite (nzhead_app_nil_l _ _ Ha). + * now unfold unorm; rewrite (nzhead_app_nil_r _ _ Ha). + + left; split; [now revert Ha; case nzhead|]. + case (uint_eq_dec (nzhead i) Nil). + * intro Hi; right; intro Hf; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + * now intro H; left. Qed. -Lemma hnorme_invol d : hnorme (hnorme d) = hnorme d. +Lemma dnorm_spec_f d : + let f := match d with Hexadecimal _ f => f | HexadecimalExp _ f _ => f end in + let f' := match dnorm d with Hexadecimal _ f => f | HexadecimalExp _ f _ => f end in + f' = f. +Proof. + case d as [i f|i f e]; [now simpl|]. + simpl; case (Decimal.int_eq_dec (Decimal.norm e) (Decimal.Pos Decimal.zero)); [now intros->|intro He]. + set (i' := match i with Pos _ => _ | _ => _ end). + set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). + replace m with (HexadecimalExp i' f (Decimal.norm e)); [now simpl|]. + unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. +Qed. + +Lemma dnorm_spec_e d : + match d, dnorm d with + | Hexadecimal _ _, Hexadecimal _ _ => True + | HexadecimalExp _ _ e, Hexadecimal _ _ => + Decimal.norm e = Decimal.Pos Decimal.zero + | HexadecimalExp _ _ e, HexadecimalExp _ _ e' => + e' = Decimal.norm e /\ e' <> Decimal.Pos Decimal.zero + | Hexadecimal _ _, HexadecimalExp _ _ _ => False + end. Proof. - case d; clear d; intros i f; [|intro e]; unfold hnorme; simpl. - - case_eq (nb_digits f); [now simpl; rewrite app_int_nil_r, norm_invol|]. - intros nf Hnf. - unfold Z.of_nat. - simpl. - set (pnf := Pos.to_uint _). - set (nz := Decimal.nzhead pnf). - assert (Hnz : nz <> Decimal.Nil). - { unfold nz, pnf. - rewrite <-DecimalFacts.unorm_0. - rewrite <-DecimalPos.Unsigned.to_of. - rewrite DecimalPos.Unsigned.of_to. - change Decimal.zero with (N.to_uint 0). - now intro H; generalize (DecimalN.Unsigned.to_uint_inj _ _ H). } - set (m := match nz with Decimal.Nil => _ | _ => _ end). - assert (Hm : m = (Decimal.Neg (Decimal.unorm pnf))). - { now revert Hnz; unfold m, nz, Decimal.unorm; fold nz; case nz. } - rewrite Hm; unfold pnf. - rewrite <-DecimalPos.Unsigned.to_of, DecimalPos.Unsigned.of_to. - simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. - rewrite Z.sub_0_r; simpl. - fold pnf; fold nz; fold m; rewrite Hm; unfold pnf. - rewrite <-DecimalPos.Unsigned.to_of, DecimalPos.Unsigned.of_to. - now rewrite app_int_nil_r, norm_invol. - - set (e' := (_ - _)%Z). - case_eq e'; [|intro pe'..]; intro Hpe'. - + now simpl; rewrite app_int_nil_r, norm_invol. - + simpl; rewrite app_int_nil_r. - apply f_equal2; [|reflexivity]. - rewrite Pos2Nat.inj_iter. - set (ne' := Pos.to_nat pe'). - fold (Nat.iter ne' double (norm (app_int i f))). - induction ne'; [now simpl; rewrite norm_invol|]. - now rewrite Unsigned.nat_iter_S, <-double_norm, IHne'. - + rewrite <-DecimalZ.to_of, !DecimalZ.of_to; simpl. - rewrite app_int_nil_r, norm_invol. - set (pnf := Pos.to_uint _). - set (nz := Decimal.nzhead pnf). - assert (Hnz : nz <> Decimal.Nil). - { unfold nz, pnf. - rewrite <-DecimalFacts.unorm_0. - rewrite <-DecimalPos.Unsigned.to_of. - rewrite DecimalPos.Unsigned.of_to. - change Decimal.zero with (N.to_uint 0). - now intro H; generalize (DecimalN.Unsigned.to_uint_inj _ _ H). } - set (m := match nz with Decimal.Nil => _ | _ => _ end). - assert (Hm : m = (Decimal.Neg (Decimal.unorm pnf))). - { now revert Hnz; unfold m, nz, Decimal.unorm; fold nz; case nz. } - rewrite Hm; unfold pnf. - now rewrite <-DecimalPos.Unsigned.to_of, DecimalPos.Unsigned.of_to. + case d as [i f|i f e]; [now simpl|]. + simpl; case (Decimal.int_eq_dec (Decimal.norm e) (Decimal.Pos Decimal.zero)); [now intros->|intro He]. + set (i' := match i with Pos _ => _ | _ => _ end). + set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). + replace m with (HexadecimalExp i' f (Decimal.norm e)); [now simpl|]. + unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. Qed. -Lemma to_of (d:hexadecimal) : - to_hexadecimal (of_hexadecimal d) = Some (hnorme d). +Lemma dnorm_involutive d : dnorm (dnorm d) = dnorm d. Proof. - unfold to_hexadecimal. - pose (t10 := fun y => (y~0~0~0~0)%positive). - assert (H : exists h e_den, - Hexadecimal.nztail (Pos.to_hex_uint (Qden (of_hexadecimal d))) - = (h, e_den) - /\ (h = D1 Nil \/ h = D2 Nil \/ h = D4 Nil \/ h = D8 Nil)). - { assert (H : forall p, - Hexadecimal.nztail (Pos.to_hex_uint (Pos.iter (Pos.mul 2) 1%positive p)) - = ((match (Pos.to_nat p) mod 4 with 0%nat => D1 | 1 => D2 | 2 => D4 | _ => D8 end)%nat Nil, - (Pos.to_nat p / 4)%nat)). - { intro p; clear d; rewrite Pos2Nat.inj_iter. - fold (Nat.iter (Pos.to_nat p) (Pos.mul 2) 1%positive). - set (n := Pos.to_nat p). - fold (Nat.iter n t10 1%positive). - set (nm4 := (n mod 4)%nat); set (nd4 := (n / 4)%nat). - rewrite (Nat.div_mod n 4); [|now simpl]. - unfold nm4, nd4; clear nm4 nd4. - generalize (Nat.mod_upper_bound n 4 ltac:(now simpl)). - generalize (n mod 4); generalize (n / 4)%nat. - intros d r Hr; clear p n. - induction d. - { simpl; revert Hr. - do 4 (case r; [now simpl|clear r; intro r]). - intro H; exfalso. - now do 4 (generalize (lt_S_n _ _ H); clear H; intro H). } - rewrite Nat.mul_succ_r, <-Nat.add_assoc, (Nat.add_comm 4), Nat.add_assoc. - rewrite (Nat.add_comm _ 4). - change (4 + _)%nat with (S (S (S (S (4 * d + r))))). - rewrite !Unsigned.nat_iter_S. - rewrite !Pos.mul_assoc. - unfold Pos.to_hex_uint. - change (2 * 2 * 2 * 2)%positive with 0x10%positive. - set (n := Nat.iter _ _ _). - change (Pos.to_little_hex_uint _) with (Unsigned.to_lu (16 * N.pos n)). - rewrite Unsigned.to_lhex_tenfold. - unfold Hexadecimal.nztail; rewrite rev_rev. - rewrite <-(rev_rev (Unsigned.to_lu _)). - set (m := _ (rev _)). - replace m with (let (r, n) := let (r, n) := m in (rev r, n) in (rev r, n)). - 2:{ now case m; intros r' n'; rewrite rev_rev. } - change (let (r, n) := m in (rev r, n)) - with (Hexadecimal.nztail (Pos.to_hex_uint n)). - now unfold n; rewrite IHd, rev_rev; clear n m. } - unfold of_hexadecimal. - case d; intros i f; [|intro e]; unfold of_hexadecimal; simpl. - - case (Z.of_nat _)%Z; [|intro p..]; - [now exists (D1 Nil), O; split; [|left] - | |now exists (D1 Nil), O; split; [|left]]. - exists (D1 Nil), (Pos.to_nat p). - split; [|now left]; simpl. - change (Pos.iter _ _ _) with (Pos.iter (Pos.mul 2) 1%positive (4 * p)). - rewrite H. - rewrite Pos2Nat.inj_mul, Nat.mul_comm, Nat.div_mul; [|now simpl]. - now rewrite Nat.mod_mul; [|now simpl]. - - case (_ - _)%Z; [|intros p..]; [now exists (D1 Nil), O; split; [|left]..|]. - simpl Qden; rewrite H. - eexists; eexists; split; [reflexivity|]. - case (_ mod _); [now left|intro n]. - case n; [now right; left|clear n; intro n]. - case n; [now right; right; left|clear n; intro n]. - now right; right; right. } - generalize (HexadecimalPos.Unsigned.nztail_to_hex_uint (Qden (of_hexadecimal d))). - destruct H as (h, (e, (He, Hh))); rewrite He; clear He. - assert (Hn1 : forall p, N.pos (Pos.iter (Pos.mul 2) 1%positive p) = 1%N -> False). - { intro p. - rewrite Pos2Nat.inj_iter. - case_eq (Pos.to_nat p); [|now simpl]. - intro H; exfalso; apply (lt_irrefl O). - rewrite <-H at 2; apply Pos2Nat.is_pos. } - assert (H16_2 : forall p, (16^p = 2^(4 * p))%positive). - { intro p. - apply (@f_equal _ _ (fun z => match z with Z.pos p => p | _ => 1%positive end) - (Z.pos _) (Z.pos _)). - rewrite !Pos2Z.inj_pow_pos, !Z.pow_pos_fold, Pos2Z.inj_mul. - now change 16%Z with (2^4)%Z; rewrite <-Z.pow_mul_r. } - assert (HN16_2 : forall n, (16^n = 2^(4 * n))%N). - { intro n. - apply N2Z.inj; rewrite !N2Z.inj_pow, N2Z.inj_mul. - change (Z.of_N 16) with (2^4)%Z. - now rewrite <-Z.pow_mul_r; [| |apply N2Z.is_nonneg]. } - assert (Hn1' : forall p, N.pos (Pos.iter (Pos.mul 16) 1%positive p) = 1%N -> False). - { intro p; fold (16^p)%positive; rewrite H16_2; apply Hn1. } - assert (Ht10inj : forall n m, t10 n = t10 m -> n = m). - { intros n m H; generalize (f_equal Z.pos H); clear H. - change (Z.pos (t10 n)) with (Z.mul 0x10 (Z.pos n)). - change (Z.pos (t10 m)) with (Z.mul 0x10 (Z.pos m)). - rewrite Z.mul_comm, (Z.mul_comm 0x10). - intro H; generalize (f_equal (fun z => Z.div z 0x10) H); clear H. - now rewrite !Z.div_mul; [|now simpl..]; intro H; inversion H. } - assert (Ht2inj : forall n m, Pos.mul 2 n = Pos.mul 2 m -> n = m). - { intros n m H; generalize (f_equal Z.pos H); clear H. - change (Z.pos (Pos.mul 2 n)) with (Z.mul 2 (Z.pos n)). - change (Z.pos (Pos.mul 2 m)) with (Z.mul 2 (Z.pos m)). - rewrite Z.mul_comm, (Z.mul_comm 2). - intro H; generalize (f_equal (fun z => Z.div z 2) H); clear H. - now rewrite !Z.div_mul; [|now simpl..]; intro H; inversion H. } - assert (Hinj : forall n m, - Nat.iter n (Pos.mul 2) 1%positive = Nat.iter m (Pos.mul 2) 1%positive - -> n = m). - { induction n; [now intro m; case m|]. - intro m; case m; [now simpl|]; clear m; intro m. - rewrite !Unsigned.nat_iter_S. - intro H; generalize (Ht2inj _ _ H); clear H; intro H. - now rewrite (IHn _ H). } - change 4%Z with (Z.of_nat 4); rewrite <-Nat2Z.inj_mul. - change 1%Z with (Z.of_nat 1); rewrite <-Nat2Z.inj_add. - change 2%Z with (Z.of_nat 2); rewrite <-Nat2Z.inj_add. - change 3%Z with (Z.of_nat 3); rewrite <-Nat2Z.inj_add. - destruct Hh as [Hh|[Hh|[Hh|Hh]]]; rewrite Hh; clear h Hh. - - case e; clear e; [|intro e]; simpl; unfold of_hexadecimal, hnorme. - + case d; clear d; intros i f; [|intro e]. - * generalize (nb_digits_pos f). - case f; - [|now clear f; intro f; intros H1 H2; exfalso; revert H1 H2; - case nb_digits; - [intros H _; apply (lt_irrefl O), H|intros n _; apply Hn1]..]. - now intros _ _; simpl; rewrite to_of. - * rewrite <-DecimalZ.to_of, DecimalZ.of_to. - set (emf := (_ - _)%Z). - case_eq emf; [|intro pemf..]. - ++ now simpl; rewrite to_of. - ++ intros Hemf _; simpl. - apply f_equal, f_equal2; [|reflexivity]. - rewrite !Pos2Nat.inj_iter. - fold (Nat.iter (Pos.to_nat pemf) (Z.mul 2) (Z.of_hex_int (app_int i f))). - fold (Nat.iter (Pos.to_nat pemf) double (norm (app_int i f))). - induction Pos.to_nat; [now simpl; rewrite HexadecimalZ.to_of|]. - now rewrite !Unsigned.nat_iter_S, <-IHn, double_to_hex_int. - ++ simpl Qden; intros _ H; exfalso; revert H; apply Hn1. - + case d; clear d; intros i f; [|intro e']. - * simpl; case_eq (nb_digits f); [|intros nf' Hnf']; - [now simpl; intros _ H; exfalso; symmetry in H; revert H; apply Hn1'|]. - unfold Z.of_nat, Z.opp, Qnum, Qden. - rewrite H16_2. - fold (Pos.mul 2); fold (2^(Pos.of_succ_nat nf')~0~0)%positive. - intro H; injection H; clear H. - unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H; intro H; injection H. - clear H; intro H; generalize (SuccNat2Pos.inj _ _ H); clear H. - intros <-. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite SuccNat2Pos.id_succ. - change (_~0)%positive with (4 * Pos.of_succ_nat nf')%positive. - now rewrite Pos2Nat.inj_mul, SuccNat2Pos.id_succ. - * set (nemf := (_ - _)%Z); intro H. - assert (H' : exists pnemf, nemf = Z.neg pnemf); [|revert H]. - { revert H; case nemf; [|intro pnemf..]; [..|now intros _; exists pnemf]; - simpl Qden; intro H; exfalso; symmetry in H; revert H; apply Hn1'. } - destruct H' as (pnemf,Hpnemf); rewrite Hpnemf. - unfold Qnum, Qden. - rewrite H16_2. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H. - intro H; revert Hpnemf; rewrite H; clear pnemf H; intro Hnemf. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite SuccNat2Pos.id_succ. - change (_~0)%positive with (4 * Pos.of_succ_nat e)%positive. - now rewrite Pos2Nat.inj_mul, SuccNat2Pos.id_succ. - - simpl Pos.of_hex_uint. - rewrite HN16_2. - rewrite <-N.pow_succ_r; [|now apply N.le_0_l]. - rewrite <-N.succ_pos_spec. - case d; clear d; intros i f; [|intro e']; unfold of_hexadecimal, hnorme. - + set (em4f := (_ - _)%Z). - case_eq em4f; [|intros pem4f..]; intro Hpem4f; - [now simpl; intros H; exfalso; symmetry in H; revert H; apply Hn1..|]. - unfold Qnum, Qden. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H; intros ->. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite SuccNat2Pos.id_succ. - case e; [now simpl|intro e'']; simpl. - unfold Pos.to_nat; simpl. - now rewrite Pmult_nat_mult, SuccNat2Pos.id_succ, Nat.mul_comm. - + set (em4f := (_ - _)%Z). - case_eq em4f; [|intros pem4f..]; intro Hpem4f; - [now simpl; intros H; exfalso; symmetry in H; revert H; apply Hn1..|]. - unfold Qnum, Qden. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H; intros ->. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite SuccNat2Pos.id_succ. - case e; [now simpl|intro e'']; simpl. - unfold Pos.to_nat; simpl. - now rewrite Pmult_nat_mult, SuccNat2Pos.id_succ, Nat.mul_comm. - - simpl Pos.of_hex_uint. - rewrite HN16_2. - change 4%N with (2 * 2)%N at 1; rewrite <-!N.mul_assoc. - do 2 (rewrite <-N.pow_succ_r; [|now apply N.le_0_l]). - rewrite <-N.succ_pos_spec. - case d; clear d; intros i f; [|intro e']; unfold of_hexadecimal, hnorme. - + set (em4f := (_ - _)%Z). - case_eq em4f; [|intros pem4f..]; intro Hpem4f; - [now simpl; intros H; exfalso; symmetry in H; revert H; apply Hn1..|]. - unfold Qnum, Qden. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H; intros ->. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite <-SuccNat2Pos.inj_succ. - rewrite SuccNat2Pos.id_succ. - case e; [now simpl|intro e'']; simpl. - unfold Pos.to_nat; simpl. - now rewrite Pmult_nat_mult, SuccNat2Pos.id_succ, Nat.mul_comm. - + set (em4f := (_ - _)%Z). - case_eq em4f; [|intros pem4f..]; intro Hpem4f; - [now simpl; intros H; exfalso; symmetry in H; revert H; apply Hn1..|]. - unfold Qnum, Qden. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H; intros ->. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite <-SuccNat2Pos.inj_succ. - rewrite SuccNat2Pos.id_succ. - case e; [now simpl|intro e'']; simpl. - unfold Pos.to_nat; simpl. - now rewrite Pmult_nat_mult, SuccNat2Pos.id_succ, Nat.mul_comm. - - simpl Pos.of_hex_uint. - rewrite HN16_2. - change 8%N with (2 * 2 * 2)%N; rewrite <-!N.mul_assoc. - do 3 (rewrite <-N.pow_succ_r; [|now apply N.le_0_l]). - rewrite <-N.succ_pos_spec. - case d; clear d; intros i f; [|intro e']; unfold of_hexadecimal, hnorme. - + set (em4f := (_ - _)%Z). - case_eq em4f; [|intros pem4f..]; intro Hpem4f; - [now simpl; intros H; exfalso; symmetry in H; revert H; apply Hn1..|]. - unfold Qnum, Qden. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H; intros ->. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite <-!SuccNat2Pos.inj_succ. - rewrite SuccNat2Pos.id_succ. - case e; [now simpl|intro e'']; simpl. - unfold Pos.to_nat; simpl. - now rewrite Pmult_nat_mult, SuccNat2Pos.id_succ, Nat.mul_comm. - + set (em4f := (_ - _)%Z). - case_eq em4f; [|intros pem4f..]; intro Hpem4f; - [now simpl; intros H; exfalso; symmetry in H; revert H; apply Hn1..|]. - unfold Qnum, Qden. - intro H; injection H; clear H; unfold Pos.pow; rewrite !Pos2Nat.inj_iter. - intro H; generalize (Hinj _ _ H); clear H; intro H. - generalize (Pos2Nat.inj _ _ H); clear H; intros ->. - rewrite to_of. - rewrite <-DecimalZ.to_of, DecimalZ.of_to; simpl. - do 4 apply f_equal. - apply Pos2Nat.inj. - rewrite <-!SuccNat2Pos.inj_succ. - rewrite SuccNat2Pos.id_succ. - case e; [now simpl|intro e'']; simpl. - unfold Pos.to_nat; simpl. - now rewrite Pmult_nat_mult, SuccNat2Pos.id_succ, Nat.mul_comm. + case d as [i f|i f e]; case i as [i|i]. + - now simpl; rewrite unorm_involutive. + - simpl; case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. + set (m := match nzhead _ with Nil =>_ | _ => _ end). + replace m with (Neg (unorm i)). + 2:{ now unfold m; revert Ha; case nzhead. } + case (uint_eq_dec (nzhead i) Nil); intro Hi. + + unfold unorm; rewrite Hi; simpl. + case (uint_eq_dec (nzhead f) Nil). + * intro Hf; exfalso; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + * now case nzhead. + + rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. + now revert Ha; case nzhead. + - simpl; case (Decimal.int_eq_dec (Decimal.norm e) (Decimal.Pos Decimal.zero)); intro He. + + now rewrite He; simpl; rewrite unorm_involutive. + + set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). + replace m with (HexadecimalExp (Pos (unorm i)) f (Decimal.norm e)). + 2:{ unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. } + simpl; rewrite DecimalFacts.norm_involutive, unorm_involutive. + revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. + - simpl; case (Decimal.int_eq_dec (Decimal.norm e) (Decimal.Pos Decimal.zero)); intro He. + + rewrite He; simpl. + case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. + set (m := match nzhead _ with Nil =>_ | _ => _ end). + replace m with (Neg (unorm i)). + 2:{ now unfold m; revert Ha; case nzhead. } + case (uint_eq_dec (nzhead i) Nil); intro Hi. + * unfold unorm; rewrite Hi; simpl. + case (uint_eq_dec (nzhead f) Nil). + -- intro Hf; exfalso; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + -- now case nzhead. + * rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. + now revert Ha; case nzhead. + + set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). + pose (i' := match nzhead (app i f) with Nil => Pos zero | _ => Neg (unorm i) end). + replace m with (HexadecimalExp i' f (Decimal.norm e)). + 2:{ unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. } + simpl; rewrite DecimalFacts.norm_involutive. + set (i'' := match i' with Pos _ => _ | _ => _ end). + clear m; set (m := match Decimal.norm e with Decimal.Pos _ => _ | _ => _ end). + replace m with (HexadecimalExp i'' f (Decimal.norm e)). + 2:{ unfold m; revert He; case (Decimal.norm e); clear m e; intro e; [|now simpl]. + now case e; clear e; [|intro e; case e|..]. } + unfold i'', i'. + case (uint_eq_dec (nzhead (app i f)) Nil); [now intros->|intro Ha]. + fold i'; replace i' with (Neg (unorm i)). + 2:{ now unfold i'; revert Ha; case nzhead. } + case (uint_eq_dec (nzhead i) Nil); intro Hi. + * unfold unorm; rewrite Hi; simpl. + case (uint_eq_dec (nzhead f) Nil). + -- intro Hf; exfalso; apply Ha. + now rewrite <-nzhead_app_nzhead, Hi, app_nil_l. + -- now case nzhead. + * rewrite unorm_involutive, (unorm_nzhead _ Hi), nzhead_app_nzhead. + now revert Ha; case nzhead. +Qed. + +Lemma IZ_to_Z_IZ_of_Z z : IZ_to_Z (IZ_of_Z z) = Some z. +Proof. now case z. Qed. + +Lemma dnorm_i_exact i f : + (nb_digits f < nb_digits (unorm (app (abs i) f)))%nat -> + match i with + | Pos i => Pos (unorm i) + | Neg i => + match nzhead (app i f) with + | Nil => Pos zero + | _ => Neg (unorm i) + end + end = norm i. +Proof. + case i as [ni|ni]; [now simpl|]; simpl. + case (uint_eq_dec (nzhead (app ni f)) Nil); intro Ha. + { now rewrite Ha, (nzhead_app_nil_l _ _ Ha). } + rewrite (unorm_nzhead _ Ha). + set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (Neg (unorm ni)); [|now unfold m; revert Ha; case nzhead]. + case (uint_eq_dec (nzhead ni) Nil); intro Hni. + { rewrite <-nzhead_app_nzhead, Hni, app_nil_l. + intro H; exfalso; revert H; apply le_not_lt, nb_digits_nzhead. } + clear m; set (m := match nzhead ni with Nil => _ | _ => _ end). + replace m with (Neg (nzhead ni)); [|now unfold m; revert Hni; case nzhead]. + now rewrite (unorm_nzhead _ Hni). +Qed. + +Lemma dnorm_i_exact' i f : + (nb_digits (unorm (app (abs i) f)) <= nb_digits f)%nat -> + match i with + | Pos i => Pos (unorm i) + | Neg i => + match nzhead (app i f) with + | Nil => Pos zero + | _ => Neg (unorm i) + end + end = + match norm (app_int i f) with + | Pos _ => Pos zero + | Neg _ => Neg zero + end. +Proof. + case i as [ni|ni]; simpl. + { now intro Hnb; rewrite (unorm_app_zero _ _ Hnb). } + unfold unorm. + case (uint_eq_dec (nzhead (app ni f)) Nil); intro Hn. + { now rewrite Hn. } + set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (nzhead (app ni f)). + 2:{ now unfold m; revert Hn; case nzhead. } + clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (Neg (unorm ni)). + 2:{ now unfold m, unorm; revert Hn; case nzhead. } + clear m; set (m := match nzhead _ with Nil => _ | _ => _ end). + replace m with (Neg (nzhead (app ni f))). + 2:{ now unfold m; revert Hn; case nzhead. } + rewrite <-(unorm_nzhead _ Hn). + now intro H; rewrite (unorm_app_zero _ _ H). +Qed. + +Lemma to_of (d:hexadecimal) : to_hexadecimal (of_hexadecimal d) = Some (dnorm d). +Proof. + case d as [i f|i f e]. + - unfold of_hexadecimal; simpl; unfold IQmake_to_hexadecimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_hexadecimal; simpl. + change (fun _ : positive => _) with (Pos.mul 16). + rewrite nztail_to_hex_uint_pow16, to_of. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + + rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + + rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + * rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + * rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. + - unfold of_hexadecimal; simpl. + rewrite <-DecimalZ.to_of. + case (Z.of_int e); clear e; [|intro e..]; simpl. + + unfold IQmake_to_hexadecimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_hexadecimal; simpl. + change (fun _ : positive => _) with (Pos.mul 16). + rewrite nztail_to_hex_uint_pow16, to_of. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + * rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + -- rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + -- rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. + + unfold IQmake_to_hexadecimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_hexadecimal; simpl. + change (fun _ : positive => _) with (Pos.mul 16). + rewrite nztail_to_hex_uint_pow16, to_of. + generalize (DecimalPos.Unsigned.to_uint_nonzero e); intro He. + set (dnorm_i := match i with Pos _ => _ | _ => _ end). + set (m := match Pos.to_uint e with Decimal.Nil => _ | _ => _ end). + replace m with (HexadecimalExp dnorm_i f (Decimal.Pos (Pos.to_uint e))). + 2:{ now unfold m; revert He; case (Pos.to_uint e); [|intro u; case u|..]. } + clear m; unfold dnorm_i. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + * rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + -- rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + -- rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. + + unfold IQmake_to_hexadecimal'. + rewrite IZ_to_Z_IZ_of_Z. + unfold IQmake_to_hexadecimal; simpl. + change (fun _ : positive => _) with (Pos.mul 16). + rewrite nztail_to_hex_uint_pow16, to_of. + case_eq (nb_digits f); [|intro nb]; intro Hnb. + * rewrite (nb_digits_0 _ Hnb), app_int_nil_r. + case i as [ni|ni]; [now simpl|]. + rewrite app_nil_r; simpl; unfold unorm. + now case (nzhead ni). + * rewrite <-Hnb. + rewrite abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnb'. + -- rewrite (del_tail_app_int_exact _ _ Hnb'). + rewrite (del_head_app_int_exact _ _ Hnb'). + now rewrite (dnorm_i_exact _ _ Hnb'). + -- rewrite (unorm_app_r _ _ Hnb'). + rewrite iter_D0_unorm; [|now apply nb_digits_n0; rewrite Hnb]. + now rewrite dnorm_i_exact'. Qed. (** Some consequences *) @@ -466,68 +436,24 @@ Proof. now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). Qed. -Lemma to_hexadecimal_surj d : exists q, to_hexadecimal q = Some (hnorme d). +Lemma to_hexadecimal_surj d : exists q, to_hexadecimal q = Some (dnorm d). Proof. exists (of_hexadecimal d). apply to_of. Qed. -Lemma of_hexadecimal_hnorme d : of_hexadecimal (hnorme d) = of_hexadecimal d. -Proof. - unfold of_hexadecimal, hnorme. - destruct d. - - simpl Z.of_int; unfold Z.of_uint, Z.of_N, Pos.of_uint. - rewrite Z.sub_0_l. - set (n4f := (- _)%Z). - case_eq n4f; [|intro pn4f..]; intro Hn4f. - + apply f_equal2; [|reflexivity]. - rewrite app_int_nil_r. - now rewrite <-HexadecimalZ.to_of, HexadecimalZ.of_to. - + apply f_equal2; [|reflexivity]. - rewrite app_int_nil_r. - generalize (app_int i f); intro i'. - rewrite !Pos2Nat.inj_iter. - generalize (Pos.to_nat pn4f); intro n. - fold (Nat.iter n double (norm i')). - fold (Nat.iter n (Z.mul 2) (Z.of_hex_int i')). - induction n; [now simpl; rewrite <-HexadecimalZ.to_of, HexadecimalZ.of_to|]. - now rewrite !Unsigned.nat_iter_S, <-IHn, of_hex_int_double. - + unfold nb_digits, Z.of_nat. - rewrite Z.mul_0_r, Z.sub_0_r. - rewrite <-DecimalZ.to_of, !DecimalZ.of_to. - rewrite app_int_nil_r. - now rewrite <-HexadecimalZ.to_of, HexadecimalZ.of_to. - - set (nem4f := (_ - _)%Z). - case_eq nem4f; [|intro pnem4f..]; intro Hnem4f. - + apply f_equal2; [|reflexivity]. - rewrite app_int_nil_r. - now rewrite <-HexadecimalZ.to_of, HexadecimalZ.of_to. - + apply f_equal2; [|reflexivity]. - rewrite app_int_nil_r. - generalize (app_int i f); intro i'. - rewrite !Pos2Nat.inj_iter. - generalize (Pos.to_nat pnem4f); intro n. - fold (Nat.iter n double (norm i')). - fold (Nat.iter n (Z.mul 2) (Z.of_hex_int i')). - induction n; [now simpl; rewrite <-HexadecimalZ.to_of, HexadecimalZ.of_to|]. - now rewrite !Unsigned.nat_iter_S, <-IHn, of_hex_int_double. - + unfold nb_digits, Z.of_nat. - rewrite Z.mul_0_r, Z.sub_0_r. - rewrite <-DecimalZ.to_of, !DecimalZ.of_to. - rewrite app_int_nil_r. - now rewrite <-HexadecimalZ.to_of, HexadecimalZ.of_to. -Qed. +Lemma of_hexadecimal_dnorm d : of_hexadecimal (dnorm d) = of_hexadecimal d. +Proof. now apply to_hexadecimal_inj; rewrite !to_of; [|rewrite dnorm_involutive]. Qed. -Lemma of_inj d d' : - of_hexadecimal d = of_hexadecimal d' -> hnorme d = hnorme d'. +Lemma of_inj d d' : of_hexadecimal d = of_hexadecimal d' -> dnorm d = dnorm d'. Proof. - intros. - cut (Some (hnorme d) = Some (hnorme d')); [now intro H'; injection H'|]. - rewrite <- !to_of. now f_equal. + intro H. + apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) + (Some (dnorm d)) (Some (dnorm d'))). + now rewrite <- !to_of, H. Qed. -Lemma of_iff d d' : - of_hexadecimal d = of_hexadecimal d' <-> hnorme d = hnorme d'. +Lemma of_iff d d' : of_hexadecimal d = of_hexadecimal d' <-> dnorm d = dnorm d'. Proof. - split. apply of_inj. intros E. rewrite <- of_hexadecimal_hnorme, E. - apply of_hexadecimal_hnorme. + split. apply of_inj. intros E. rewrite <- of_hexadecimal_dnorm, E. + apply of_hexadecimal_dnorm. Qed. diff --git a/theories/Numbers/HexadecimalR.v b/theories/Numbers/HexadecimalR.v new file mode 100644 index 0000000000..2deecc5847 --- /dev/null +++ b/theories/Numbers/HexadecimalR.v @@ -0,0 +1,302 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** * HexadecimalR + + Proofs that conversions between hexadecimal numbers and [R] + are bijections. *) + +Require Import Decimal DecimalFacts. +Require Import Hexadecimal HexadecimalFacts HexadecimalPos HexadecimalZ. +Require Import HexadecimalQ Rdefinitions. + +Lemma of_IQmake_to_hexadecimal num den : + match IQmake_to_hexadecimal num den with + | None => True + | Some (HexadecimalExp _ _ _) => False + | Some (Hexadecimal i f) => + of_hexadecimal (Hexadecimal i f) = IRQ (QArith_base.Qmake num den) + end. +Proof. + unfold IQmake_to_hexadecimal. + case (Pos.eq_dec den 1); [now intros->|intro Hden]. + assert (Hf : match QArith_base.IQmake_to_hexadecimal num den with + | Some (Hexadecimal i f) => f <> Nil + | _ => True + end). + { unfold QArith_base.IQmake_to_hexadecimal; simpl. + generalize (Unsigned.nztail_to_hex_uint den). + case Hexadecimal.nztail as [den' e_den']. + case den'; [now simpl|now simpl| |now simpl..]; clear den'; intro den'. + case den'; [ |now simpl..]; clear den'. + case e_den' as [|e_den']; [now simpl; intros H _; apply Hden; injection H|]. + intros _. + case Nat.ltb_spec; intro He_den'. + - apply del_head_nonnil. + revert He_den'; case nb_digits as [|n]; [now simpl|]. + now intro H; simpl; apply le_lt_n_Sm, Nat.le_sub_l. + - apply nb_digits_n0. + now rewrite nb_digits_iter_D0, Nat.sub_add. } + replace (match den with 1%positive => _ | _ => _ end) + with (QArith_base.IQmake_to_hexadecimal num den); [|now revert Hden; case den]. + generalize (of_IQmake_to_hexadecimal num den). + case QArith_base.IQmake_to_hexadecimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + unfold of_hexadecimal; simpl. + intro H; injection H; clear H; intros <-. + intro H; generalize (f_equal QArith_base.IZ_to_Z H); clear H. + rewrite !IZ_to_Z_IZ_of_Z; intro H; injection H; clear H; intros<-. + now revert Hf; case f. +Qed. + +Lemma of_to (q:IR) : forall d, to_hexadecimal q = Some d -> of_hexadecimal d = q. +Proof. + intro d. + case q as [z|q|r r'|r r']; simpl. + - case z as [z p| |p|p]. + + now simpl. + + now simpl; intro H; injection H; clear H; intros<-. + + simpl; intro H; injection H; clear H; intros<-. + now unfold of_hexadecimal; simpl; unfold Z.of_hex_uint; rewrite Unsigned.of_to. + + simpl; intro H; injection H; clear H; intros<-. + now unfold of_hexadecimal; simpl; unfold Z.of_hex_uint; rewrite Unsigned.of_to. + - case q as [num den]. + generalize (of_IQmake_to_hexadecimal num den). + case IQmake_to_hexadecimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + now intros H H'; injection H'; intros<-. + - case r as [z|q| |]; [|case q as[num den]|now simpl..]; + (case r' as [z'| | |]; [|now simpl..]); + (case z' as [p e| | |]; [|now simpl..]). + + case (Z.eq_dec p 2); [intros->|intro Hp]. + 2:{ now revert Hp; case p; + [|intro d0; case d0; [intro d1..|]; [|case d1|]..]. } + case z as [| |p|p]; [now simpl|..]; intro H; injection H; intros<-. + * now unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. + * unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. + now unfold Z.of_hex_uint; rewrite Unsigned.of_to. + * unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. + now unfold Z.of_hex_uint; rewrite Unsigned.of_to. + + case (Z.eq_dec p 2); [intros->|intro Hp]. + 2:{ now revert Hp; case p; + [|intro d0; case d0; [intro d1..|]; [|case d1|]..]. } + generalize (of_IQmake_to_hexadecimal num den). + case IQmake_to_hexadecimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros H H'; injection H'; clear H'; intros<-. + unfold of_hexadecimal; simpl. + change (match f with Nil => _ | _ => _ end) with (of_hexadecimal (Hexadecimal i f)). + rewrite H; clear H. + now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. + - case r as [z|q| |]; [|case q as[num den]|now simpl..]; + (case r' as [z'| | |]; [|now simpl..]); + (case z' as [p e| | |]; [|now simpl..]). + + case (Z.eq_dec p 2); [intros->|intro Hp]. + 2:{ now revert Hp; case p; + [|intro d0; case d0; [intro d1..|]; [|case d1|]..]. } + case z as [| |p|p]; [now simpl|..]; intro H; injection H; intros<-. + * now unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. + * unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. + now unfold Z.of_hex_uint; rewrite Unsigned.of_to. + * unfold of_hexadecimal; simpl; unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to; simpl. + now unfold Z.of_hex_uint; rewrite Unsigned.of_to. + + case (Z.eq_dec p 2); [intros->|intro Hp]. + 2:{ now revert Hp; case p; + [|intro d0; case d0; [intro d1..|]; [|case d1|]..]. } + generalize (of_IQmake_to_hexadecimal num den). + case IQmake_to_hexadecimal as [d'|]; [|now simpl]. + case d' as [i f|]; [|now simpl]. + intros H H'; injection H'; clear H'; intros<-. + unfold of_hexadecimal; simpl. + change (match f with Nil => _ | _ => _ end) with (of_hexadecimal (Hexadecimal i f)). + rewrite H; clear H. + now unfold Z.of_uint; rewrite DecimalPos.Unsigned.of_to. +Qed. + +Lemma to_of (d:hexadecimal) : to_hexadecimal (of_hexadecimal d) = Some (dnorm d). +Proof. + case d as [i f|i f e]. + - unfold of_hexadecimal; simpl. + case (uint_eq_dec f Nil); intro Hf. + + rewrite Hf; clear f Hf. + unfold to_hexadecimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, HexadecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + + set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_hexadecimal; simpl. + unfold IQmake_to_hexadecimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_hexadecimal (Z.of_hex_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_hexadecimal, n; simpl. + rewrite nztail_to_hex_uint_pow16. + clear r; set (r := if _ <? _ then Some (Hexadecimal _ _) else Some _). + clear m; set (m := match nb_digits f with 0 => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite HexadecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + * rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + * rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. + - unfold of_hexadecimal; simpl. + rewrite <-(DecimalZ.to_of e). + case (Z.of_int e); clear e; [|intro e..]; simpl. + + case (uint_eq_dec f Nil); intro Hf. + * rewrite Hf; clear f Hf. + unfold to_hexadecimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, HexadecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + * set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_hexadecimal; simpl. + unfold IQmake_to_hexadecimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_hexadecimal (Z.of_hex_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_hexadecimal, n; simpl. + rewrite nztail_to_hex_uint_pow16. + clear r; set (r := if _ <? _ then Some (Hexadecimal _ _) else Some _). + clear m; set (m := match nb_digits f with 0 => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite HexadecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + -- rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + -- rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. + + set (i' := match i with Pos _ => _ | _ => _ end). + set (m := match Pos.to_uint e with Decimal.Nil => _ | _ => _ end). + replace m with (HexadecimalExp i' f (Decimal.Pos (Pos.to_uint e))). + 2:{ unfold m; generalize (DecimalPos.Unsigned.to_uint_nonzero e). + now case Pos.to_uint; [|intro u; case u|..]. } + unfold i'; clear i' m. + case (uint_eq_dec f Nil); intro Hf. + * rewrite Hf; clear f Hf. + unfold to_hexadecimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, HexadecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + * set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_hexadecimal; simpl. + unfold IQmake_to_hexadecimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_hexadecimal (Z.of_hex_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_hexadecimal, n; simpl. + rewrite nztail_to_hex_uint_pow16. + clear r; set (r := if _ <? _ then Some (Hexadecimal _ _) else Some _). + clear m; set (m := match nb_digits f with 0 => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite HexadecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + -- rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + -- rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. + + case (uint_eq_dec f Nil); intro Hf. + * rewrite Hf; clear f Hf. + unfold to_hexadecimal; simpl. + rewrite IZ_to_Z_IZ_of_Z, HexadecimalZ.to_of. + case i as [i|i]; [now simpl|]; simpl. + rewrite app_nil_r. + case (uint_eq_dec (nzhead i) Nil); [now intros->|intro Hi]. + now rewrite (unorm_nzhead _ Hi); revert Hi; case nzhead. + * set (r := IRQ _). + set (m := match f with Nil => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + unfold to_hexadecimal; simpl. + unfold IQmake_to_hexadecimal; simpl. + set (n := Nat.iter _ _ _). + case (Pos.eq_dec n 1); intro Hn. + exfalso; apply Hf. + { now apply nb_digits_0; revert Hn; unfold n; case nb_digits. } + clear m; set (m := match n with 1%positive | _ => _ end). + replace m with (QArith_base.IQmake_to_hexadecimal (Z.of_hex_int (app_int i f)) n). + 2:{ now unfold m; revert Hn; case n. } + unfold QArith_base.IQmake_to_hexadecimal, n; simpl. + rewrite nztail_to_hex_uint_pow16. + clear r; set (r := if _ <? _ then Some (Hexadecimal _ _) else Some _). + clear m; set (m := match nb_digits f with 0 => _ | _ => _ end). + replace m with r; [unfold r|now unfold m; revert Hf; case f]. + rewrite HexadecimalZ.to_of, abs_norm, abs_app_int. + case Nat.ltb_spec; intro Hnf. + -- rewrite (del_tail_app_int_exact _ _ Hnf). + rewrite (del_head_app_int_exact _ _ Hnf). + now rewrite (dnorm_i_exact _ _ Hnf). + -- rewrite (unorm_app_r _ _ Hnf). + rewrite (iter_D0_unorm _ Hf). + now rewrite dnorm_i_exact'. +Qed. + +(** Some consequences *) + +Lemma to_hexadecimal_inj q q' : + to_hexadecimal q <> None -> to_hexadecimal q = to_hexadecimal q' -> q = q'. +Proof. + intros Hnone EQ. + generalize (of_to q) (of_to q'). + rewrite <-EQ. + revert Hnone; case to_hexadecimal; [|now simpl]. + now intros d _ H1 H2; rewrite <-(H1 d eq_refl), <-(H2 d eq_refl). +Qed. + +Lemma to_hexadecimal_surj d : exists q, to_hexadecimal q = Some (dnorm d). +Proof. + exists (of_hexadecimal d). apply to_of. +Qed. + +Lemma of_hexadecimal_dnorm d : of_hexadecimal (dnorm d) = of_hexadecimal d. +Proof. now apply to_hexadecimal_inj; rewrite !to_of; [|rewrite dnorm_involutive]. Qed. + +Lemma of_inj d d' : of_hexadecimal d = of_hexadecimal d' -> dnorm d = dnorm d'. +Proof. + intro H. + apply (@f_equal _ _ (fun x => match x with Some x => x | _ => d end) + (Some (dnorm d)) (Some (dnorm d'))). + now rewrite <- !to_of, H. +Qed. + +Lemma of_iff d d' : of_hexadecimal d = of_hexadecimal d' <-> dnorm d = dnorm d'. +Proof. + split. apply of_inj. intros E. rewrite <- of_hexadecimal_dnorm, E. + apply of_hexadecimal_dnorm. +Qed. diff --git a/theories/Numbers/HexadecimalZ.v b/theories/Numbers/HexadecimalZ.v index c5ed0b5b28..1d78ad1ad2 100644 --- a/theories/Numbers/HexadecimalZ.v +++ b/theories/Numbers/HexadecimalZ.v @@ -80,9 +80,11 @@ Lemma of_hex_uint_iter_D0 d n : Z.of_hex_uint (app d (Nat.iter n D0 Nil)) = Nat.iter n (Z.mul 0x10) (Z.of_hex_uint d). Proof. - unfold Z.of_hex_uint. - unfold app; rewrite <-rev_revapp. - rewrite Unsigned.of_lu_rev, Unsigned.of_lu_revapp. + rewrite <-(rev_rev (app _ _)), <-(of_list_to_list (rev (app _ _))). + rewrite rev_spec, app_spec, List.rev_app_distr. + rewrite <-!rev_spec, <-app_spec, of_list_to_list. + unfold Z.of_hex_uint; rewrite Unsigned.of_lu_rev. + unfold app; rewrite Unsigned.of_lu_revapp, !rev_rev. rewrite <-!Unsigned.of_lu_rev, !rev_rev. assert (H' : Pos.of_hex_uint (Nat.iter n D0 Nil) = 0%N). { now induction n; [|rewrite Unsigned.nat_iter_S]. } @@ -140,3 +142,22 @@ Qed. Lemma double_to_hex_int n : double (Z.to_hex_int n) = Z.to_hex_int (Z.double n). Proof. now rewrite <-(of_to n), <-of_hex_int_double, !to_of, double_norm. Qed. + +Lemma nztail_to_hex_uint_pow16 n : + Hexadecimal.nztail (Pos.to_hex_uint (Nat.iter n (Pos.mul 16) 1%positive)) + = (D1 Nil, n). +Proof. + case n as [|n]; [now simpl|]. + rewrite <-(Nat2Pos.id (S n)); [|now simpl]. + generalize (Pos.of_nat (S n)); clear n; intro p. + induction (Pos.to_nat p); [now simpl|]. + rewrite Unsigned.nat_iter_S. + unfold Pos.to_hex_uint. + change (Pos.to_little_hex_uint _) + with (Unsigned.to_lu (16 * N.pos (Nat.iter n (Pos.mul 16) 1%positive))). + rewrite Unsigned.to_lhex_tenfold. + revert IHn; unfold Pos.to_hex_uint. + unfold Hexadecimal.nztail; rewrite !rev_rev; simpl. + set (f'' := _ (Pos.to_little_hex_uint _)). + now case f''; intros r n' H; inversion H. +Qed. diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v index 2361d59c26..0c097b6773 100644 --- a/theories/Numbers/Integer/Abstract/ZAdd.v +++ b/theories/Numbers/Integer/Abstract/ZAdd.v @@ -20,159 +20,157 @@ Include ZBaseProp Z. Hint Rewrite opp_0 : nz. -Theorem add_pred_l : forall n m, P n + m == P (n + m). +Theorem add_pred_l n m : P n + m == P (n + m). Proof. -intros n m. rewrite <- (succ_pred n) at 2. now rewrite add_succ_l, pred_succ. Qed. -Theorem add_pred_r : forall n m, n + P m == P (n + m). +Theorem add_pred_r n m : n + P m == P (n + m). Proof. -intros n m; rewrite 2 (add_comm n); apply add_pred_l. +rewrite 2 (add_comm n); apply add_pred_l. Qed. -Theorem add_opp_r : forall n m, n + (- m) == n - m. +Theorem add_opp_r n m : n + (- m) == n - m. Proof. nzinduct m. now nzsimpl. intro m. rewrite opp_succ, sub_succ_r, add_pred_r. now rewrite pred_inj_wd. Qed. -Theorem sub_0_l : forall n, 0 - n == - n. +Theorem sub_0_l n : 0 - n == - n. Proof. -intro n; rewrite <- add_opp_r; now rewrite add_0_l. +rewrite <- add_opp_r; now rewrite add_0_l. Qed. -Theorem sub_succ_l : forall n m, S n - m == S (n - m). +Theorem sub_succ_l n m : S n - m == S (n - m). Proof. -intros n m; rewrite <- 2 add_opp_r; now rewrite add_succ_l. +rewrite <- 2 add_opp_r; now rewrite add_succ_l. Qed. -Theorem sub_pred_l : forall n m, P n - m == P (n - m). +Theorem sub_pred_l n m : P n - m == P (n - m). Proof. -intros n m. rewrite <- (succ_pred n) at 2. +rewrite <- (succ_pred n) at 2. rewrite sub_succ_l; now rewrite pred_succ. Qed. -Theorem sub_pred_r : forall n m, n - (P m) == S (n - m). +Theorem sub_pred_r n m : n - (P m) == S (n - m). Proof. -intros n m. rewrite <- (succ_pred m) at 2. +rewrite <- (succ_pred m) at 2. rewrite sub_succ_r; now rewrite succ_pred. Qed. -Theorem opp_pred : forall n, - (P n) == S (- n). +Theorem opp_pred n : - (P n) == S (- n). Proof. -intro n. rewrite <- (succ_pred n) at 2. +rewrite <- (succ_pred n) at 2. rewrite opp_succ. now rewrite succ_pred. Qed. -Theorem sub_diag : forall n, n - n == 0. +Theorem sub_diag n : n - n == 0. Proof. nzinduct n. now nzsimpl. intro n. rewrite sub_succ_r, sub_succ_l; now rewrite pred_succ. Qed. -Theorem add_opp_diag_l : forall n, - n + n == 0. +Theorem add_opp_diag_l n : - n + n == 0. Proof. -intro n; now rewrite add_comm, add_opp_r, sub_diag. +now rewrite add_comm, add_opp_r, sub_diag. Qed. -Theorem add_opp_diag_r : forall n, n + (- n) == 0. +Theorem add_opp_diag_r n : n + (- n) == 0. Proof. -intro n; rewrite add_comm; apply add_opp_diag_l. +rewrite add_comm; apply add_opp_diag_l. Qed. -Theorem add_opp_l : forall n m, - m + n == n - m. +Theorem add_opp_l n m : - m + n == n - m. Proof. -intros n m; rewrite <- add_opp_r; now rewrite add_comm. +rewrite <- add_opp_r; now rewrite add_comm. Qed. -Theorem add_sub_assoc : forall n m p, n + (m - p) == (n + m) - p. +Theorem add_sub_assoc n m p : n + (m - p) == (n + m) - p. Proof. -intros n m p; rewrite <- 2 add_opp_r; now rewrite add_assoc. +rewrite <- 2 add_opp_r; now rewrite add_assoc. Qed. -Theorem opp_involutive : forall n, - (- n) == n. +Theorem opp_involutive n : - (- n) == n. Proof. nzinduct n. now nzsimpl. intro n. rewrite opp_succ, opp_pred. now rewrite succ_inj_wd. Qed. -Theorem opp_add_distr : forall n m, - (n + m) == - n + (- m). +Theorem opp_add_distr n m : - (n + m) == - n + (- m). Proof. -intros n m; nzinduct n. +nzinduct n. now nzsimpl. intro n. rewrite add_succ_l; do 2 rewrite opp_succ; rewrite add_pred_l. now rewrite pred_inj_wd. Qed. -Theorem opp_sub_distr : forall n m, - (n - m) == - n + m. +Theorem opp_sub_distr n m : - (n - m) == - n + m. Proof. -intros n m; rewrite <- add_opp_r, opp_add_distr. +rewrite <- add_opp_r, opp_add_distr. now rewrite opp_involutive. Qed. -Theorem opp_inj : forall n m, - n == - m -> n == m. +Theorem opp_inj n m : - n == - m -> n == m. Proof. -intros n m H. apply opp_wd in H. now rewrite 2 opp_involutive in H. +intros H. apply opp_wd in H. now rewrite 2 opp_involutive in H. Qed. -Theorem opp_inj_wd : forall n m, - n == - m <-> n == m. +Theorem opp_inj_wd n m : - n == - m <-> n == m. Proof. -intros n m; split; [apply opp_inj | intros; now f_equiv]. +split; [apply opp_inj | intros; now f_equiv]. Qed. -Theorem eq_opp_l : forall n m, - n == m <-> n == - m. +Theorem eq_opp_l n m : - n == m <-> n == - m. Proof. -intros n m. now rewrite <- (opp_inj_wd (- n) m), opp_involutive. +now rewrite <- (opp_inj_wd (- n) m), opp_involutive. Qed. -Theorem eq_opp_r : forall n m, n == - m <-> - n == m. +Theorem eq_opp_r n m : n == - m <-> - n == m. Proof. symmetry; apply eq_opp_l. Qed. -Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p. +Theorem sub_add_distr n m p : n - (m + p) == (n - m) - p. Proof. -intros n m p; rewrite <- add_opp_r, opp_add_distr, add_assoc. +rewrite <- add_opp_r, opp_add_distr, add_assoc. now rewrite 2 add_opp_r. Qed. -Theorem sub_sub_distr : forall n m p, n - (m - p) == (n - m) + p. +Theorem sub_sub_distr n m p : n - (m - p) == (n - m) + p. Proof. -intros n m p; rewrite <- add_opp_r, opp_sub_distr, add_assoc. +rewrite <- add_opp_r, opp_sub_distr, add_assoc. now rewrite add_opp_r. Qed. -Theorem sub_opp_l : forall n m, - n - m == - m - n. +Theorem sub_opp_l n m : - n - m == - m - n. Proof. -intros n m. rewrite <- 2 add_opp_r. now rewrite add_comm. +rewrite <- 2 add_opp_r. now rewrite add_comm. Qed. -Theorem sub_opp_r : forall n m, n - (- m) == n + m. +Theorem sub_opp_r n m : n - (- m) == n + m. Proof. -intros n m; rewrite <- add_opp_r; now rewrite opp_involutive. +rewrite <- add_opp_r; now rewrite opp_involutive. Qed. -Theorem add_sub_swap : forall n m p, n + m - p == n - p + m. +Theorem add_sub_swap n m p : n + m - p == n - p + m. Proof. -intros n m p. rewrite <- add_sub_assoc, <- (add_opp_r n p), <- add_assoc. +rewrite <- add_sub_assoc, <- (add_opp_r n p), <- add_assoc. now rewrite add_opp_l. Qed. -Theorem sub_cancel_l : forall n m p, n - m == n - p <-> m == p. +Theorem sub_cancel_l n m p : n - m == n - p <-> m == p. Proof. -intros n m p. rewrite <- (add_cancel_l (n - m) (n - p) (- n)). +rewrite <- (add_cancel_l (n - m) (n - p) (- n)). rewrite 2 add_sub_assoc. rewrite add_opp_diag_l; rewrite 2 sub_0_l. apply opp_inj_wd. Qed. -Theorem sub_cancel_r : forall n m p, n - p == m - p <-> n == m. +Theorem sub_cancel_r n m p : n - p == m - p <-> n == m. Proof. -intros n m p. stepl (n - p + p == m - p + p) by apply add_cancel_r. now do 2 rewrite <- sub_sub_distr, sub_diag, sub_0_r. Qed. @@ -182,16 +180,15 @@ Qed. in the original equation ([add] or [sub]) and the indication whether the left or right term is moved. *) -Theorem add_move_l : forall n m p, n + m == p <-> m == p - n. +Theorem add_move_l n m p : n + m == p <-> m == p - n. Proof. -intros n m p. stepl (n + m - n == p - n) by apply sub_cancel_r. now rewrite add_comm, <- add_sub_assoc, sub_diag, add_0_r. Qed. -Theorem add_move_r : forall n m p, n + m == p <-> n == p - m. +Theorem add_move_r n m p : n + m == p <-> n == p - m. Proof. -intros n m p; rewrite add_comm; now apply add_move_l. +rewrite add_comm; now apply add_move_l. Qed. (** The two theorems above do not allow rewriting subformulas of the @@ -199,98 +196,98 @@ Qed. right-hand side of the equation. Hence the following two theorems. *) -Theorem sub_move_l : forall n m p, n - m == p <-> - m == p - n. +Theorem sub_move_l n m p : n - m == p <-> - m == p - n. Proof. -intros n m p; rewrite <- (add_opp_r n m); apply add_move_l. +rewrite <- (add_opp_r n m); apply add_move_l. Qed. -Theorem sub_move_r : forall n m p, n - m == p <-> n == p + m. +Theorem sub_move_r n m p : n - m == p <-> n == p + m. Proof. -intros n m p; rewrite <- (add_opp_r n m). now rewrite add_move_r, sub_opp_r. +rewrite <- (add_opp_r n m). now rewrite add_move_r, sub_opp_r. Qed. -Theorem add_move_0_l : forall n m, n + m == 0 <-> m == - n. +Theorem add_move_0_l n m : n + m == 0 <-> m == - n. Proof. -intros n m; now rewrite add_move_l, sub_0_l. +now rewrite add_move_l, sub_0_l. Qed. -Theorem add_move_0_r : forall n m, n + m == 0 <-> n == - m. +Theorem add_move_0_r n m : n + m == 0 <-> n == - m. Proof. -intros n m; now rewrite add_move_r, sub_0_l. +now rewrite add_move_r, sub_0_l. Qed. -Theorem sub_move_0_l : forall n m, n - m == 0 <-> - m == - n. +Theorem sub_move_0_l n m : n - m == 0 <-> - m == - n. Proof. -intros n m. now rewrite sub_move_l, sub_0_l. +now rewrite sub_move_l, sub_0_l. Qed. -Theorem sub_move_0_r : forall n m, n - m == 0 <-> n == m. +Theorem sub_move_0_r n m : n - m == 0 <-> n == m. Proof. -intros n m. now rewrite sub_move_r, add_0_l. +now rewrite sub_move_r, add_0_l. Qed. (** The following section is devoted to cancellation of like terms. The name includes the first operator and the position of the term being canceled. *) -Theorem add_simpl_l : forall n m, n + m - n == m. +Theorem add_simpl_l n m : n + m - n == m. Proof. -intros; now rewrite add_sub_swap, sub_diag, add_0_l. +now rewrite add_sub_swap, sub_diag, add_0_l. Qed. -Theorem add_simpl_r : forall n m, n + m - m == n. +Theorem add_simpl_r n m : n + m - m == n. Proof. -intros; now rewrite <- add_sub_assoc, sub_diag, add_0_r. +now rewrite <- add_sub_assoc, sub_diag, add_0_r. Qed. -Theorem sub_simpl_l : forall n m, - n - m + n == - m. +Theorem sub_simpl_l n m : - n - m + n == - m. Proof. -intros; now rewrite <- add_sub_swap, add_opp_diag_l, sub_0_l. +now rewrite <- add_sub_swap, add_opp_diag_l, sub_0_l. Qed. -Theorem sub_simpl_r : forall n m, n - m + m == n. +Theorem sub_simpl_r n m : n - m + m == n. Proof. -intros; now rewrite <- sub_sub_distr, sub_diag, sub_0_r. +now rewrite <- sub_sub_distr, sub_diag, sub_0_r. Qed. -Theorem sub_add : forall n m, m - n + n == m. +Theorem sub_add n m : m - n + n == m. Proof. - intros. now rewrite <- add_sub_swap, add_simpl_r. +now rewrite <- add_sub_swap, add_simpl_r. Qed. (** Now we have two sums or differences; the name includes the two operators and the position of the terms being canceled *) -Theorem add_add_simpl_l_l : forall n m p, (n + m) - (n + p) == m - p. +Theorem add_add_simpl_l_l n m p : (n + m) - (n + p) == m - p. Proof. -intros n m p. now rewrite (add_comm n m), <- add_sub_assoc, +now rewrite (add_comm n m), <- add_sub_assoc, sub_add_distr, sub_diag, sub_0_l, add_opp_r. Qed. -Theorem add_add_simpl_l_r : forall n m p, (n + m) - (p + n) == m - p. +Theorem add_add_simpl_l_r n m p : (n + m) - (p + n) == m - p. Proof. -intros n m p. rewrite (add_comm p n); apply add_add_simpl_l_l. +rewrite (add_comm p n); apply add_add_simpl_l_l. Qed. -Theorem add_add_simpl_r_l : forall n m p, (n + m) - (m + p) == n - p. +Theorem add_add_simpl_r_l n m p : (n + m) - (m + p) == n - p. Proof. -intros n m p. rewrite (add_comm n m); apply add_add_simpl_l_l. +rewrite (add_comm n m); apply add_add_simpl_l_l. Qed. -Theorem add_add_simpl_r_r : forall n m p, (n + m) - (p + m) == n - p. +Theorem add_add_simpl_r_r n m p : (n + m) - (p + m) == n - p. Proof. -intros n m p. rewrite (add_comm p m); apply add_add_simpl_r_l. +rewrite (add_comm p m); apply add_add_simpl_r_l. Qed. -Theorem sub_add_simpl_r_l : forall n m p, (n - m) + (m + p) == n + p. +Theorem sub_add_simpl_r_l n m p : (n - m) + (m + p) == n + p. Proof. -intros n m p. now rewrite <- sub_sub_distr, sub_add_distr, sub_diag, +now rewrite <- sub_sub_distr, sub_add_distr, sub_diag, sub_0_l, sub_opp_r. Qed. -Theorem sub_add_simpl_r_r : forall n m p, (n - m) + (p + m) == n + p. +Theorem sub_add_simpl_r_r n m p : (n - m) + (p + m) == n + p. Proof. -intros n m p. rewrite (add_comm p m); apply sub_add_simpl_r_l. +rewrite (add_comm p m); apply sub_add_simpl_r_l. Qed. (** Of course, there are many other variants *) diff --git a/theories/Numbers/Integer/Abstract/ZAddOrder.v b/theories/Numbers/Integer/Abstract/ZAddOrder.v index 40a37be5f9..5a293c6483 100644 --- a/theories/Numbers/Integer/Abstract/ZAddOrder.v +++ b/theories/Numbers/Integer/Abstract/ZAddOrder.v @@ -241,25 +241,25 @@ Qed. Theorem sub_neg_cases : forall n m, n - m < 0 -> n < 0 \/ 0 < m. Proof. -intros. +intros n m ?. rewrite <- (opp_neg_pos m). apply add_neg_cases. now rewrite add_opp_r. Qed. Theorem sub_pos_cases : forall n m, 0 < n - m -> 0 < n \/ m < 0. Proof. -intros. +intros n m ?. rewrite <- (opp_pos_neg m). apply add_pos_cases. now rewrite add_opp_r. Qed. Theorem sub_nonpos_cases : forall n m, n - m <= 0 -> n <= 0 \/ 0 <= m. Proof. -intros. +intros n m ?. rewrite <- (opp_nonpos_nonneg m). apply add_nonpos_cases. now rewrite add_opp_r. Qed. Theorem sub_nonneg_cases : forall n m, 0 <= n - m -> 0 <= n \/ m <= 0. Proof. -intros. +intros n m ?. rewrite <- (opp_nonneg_nonpos m). apply add_nonneg_cases. now rewrite add_opp_r. Qed. diff --git a/theories/Numbers/Integer/Abstract/ZBits.v b/theories/Numbers/Integer/Abstract/ZBits.v index 0f40d3d7b6..4d2361689d 100644 --- a/theories/Numbers/Integer/Abstract/ZBits.v +++ b/theories/Numbers/Integer/Abstract/ZBits.v @@ -244,7 +244,7 @@ Qed. Lemma bit0_odd : forall a, a.[0] = odd a. Proof. - intros. symmetry. + intros a. symmetry. destruct (exists_div2 a) as (a' & b & EQ). rewrite EQ, testbit_0_r, add_comm, odd_add_mul_2. destruct b; simpl; apply odd_1 || apply odd_0. @@ -428,14 +428,14 @@ Qed. Lemma mul_pow2_bits : forall a n m, 0<=n -> (a*2^n).[m] = a.[m-n]. Proof. - intros. + intros a n m ?. rewrite <- (add_simpl_r m n) at 1. rewrite add_sub_swap, add_comm. now apply mul_pow2_bits_add. Qed. Lemma mul_pow2_bits_low : forall a n m, m<n -> (a*2^n).[m] = false. Proof. - intros. + intros a n m ?. destruct (le_gt_cases 0 n). rewrite mul_pow2_bits by trivial. apply testbit_neg_r. now apply lt_sub_0. @@ -561,7 +561,10 @@ Proof. split. apply bits_inj'. intros EQ n Hn; now rewrite EQ. Qed. -Ltac bitwise := apply bits_inj'; intros ?m ?Hm; autorewrite with bitwise. +Tactic Notation "bitwise" "as" simple_intropattern(m) simple_intropattern(Hm) + := apply bits_inj'; intros m Hm; autorewrite with bitwise. + +Ltac bitwise := bitwise as ?m ?Hm. Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. @@ -619,7 +622,7 @@ Qed. Lemma shiftl_spec : forall a n m, 0<=m -> (a << n).[m] = a.[m-n]. Proof. - intros. + intros a n m ?. destruct (le_gt_cases n m). now apply shiftl_spec_high. rewrite shiftl_spec_low, testbit_neg_r; trivial. now apply lt_sub_0. @@ -693,7 +696,7 @@ Qed. Lemma shiftl_shiftl : forall a n m, 0<=n -> (a << n) << m == a << (n+m). Proof. - intros a n p Hn. bitwise. + intros a n p Hn. bitwise as m Hm. rewrite 2 (shiftl_spec _ _ m) by trivial. rewrite add_comm, sub_add_distr. destruct (le_gt_cases 0 (m-p)) as [H|H]. @@ -745,8 +748,8 @@ Qed. Lemma shiftl_0_l : forall n, 0 << n == 0. Proof. - intros. - destruct (le_ge_cases 0 n). + intros n. + destruct (le_ge_cases 0 n) as [H|H]. rewrite shiftl_mul_pow2 by trivial. now nzsimpl. rewrite shiftl_div_pow2 by trivial. rewrite <- opp_nonneg_nonpos in H. nzsimpl; order_nz. @@ -901,7 +904,7 @@ Qed. Lemma lor_eq_0_l : forall a b, lor a b == 0 -> a == 0. Proof. - intros a b H. bitwise. + intros a b H. bitwise as m ?. apply (orb_false_iff a.[m] b.[m]). now rewrite <- lor_spec, H, bits_0. Qed. @@ -909,7 +912,7 @@ Qed. Lemma lor_eq_0_iff : forall a b, lor a b == 0 <-> a == 0 /\ b == 0. Proof. intros a b. split. - split. now apply lor_eq_0_l in H. + intro H; split. now apply lor_eq_0_l in H. rewrite lor_comm in H. now apply lor_eq_0_l in H. intros (EQ,EQ'). now rewrite EQ, lor_0_l. Qed. @@ -1022,13 +1025,13 @@ Proof. unfold clearbit. solve_proper. Qed. Lemma pow2_bits_true : forall n, 0<=n -> (2^n).[n] = true. Proof. - intros. rewrite <- (mul_1_l (2^n)). + intros n ?. rewrite <- (mul_1_l (2^n)). now rewrite mul_pow2_bits, sub_diag, bit0_odd, odd_1. Qed. Lemma pow2_bits_false : forall n m, n~=m -> (2^n).[m] = false. Proof. - intros. + intros n m ?. destruct (le_gt_cases 0 n); [|now rewrite pow_neg_r, bits_0]. destruct (le_gt_cases n m). rewrite <- (mul_1_l (2^n)), mul_pow2_bits; trivial. @@ -1073,7 +1076,7 @@ Qed. Lemma clearbit_eqb : forall a n m, (clearbit a n).[m] = a.[m] && negb (eqb n m). Proof. - intros. + intros a n m. destruct (le_gt_cases 0 m); [| now rewrite 2 testbit_neg_r]. rewrite clearbit_spec', ldiff_spec. f_equal. f_equal. destruct (le_gt_cases 0 n) as [Hn|Hn]. @@ -1090,7 +1093,7 @@ Qed. Lemma clearbit_eq : forall a n, (clearbit a n).[n] = false. Proof. - intros. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)). + intros a n. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)). apply andb_false_r. Qed. @@ -1161,7 +1164,7 @@ Proof. unfold lnot. solve_proper. Qed. Lemma lnot_spec : forall a n, 0<=n -> (lnot a).[n] = negb a.[n]. Proof. - intros. unfold lnot. rewrite <- (opp_involutive a) at 2. + intros a n ?. unfold lnot. rewrite <- (opp_involutive a) at 2. rewrite bits_opp, negb_involutive; trivial. Qed. @@ -1214,7 +1217,7 @@ Qed. Lemma lor_lnot_diag : forall a, lor a (lnot a) == -1. Proof. - intros a. bitwise. rewrite lnot_spec, bits_m1; trivial. + intros a. bitwise as m ?. rewrite lnot_spec, bits_m1; trivial. now destruct a.[m]. Qed. @@ -1267,7 +1270,7 @@ Qed. Lemma lxor_m1_r : forall a, lxor a (-1) == lnot a. Proof. - intros. now rewrite <- (lxor_0_r (lnot a)), <- lnot_m1, lxor_lnot_lnot. + intros a. now rewrite <- (lxor_0_r (lnot a)), <- lnot_m1, lxor_lnot_lnot. Qed. Lemma lxor_m1_l : forall a, lxor (-1) a == lnot a. @@ -1278,7 +1281,7 @@ Qed. Lemma lxor_lor : forall a b, land a b == 0 -> lxor a b == lor a b. Proof. - intros a b H. bitwise. + intros a b H. bitwise as m ?. assert (a.[m] && b.[m] = false) by now rewrite <- land_spec, H, bits_0. now destruct a.[m], b.[m]. @@ -1299,7 +1302,7 @@ Proof. unfold ones. solve_proper. Qed. Lemma ones_equiv : forall n, ones n == P (2^n). Proof. - intros. unfold ones. + intros n. unfold ones. destruct (le_gt_cases 0 n). now rewrite shiftl_mul_pow2, mul_1_l. f_equiv. rewrite pow_neg_r; trivial. @@ -1367,7 +1370,7 @@ Qed. Lemma lor_ones_low : forall a n, 0<=a -> log2 a < n -> lor a (ones n) == ones n. Proof. - intros a n Ha H. bitwise. destruct (le_gt_cases n m). + intros a n Ha H. bitwise as m ?. destruct (le_gt_cases n m). rewrite ones_spec_high, bits_above_log2; try split; trivial. now apply lt_le_trans with n. apply le_trans with (log2 a); order_pos. @@ -1376,7 +1379,7 @@ Qed. Lemma land_ones : forall a n, 0<=n -> land a (ones n) == a mod 2^n. Proof. - intros a n Hn. bitwise. destruct (le_gt_cases n m). + intros a n Hn. bitwise as m ?. destruct (le_gt_cases n m). rewrite ones_spec_high, mod_pow2_bits_high, andb_false_r; try split; trivial. rewrite ones_spec_low, mod_pow2_bits_low, andb_true_r; @@ -1396,7 +1399,7 @@ Qed. Lemma ldiff_ones_r : forall a n, 0<=n -> ldiff a (ones n) == (a >> n) << n. Proof. - intros a n Hn. bitwise. destruct (le_gt_cases n m). + intros a n Hn. bitwise as m ?. destruct (le_gt_cases n m). rewrite ones_spec_high, shiftl_spec_high, shiftr_spec; trivial. rewrite sub_add; trivial. apply andb_true_r. now apply le_0_sub. @@ -1408,7 +1411,7 @@ Qed. Lemma ldiff_ones_r_low : forall a n, 0<=a -> log2 a < n -> ldiff a (ones n) == 0. Proof. - intros a n Ha H. bitwise. destruct (le_gt_cases n m). + intros a n Ha H. bitwise as m ?. destruct (le_gt_cases n m). rewrite ones_spec_high, bits_above_log2; trivial. now apply lt_le_trans with n. split; trivial. now apply le_trans with (log2 a); order_pos. @@ -1418,7 +1421,7 @@ Qed. Lemma ldiff_ones_l_low : forall a n, 0<=a -> log2 a < n -> ldiff (ones n) a == lxor a (ones n). Proof. - intros a n Ha H. bitwise. destruct (le_gt_cases n m). + intros a n Ha H. bitwise as m ?. destruct (le_gt_cases n m). rewrite ones_spec_high, bits_above_log2; trivial. now apply lt_le_trans with n. split; trivial. now apply le_trans with (log2 a); order_pos. @@ -1585,7 +1588,7 @@ Qed. Lemma log2_shiftr : forall a n, 0<a -> log2 (a >> n) == max 0 (log2 a - n). Proof. intros a n Ha. - destruct (le_gt_cases 0 (log2 a - n)); + destruct (le_gt_cases 0 (log2 a - n)) as [H|H]; [rewrite max_r | rewrite max_l]; try order. apply log2_bits_unique. now rewrite shiftr_spec, sub_add, bit_log2. @@ -1698,7 +1701,7 @@ Qed. Lemma add_carry_div2 : forall a b (c0:bool), (a + b + c0)/2 == a/2 + b/2 + nextcarry a.[0] b.[0] c0. Proof. - intros. + intros a b c0. rewrite <- add3_bits_div2. rewrite (add_comm ((a/2)+_)). rewrite <- div_add by order'. @@ -1767,7 +1770,7 @@ Proof. apply div_lt_upper_bound. order'. now rewrite <- pow_succ_r. exists (c0 + 2*c). repeat split. (* step, add *) - bitwise. + bitwise as m Hm. le_elim Hm. rewrite <- (succ_pred m), lt_succ_r in Hm. rewrite <- (succ_pred m), <- !div2_bits, <- 2 lxor_spec by trivial. @@ -1777,7 +1780,7 @@ Proof. now rewrite add_b2z_double_bit0, add3_bit0, b2z_bit0. (* step, carry *) rewrite add_b2z_double_div2. - bitwise. + bitwise as m Hm. le_elim Hm. rewrite <- (succ_pred m), lt_succ_r in Hm. rewrite <- (succ_pred m), <- !div2_bits, IH2 by trivial. @@ -1905,7 +1908,7 @@ Proof. rewrite sub_add. symmetry. rewrite add_nocarry_lxor; trivial. - bitwise. + bitwise as m ?. apply bits_inj_iff in H. specialize (H m). rewrite ldiff_spec, bits_0 in H. now destruct a.[m], b.[m]. @@ -1938,7 +1941,7 @@ Lemma add_nocarry_mod_lt_pow2 : forall a b n, 0<=n -> land a b == 0 -> Proof. intros a b n Hn H. apply add_nocarry_lt_pow2. - bitwise. + bitwise as m ?. destruct (le_gt_cases n m). rewrite mod_pow2_bits_high; now split. now rewrite !mod_pow2_bits_low, <- land_spec, H, bits_0. diff --git a/theories/Numbers/Integer/Abstract/ZDivFloor.v b/theories/Numbers/Integer/Abstract/ZDivFloor.v index 44cba37eb2..d28d010ae8 100644 --- a/theories/Numbers/Integer/Abstract/ZDivFloor.v +++ b/theories/Numbers/Integer/Abstract/ZDivFloor.v @@ -51,7 +51,7 @@ Qed. Lemma mod_bound_abs : forall a b, b~=0 -> abs (a mod b) < abs b. Proof. -intros. +intros a b **. destruct (abs_spec b) as [(LE,EQ)|(LE,EQ)]; rewrite EQ. destruct (mod_pos_bound a b). order. now rewrite abs_eq. destruct (mod_neg_bound a b). order. rewrite abs_neq; trivial. @@ -87,11 +87,11 @@ Qed. Theorem div_unique_pos: forall a b q r, 0<=r<b -> a == b*q + r -> q == a/b. -Proof. intros; apply div_unique with r; auto. Qed. +Proof. intros a b q r **; apply div_unique with r; auto. Qed. Theorem div_unique_neg: forall a b q r, b<r<=0 -> a == b*q + r -> q == a/b. -Proof. intros; apply div_unique with r; auto. Qed. +Proof. intros a b q r **; apply div_unique with r; auto. Qed. Theorem mod_unique: forall a b q r, (0<=r<b \/ b<r<=0) -> a == b*q + r -> r == a mod b. @@ -106,11 +106,11 @@ Qed. Theorem mod_unique_pos: forall a b q r, 0<=r<b -> a == b*q + r -> r == a mod b. -Proof. intros; apply mod_unique with q; auto. Qed. +Proof. intros a b q r **; apply mod_unique with q; auto. Qed. Theorem mod_unique_neg: forall a b q r, b<r<=0 -> a == b*q + r -> r == a mod b. -Proof. intros; apply mod_unique with q; auto. Qed. +Proof. intros a b q r **; apply mod_unique with q; auto. Qed. (** Sign rules *) @@ -121,7 +121,7 @@ Ltac pos_or_neg a := Fact mod_bound_or : forall a b, b~=0 -> 0<=a mod b<b \/ b<a mod b<=0. Proof. -intros. +intros a b **. destruct (lt_ge_cases 0 b); [left|right]. apply mod_pos_bound; trivial. apply mod_neg_bound; order. Qed. @@ -129,7 +129,7 @@ Qed. Fact opp_mod_bound_or : forall a b, b~=0 -> 0 <= -(a mod b) < -b \/ -b < -(a mod b) <= 0. Proof. -intros. +intros a b **. destruct (lt_ge_cases 0 b); [right|left]. rewrite <- opp_lt_mono, opp_nonpos_nonneg. destruct (mod_pos_bound a b); intuition; order. @@ -139,14 +139,14 @@ Qed. Lemma div_opp_opp : forall a b, b~=0 -> -a/-b == a/b. Proof. -intros. symmetry. apply div_unique with (- (a mod b)). +intros a b **. symmetry. apply div_unique with (- (a mod b)). now apply opp_mod_bound_or. rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order. Qed. Lemma mod_opp_opp : forall a b, b~=0 -> (-a) mod (-b) == - (a mod b). Proof. -intros. symmetry. apply mod_unique with (a/b). +intros a b **. symmetry. apply mod_unique with (a/b). now apply opp_mod_bound_or. rewrite mul_opp_l, <- opp_add_distr, <- div_mod; order. Qed. @@ -200,28 +200,28 @@ Qed. Lemma div_opp_r_z : forall a b, b~=0 -> a mod b == 0 -> a/(-b) == -(a/b). Proof. -intros. rewrite <- (opp_involutive a) at 1. +intros a b **. rewrite <- (opp_involutive a) at 1. rewrite div_opp_opp; auto using div_opp_l_z. Qed. Lemma div_opp_r_nz : forall a b, b~=0 -> a mod b ~= 0 -> a/(-b) == -(a/b)-1. Proof. -intros. rewrite <- (opp_involutive a) at 1. +intros a b **. rewrite <- (opp_involutive a) at 1. rewrite div_opp_opp; auto using div_opp_l_nz. Qed. Lemma mod_opp_r_z : forall a b, b~=0 -> a mod b == 0 -> a mod (-b) == 0. Proof. -intros. rewrite <- (opp_involutive a) at 1. +intros a b **. rewrite <- (opp_involutive a) at 1. now rewrite mod_opp_opp, mod_opp_l_z, opp_0. Qed. Lemma mod_opp_r_nz : forall a b, b~=0 -> a mod b ~= 0 -> a mod (-b) == (a mod b) - b. Proof. -intros. rewrite <- (opp_involutive a) at 1. +intros a b **. rewrite <- (opp_involutive a) at 1. rewrite mod_opp_opp, mod_opp_l_nz by trivial. now rewrite opp_sub_distr, add_comm, add_opp_r. Qed. @@ -247,7 +247,7 @@ Qed. Lemma mod_sign_mul : forall a b, b~=0 -> 0 <= (a mod b) * b. Proof. -intros. destruct (lt_ge_cases 0 b). +intros a b **. destruct (lt_ge_cases 0 b). apply mul_nonneg_nonneg; destruct (mod_pos_bound a b); order. apply mul_nonpos_nonpos; destruct (mod_neg_bound a b); order. Qed. @@ -256,7 +256,7 @@ Qed. Lemma div_same : forall a, a~=0 -> a/a == 1. Proof. -intros. pos_or_neg a. apply div_same; order. +intros a ?. pos_or_neg a. apply div_same; order. rewrite <- div_opp_opp by trivial. now apply div_same. Qed. @@ -279,7 +279,7 @@ Proof. exact mod_small. Qed. Lemma div_0_l: forall a, a~=0 -> 0/a == 0. Proof. -intros. pos_or_neg a. apply div_0_l; order. +intros a ?. pos_or_neg a. apply div_0_l; order. rewrite <- div_opp_opp, opp_0 by trivial. now apply div_0_l. Qed. @@ -308,7 +308,7 @@ Proof. exact mod_1_l. Qed. Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a. Proof. -intros. symmetry. apply div_unique with 0. +intros a b ?. symmetry. apply div_unique with 0. destruct (lt_ge_cases 0 b); [left|right]; split; order. nzsimpl; apply mul_comm. Qed. @@ -350,7 +350,7 @@ Qed. Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> 0<=a<b \/ b<a<=0). Proof. -intros. +intros a b **. rewrite <- div_small_iff, mod_eq by trivial. rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l. rewrite eq_sym_iff, eq_mul_0. tauto. @@ -393,7 +393,7 @@ Qed. Lemma mul_div_le : forall a b, 0<b -> b*(a/b) <= a. Proof. -intros. +intros a b **. rewrite (div_mod a b) at 2; try order. rewrite <- (add_0_r (b*(a/b))) at 1. rewrite <- add_le_mono_l. @@ -412,7 +412,7 @@ Qed. Lemma mul_succ_div_gt: forall a b, 0<b -> a < b*(S (a/b)). Proof. -intros. +intros a b ?. nzsimpl. rewrite (div_mod a b) at 1; try order. rewrite <- add_lt_mono_l. @@ -432,7 +432,7 @@ Qed. Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). Proof. -intros. +intros a b **. rewrite (div_mod a b) at 1; try order. rewrite <- (add_0_r (b*(a/b))) at 2. apply add_cancel_l. @@ -443,7 +443,7 @@ Qed. Theorem div_lt_upper_bound: forall a b q, 0<b -> a < b*q -> a/b < q. Proof. -intros. +intros a b q **. rewrite (mul_lt_mono_pos_l b) by trivial. apply le_lt_trans with a; trivial. now apply mul_div_le. @@ -452,7 +452,7 @@ Qed. Theorem div_le_upper_bound: forall a b q, 0<b -> a <= b*q -> a/b <= q. Proof. -intros. +intros a b q **. rewrite <- (div_mul q b) by order. apply div_le_mono; trivial. now rewrite mul_comm. Qed. @@ -460,7 +460,7 @@ Qed. Theorem div_le_lower_bound: forall a b q, 0<b -> b*q <= a -> q <= a/b. Proof. -intros. +intros a b q **. rewrite <- (div_mul q b) by order. apply div_le_mono; trivial. now rewrite mul_comm. Qed. @@ -475,7 +475,7 @@ Proof. exact div_le_compat_l. Qed. Lemma mod_add : forall a b c, c~=0 -> (a + b * c) mod c == a mod c. Proof. -intros. +intros a b c **. symmetry. apply mod_unique with (a/c+b); trivial. now apply mod_bound_or. @@ -486,7 +486,7 @@ Qed. Lemma div_add : forall a b c, c~=0 -> (a + b * c) / c == a / c + b. Proof. -intros. +intros a b c **. apply (mul_cancel_l _ _ c); try order. apply (add_cancel_r _ _ ((a+b*c) mod c)). rewrite <- div_mod, mod_add by order. @@ -506,7 +506,7 @@ Qed. Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> (a*c)/(b*c) == a/b. Proof. -intros. +intros a b c **. symmetry. apply div_unique with ((a mod b)*c). (* ineqs *) @@ -525,13 +525,13 @@ Qed. Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> (c*a)/(c*b) == a/b. Proof. -intros. rewrite !(mul_comm c); now apply div_mul_cancel_r. +intros a b c **. rewrite !(mul_comm c); now apply div_mul_cancel_r. Qed. Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 -> (c*a) mod (c*b) == c * (a mod b). Proof. -intros. +intros a b c **. rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). rewrite <- div_mod. rewrite div_mul_cancel_l by trivial. @@ -543,7 +543,7 @@ Qed. Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 -> (a*c) mod (b*c) == (a mod b) * c. Proof. - intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. + intros a b c **. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. Qed. @@ -570,7 +570,7 @@ Qed. Lemma mul_mod_idemp_r : forall a b n, n~=0 -> (a*(b mod n)) mod n == (a*b) mod n. Proof. - intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l. + intros a b n **. rewrite !(mul_comm a). now apply mul_mod_idemp_l. Qed. Theorem mul_mod: forall a b n, n~=0 -> @@ -591,7 +591,7 @@ Qed. Lemma add_mod_idemp_r : forall a b n, n~=0 -> (a+(b mod n)) mod n == (a+b) mod n. Proof. - intros. rewrite !(add_comm a). now apply add_mod_idemp_l. + intros a b n **. rewrite !(add_comm a). now apply add_mod_idemp_l. Qed. Theorem add_mod: forall a b n, n~=0 -> diff --git a/theories/Numbers/Integer/Abstract/ZDivTrunc.v b/theories/Numbers/Integer/Abstract/ZDivTrunc.v index 4915d69c5b..7d374bd4be 100644 --- a/theories/Numbers/Integer/Abstract/ZDivTrunc.v +++ b/theories/Numbers/Integer/Abstract/ZDivTrunc.v @@ -69,7 +69,7 @@ Proof. intros. now rewrite rem_opp_r, rem_opp_l. Qed. Lemma quot_opp_l : forall a b, b ~= 0 -> (-a)÷b == -(a÷b). Proof. -intros. +intros a b ?. rewrite <- (mul_cancel_l _ _ b) by trivial. rewrite <- (add_cancel_r _ _ ((-a) rem b)). now rewrite <- quot_rem, rem_opp_l, mul_opp_r, <- opp_add_distr, <- quot_rem. @@ -77,7 +77,7 @@ Qed. Lemma quot_opp_r : forall a b, b ~= 0 -> a÷(-b) == -(a÷b). Proof. -intros. +intros a b ?. assert (-b ~= 0) by (now rewrite eq_opp_l, opp_0). rewrite <- (mul_cancel_l _ _ (-b)) by trivial. rewrite <- (add_cancel_r _ _ (a rem (-b))). @@ -105,17 +105,17 @@ Qed. Theorem quot_unique: forall a b q r, 0<=a -> 0<=r<b -> a == b*q + r -> q == a÷b. -Proof. intros; now apply NZQuot.div_unique with r. Qed. +Proof. intros a b q r **; now apply NZQuot.div_unique with r. Qed. Theorem rem_unique: forall a b q r, 0<=a -> 0<=r<b -> a == b*q + r -> r == a rem b. -Proof. intros; now apply NZQuot.mod_unique with q. Qed. +Proof. intros a b q r **; now apply NZQuot.mod_unique with q. Qed. (** A division by itself returns 1 *) Lemma quot_same : forall a, a~=0 -> a÷a == 1. Proof. -intros. pos_or_neg a. apply NZQuot.div_same; order. +intros a ?. pos_or_neg a. apply NZQuot.div_same; order. rewrite <- quot_opp_opp by trivial. now apply NZQuot.div_same. Qed. @@ -138,7 +138,7 @@ Proof. exact NZQuot.mod_small. Qed. Lemma quot_0_l: forall a, a~=0 -> 0÷a == 0. Proof. -intros. pos_or_neg a. apply NZQuot.div_0_l; order. +intros a ?. pos_or_neg a. apply NZQuot.div_0_l; order. rewrite <- quot_opp_opp, opp_0 by trivial. now apply NZQuot.div_0_l. Qed. @@ -149,7 +149,7 @@ Qed. Lemma quot_1_r: forall a, a÷1 == a. Proof. -intros. pos_or_neg a. now apply NZQuot.div_1_r. +intros a. pos_or_neg a. now apply NZQuot.div_1_r. apply opp_inj. rewrite <- quot_opp_l. apply NZQuot.div_1_r; order. intro EQ; symmetry in EQ; revert EQ; apply lt_neq, lt_0_1. Qed. @@ -168,7 +168,7 @@ Proof. exact NZQuot.mod_1_l. Qed. Lemma quot_mul : forall a b, b~=0 -> (a*b)÷b == a. Proof. -intros. pos_or_neg a; pos_or_neg b. apply NZQuot.div_mul; order. +intros a b ?. pos_or_neg a; pos_or_neg b. apply NZQuot.div_mul; order. rewrite <- quot_opp_opp, <- mul_opp_r by order. apply NZQuot.div_mul; order. rewrite <- opp_inj_wd, <- quot_opp_l, <- mul_opp_l by order. apply NZQuot.div_mul; order. @@ -190,7 +190,7 @@ Qed. Lemma rem_nonneg : forall a b, b~=0 -> 0 <= a -> 0 <= a rem b. Proof. - intros. pos_or_neg b. destruct (rem_bound_pos a b); order. + intros a b **. pos_or_neg b. destruct (rem_bound_pos a b); order. rewrite <- rem_opp_r; trivial. destruct (rem_bound_pos a (-b)); trivial. Qed. @@ -309,7 +309,7 @@ Proof. exact NZQuot.div_str_pos. Qed. Lemma quot_small_iff : forall a b, b~=0 -> (a÷b==0 <-> abs a < abs b). Proof. -intros. pos_or_neg a; pos_or_neg b. +intros a b ?. pos_or_neg a; pos_or_neg b. rewrite NZQuot.div_small_iff; try order. rewrite 2 abs_eq; intuition; order. rewrite <- opp_inj_wd, opp_0, <- quot_opp_r, NZQuot.div_small_iff by order. rewrite (abs_eq a), (abs_neq' b); intuition; order. @@ -321,7 +321,7 @@ Qed. Lemma rem_small_iff : forall a b, b~=0 -> (a rem b == a <-> abs a < abs b). Proof. -intros. rewrite rem_eq, <- quot_small_iff by order. +intros a b ?. rewrite rem_eq, <- quot_small_iff by order. rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l. rewrite eq_sym_iff, eq_mul_0. tauto. Qed. @@ -336,7 +336,7 @@ Proof. exact NZQuot.div_lt. Qed. Lemma quot_le_mono : forall a b c, 0<c -> a<=b -> a÷c <= b÷c. Proof. -intros. pos_or_neg a. apply NZQuot.div_le_mono; auto. +intros a b c **. pos_or_neg a. apply NZQuot.div_le_mono; auto. pos_or_neg b. apply le_trans with 0. rewrite <- opp_nonneg_nonpos, <- quot_opp_l by order. apply quot_pos; order. @@ -350,7 +350,7 @@ Qed. Lemma mul_quot_le : forall a b, 0<=a -> b~=0 -> 0 <= b*(a÷b) <= a. Proof. -intros. pos_or_neg b. +intros a b **. pos_or_neg b. split. apply mul_nonneg_nonneg; [|apply quot_pos]; order. apply NZQuot.mul_div_le; order. @@ -362,7 +362,7 @@ Qed. Lemma mul_quot_ge : forall a b, a<=0 -> b~=0 -> a <= b*(a÷b) <= 0. Proof. -intros. +intros a b **. rewrite <- opp_nonneg_nonpos, opp_le_mono, <-mul_opp_r, <-quot_opp_l by order. rewrite <- opp_nonneg_nonpos in *. destruct (mul_quot_le (-a) b); tauto. @@ -415,7 +415,7 @@ Proof. exact NZQuot.div_lt_upper_bound. Qed. Theorem quot_le_upper_bound: forall a b q, 0<b -> a <= b*q -> a÷b <= q. Proof. -intros. +intros a b q **. rewrite <- (quot_mul q b) by order. apply quot_le_mono; trivial. now rewrite mul_comm. Qed. @@ -423,7 +423,7 @@ Qed. Theorem quot_le_lower_bound: forall a b q, 0<b -> b*q <= a -> q <= a÷b. Proof. -intros. +intros a b q **. rewrite <- (quot_mul q b) by order. apply quot_le_mono; trivial. now rewrite mul_comm. Qed. @@ -443,7 +443,7 @@ Lemma rem_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> (a + b * c) rem c == a rem c. Proof. assert (forall a b c, c~=0 -> 0<=a -> 0<=a+b*c -> (a+b*c) rem c == a rem c). - intros. pos_or_neg c. apply NZQuot.mod_add; order. + intros a b c **. pos_or_neg c. apply NZQuot.mod_add; order. rewrite <- (rem_opp_r a), <- (rem_opp_r (a+b*c)) by order. rewrite <- mul_opp_opp in *. apply NZQuot.mod_add; order. @@ -457,7 +457,7 @@ Qed. Lemma quot_add : forall a b c, c~=0 -> 0 <= (a+b*c)*a -> (a + b * c) ÷ c == a ÷ c + b. Proof. -intros. +intros a b c **. rewrite <- (mul_cancel_l _ _ c) by trivial. rewrite <- (add_cancel_r _ _ ((a+b*c) rem c)). rewrite <- quot_rem, rem_add by trivial. @@ -476,14 +476,14 @@ Lemma quot_mul_cancel_r : forall a b c, b~=0 -> c~=0 -> (a*c)÷(b*c) == a÷b. Proof. assert (Aux1 : forall a b c, 0<=a -> 0<b -> c~=0 -> (a*c)÷(b*c) == a÷b). - intros. pos_or_neg c. apply NZQuot.div_mul_cancel_r; order. + intros a b c **. pos_or_neg c. apply NZQuot.div_mul_cancel_r; order. rewrite <- quot_opp_opp, <- 2 mul_opp_r. apply NZQuot.div_mul_cancel_r; order. rewrite <- neq_mul_0; intuition order. assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a*c)÷(b*c) == a÷b). - intros. pos_or_neg b. apply Aux1; order. + intros a b c **. pos_or_neg b. apply Aux1; order. apply opp_inj. rewrite <- 2 quot_opp_r, <- mul_opp_l; try order. apply Aux1; order. rewrite <- neq_mul_0; intuition order. -intros. pos_or_neg a. apply Aux2; order. +intros a b c **. pos_or_neg a. apply Aux2; order. apply opp_inj. rewrite <- 2 quot_opp_l, <- mul_opp_l; try order. apply Aux2; order. rewrite <- neq_mul_0; intuition order. Qed. @@ -491,13 +491,13 @@ Qed. Lemma quot_mul_cancel_l : forall a b c, b~=0 -> c~=0 -> (c*a)÷(c*b) == a÷b. Proof. -intros. rewrite !(mul_comm c); now apply quot_mul_cancel_r. +intros a b c **. rewrite !(mul_comm c); now apply quot_mul_cancel_r. Qed. Lemma mul_rem_distr_r: forall a b c, b~=0 -> c~=0 -> (a*c) rem (b*c) == (a rem b) * c. Proof. -intros. +intros a b c **. assert (b*c ~= 0) by (rewrite <- neq_mul_0; tauto). rewrite ! rem_eq by trivial. rewrite quot_mul_cancel_r by order. @@ -507,7 +507,7 @@ Qed. Lemma mul_rem_distr_l: forall a b c, b~=0 -> c~=0 -> (c*a) rem (c*b) == c * (a rem b). Proof. -intros; rewrite !(mul_comm c); now apply mul_rem_distr_r. +intros a b c **; rewrite !(mul_comm c); now apply mul_rem_distr_r. Qed. (** Operations modulo. *) @@ -515,7 +515,7 @@ Qed. Theorem rem_rem: forall a n, n~=0 -> (a rem n) rem n == a rem n. Proof. -intros. pos_or_neg a; pos_or_neg n. apply NZQuot.mod_mod; order. +intros a n **. pos_or_neg a; pos_or_neg n. apply NZQuot.mod_mod; order. rewrite <- ! (rem_opp_r _ n) by trivial. apply NZQuot.mod_mod; order. apply opp_inj. rewrite <- !rem_opp_l by order. apply NZQuot.mod_mod; order. apply opp_inj. rewrite <- !rem_opp_opp by order. apply NZQuot.mod_mod; order. @@ -526,11 +526,11 @@ Lemma mul_rem_idemp_l : forall a b n, n~=0 -> Proof. assert (Aux1 : forall a b n, 0<=a -> 0<=b -> n~=0 -> ((a rem n)*b) rem n == (a*b) rem n). - intros. pos_or_neg n. apply NZQuot.mul_mod_idemp_l; order. + intros a b n **. pos_or_neg n. apply NZQuot.mul_mod_idemp_l; order. rewrite <- ! (rem_opp_r _ n) by order. apply NZQuot.mul_mod_idemp_l; order. assert (Aux2 : forall a b n, 0<=a -> n~=0 -> ((a rem n)*b) rem n == (a*b) rem n). - intros. pos_or_neg b. now apply Aux1. + intros a b n **. pos_or_neg b. now apply Aux1. apply opp_inj. rewrite <-2 rem_opp_l, <-2 mul_opp_r by order. apply Aux1; order. intros a b n Hn. pos_or_neg a. now apply Aux2. @@ -541,7 +541,7 @@ Qed. Lemma mul_rem_idemp_r : forall a b n, n~=0 -> (a*(b rem n)) rem n == (a*b) rem n. Proof. -intros. rewrite !(mul_comm a). now apply mul_rem_idemp_l. +intros a b n **. rewrite !(mul_comm a). now apply mul_rem_idemp_l. Qed. Theorem mul_rem: forall a b n, n~=0 -> @@ -564,7 +564,7 @@ Lemma add_rem_idemp_l : forall a b n, n~=0 -> 0 <= a*b -> Proof. assert (Aux : forall a b n, 0<=a -> 0<=b -> n~=0 -> ((a rem n)+b) rem n == (a+b) rem n). - intros. pos_or_neg n. apply NZQuot.add_mod_idemp_l; order. + intros a b n **. pos_or_neg n. apply NZQuot.add_mod_idemp_l; order. rewrite <- ! (rem_opp_r _ n) by order. apply NZQuot.add_mod_idemp_l; order. intros a b n Hn Hab. destruct (le_0_mul _ _ Hab) as [(Ha,Hb)|(Ha,Hb)]. now apply Aux. @@ -576,7 +576,7 @@ Qed. Lemma add_rem_idemp_r : forall a b n, n~=0 -> 0 <= a*b -> (a+(b rem n)) rem n == (a+b) rem n. Proof. -intros. rewrite !(add_comm a). apply add_rem_idemp_l; trivial. +intros a b n **. rewrite !(add_comm a). apply add_rem_idemp_l; trivial. now rewrite mul_comm. Qed. @@ -598,16 +598,16 @@ Lemma quot_quot : forall a b c, b~=0 -> c~=0 -> (a÷b)÷c == a÷(b*c). Proof. assert (Aux1 : forall a b c, 0<=a -> 0<b -> c~=0 -> (a÷b)÷c == a÷(b*c)). - intros. pos_or_neg c. apply NZQuot.div_div; order. + intros a b c **. pos_or_neg c. apply NZQuot.div_div; order. apply opp_inj. rewrite <- 2 quot_opp_r, <- mul_opp_r; trivial. apply NZQuot.div_div; order. rewrite <- neq_mul_0; intuition order. assert (Aux2 : forall a b c, 0<=a -> b~=0 -> c~=0 -> (a÷b)÷c == a÷(b*c)). - intros. pos_or_neg b. apply Aux1; order. + intros a b c **. pos_or_neg b. apply Aux1; order. apply opp_inj. rewrite <- quot_opp_l, <- 2 quot_opp_r, <- mul_opp_l; trivial. apply Aux1; trivial. rewrite <- neq_mul_0; intuition order. -intros. pos_or_neg a. apply Aux2; order. +intros a b c **. pos_or_neg a. apply Aux2; order. apply opp_inj. rewrite <- 3 quot_opp_l; try order. apply Aux2; order. rewrite <- neq_mul_0. tauto. Qed. diff --git a/theories/Numbers/Integer/Abstract/ZGcd.v b/theories/Numbers/Integer/Abstract/ZGcd.v index 09d28a18ec..755557ff17 100644 --- a/theories/Numbers/Integer/Abstract/ZGcd.v +++ b/theories/Numbers/Integer/Abstract/ZGcd.v @@ -98,7 +98,7 @@ Qed. Lemma gcd_abs_l : forall n m, gcd (abs n) m == gcd n m. Proof. - intros. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. + intros n m. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. easy. apply gcd_opp_l. Qed. @@ -125,7 +125,7 @@ Qed. Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m. Proof. - intros. apply gcd_unique_alt; try apply gcd_nonneg. + intros n m p. apply gcd_unique_alt; try apply gcd_nonneg. intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial. apply divide_add_r; trivial. now apply divide_mul_r. apply divide_add_cancel_r with (p*n); trivial. @@ -164,12 +164,12 @@ Proof. (* First, a version restricted to natural numbers *) assert (aux : forall n, 0<=n -> forall m, 0<=m -> Bezout n m (gcd n m)). intros n Hn; pattern n. - apply strong_right_induction with (z:=0); trivial. + apply (fun H => strong_right_induction _ H 0); trivial. unfold Bezout. solve_proper. clear n Hn. intros n Hn IHn. apply le_lteq in Hn; destruct Hn as [Hn|Hn]. intros m Hm; pattern m. - apply strong_right_induction with (z:=0); trivial. + apply (fun H => strong_right_induction _ H 0); trivial. unfold Bezout. solve_proper. clear m Hm. intros m Hm IHm. destruct (lt_trichotomy n m) as [LT|[EQ|LT]]. @@ -227,7 +227,7 @@ Qed. Lemma gcd_mul_mono_l_nonneg : forall n m p, 0<=p -> gcd (p*n) (p*m) == p * gcd n m. Proof. - intros. rewrite <- (abs_eq p) at 3; trivial. apply gcd_mul_mono_l. + intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply gcd_mul_mono_l. Qed. Lemma gcd_mul_mono_r : @@ -239,7 +239,7 @@ Qed. Lemma gcd_mul_mono_r_nonneg : forall n m p, 0<=p -> gcd (n*p) (m*p) == gcd n m * p. Proof. - intros. rewrite <- (abs_eq p) at 3; trivial. apply gcd_mul_mono_r. + intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply gcd_mul_mono_r. Qed. Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p). diff --git a/theories/Numbers/Integer/Abstract/ZLcm.v b/theories/Numbers/Integer/Abstract/ZLcm.v index 6aa828ebfc..c45ea12868 100644 --- a/theories/Numbers/Integer/Abstract/ZLcm.v +++ b/theories/Numbers/Integer/Abstract/ZLcm.v @@ -33,14 +33,14 @@ Module Type ZLcmProp Lemma quot_div_nonneg : forall a b, 0<=a -> 0<b -> a÷b == a/b. Proof. - intros. apply div_unique_pos with (a rem b). + intros a b **. apply div_unique_pos with (a rem b). now apply rem_bound_pos. apply quot_rem. order. Qed. Lemma rem_mod_nonneg : forall a b, 0<=a -> 0<b -> a rem b == a mod b. Proof. - intros. apply mod_unique_pos with (a÷b). + intros a b **. apply mod_unique_pos with (a÷b). now apply rem_bound_pos. apply quot_rem. order. Qed. @@ -290,7 +290,7 @@ Qed. Lemma lcm_divide_iff : forall n m p, (lcm n m | p) <-> (n | p) /\ (m | p). Proof. - intros. split. split. + intros n m p. split. split. transitivity (lcm n m); trivial using divide_lcm_l. transitivity (lcm n m); trivial using divide_lcm_r. intros (H,H'). now apply lcm_least. @@ -387,7 +387,7 @@ Qed. Lemma lcm_abs_l : forall n m, lcm (abs n) m == lcm n m. Proof. - intros. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. + intros n m. destruct (abs_eq_or_opp n) as [H|H]; rewrite H. easy. apply lcm_opp_l. Qed. @@ -438,7 +438,7 @@ Qed. Lemma lcm_mul_mono_l_nonneg : forall n m p, 0<=p -> lcm (p*n) (p*m) == p * lcm n m. Proof. - intros. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_l. + intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_l. Qed. Lemma lcm_mul_mono_r : @@ -450,7 +450,7 @@ Qed. Lemma lcm_mul_mono_r_nonneg : forall n m p, 0<=p -> lcm (n*p) (m*p) == lcm n m * p. Proof. - intros. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_r. + intros n m p ?. rewrite <- (abs_eq p) at 3; trivial. apply lcm_mul_mono_r. Qed. Lemma gcd_1_lcm_mul : forall n m, n~=0 -> m~=0 -> diff --git a/theories/Numbers/Integer/Abstract/ZMaxMin.v b/theories/Numbers/Integer/Abstract/ZMaxMin.v index ed0b0c69a0..4af24b7754 100644 --- a/theories/Numbers/Integer/Abstract/ZMaxMin.v +++ b/theories/Numbers/Integer/Abstract/ZMaxMin.v @@ -20,133 +20,133 @@ Include ZMulOrderProp Z. (** Succ *) -Lemma succ_max_distr : forall n m, S (max n m) == max (S n) (S m). +Lemma succ_max_distr n m : S (max n m) == max (S n) (S m). Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono. Qed. -Lemma succ_min_distr : forall n m, S (min n m) == min (S n) (S m). +Lemma succ_min_distr n m : S (min n m) == min (S n) (S m). Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?succ_le_mono. Qed. (** Pred *) -Lemma pred_max_distr : forall n m, P (max n m) == max (P n) (P m). +Lemma pred_max_distr n m : P (max n m) == max (P n) (P m). Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?pred_le_mono. Qed. -Lemma pred_min_distr : forall n m, P (min n m) == min (P n) (P m). +Lemma pred_min_distr n m : P (min n m) == min (P n) (P m). Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?pred_le_mono. Qed. (** Add *) -Lemma add_max_distr_l : forall n m p, max (p + n) (p + m) == p + max n m. +Lemma add_max_distr_l n m p : max (p + n) (p + m) == p + max n m. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_l. Qed. -Lemma add_max_distr_r : forall n m p, max (n + p) (m + p) == max n m + p. +Lemma add_max_distr_r n m p : max (n + p) (m + p) == max n m + p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_r. Qed. -Lemma add_min_distr_l : forall n m p, min (p + n) (p + m) == p + min n m. +Lemma add_min_distr_l n m p : min (p + n) (p + m) == p + min n m. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_l. Qed. -Lemma add_min_distr_r : forall n m p, min (n + p) (m + p) == min n m + p. +Lemma add_min_distr_r n m p : min (n + p) (m + p) == min n m + p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_r. Qed. (** Opp *) -Lemma opp_max_distr : forall n m, -(max n m) == min (-n) (-m). +Lemma opp_max_distr n m : -(max n m) == min (-n) (-m). Proof. - intros. destruct (le_ge_cases n m). + destruct (le_ge_cases n m). rewrite max_r by trivial. symmetry. apply min_r. now rewrite <- opp_le_mono. rewrite max_l by trivial. symmetry. apply min_l. now rewrite <- opp_le_mono. Qed. -Lemma opp_min_distr : forall n m, -(min n m) == max (-n) (-m). +Lemma opp_min_distr n m : -(min n m) == max (-n) (-m). Proof. - intros. destruct (le_ge_cases n m). + destruct (le_ge_cases n m). rewrite min_l by trivial. symmetry. apply max_l. now rewrite <- opp_le_mono. rewrite min_r by trivial. symmetry. apply max_r. now rewrite <- opp_le_mono. Qed. (** Sub *) -Lemma sub_max_distr_l : forall n m p, max (p - n) (p - m) == p - min n m. +Lemma sub_max_distr_l n m p : max (p - n) (p - m) == p - min n m. Proof. - intros. destruct (le_ge_cases n m). + destruct (le_ge_cases n m). rewrite min_l by trivial. apply max_l. now rewrite <- sub_le_mono_l. rewrite min_r by trivial. apply max_r. now rewrite <- sub_le_mono_l. Qed. -Lemma sub_max_distr_r : forall n m p, max (n - p) (m - p) == max n m - p. +Lemma sub_max_distr_r n m p : max (n - p) (m - p) == max n m - p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply sub_le_mono_r. Qed. -Lemma sub_min_distr_l : forall n m p, min (p - n) (p - m) == p - max n m. +Lemma sub_min_distr_l n m p : min (p - n) (p - m) == p - max n m. Proof. - intros. destruct (le_ge_cases n m). + destruct (le_ge_cases n m). rewrite max_r by trivial. apply min_r. now rewrite <- sub_le_mono_l. rewrite max_l by trivial. apply min_l. now rewrite <- sub_le_mono_l. Qed. -Lemma sub_min_distr_r : forall n m p, min (n - p) (m - p) == min n m - p. +Lemma sub_min_distr_r n m p : min (n - p) (m - p) == min n m - p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply sub_le_mono_r. Qed. (** Mul *) -Lemma mul_max_distr_nonneg_l : forall n m p, 0 <= p -> +Lemma mul_max_distr_nonneg_l n m p : 0 <= p -> max (p * n) (p * m) == p * max n m. Proof. intros. destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_nonneg_l. Qed. -Lemma mul_max_distr_nonneg_r : forall n m p, 0 <= p -> +Lemma mul_max_distr_nonneg_r n m p : 0 <= p -> max (n * p) (m * p) == max n m * p. Proof. intros. destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_nonneg_r. Qed. -Lemma mul_min_distr_nonneg_l : forall n m p, 0 <= p -> +Lemma mul_min_distr_nonneg_l n m p : 0 <= p -> min (p * n) (p * m) == p * min n m. Proof. intros. destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_nonneg_l. Qed. -Lemma mul_min_distr_nonneg_r : forall n m p, 0 <= p -> +Lemma mul_min_distr_nonneg_r n m p : 0 <= p -> min (n * p) (m * p) == min n m * p. Proof. intros. destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_nonneg_r. Qed. -Lemma mul_max_distr_nonpos_l : forall n m p, p <= 0 -> +Lemma mul_max_distr_nonpos_l n m p : p <= 0 -> max (p * n) (p * m) == p * min n m. Proof. intros. destruct (le_ge_cases n m). @@ -154,7 +154,7 @@ Proof. rewrite min_r by trivial. rewrite max_r. reflexivity. now apply mul_le_mono_nonpos_l. Qed. -Lemma mul_max_distr_nonpos_r : forall n m p, p <= 0 -> +Lemma mul_max_distr_nonpos_r n m p : p <= 0 -> max (n * p) (m * p) == min n m * p. Proof. intros. destruct (le_ge_cases n m). @@ -162,7 +162,7 @@ Proof. rewrite min_r by trivial. rewrite max_r. reflexivity. now apply mul_le_mono_nonpos_r. Qed. -Lemma mul_min_distr_nonpos_l : forall n m p, p <= 0 -> +Lemma mul_min_distr_nonpos_l n m p : p <= 0 -> min (p * n) (p * m) == p * max n m. Proof. intros. destruct (le_ge_cases n m). @@ -170,7 +170,7 @@ Proof. rewrite max_l by trivial. rewrite min_l. reflexivity. now apply mul_le_mono_nonpos_l. Qed. -Lemma mul_min_distr_nonpos_r : forall n m p, p <= 0 -> +Lemma mul_min_distr_nonpos_r n m p : p <= 0 -> min (n * p) (m * p) == max n m * p. Proof. intros. destruct (le_ge_cases n m). diff --git a/theories/Numbers/Integer/Abstract/ZMulOrder.v b/theories/Numbers/Integer/Abstract/ZMulOrder.v index 7d97d11818..0275a5fa65 100644 --- a/theories/Numbers/Integer/Abstract/ZMulOrder.v +++ b/theories/Numbers/Integer/Abstract/ZMulOrder.v @@ -167,7 +167,7 @@ Qed. Theorem eq_mul_1 : forall n m, n * m == 1 -> n == 1 \/ n == -1. Proof. assert (F := lt_m1_0). -zero_pos_neg n. +intro n; zero_pos_neg n. (* n = 0 *) intros m. nzsimpl. now left. (* 0 < n, proving P n /\ P (-n) *) @@ -205,7 +205,7 @@ Qed. Theorem lt_mul_r : forall n m p, 0 < n -> 1 < p -> n < m -> n < m * p. Proof. -intros. stepl (n * 1) by now rewrite mul_1_r. +intros n m p **. stepl (n * 1) by now rewrite mul_1_r. apply mul_lt_mono_nonneg. now apply lt_le_incl. assumption. apply le_0_1. assumption. Qed. diff --git a/theories/Numbers/Integer/Abstract/ZParity.v b/theories/Numbers/Integer/Abstract/ZParity.v index 4b61b18479..0f68278cf0 100644 --- a/theories/Numbers/Integer/Abstract/ZParity.v +++ b/theories/Numbers/Integer/Abstract/ZParity.v @@ -19,19 +19,19 @@ Include NZParityProp Z Z ZP. Lemma odd_pred : forall n, odd (P n) = even n. Proof. - intros. rewrite <- (succ_pred n) at 2. symmetry. apply even_succ. + intros n. rewrite <- (succ_pred n) at 2. symmetry. apply even_succ. Qed. Lemma even_pred : forall n, even (P n) = odd n. Proof. - intros. rewrite <- (succ_pred n) at 2. symmetry. apply odd_succ. + intros n. rewrite <- (succ_pred n) at 2. symmetry. apply odd_succ. Qed. Lemma even_opp : forall n, even (-n) = even n. Proof. assert (H : forall n, Even n -> Even (-n)). intros n (m,H). exists (-m). rewrite mul_opp_r. now f_equiv. - intros. rewrite eq_iff_eq_true, !even_spec. + intros n. rewrite eq_iff_eq_true, !even_spec. split. rewrite <- (opp_involutive n) at 2. apply H. apply H. Qed. diff --git a/theories/Numbers/Integer/Abstract/ZPow.v b/theories/Numbers/Integer/Abstract/ZPow.v index bec77fd136..9557212a86 100644 --- a/theories/Numbers/Integer/Abstract/ZPow.v +++ b/theories/Numbers/Integer/Abstract/ZPow.v @@ -73,7 +73,7 @@ Qed. Lemma pow_even_abs : forall a b, Even b -> a^b == (abs a)^b. Proof. - intros. destruct (abs_eq_or_opp a) as [EQ|EQ]; rewrite EQ. + intros a b ?. destruct (abs_eq_or_opp a) as [EQ|EQ]; rewrite EQ. reflexivity. symmetry. now apply pow_opp_even. Qed. @@ -119,7 +119,7 @@ Qed. Lemma abs_pow : forall a b, abs (a^b) == (abs a)^b. Proof. intros a b. - destruct (Even_or_Odd b). + destruct (Even_or_Odd b) as [H|H]. rewrite pow_even_abs by trivial. apply abs_eq, pow_nonneg, abs_nonneg. rewrite pow_odd_abs_sgn by trivial. diff --git a/theories/Numbers/Integer/Abstract/ZSgnAbs.v b/theories/Numbers/Integer/Abstract/ZSgnAbs.v index 03e0c0345d..3ebbec9397 100644 --- a/theories/Numbers/Integer/Abstract/ZSgnAbs.v +++ b/theories/Numbers/Integer/Abstract/ZSgnAbs.v @@ -40,11 +40,11 @@ Module Type GenericSgn (Import Z : ZDecAxiomsSig') (Import ZP : ZMulOrderProp Z) <: HasSgn Z. Definition sgn n := match compare 0 n with Eq => 0 | Lt => 1 | Gt => -1 end. - Lemma sgn_null : forall n, n==0 -> sgn n == 0. + Lemma sgn_null n : n==0 -> sgn n == 0. Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. - Lemma sgn_pos : forall n, 0<n -> sgn n == 1. + Lemma sgn_pos n : 0<n -> sgn n == 1. Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. - Lemma sgn_neg : forall n, n<0 -> sgn n == -1. + Lemma sgn_neg n : n<0 -> sgn n == -1. Proof. unfold sgn; intros. destruct (compare_spec 0 n); order. Qed. End GenericSgn. @@ -101,7 +101,7 @@ Qed. Lemma abs_opp : forall n, abs (-n) == abs n. Proof. - intros. destruct_max n. + intros n. destruct_max n. rewrite (abs_neq (-n)), opp_involutive. reflexivity. now rewrite opp_nonpos_nonneg. rewrite (abs_eq (-n)). reflexivity. @@ -115,14 +115,14 @@ Qed. Lemma abs_0_iff : forall n, abs n == 0 <-> n==0. Proof. - split. destruct_max n; auto. + intros n; split. destruct_max n; auto. now rewrite eq_opp_l, opp_0. intros EQ; rewrite EQ. rewrite abs_eq; auto using eq_refl, le_refl. Qed. Lemma abs_pos : forall n, 0 < abs n <-> n~=0. Proof. - intros. rewrite <- abs_0_iff. split; [intros LT| intros NEQ]. + intros n. rewrite <- abs_0_iff. split; [intros LT| intros NEQ]. intro EQ. rewrite EQ in LT. now elim (lt_irrefl 0). assert (LE : 0 <= abs n) by apply abs_nonneg. rewrite lt_eq_cases in LE; destruct LE; auto. @@ -131,12 +131,12 @@ Qed. Lemma abs_eq_or_opp : forall n, abs n == n \/ abs n == -n. Proof. - intros. destruct_max n; auto with relations. + intros n. destruct_max n; auto with relations. Qed. Lemma abs_or_opp_abs : forall n, n == abs n \/ n == - abs n. Proof. - intros. destruct_max n; rewrite ? opp_involutive; auto with relations. + intros n. destruct_max n; rewrite ? opp_involutive; auto with relations. Qed. Lemma abs_involutive : forall n, abs (abs n) == abs n. @@ -147,7 +147,7 @@ Qed. Lemma abs_spec : forall n, (0 <= n /\ abs n == n) \/ (n < 0 /\ abs n == -n). Proof. - intros. destruct (le_gt_cases 0 n). + intros n. destruct (le_gt_cases 0 n). left; split; auto. now apply abs_eq. right; split; auto. apply abs_neq. now apply lt_le_incl. Qed. @@ -156,7 +156,7 @@ Lemma abs_case_strong : forall (P:t->Prop) n, Proper (eq==>iff) P -> (0<=n -> P n) -> (n<=0 -> P (-n)) -> P (abs n). Proof. - intros. destruct_max n; auto. + intros P n **. destruct_max n; auto. Qed. Lemma abs_case : forall (P:t->Prop) n, Proper (eq==>iff) P -> @@ -196,7 +196,7 @@ Qed. Lemma abs_triangle : forall n m, abs (n + m) <= abs n + abs m. Proof. - intros. destruct_max n; destruct_max m. + intros n m. destruct_max n; destruct_max m. rewrite abs_eq. apply le_refl. now apply add_nonneg_nonneg. destruct_max (n+m); try rewrite opp_add_distr; apply add_le_mono_l || apply add_le_mono_r. @@ -212,7 +212,7 @@ Qed. Lemma abs_sub_triangle : forall n m, abs n - abs m <= abs (n-m). Proof. - intros. + intros n m. rewrite le_sub_le_add_l, add_comm. rewrite <- (sub_simpl_r n m) at 1. apply abs_triangle. @@ -223,10 +223,10 @@ Qed. Lemma abs_mul : forall n m, abs (n * m) == abs n * abs m. Proof. assert (H : forall n m, 0<=n -> abs (n*m) == n * abs m). - intros. destruct_max m. + intros n m ?. destruct_max m. rewrite abs_eq. apply eq_refl. now apply mul_nonneg_nonneg. rewrite abs_neq, mul_opp_r. reflexivity. now apply mul_nonneg_nonpos . - intros. destruct_max n. now apply H. + intros n m. destruct_max n. now apply H. rewrite <- mul_opp_opp, H, abs_opp. reflexivity. now apply opp_nonneg_nonpos. Qed. @@ -271,7 +271,7 @@ Qed. Lemma sgn_pos_iff : forall n, sgn n == 1 <-> 0<n. Proof. - split; try apply sgn_pos. destruct_sgn n; auto. + intros n; split; try apply sgn_pos. destruct_sgn n; auto. intros. elim (lt_neq 0 1); auto. apply lt_0_1. intros. elim (lt_neq (-1) 1); auto. apply lt_trans with 0. rewrite opp_neg_pos. apply lt_0_1. apply lt_0_1. @@ -279,7 +279,7 @@ Qed. Lemma sgn_null_iff : forall n, sgn n == 0 <-> n==0. Proof. - split; try apply sgn_null. destruct_sgn n; auto with relations. + intros n; split; try apply sgn_null. destruct_sgn n; auto with relations. intros. elim (lt_neq 0 1); auto with relations. apply lt_0_1. intros. elim (lt_neq (-1) 0); auto. rewrite opp_neg_pos. apply lt_0_1. @@ -287,7 +287,7 @@ Qed. Lemma sgn_neg_iff : forall n, sgn n == -1 <-> n<0. Proof. - split; try apply sgn_neg. destruct_sgn n; auto with relations. + intros n; split; try apply sgn_neg. destruct_sgn n; auto with relations. intros. elim (lt_neq (-1) 1); auto with relations. apply lt_trans with 0. rewrite opp_neg_pos. apply lt_0_1. apply lt_0_1. intros. elim (lt_neq (-1) 0); auto with relations. @@ -296,7 +296,7 @@ Qed. Lemma sgn_opp : forall n, sgn (-n) == - sgn n. Proof. - intros. destruct_sgn n. + intros n. destruct_sgn n. apply sgn_neg. now rewrite opp_neg_pos. setoid_replace n with 0 by auto with relations. rewrite opp_0. apply sgn_0. @@ -305,7 +305,7 @@ Qed. Lemma sgn_nonneg : forall n, 0 <= sgn n <-> 0 <= n. Proof. - split. + intros n; split. destruct_sgn n; intros. now apply lt_le_incl. order. @@ -323,7 +323,7 @@ Qed. Lemma sgn_mul : forall n m, sgn (n*m) == sgn n * sgn m. Proof. - intros. destruct_sgn n; nzsimpl. + intros n m. destruct_sgn n; nzsimpl. destruct_sgn m. apply sgn_pos. now apply mul_pos_pos. apply sgn_null. rewrite eq_mul_0; auto with relations. @@ -337,7 +337,7 @@ Qed. Lemma sgn_abs : forall n, n * sgn n == abs n. Proof. - intros. symmetry. + intros n. symmetry. destruct_sgn n; try rewrite mul_opp_r; nzsimpl. apply abs_eq. now apply lt_le_incl. rewrite abs_0_iff; auto with relations. @@ -346,7 +346,7 @@ Qed. Lemma abs_sgn : forall n, abs n * sgn n == n. Proof. - intros. + intros n. destruct_sgn n; try rewrite mul_opp_r; nzsimpl; auto. apply abs_eq. now apply lt_le_incl. rewrite eq_opp_l. apply abs_neq. now apply lt_le_incl. @@ -354,7 +354,7 @@ Qed. Lemma sgn_sgn : forall x, sgn (sgn x) == sgn x. Proof. - intros. + intros x. destruct (sgn_spec x) as [(LT,EQ)|[(EQ',EQ)|(LT,EQ)]]; rewrite EQ. apply sgn_pos, lt_0_1. now apply sgn_null. 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/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v index b41cd571dc..2ec9f4d871 100644 --- a/theories/PArith/BinPosDef.v +++ b/theories/PArith/BinPosDef.v @@ -639,10 +639,10 @@ Fixpoint of_hex_uint (d:Hexadecimal.uint) : N := | Hexadecimal.Df l => Npos (of_hex_uint_acc l 1~1~1~1) end. -Definition of_num_uint (d:Numeral.uint) : N := +Definition of_num_uint (d:Number.uint) : N := match d with - | Numeral.UIntDec d => of_uint d - | Numeral.UIntHex d => of_hex_uint d + | Number.UIntDecimal d => of_uint d + | Number.UIntHexadecimal d => of_hex_uint d end. Definition of_int (d:Decimal.int) : option positive := @@ -665,10 +665,10 @@ Definition of_hex_int (d:Hexadecimal.int) : option positive := | Hexadecimal.Neg _ => None end. -Definition of_num_int (d:Numeral.int) : option positive := +Definition of_num_int (d:Number.int) : option positive := match d with - | Numeral.IntDec d => of_int d - | Numeral.IntHex d => of_hex_int d + | Number.IntDecimal d => of_int d + | Number.IntHexadecimal d => of_hex_int d end. Fixpoint to_little_uint p := @@ -689,13 +689,13 @@ Fixpoint to_little_hex_uint p := Definition to_hex_uint p := Hexadecimal.rev (to_little_hex_uint p). -Definition to_num_uint p := Numeral.UIntDec (to_uint p). +Definition to_num_uint p := Number.UIntDecimal (to_uint p). Definition to_int n := Decimal.Pos (to_uint n). Definition to_hex_int p := Hexadecimal.Pos (to_hex_uint p). -Definition to_num_int n := Numeral.IntDec (to_int n). +Definition to_num_int n := Number.IntDecimal (to_int n). Number Notation positive of_num_int to_num_uint : positive_scope. 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 192dcd885b..b008c6c2aa 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -18,6 +18,9 @@ Require Export Morphisms Setoid Bool. Record Q : Set := Qmake {Qnum : Z; Qden : positive}. +Declare Scope hex_Q_scope. +Delimit Scope hex_Q_scope with xQ. + Declare Scope Q_scope. Delimit Scope Q_scope with Q. Bind Scope Q_scope with Q. @@ -33,104 +36,6 @@ Ltac simpl_mult := rewrite ?Pos2Z.inj_mul. Notation "a # b" := (Qmake a b) (at level 55, no associativity) : Q_scope. -Definition of_decimal (d:Decimal.decimal) : Q := - let '(i, f, e) := - match d with - | Decimal.Decimal i f => (i, f, Decimal.Pos Decimal.Nil) - | Decimal.DecimalExp i f e => (i, f, e) - end in - let num := Z.of_int (Decimal.app_int i f) in - let e := Z.sub (Z.of_int e) (Z.of_nat (Decimal.nb_digits f)) in - match e with - | Z0 => Qmake num 1 - | Zpos e => Qmake (Pos.iter (Z.mul 10) num e) 1 - | Zneg e => Qmake num (Pos.iter (Pos.mul 10) 1%positive e) - end. - -Definition to_decimal (q:Q) : option Decimal.decimal := - (* choose between 123e-2 and 1.23, this is purely heuristic - and doesn't play any soundness role *) - let choose_exponent i ne := - let i := match i with Decimal.Pos i | Decimal.Neg i => i end in - let li := Decimal.nb_digits i in - let le := Decimal.nb_digits (Nat.to_uint ne) in - Nat.ltb (Nat.add li le) ne in - (* print 123 / 100 as 123e-2 *) - let decimal_exponent i ne := - let e := Z.to_int (Z.opp (Z.of_nat ne)) in - Decimal.DecimalExp i Decimal.Nil e in - (* print 123 / 100 as 1.23 *) - let decimal_dot i ne := - let ai := match i with Decimal.Pos i | Decimal.Neg i => i end in - let ni := Decimal.nb_digits ai in - if Nat.ltb ne ni then - let i := Decimal.del_tail_int ne i in - let f := Decimal.del_head (Nat.sub ni ne) ai in - Decimal.Decimal i f - else - let z := match i with - | Decimal.Pos _ => Decimal.Pos (Decimal.zero) - | Decimal.Neg _ => Decimal.Neg (Decimal.zero) end in - Decimal.Decimal z (Nat.iter (Nat.sub ne ni) Decimal.D0 ai) in - let num := Z.to_int (Qnum q) in - let (den, e_den) := Decimal.nztail (Pos.to_uint (Qden q)) in - match den with - | Decimal.D1 Decimal.Nil => - match e_den with - | O => Some (Decimal.Decimal num Decimal.Nil) - | ne => - if choose_exponent num ne then Some (decimal_exponent num ne) - else Some (decimal_dot num ne) - end - | _ => None - end. - -Definition of_hexadecimal (d:Hexadecimal.hexadecimal) : Q := - let '(i, f, e) := - match d with - | Hexadecimal.Hexadecimal i f => (i, f, Decimal.Pos Decimal.Nil) - | Hexadecimal.HexadecimalExp i f e => (i, f, e) - end in - let num := Z.of_hex_int (Hexadecimal.app_int i f) in - let e := Z.sub (Z.of_int e) (Z.mul 4 (Z.of_nat (Hexadecimal.nb_digits f))) in - match e with - | Z0 => Qmake num 1 - | Zpos e => Qmake (Pos.iter (Z.mul 2) num e) 1 - | Zneg e => Qmake num (Pos.iter (Pos.mul 2) 1%positive e) - end. - -Definition to_hexadecimal (q:Q) : option Hexadecimal.hexadecimal := - let mk_exp i e := - Hexadecimal.HexadecimalExp i Hexadecimal.Nil (Z.to_int (Z.opp e)) in - let num := Z.to_hex_int (Qnum q) in - let (den, e_den) := Hexadecimal.nztail (Pos.to_hex_uint (Qden q)) in - let e := Z.of_nat e_den in - match den with - | Hexadecimal.D1 Hexadecimal.Nil => - match e_den with - | O => Some (Hexadecimal.Hexadecimal num Hexadecimal.Nil) - | _ => Some (mk_exp num (4 * e)%Z) - end - | Hexadecimal.D2 Hexadecimal.Nil => Some (mk_exp num (1 + 4 * e)%Z) - | Hexadecimal.D4 Hexadecimal.Nil => Some (mk_exp num (2 + 4 * e)%Z) - | Hexadecimal.D8 Hexadecimal.Nil => Some (mk_exp num (3 + 4 * e)%Z) - | _ => None - end. - -Definition of_numeral (d:Numeral.numeral) : option Q := - match d with - | Numeral.Dec d => Some (of_decimal d) - | Numeral.Hex d => Some (of_hexadecimal d) - end. - -Definition to_numeral (q:Q) : option Numeral.numeral := - match to_decimal q with - | None => None - | Some q => Some (Numeral.Dec q) - end. - -Number Notation Q of_numeral to_numeral : Q_scope. - Definition inject_Z (x : Z) := Qmake x 1. Arguments inject_Z x%Z. @@ -190,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). @@ -222,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. *) @@ -298,6 +207,7 @@ Proof. rewrite !Qeq_bool_iff; apply Qeq_trans. Qed. +#[global] Hint Resolve Qnot_eq_sym : qarith. (** * Addition, multiplication and opposite *) @@ -316,7 +226,7 @@ Definition Qminus (x y : Q) := Qplus x (Qopp y). Definition Qinv (x : Q) := match Qnum x with - | Z0 => 0 + | Z0 => 0#1 | Zpos p => (QDen x)#p | Zneg p => (Zneg (Qden x))#p end. @@ -335,6 +245,188 @@ Register Qminus as rat.Q.Qminus. Register Qopp as rat.Q.Qopp. Register Qmult as rat.Q.Qmult. +(** Number notation for constants *) + +Inductive IZ := + | IZpow_pos : Z -> positive -> IZ + | IZ0 : IZ + | IZpos : positive -> IZ + | IZneg : positive -> IZ. + +Inductive IQ := + | IQmake : IZ -> positive -> IQ + | IQmult : IQ -> IQ -> IQ + | IQdiv : IQ -> IQ -> IQ. + +Definition IZ_of_Z z := + match z with + | Z0 => IZ0 + | Zpos e => IZpos e + | Zneg e => IZneg e + end. + +Definition IZ_to_Z z := + match z with + | IZ0 => Some Z0 + | IZpos e => Some (Zpos e) + | IZneg e => Some (Zneg e) + | IZpow_pos _ _ => None + end. + +Definition of_decimal (d:Decimal.decimal) : IQ := + let '(i, f, e) := + match d with + | Decimal.Decimal i f => (i, f, Decimal.Pos Decimal.Nil) + | Decimal.DecimalExp i f e => (i, f, e) + end in + let num := Z.of_int (Decimal.app_int i f) in + let den := Nat.iter (Decimal.nb_digits f) (Pos.mul 10) 1%positive in + let q := IQmake (IZ_of_Z num) den in + let e := Z.of_int e in + match e with + | Z0 => q + | Zpos e => IQmult q (IQmake (IZpow_pos 10 e) 1) + | Zneg e => IQdiv q (IQmake (IZpow_pos 10 e) 1) + end. + +Definition IQmake_to_decimal num den := + let num := Z.to_int num in + let (den, e_den) := Decimal.nztail (Pos.to_uint den) in + match den with + | Decimal.D1 Decimal.Nil => + match e_den with + | O => Some (Decimal.Decimal num Decimal.Nil) + | ne => + let ai := Decimal.abs num in + let ni := Decimal.nb_digits ai in + if Nat.ltb ne ni then + let i := Decimal.del_tail_int ne num in + let f := Decimal.del_head (Nat.sub ni ne) ai in + Some (Decimal.Decimal i f) + else + let z := match num with + | Decimal.Pos _ => Decimal.Pos (Decimal.zero) + | Decimal.Neg _ => Decimal.Neg (Decimal.zero) end in + Some (Decimal.Decimal z (Nat.iter (Nat.sub ne ni) Decimal.D0 ai)) + end + | _ => None + end. + +Definition IQmake_to_decimal' num den := + match IZ_to_Z num with + | None => None + | Some num => IQmake_to_decimal num den + end. + +Definition to_decimal (n : IQ) : option Decimal.decimal := + match n with + | IQmake num den => IQmake_to_decimal' num den + | IQmult (IQmake num den) (IQmake (IZpow_pos 10 e) 1) => + match IQmake_to_decimal' num den with + | Some (Decimal.Decimal i f) => + Some (Decimal.DecimalExp i f (Pos.to_int e)) + | _ => None + end + | IQdiv (IQmake num den) (IQmake (IZpow_pos 10 e) 1) => + match IQmake_to_decimal' num den with + | Some (Decimal.Decimal i f) => + Some (Decimal.DecimalExp i f (Decimal.Neg (Pos.to_uint e))) + | _ => None + end + | _ => None + end. + +Definition of_hexadecimal (d:Hexadecimal.hexadecimal) : IQ := + let '(i, f, e) := + match d with + | Hexadecimal.Hexadecimal i f => (i, f, Decimal.Pos Decimal.Nil) + | Hexadecimal.HexadecimalExp i f e => (i, f, e) + end in + let num := Z.of_hex_int (Hexadecimal.app_int i f) in + let den := Nat.iter (Hexadecimal.nb_digits f) (Pos.mul 16) 1%positive in + let q := IQmake (IZ_of_Z num) den in + let e := Z.of_int e in + match e with + | Z0 => q + | Zpos e => IQmult q (IQmake (IZpow_pos 2 e) 1) + | Zneg e => IQdiv q (IQmake (IZpow_pos 2 e) 1) + end. + +Definition IQmake_to_hexadecimal num den := + let num := Z.to_hex_int num in + let (den, e_den) := Hexadecimal.nztail (Pos.to_hex_uint den) in + match den with + | Hexadecimal.D1 Hexadecimal.Nil => + match e_den with + | O => Some (Hexadecimal.Hexadecimal num Hexadecimal.Nil) + | ne => + let ai := Hexadecimal.abs num in + let ni := Hexadecimal.nb_digits ai in + if Nat.ltb ne ni then + let i := Hexadecimal.del_tail_int ne num in + let f := Hexadecimal.del_head (Nat.sub ni ne) ai in + Some (Hexadecimal.Hexadecimal i f) + else + let z := match num with + | Hexadecimal.Pos _ => Hexadecimal.Pos (Hexadecimal.zero) + | Hexadecimal.Neg _ => Hexadecimal.Neg (Hexadecimal.zero) end in + Some (Hexadecimal.Hexadecimal z (Nat.iter (Nat.sub ne ni) Hexadecimal.D0 ai)) + end + | _ => None + end. + +Definition IQmake_to_hexadecimal' num den := + match IZ_to_Z num with + | None => None + | Some num => IQmake_to_hexadecimal num den + end. + +Definition to_hexadecimal (n : IQ) : option Hexadecimal.hexadecimal := + match n with + | IQmake num den => IQmake_to_hexadecimal' num den + | IQmult (IQmake num den) (IQmake (IZpow_pos 2 e) 1) => + match IQmake_to_hexadecimal' num den with + | Some (Hexadecimal.Hexadecimal i f) => + Some (Hexadecimal.HexadecimalExp i f (Pos.to_int e)) + | _ => None + end + | IQdiv (IQmake num den) (IQmake (IZpow_pos 2 e) 1) => + match IQmake_to_hexadecimal' num den with + | Some (Hexadecimal.Hexadecimal i f) => + Some (Hexadecimal.HexadecimalExp i f (Decimal.Neg (Pos.to_uint e))) + | _ => None + end + | _ => None + end. + +Definition of_number (n : Number.number) : IQ := + match n with + | Number.Decimal d => of_decimal d + | Number.Hexadecimal h => of_hexadecimal h + end. + +Definition to_number (q:IQ) : option Number.number := + match to_decimal q with + | None => None + | Some q => Some (Number.Decimal q) + end. + +Definition to_hex_number q := + match to_hexadecimal q with + | None => None + | Some q => Some (Number.Hexadecimal q) + end. + +Number Notation Q of_number to_hex_number (via IQ + mapping [Qmake => IQmake, Qmult => IQmult, Qdiv => IQdiv, + Z.pow_pos => IZpow_pos, Z0 => IZ0, Zpos => IZpos, Zneg => IZneg]) + : hex_Q_scope. + +Number Notation Q of_number to_number (via IQ + mapping [Qmake => IQmake, Qmult => IQmult, Qdiv => IQdiv, + Z.pow_pos => IZpow_pos, Z0 => IZ0, Zpos => IZpos, Zneg => IZneg]) + : Q_scope. + (** A light notation for [Zpos] *) Lemma Qmake_Qdiv a b : a#b==inject_Z a/inject_Z (Zpos b). @@ -696,6 +788,7 @@ Proof. Close Scope Z_scope. Qed. +#[global] Hint Resolve Qle_trans : qarith. Lemma Qlt_irrefl x : ~x<x. @@ -776,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. @@ -817,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 1baefd6bf7..5a23a20811 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -13,14 +13,13 @@ Require Export QArith_base. (** Injection of rational numbers into real numbers. *) -Definition Q2R (x : Q) : R := (IZR (Qnum x) * / IZR (QDen x))%R. - Lemma IZR_nz : forall p : positive, IZR (Zpos p) <> 0%R. Proof. 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/Rdefinitions.v b/theories/Reals/Rdefinitions.v index affa129771..40736c61f2 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -22,11 +22,12 @@ Require Import ConstructiveRcomplete. Require Import ClassicalDedekindReals. -(* Declare primitive numeral notations for Scope R_scope *) +(* Declare primitive number notations for Scope R_scope *) +Declare Scope hex_R_scope. Declare Scope R_scope. -Declare ML Module "r_syntax_plugin". (* Declare Scope R_scope with Key R *) +Delimit Scope hex_R_scope with xR. Delimit Scope R_scope with R. Local Open Scope R_scope. @@ -224,3 +225,165 @@ Proof. - (* x = n-1 *) exact n. - exact (Z.pred n). Defined. + +(** Injection of rational numbers into real numbers. *) + +Definition Q2R (x : Q) : R := (IZR (Qnum x) * / IZR (QDen x))%R. + +(**********************************************************) +(** * Number notation for constants *) +(**********************************************************) + +Inductive IR := + | IRZ : IZ -> IR + | IRQ : Q -> IR + | IRmult : IR -> IR -> IR + | IRdiv : IR -> IR -> IR. + +Definition of_decimal (d : Decimal.decimal) : IR := + let '(i, f, e) := + match d with + | Decimal.Decimal i f => (i, f, Decimal.Pos Decimal.Nil) + | Decimal.DecimalExp i f e => (i, f, e) + end in + let zq := match f with + | Decimal.Nil => IRZ (IZ_of_Z (Z.of_int i)) + | _ => + let num := Z.of_int (Decimal.app_int i f) in + let den := Nat.iter (Decimal.nb_digits f) (Pos.mul 10) 1%positive in + IRQ (Qmake num den) end in + let e := Z.of_int e in + match e with + | Z0 => zq + | Zpos e => IRmult zq (IRZ (IZpow_pos 10 e)) + | Zneg e => IRdiv zq (IRZ (IZpow_pos 10 e)) + end. + +Definition of_hexadecimal (d : Hexadecimal.hexadecimal) : IR := + let '(i, f, e) := + match d with + | Hexadecimal.Hexadecimal i f => (i, f, Decimal.Pos Decimal.Nil) + | Hexadecimal.HexadecimalExp i f e => (i, f, e) + end in + let zq := match f with + | Hexadecimal.Nil => IRZ (IZ_of_Z (Z.of_hex_int i)) + | _ => + let num := Z.of_hex_int (Hexadecimal.app_int i f) in + let den := Nat.iter (Hexadecimal.nb_digits f) (Pos.mul 16) 1%positive in + IRQ (Qmake num den) end in + let e := Z.of_int e in + match e with + | Z0 => zq + | Zpos e => IRmult zq (IRZ (IZpow_pos 2 e)) + | Zneg e => IRdiv zq (IRZ (IZpow_pos 2 e)) + end. + +Definition of_number (n : Number.number) : IR := + match n with + | Number.Decimal d => of_decimal d + | Number.Hexadecimal h => of_hexadecimal h + end. + +Definition IQmake_to_decimal num den := + match den with + | 1%positive => None (* this should be encoded as IRZ *) + | _ => IQmake_to_decimal num den + end. + +Definition to_decimal (n : IR) : option Decimal.decimal := + match n with + | IRZ z => + match IZ_to_Z z with + | Some z => Some (Decimal.Decimal (Z.to_int z) Decimal.Nil) + | None => None + end + | IRQ (Qmake num den) => IQmake_to_decimal num den + | IRmult (IRZ z) (IRZ (IZpow_pos 10 e)) => + match IZ_to_Z z with + | Some z => + Some (Decimal.DecimalExp (Z.to_int z) Decimal.Nil (Pos.to_int e)) + | None => None + end + | IRmult (IRQ (Qmake num den)) (IRZ (IZpow_pos 10 e)) => + match IQmake_to_decimal num den with + | Some (Decimal.Decimal i f) => + Some (Decimal.DecimalExp i f (Pos.to_int e)) + | _ => None + end + | IRdiv (IRZ z) (IRZ (IZpow_pos 10 e)) => + match IZ_to_Z z with + | Some z => + Some (Decimal.DecimalExp (Z.to_int z) Decimal.Nil (Decimal.Neg (Pos.to_uint e))) + | None => None + end + | IRdiv (IRQ (Qmake num den)) (IRZ (IZpow_pos 10 e)) => + match IQmake_to_decimal num den with + | Some (Decimal.Decimal i f) => + Some (Decimal.DecimalExp i f (Decimal.Neg (Pos.to_uint e))) + | _ => None + end + | _ => None + end. + +Definition IQmake_to_hexadecimal num den := + match den with + | 1%positive => None (* this should be encoded as IRZ *) + | _ => IQmake_to_hexadecimal num den + end. + +Definition to_hexadecimal (n : IR) : option Hexadecimal.hexadecimal := + match n with + | IRZ z => + match IZ_to_Z z with + | Some z => Some (Hexadecimal.Hexadecimal (Z.to_hex_int z) Hexadecimal.Nil) + | None => None + end + | IRQ (Qmake num den) => IQmake_to_hexadecimal num den + | IRmult (IRZ z) (IRZ (IZpow_pos 2 e)) => + match IZ_to_Z z with + | Some z => + Some (Hexadecimal.HexadecimalExp (Z.to_hex_int z) Hexadecimal.Nil (Pos.to_int e)) + | None => None + end + | IRmult (IRQ (Qmake num den)) (IRZ (IZpow_pos 2 e)) => + match IQmake_to_hexadecimal num den with + | Some (Hexadecimal.Hexadecimal i f) => + Some (Hexadecimal.HexadecimalExp i f (Pos.to_int e)) + | _ => None + end + | IRdiv (IRZ z) (IRZ (IZpow_pos 2 e)) => + match IZ_to_Z z with + | Some z => + Some (Hexadecimal.HexadecimalExp (Z.to_hex_int z) Hexadecimal.Nil (Decimal.Neg (Pos.to_uint e))) + | None => None + end + | IRdiv (IRQ (Qmake num den)) (IRZ (IZpow_pos 2 e)) => + match IQmake_to_hexadecimal num den with + | Some (Hexadecimal.Hexadecimal i f) => + Some (Hexadecimal.HexadecimalExp i f (Decimal.Neg (Pos.to_uint e))) + | _ => None + end + | _ => None + end. + +Definition to_number q := + match to_decimal q with + | None => None + | Some q => Some (Number.Decimal q) + end. + +Definition to_hex_number q := + match to_hexadecimal q with + | None => None + | Some q => Some (Number.Hexadecimal q) + end. + +Number Notation R of_number to_hex_number (via IR + mapping [IZR => IRZ, Q2R => IRQ, Rmult => IRmult, Rdiv => IRdiv, + Z.pow_pos => IZpow_pos, Z0 => IZ0, Zpos => IZpos, Zneg => IZneg]) + : hex_R_scope. + +Number Notation R of_number to_number (via IR + mapping [IZR => IRZ, Q2R => IRQ, Rmult => IRmult, Rdiv => IRdiv, + Z.pow_pos => IZpow_pos, Z0 => IZ0, Zpos => IZpos, Zneg => IZneg]) + : R_scope. 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/Reals/Rregisternames.v b/theories/Reals/Rregisternames.v index 8b078f2cf3..8117d975fe 100644 --- a/theories/Reals/Rregisternames.v +++ b/theories/Reals/Rregisternames.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Raxioms Rfunctions Qreals. +Require Import Raxioms Rfunctions. (*****************************************************************) (** Register names for use in plugins *) @@ -31,4 +31,4 @@ Register IZR as reals.R.IZR. Register Rabs as reals.R.Rabs. Register powerRZ as reals.R.powerRZ. Register pow as reals.R.pow. -Register Qreals.Q2R as reals.R.Q2R. +Register Q2R as reals.R.Q2R. 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/Strings/Ascii.v b/theories/Strings/Ascii.v index c155395ecd..06b02ab211 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -128,28 +128,28 @@ Definition nat_of_ascii (a : ascii) : nat := N.to_nat (N_of_ascii a). Theorem ascii_N_embedding : forall a : ascii, ascii_of_N (N_of_ascii a) = a. Proof. - destruct a as [[|][|][|][|][|][|][|][|]]; vm_compute; reflexivity. + intro a; destruct a as [[|][|][|][|][|][|][|][|]]; vm_compute; reflexivity. Qed. Theorem N_ascii_embedding : forall n:N, (n < 256)%N -> N_of_ascii (ascii_of_N n) = n. Proof. -destruct n. +intro n; destruct n as [|p]. reflexivity. -do 8 (destruct p; [ | | intros; vm_compute; reflexivity ]); +do 8 (destruct p as [p|p|]; [ | | intros; vm_compute; reflexivity ]); intro H; vm_compute in H; destruct p; discriminate. Qed. Theorem N_ascii_bounded : forall a : ascii, (N_of_ascii a < 256)%N. Proof. - destruct a as [[|][|][|][|][|][|][|][|]]; vm_compute; reflexivity. + intro a; destruct a as [[|][|][|][|][|][|][|][|]]; vm_compute; reflexivity. Qed. Theorem ascii_nat_embedding : forall a : ascii, ascii_of_nat (nat_of_ascii a) = a. Proof. - destruct a as [[|][|][|][|][|][|][|][|]]; compute; reflexivity. + intro a; destruct a as [[|][|][|][|][|][|][|][|]]; compute; reflexivity. Qed. Theorem nat_ascii_embedding : diff --git a/theories/Strings/ByteVector.v b/theories/Strings/ByteVector.v index ac0323442a..144ffd59e0 100644 --- a/theories/Strings/ByteVector.v +++ b/theories/Strings/ByteVector.v @@ -42,7 +42,7 @@ Fixpoint to_Bvector {n : nat} (v : ByteVector n) : Bvector (n * 8) := Fixpoint of_Bvector {n : nat} : Bvector (n * 8) -> ByteVector n := match n with | 0 => fun _ => [] - | S n' => + | S _ => fun v => let (b0, v1) := uncons v in let (b1, v2) := uncons v1 in diff --git a/theories/Strings/String.v b/theories/Strings/String.v index a468a4fe87..b792acc9f9 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -54,7 +54,8 @@ Infix "=?" := eqb : string_scope. Lemma eqb_spec s1 s2 : Bool.reflect (s1 = s2) (s1 =? s2)%string. Proof. - revert s2. induction s1; destruct s2; try (constructor; easy); simpl. + revert s2. induction s1 as [|? s1 IHs1]; + intro s2; destruct s2; try (constructor; easy); simpl. case Ascii.eqb_spec; simpl; [intros -> | constructor; now intros [= ]]. case IHs1; [intros ->; now constructor | constructor; now intros [= ]]. Qed. @@ -117,7 +118,7 @@ intros s1; elim s1; simpl. intros s2; case s2; simpl; split; auto. intros H; generalize (H O); intros H1; inversion H1. intros; discriminate. -intros a s1' Rec s2; case s2; simpl; split; auto. +intros a s1' Rec s2; case s2 as [|? s]; simpl; split; auto. intros H; generalize (H O); intros H1; inversion H1. intros; discriminate. intros H; generalize (H O); simpl; intros H1; inversion H1. @@ -249,7 +250,7 @@ intros b s2'; case (ascii_dec a b); simpl; auto. intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto. rewrite e; rewrite H1; auto. apply H2; injection H3; auto. -intros n; split; intros; try discriminate. +intros n; split; intros H; try discriminate. case n; injection H; auto. Qed. 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/OrdersEx.v b/theories/Structures/OrdersEx.v index adffa1ded4..382538875d 100644 --- a/theories/Structures/OrdersEx.v +++ b/theories/Structures/OrdersEx.v @@ -138,12 +138,12 @@ Module PositiveOrderedTypeBits <: UsualOrderedType. Fixpoint compare x y := match x, y with | x~1, y~1 => compare x y - | x~1, _ => Gt + | _~1, _ => Gt | x~0, y~0 => compare x y - | x~0, _ => Lt - | 1, y~1 => Lt + | _~0, _ => Lt + | 1, _~1 => Lt | 1, 1 => Eq - | 1, y~0 => Gt + | 1, _~0 => Gt end. Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). 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/Fin.v b/theories/Vectors/Fin.v index 18e286b943..45fcbfb329 100644 --- a/theories/Vectors/Fin.v +++ b/theories/Vectors/Fin.v @@ -111,7 +111,7 @@ Qed. Lemma of_nat_to_nat_inv {m} (p : t m) : of_nat_lt (proj2_sig (to_nat p)) = p. Proof. -induction p; simpl. +induction p as [|? p]; simpl. - reflexivity. - destruct (to_nat p); simpl in *. f_equal. subst p. apply of_nat_ext. Qed. @@ -119,7 +119,7 @@ Qed. Lemma to_nat_of_nat {p}{n} (h : p < n) : to_nat (of_nat_lt h) = exist _ p h. Proof. revert n h. - induction p; (destruct n ; intros h; [ destruct (Lt.lt_n_O _ h) | cbn]); + induction p as [|p IHp]; (intro n; destruct n as [|n]; intros h; [ destruct (Lt.lt_n_O _ h) | cbn]); [ | rewrite (IHp _ (Lt.lt_S_n p n h))]; f_equal; apply Peano_dec.le_unique. Qed. @@ -153,7 +153,7 @@ Fixpoint L {m} n (p : t m) : t (m + n) := Lemma L_sanity {m} n (p : t m) : proj1_sig (to_nat (L n p)) = proj1_sig (to_nat p). Proof. -induction p. +induction p as [|? p IHp]. - reflexivity. - simpl; destruct (to_nat (L n p)); simpl in *; rewrite IHp. now destruct (to_nat p). Qed. @@ -163,7 +163,7 @@ Qed. Really really inefficient !!! *) Definition L_R {m} n (p : t m) : t (n + m). Proof. -induction n. +induction n as [|n IHn]. - exact p. - exact ((fix LS k (p: t k) := match p with @@ -179,7 +179,7 @@ Fixpoint R {m} n (p : t m) : t (n + m) := Lemma R_sanity {m} n (p : t m) : proj1_sig (to_nat (R n p)) = n + proj1_sig (to_nat p). Proof. -induction n. +induction n as [|n IHn]. - reflexivity. - simpl; destruct (to_nat (R n p)); simpl in *; rewrite IHn. now destruct (to_nat p). Qed. @@ -193,7 +193,7 @@ end. Lemma depair_sanity {m n} (o : t m) (p : t n) : proj1_sig (to_nat (depair o p)) = n * (proj1_sig (to_nat o)) + (proj1_sig (to_nat p)). Proof. -induction o ; simpl. +induction o as [|? o IHo] ; simpl. - rewrite L_sanity. now rewrite Mult.mult_0_r. - rewrite R_sanity. rewrite IHo. @@ -211,7 +211,8 @@ end. Lemma eqb_nat_eq : forall m n (p : t m) (q : t n), eqb p q = true -> m = n. Proof. -intros m n p; revert n; induction p; destruct q; simpl; intros; f_equal. +intros m n p; revert n; induction p as [|? p IHp]; + intros ? q; destruct q; simpl; intros; f_equal. - now apply EqNat.beq_nat_true. - easy. - easy. diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index 57241e5f42..3799ffaca9 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -167,7 +167,7 @@ Fixpoint take {A} {n} (p:nat) (le:p <= n) (v:t A n) : t A p := Lemma trunc : forall {A} {n} (p:nat), n > p -> t A n -> t A (n - p). Proof. - induction p as [| p f]; intros H v. + intros A n p; induction p as [| p f]; intros H v. rewrite <- minus_n_O. exact 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/Vectors/VectorEq.v b/theories/Vectors/VectorEq.v index 6bd2c30205..c36917aa90 100644 --- a/theories/Vectors/VectorEq.v +++ b/theories/Vectors/VectorEq.v @@ -36,7 +36,7 @@ Section BEQ. (Hbeq: eqb v1 v2 = true), m = n. Proof. intros m n v1; revert n. - induction v1; destruct v2; + induction v1; intros ? v2; destruct v2; [now constructor | discriminate | discriminate | simpl]. intros Hbeq; apply andb_prop in Hbeq; destruct Hbeq. f_equal; eauto. diff --git a/theories/Vectors/VectorSpec.v b/theories/Vectors/VectorSpec.v index 443931e5bb..10545332bb 100644 --- a/theories/Vectors/VectorSpec.v +++ b/theories/Vectors/VectorSpec.v @@ -26,7 +26,7 @@ Definition cons_inj {A} {a1 a2} {n} {v1 v2 : t A n} Lemma eta {A} {n} (v : t A (S n)) : v = hd v :: tl v. Proof. -intros; apply caseS with (v:=v); intros; reflexivity. +intros; apply (fun P IS => caseS P IS (n := n) v); intros; reflexivity. Defined. (** Lemmas are done for functions that use [Fin.t] but thanks to [Peano_dec.le_unique], all @@ -38,9 +38,9 @@ Lemma eq_nth_iff A n (v1 v2: t A n): (forall p1 p2, p1 = p2 -> v1 [@ p1 ] = v2 [@ p2 ]) <-> v1 = v2. Proof. split. -- revert n v1 v2; refine (@rect2 _ _ _ _ _); simpl; intros. +- revert n v1 v2; refine (@rect2 _ _ _ _ _); simpl. + reflexivity. - + f_equal. apply (H0 Fin.F1 Fin.F1 eq_refl). + + intros n ? ? H ? ? H0. f_equal. apply (H0 Fin.F1 Fin.F1 eq_refl). apply H. intros p1 p2 H1; apply (H0 (Fin.FS p1) (Fin.FS p2) (f_equal (@Fin.FS n) H1)). - intros; now f_equal. @@ -48,12 +48,12 @@ Qed. Lemma nth_order_hd A: forall n (v : t A (S n)) (H : 0 < S n), nth_order v H = hd v. -Proof. intros; now rewrite (eta v). Qed. +Proof. intros n v H; now rewrite (eta v). Qed. Lemma nth_order_tl A: forall n k (v : t A (S n)) (H : k < n) (HS : S k < S n), nth_order (tl v) H = nth_order v HS. Proof. -induction n; intros. +intros n; induction n; intros k v H HS. - inversion H. - rewrite (eta v). unfold nth_order; simpl. @@ -69,7 +69,7 @@ Qed. Lemma nth_order_ext A: forall n k (v : t A n) (H1 H2 : k < n), nth_order v H1 = nth_order v H2. Proof. -intros; unfold nth_order. +intros n k v H1 H2; unfold nth_order. now rewrite (Fin.of_nat_ext H1 H2). Qed. @@ -78,7 +78,7 @@ Qed. Lemma shiftin_nth A a n (v: t A n) k1 k2 (eq: k1 = k2): nth (shiftin a v) (Fin.L_R 1 k1) = nth v k2. Proof. -subst k2; induction k1. +subst k2; induction k1 as [n|n k1]. - generalize dependent n. apply caseS ; intros. now simpl. - generalize dependent n. refine (@caseS _ _ _) ; intros. now simpl. Qed. @@ -92,14 +92,14 @@ Lemma shiftrepeat_nth A: forall n k (v: t A (S n)), nth (shiftrepeat v) (Fin.L_R 1 k) = nth v k. Proof. refine (@Fin.rectS _ _ _); lazy beta; [ intros n v | intros n p H v ]. -- revert n v; refine (@caseS _ _ _); simpl; intros. now destruct t. +- revert n v; refine (@caseS _ _ _); simpl; intros ? ? t. now destruct t. - revert p H. refine (match v as v' in t _ m return match m as m' return t A m' -> Prop with |S (S n) => fun v => forall p : Fin.t (S n), (forall v0 : t A (S n), (shiftrepeat v0) [@ Fin.L_R 1 p ] = v0 [@p]) -> (shiftrepeat v) [@Fin.L_R 1 (Fin.FS p)] = v [@Fin.FS p] |_ => fun _ => True end v' with - |[] => I |h :: t => _ end). destruct n0. exact I. now simpl. + |[] => I | cons _ h n t => _ end). destruct n. exact I. now simpl. Qed. Lemma shiftrepeat_last A: forall n (v: t A (S n)), last (shiftrepeat v) = last v. @@ -112,7 +112,7 @@ Qed. Lemma nth_order_replace_eq A: forall n k (v : t A n) a (H1 : k < n) (H2 : k < n), nth_order (replace v (Fin.of_nat_lt H2) a) H1 = a. Proof. -intros n k; revert n; induction k; intros; +intros n k; revert n; induction k as [|k IHk]; intros n v a H1 H2; (destruct n; [ inversion H1 | subst ]). - now rewrite nth_order_hd, (eta v). - rewrite <- (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) H1)), (eta v). @@ -123,7 +123,7 @@ Lemma nth_order_replace_neq A: forall n k1 k2, k1 <> k2 -> forall (v : t A n) a (H1 : k1 < n) (H2 : k2 < n), nth_order (replace v (Fin.of_nat_lt H2) a) H1 = nth_order v H1. Proof. -intros n k1; revert n; induction k1; intros; +intros n k1; revert n; induction k1 as [|k1 IHk1]; intros n k2 H v a H1 H2; (destruct n ; [ inversion H1 | subst ]). - rewrite 2 nth_order_hd. destruct k2; intuition. @@ -137,15 +137,15 @@ Qed. Lemma replace_id A: forall n p (v : t A n), replace v p (nth v p) = v. Proof. -induction p; intros; rewrite 2 (eta v); simpl; auto. +intros n p; induction p as [|? p IHp]; intros v; rewrite 2 (eta v); simpl; auto. now rewrite IHp. Qed. Lemma replace_replace_eq A: forall n p (v : t A n) a b, replace (replace v p a) p b = replace v p b. Proof. -intros. -induction p; rewrite 2 (eta v); simpl; auto. +intros n p v a b. +induction p as [|? p IHp]; rewrite 2 (eta v); simpl; auto. now rewrite IHp. Qed. @@ -161,7 +161,7 @@ apply (Fin.rect2 (fun n p1 p2 => forall v a b, - intros n p1 v; revert n v p1. refine (@rectS _ _ _ _); auto. - intros n p1 p2 IH v; revert n v p1 p2 IH. - refine (@rectS _ _ _ _); simpl; do 6 intro; [ | do 3 intro ]; intro Hneq; + refine (@rectS _ _ _ _); simpl; intro n; [| do 3 intro]; intros ? ? IH p1 p2; intro Hneq; f_equal; apply IH; intros Heq; apply Hneq; now subst. Qed. @@ -177,19 +177,19 @@ Qed. Lemma map_id A: forall n (v : t A n), map (fun x => x) v = v. Proof. -induction v; simpl; [ | rewrite IHv ]; auto. +intros n v; induction v as [|? ? v IHv]; simpl; [ | rewrite IHv ]; auto. Qed. Lemma map_map A B C: forall (f:A->B) (g:B->C) n (v : t A n), map g (map f v) = map (fun x => g (f x)) v. Proof. -induction v; simpl; [ | rewrite IHv ]; auto. +intros f g n v; induction v as [|? ? v IHv]; simpl; [ | rewrite IHv ]; auto. Qed. Lemma map_ext_in A B: forall (f g:A->B) n (v : t A n), (forall a, In a v -> f a = g a) -> map f v = map g v. Proof. -induction v; simpl; auto. +intros f g n v H; induction v as [|? ? v IHv]; simpl; auto. intros; rewrite H by constructor; rewrite IHv; intuition. apply H; now constructor. Qed. @@ -203,7 +203,7 @@ Qed. Lemma nth_map {A B} (f: A -> B) {n} v (p1 p2: Fin.t n) (eq: p1 = p2): (map f v) [@ p1] = f (v [@ p2]). Proof. -subst p2; induction p1. +subst p2; induction p1 as [n|n p1 IHp1]. - revert n v; refine (@caseS _ _ _); now simpl. - revert n v p1 IHp1; refine (@caseS _ _ _); now simpl. Qed. @@ -225,10 +225,10 @@ Lemma fold_left_right_assoc_eq {A B} {f: A -> B -> A} {n} (v: t B n): forall a, fold_left f a v = fold_right (fun x y => f y x) v a. Proof. assert (forall n h (v: t B n) a, fold_left f (f a h) v = f (fold_left f a v) h). -- induction v0. +- intros n0 h v0; induction v0 as [|? ? v0 IHv0]. + now simpl. + intros; simpl. rewrite<- IHv0, assoc. now f_equal. -- induction v. +- induction v as [|? ? v IHv]. + reflexivity. + simpl. intros; now rewrite<- (IHv). Qed. @@ -245,31 +245,31 @@ Qed. (** ** Properties of [take] *) Lemma take_O : forall {A} {n} le (v:t A n), take 0 le v = []. -Proof. +Proof. reflexivity. -Qed. +Qed. Lemma take_idem : forall {A} p n (v:t A n) le le', take p le' (take p le v) = take p le v. -Proof. - induction p; intros n v le le'. - - auto. - - destruct v. inversion le. simpl. apply f_equal. apply IHp. +Proof. + intros A p; induction p as [|p IHp]; intros n v le le'. + - auto. + - destruct v. inversion le. simpl. apply f_equal. apply IHp. Qed. Lemma take_app : forall {A} {n} (v:t A n) {m} (w:t A m) le, take n le (append v w) = v. -Proof. - induction v; intros m w le. - - reflexivity. - - simpl. apply f_equal. apply IHv. +Proof. + intros a n v; induction v as [|? ? v IHv]; intros m w le. + - reflexivity. + - simpl. apply f_equal. apply IHv. Qed. (* Proof is irrelevant for [take] *) Lemma take_prf_irr : forall {A} p {n} (v:t A n) le le', take p le v = take p le' v. -Proof. - induction p; intros n v le le'. - - reflexivity. - - destruct v. inversion le. simpl. apply f_equal. apply IHp. +Proof. + intros A p; induction p as [|p IHp]; intros n v le le'. + - reflexivity. + - destruct v. inversion le. simpl. apply f_equal. apply IHp. Qed. (** ** Properties of [uncons] and [splitat] *) @@ -289,7 +289,7 @@ Lemma splitat_append {A} : forall {n m : nat} (v : t A n) (w : t A m), Proof with simpl; auto. intros n m v. generalize dependent m. - induction v; intros... + induction v as [|? ? v IHv]; intros... rewrite IHv... Qed. @@ -299,10 +299,10 @@ Lemma append_splitat {A} : forall {n m : nat} (v : t A n) (w : t A m) (vw : t A Proof with auto. intros n m v. generalize dependent m. - induction v; intros; inversion H... + induction v as [|a n v IHv]; intros m w vw H; inversion H as [H1]... destruct (splitat n (tl vw)) as [v' w'] eqn:Heq. apply pair_equal_spec in H1. - destruct H1; subst. + destruct H1 as [H0]; subst. rewrite <- append_comm_cons. rewrite (eta vw). apply cons_inj in H0. @@ -316,7 +316,7 @@ Qed. Lemma Forall_impl A: forall (P Q : A -> Prop), (forall a, P a -> Q a) -> forall n (v : t A n), Forall P v -> Forall Q v. Proof. -induction v; intros HP; constructor; inversion HP as [| ? ? ? ? ? Heq1 [Heq2 He]]; +intros P Q H n v; induction v; intros HP; constructor; inversion HP as [| ? ? ? ? ? Heq1 [Heq2 He]]; apply (inj_pair2_eq_dec _ Nat.eq_dec) in He; subst; intuition. Qed. @@ -328,7 +328,7 @@ intros P n v; split. revert HP; induction Hin; intros HP; inversion HP as [| ? ? ? ? ? Heq1 [Heq2 He]]; subst; auto. apply (inj_pair2_eq_dec _ Nat.eq_dec) in He; subst; auto. -- induction v; intros Hin; constructor. +- induction v as [|? ? v IHv]; intros Hin; constructor. + apply Hin; constructor. + apply IHv; intros a Ha. apply Hin; now constructor. @@ -337,7 +337,7 @@ Qed. Lemma Forall_nth_order A: forall P n (v : t A n), Forall P v <-> forall i (Hi : i < n), P (nth_order v Hi). Proof. -split; induction n. +intros P n v; split; induction n as [|n IHn]. - intros HF i Hi; inversion Hi. - intros HF i Hi. rewrite (eta v). @@ -354,7 +354,7 @@ split; induction n. rewrite (eta v); constructor. + specialize HP with 0 (Nat.lt_0_succ n). now rewrite nth_order_hd in HP. - + apply IHn; intros. + + apply IHn; intros i Hi. specialize HP with (S i) (proj1 (Nat.succ_lt_mono _ _) Hi). now rewrite <- (nth_order_tl _ _ _ _ Hi) in HP. Qed. @@ -363,7 +363,7 @@ Lemma Forall2_nth_order A: forall P n (v1 v2 : t A n), Forall2 P v1 v2 <-> forall i (Hi1 : i < n) (Hi2 : i < n), P (nth_order v1 Hi1) (nth_order v2 Hi2). Proof. -split; induction n. +intros P n v1 v2; split; induction n as [|n IHn]. - intros HF i Hi1 Hi2; inversion Hi1. - intros HF i Hi1 Hi2. rewrite (eta v1), (eta v2). @@ -382,7 +382,7 @@ split; induction n. rewrite (eta v1), (eta v2); constructor. + specialize HP with 0 (Nat.lt_0_succ _) (Nat.lt_0_succ _). now rewrite nth_order_hd in HP. - + apply IHn; intros. + + apply IHn; intros i Hi1 Hi2. specialize HP with (S i) (proj1 (Nat.succ_lt_mono _ _) Hi1) (proj1 (Nat.succ_lt_mono _ _) Hi2). now rewrite <- (nth_order_tl _ _ _ _ Hi1), <- (nth_order_tl _ _ _ _ Hi2) in HP. 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 9a30e011af..47137414dc 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -126,7 +126,7 @@ Lemma pos_sub_spec p q : | Gt => pos (p - q) end. Proof. - revert q. induction p; destruct q; simpl; trivial; + revert q. induction p as [p IHp|p IHp|]; intros q; destruct q; simpl; trivial; rewrite ?Pos.compare_xI_xI, ?Pos.compare_xO_xI, ?Pos.compare_xI_xO, ?Pos.compare_xO_xO, IHp; simpl; case Pos.compare_spec; intros; simpl; trivial; @@ -168,7 +168,7 @@ Qed. Lemma pos_sub_opp p q : - pos_sub p q = pos_sub q p. Proof. - revert q; induction p; destruct q; simpl; trivial; + revert q; induction p as [p IHp|p IHp|]; intros q; destruct q; simpl; trivial; rewrite <- IHp; now destruct pos_sub. Qed. @@ -468,13 +468,13 @@ Lemma peano_ind (P : Z -> Prop) : (forall x, P x -> P (pred x)) -> forall z, P z. Proof. - intros H0 Hs Hp z; destruct z. + intros H0 Hs Hp z; destruct z as [|p|p]. assumption. - induction p using Pos.peano_ind. + induction p as [|p IHp] using Pos.peano_ind. now apply (Hs 0). rewrite <- Pos.add_1_r. now apply (Hs (pos p)). - induction p using Pos.peano_ind. + induction p as [|p IHp] using Pos.peano_ind. now apply (Hp 0). rewrite <- Pos.add_1_r. now apply (Hp (neg p)). @@ -486,7 +486,7 @@ Lemma bi_induction (P : Z -> Prop) : (forall x, P x <-> P (succ x)) -> forall z, P z. Proof. - intros _ H0 Hs. induction z using peano_ind. + intros _ H0 Hs z. induction z using peano_ind. assumption. now apply -> Hs. apply Hs. now rewrite succ_pred. @@ -569,7 +569,7 @@ Qed. Lemma sqrtrem_spec n : 0<=n -> let (s,r) := sqrtrem n in n = s*s + r /\ 0 <= r <= 2*s. Proof. - destruct n. now repeat split. + destruct n as [|p|p]. now repeat split. generalize (Pos.sqrtrem_spec p). simpl. destruct 1; simpl; subst; now repeat split. now destruct 1. @@ -578,7 +578,7 @@ Qed. Lemma sqrt_spec n : 0<=n -> let s := sqrt n in s*s <= n < (succ s)*(succ s). Proof. - destruct n. now repeat split. unfold sqrt. + destruct n as [|p|p]. now repeat split. unfold sqrt. intros _. simpl succ. rewrite Pos.add_1_r. apply (Pos.sqrt_spec p). now destruct 1. Qed. @@ -590,7 +590,7 @@ Qed. Lemma sqrtrem_sqrt n : fst (sqrtrem n) = sqrt n. Proof. - destruct n; try reflexivity. + destruct n as [|p|p]; try reflexivity. unfold sqrtrem, sqrt, Pos.sqrt. destruct (Pos.sqrtrem p) as (s,r). now destruct r. Qed. @@ -655,7 +655,7 @@ Lemma pos_div_eucl_eq a b : 0 < b -> let (q, r) := pos_div_eucl a b in pos a = q * b + r. Proof. intros Hb. - induction a; unfold pos_div_eucl; fold pos_div_eucl. + induction a as [a IHa|a IHa|]; unfold pos_div_eucl; fold pos_div_eucl. - (* ~1 *) destruct pos_div_eucl as (q,r). change (pos a~1) with (2*(pos a)+1). @@ -720,7 +720,7 @@ Proof. now rewrite Pos.add_diag. intros Hb. destruct b as [|b|b]; discriminate Hb || clear Hb. - induction a; unfold pos_div_eucl; fold pos_div_eucl. + induction a as [a IHa|a IHa|]; unfold pos_div_eucl; fold pos_div_eucl. (* ~1 *) destruct pos_div_eucl as (q,r). simpl in IHa; destruct IHa as (Hr,Hr'). @@ -996,7 +996,7 @@ Proof. intros Hn Hm. unfold shiftr. destruct n as [ |n|n]; (now destruct Hn) || clear Hn; simpl. now rewrite add_0_r. - assert (forall p, to_N (m + pos p) = (to_N m + N.pos p)%N). + assert (forall p, to_N (m + pos p) = (to_N m + N.pos p)%N) as H. destruct m; trivial; now destruct Hm. assert (forall p, 0 <= m + pos p). destruct m; easy || now destruct Hm. @@ -1054,7 +1054,7 @@ Proof. subst. now rewrite N.sub_diag. simpl. destruct (Pos.sub_mask_pos' m n H') as (p & -> & <-). f_equal. now rewrite Pos.add_comm, Pos.add_sub. - destruct a; unfold shiftl. + destruct a as [|p|p]; unfold shiftl. (* ... a = 0 *) replace (Pos.iter (mul 2) 0 n) with 0 by (apply Pos.iter_invariant; intros; subst; trivial). @@ -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/BinIntDef.v b/theories/ZArith/BinIntDef.v index 69ed101f24..58bc75b62c 100644 --- a/theories/ZArith/BinIntDef.v +++ b/theories/ZArith/BinIntDef.v @@ -311,10 +311,10 @@ Definition of_uint (d:Decimal.uint) := of_N (Pos.of_uint d). Definition of_hex_uint (d:Hexadecimal.uint) := of_N (Pos.of_hex_uint d). -Definition of_num_uint (d:Numeral.uint) := +Definition of_num_uint (d:Number.uint) := match d with - | Numeral.UIntDec d => of_uint d - | Numeral.UIntHex d => of_hex_uint d + | Number.UIntDecimal d => of_uint d + | Number.UIntHexadecimal d => of_hex_uint d end. Definition of_int (d:Decimal.int) := @@ -329,10 +329,10 @@ Definition of_hex_int (d:Hexadecimal.int) := | Hexadecimal.Neg d => opp (of_hex_uint d) end. -Definition of_num_int (d:Numeral.int) := +Definition of_num_int (d:Number.int) := match d with - | Numeral.IntDec d => of_int d - | Numeral.IntHex d => of_hex_int d + | Number.IntDecimal d => of_int d + | Number.IntHexadecimal d => of_hex_int d end. Definition to_int n := @@ -349,7 +349,7 @@ Definition to_hex_int n := | neg p => Hexadecimal.Neg (Pos.to_hex_uint p) end. -Definition to_num_int n := Numeral.IntDec (to_int n). +Definition to_num_int n := Number.IntDecimal (to_int n). (** ** Iteration of a function diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v index 62fccf3ce2..9fa05dd2f7 100644 --- a/theories/ZArith/Wf_Z.v +++ b/theories/ZArith/Wf_Z.v @@ -67,7 +67,7 @@ Lemma natlike_ind : forall x:Z, 0 <= x -> P x. Proof. intros P Ho Hrec x Hx; apply Z_of_nat_prop; trivial. - induction n. exact Ho. + intros n; induction n. exact Ho. rewrite Nat2Z.inj_succ. apply Hrec; trivial using Nat2Z.is_nonneg. Qed. @@ -78,7 +78,7 @@ Lemma natlike_rec : forall x:Z, 0 <= x -> P x. Proof. intros P Ho Hrec x Hx; apply Z_of_nat_set; trivial. - induction n. exact Ho. + intros n; induction n. exact Ho. rewrite Nat2Z.inj_succ. apply Hrec; trivial using Nat2Z.is_nonneg. Qed. @@ -101,9 +101,9 @@ Section Efficient_Rec. (forall z:Z, 0 <= z -> P z -> P (Z.succ z)) -> forall z:Z, 0 <= z -> P z. Proof. - intros P Ho Hrec. + intros P Ho Hrec z. induction z as [z IH] using (well_founded_induction_type R_wf). - destruct z; intros Hz. + destruct z as [|p|p]; intros Hz. - apply Ho. - set (y:=Z.pred (Zpos p)). assert (LE : 0 <= y) by (unfold y; now apply Z.lt_le_pred). @@ -121,9 +121,9 @@ Section Efficient_Rec. (forall z:Z, 0 < z -> P (Z.pred z) -> P z) -> forall z:Z, 0 <= z -> P z. Proof. - intros P Ho Hrec. + intros P Ho Hrec z. induction z as [z IH] using (well_founded_induction_type R_wf). - destruct z; intros Hz. + destruct z as [|p|p]; intros Hz. - apply Ho. - assert (EQ : 0 <= Z.pred (Zpos p)) by now apply Z.lt_le_pred. apply Hrec. easy. apply IH; trivial. split; trivial. @@ -138,7 +138,7 @@ Section Efficient_Rec. (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) -> forall x:Z, 0 <= x -> P x. Proof. - intros P Hrec. + intros P Hrec x. induction x as [x IH] using (well_founded_induction_type R_wf). destruct x; intros Hx. - apply Hrec; trivial. intros y (Hy,Hy'). @@ -196,7 +196,7 @@ Section Efficient_Rec. (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) -> forall x:Z, z <= x -> P x. Proof. - intros; now apply Zlt_lower_bound_rec with z. + intros P z ? x ?; now apply Zlt_lower_bound_rec with z. Qed. End Efficient_Rec. 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/ZArith_dec.v b/theories/ZArith/ZArith_dec.v index 834f16cd9e..dc40f9ea51 100644 --- a/theories/ZArith/ZArith_dec.v +++ b/theories/ZArith/ZArith_dec.v @@ -19,7 +19,7 @@ Local Open Scope Z_scope. (* Trivial, to deprecate? *) Lemma Dcompare_inf : forall r:comparison, {r = Eq} + {r = Lt} + {r = Gt}. Proof. - induction r; auto. + intros r; induction r; auto. Defined. (* end hide *) @@ -92,7 +92,7 @@ Section decidability. Definition Z_le_lt_eq_dec : x <= y -> {x < y} + {x = y}. Proof. intro H. - apply Zcompare_rec with (n := x) (m := y). + apply (Zcompare_rec _ x y). intro. right. elim (Z.compare_eq_iff x y); auto with arith. intro. left. elim (Z.compare_eq_iff x y); auto with arith. intro H1. absurd (x > y); auto with arith. @@ -111,7 +111,7 @@ Proof. assumption. intro. right. - apply Z.le_lt_trans with (m := x). + apply (Z.le_lt_trans _ x). apply Z.ge_le. assumption. assumption. @@ -123,14 +123,14 @@ Proof. case (Zlt_cotrans 0 (x + y) H x). - now left. - right. - apply Z.add_lt_mono_l with (p := x). + apply (Z.add_lt_mono_l _ _ x). now rewrite Z.add_0_r. Defined. Lemma Zlt_cotrans_neg : forall n m:Z, n + m < 0 -> {n < 0} + {m < 0}. Proof. intros x y H; case (Zlt_cotrans (x + y) 0 H x); intro Hxy; - [ right; apply Z.add_lt_mono_l with (p := x); rewrite Z.add_0_r | left ]; + [ right; apply (Z.add_lt_mono_l _ _ x); rewrite Z.add_0_r | left ]; assumption. Defined. @@ -143,7 +143,7 @@ Proof. assumption. intro H0. generalize (Z.ge_le _ _ H0). - intro. + intro H1. case (Z_le_lt_eq_dec _ _ H1). intro. right. diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v index 21086d9b61..f869e15023 100644 --- a/theories/ZArith/Zabs.v +++ b/theories/ZArith/Zabs.v @@ -49,12 +49,12 @@ Qed. Theorem Zabs_intro : forall P (n:Z), P (- n) -> P n -> P (Z.abs n). Proof. - now destruct n. + intros P n; now destruct n. Qed. Definition Zabs_dec : forall x:Z, {x = Z.abs x} + {x = - Z.abs x}. Proof. - destruct x; auto. + intros x; destruct x; auto. Defined. Lemma Zabs_spec x : diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v index c9e1b340a6..c848623d06 100644 --- a/theories/ZArith/Zcomplements.v +++ b/theories/ZArith/Zcomplements.v @@ -13,7 +13,6 @@ Require Import ZArith_base. Require Import Wf_nat. Local Open Scope Z_scope. - (**********************************************************************) (** About parity *) @@ -39,7 +38,7 @@ Proof. reflexivity. Qed. Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p. Proof. - unfold floor. induction p as [p [IH1p IH2p]|p [IH1p IH2]|]; simpl. + unfold floor. intros p; induction p as [p [IH1p IH2p]|p [IH1p IH2]|]; simpl. - rewrite !Pos2Z.inj_xI, (Pos2Z.inj_xO (xO _)), Pos2Z.inj_xO. split. + apply Z.le_trans with (2 * Z.pos p); auto with zarith. @@ -69,10 +68,10 @@ Proof. apply (Z_lt_rec Q); auto with zarith. subst Q; intros x H. split; apply HP. - - rewrite Z.abs_eq; auto; intros. + - rewrite Z.abs_eq; auto; intros m ?. destruct (H (Z.abs m)); auto with zarith. destruct (Zabs_dec m) as [-> | ->]; trivial. - - rewrite Z.abs_neq, Z.opp_involutive; intros. + - rewrite Z.abs_neq, Z.opp_involutive; [intros m ?|]. + destruct (H (Z.abs m)); auto with zarith. destruct (Zabs_dec m) as [-> | ->]; trivial. + apply Z.opp_le_mono; rewrite Z.opp_involutive; auto. @@ -85,15 +84,15 @@ Theorem Z_lt_abs_induction : Proof. intros P HP p. set (Q := fun z => 0 <= z -> P z /\ P (- z)) in *. - enough (Q (Z.abs p)) by + enough (Q (Z.abs p)) as H by (destruct (Zabs_dec p) as [-> | ->]; elim H; auto with zarith). apply (Z_lt_induction Q); auto with zarith. - subst Q; intros. + subst Q; intros ? H. split; apply HP. - - rewrite Z.abs_eq; auto; intros. + - rewrite Z.abs_eq; auto; intros m ?. elim (H (Z.abs m)); intros; auto with zarith. elim (Zabs_dec m); intro eq; rewrite eq; trivial. - - rewrite Z.abs_neq, Z.opp_involutive; intros. + - rewrite Z.abs_neq, Z.opp_involutive; [intros m ?|]. + destruct (H (Z.abs m)); auto with zarith. destruct (Zabs_dec m) as [-> | ->]; trivial. + apply Z.opp_le_mono; rewrite Z.opp_involutive; auto. @@ -136,7 +135,7 @@ Section Zlength_properties. Lemma Zlength_correct l : Zlength l = Z.of_nat (length l). Proof. assert (H : forall l acc, Zlength_aux acc A l = acc + Z.of_nat (length l)). - clear l. induction l. + clear l. intros l; induction l as [|? ? IHl]. auto with zarith. intros. simpl length; simpl Zlength_aux. rewrite IHl, Nat2Z.inj_succ, Z.add_succ_comm; auto. diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index b6fbe64499..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. *) @@ -174,22 +175,22 @@ Proof. intros; eapply Zmod_unique_full; eauto. Qed. Lemma Zmod_0_l: forall a, 0 mod a = 0. Proof. - destruct a; simpl; auto. + intros a; destruct a; simpl; auto. Qed. Lemma Zmod_0_r: forall a, a mod 0 = 0. Proof. - destruct a; simpl; auto. + intros a; destruct a; simpl; auto. Qed. Lemma Zdiv_0_l: forall a, 0/a = 0. Proof. - destruct a; simpl; auto. + intros a; destruct a; simpl; auto. Qed. Lemma Zdiv_0_r: forall a, a/0 = 0. Proof. - destruct a; simpl; auto. + intros a; destruct a; simpl; auto. Qed. Ltac zero_or_not a := @@ -198,11 +199,12 @@ Ltac zero_or_not a := auto with zarith|]. Lemma Zmod_1_r: forall a, a mod 1 = 0. -Proof. intros. zero_or_not a. apply Z.mod_1_r. Qed. +Proof. intros a. zero_or_not a. apply Z.mod_1_r. Qed. Lemma Zdiv_1_r: forall a, a/1 = a. -Proof. intros. zero_or_not a. apply Z.div_1_r. Qed. +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. @@ -216,10 +218,10 @@ Lemma Z_div_same_full : forall a:Z, a<>0 -> a/a = 1. Proof Z.div_same. Lemma Z_mod_same_full : forall a, a mod a = 0. -Proof. intros. zero_or_not a. apply Z.mod_same; auto. Qed. +Proof. intros a. zero_or_not a. apply Z.mod_same; auto. Qed. Lemma Z_mod_mult : forall a b, (a*b) mod b = 0. -Proof. intros. zero_or_not b. apply Z.mod_mul. auto. Qed. +Proof. intros a b. zero_or_not b. apply Z.mod_mul. auto. Qed. Lemma Z_div_mult_full : forall a b:Z, b <> 0 -> (a*b)/b = a. Proof Z.div_mul. @@ -313,7 +315,7 @@ Proof. intros; apply Z.div_le_compat_l; intuition auto using Z.lt_le_incl. Qed. Theorem Zdiv_sgn: forall a b, 0 <= Z.sgn (a/b) * Z.sgn a * Z.sgn b. Proof. - destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; + intros a b; destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; generalize (Z.div_pos (Zpos a) (Zpos b)); unfold Z.div, Z.div_eucl; destruct Z.pos_div_eucl as (q,r); destruct r; rewrite ?Z.mul_1_r, <-?Z.opp_eq_mul_m1, ?Z.sgn_opp, ?Z.opp_involutive; @@ -325,7 +327,7 @@ Qed. (** * Relations between usual operations and Z.modulo and Z.div *) Lemma Z_mod_plus_full : forall a b c:Z, (a + b * c) mod c = a mod c. -Proof. intros. zero_or_not c. apply Z.mod_add; auto. Qed. +Proof. intros a b c. zero_or_not c. apply Z.mod_add; auto. Qed. Lemma Z_div_plus_full : forall a b c:Z, c <> 0 -> (a + b * c) / c = a / c + b. Proof Z.div_add. @@ -338,34 +340,34 @@ Proof Z.div_add_l. some of the relations about [Z.opp] and divisions are rather complex. *) Lemma Zdiv_opp_opp : forall a b:Z, (-a)/(-b) = a/b. -Proof. intros. zero_or_not b. apply Z.div_opp_opp; auto. Qed. +Proof. intros a b. zero_or_not b. apply Z.div_opp_opp; auto. Qed. Lemma Zmod_opp_opp : forall a b:Z, (-a) mod (-b) = - (a mod b). -Proof. intros. zero_or_not b. apply Z.mod_opp_opp; auto. Qed. +Proof. intros a b. zero_or_not b. apply Z.mod_opp_opp; auto. Qed. Lemma Z_mod_zero_opp_full : forall a b:Z, a mod b = 0 -> (-a) mod b = 0. -Proof. intros. zero_or_not b. apply Z.mod_opp_l_z; auto. Qed. +Proof. intros a b. zero_or_not b. apply Z.mod_opp_l_z; auto. Qed. Lemma Z_mod_nz_opp_full : forall a b:Z, a mod b <> 0 -> (-a) mod b = b - (a mod b). -Proof. intros. zero_or_not b. apply Z.mod_opp_l_nz; auto. Qed. +Proof. intros a b. zero_or_not b. apply Z.mod_opp_l_nz; auto. Qed. Lemma Z_mod_zero_opp_r : forall a b:Z, a mod b = 0 -> a mod (-b) = 0. -Proof. intros. zero_or_not b. apply Z.mod_opp_r_z; auto. Qed. +Proof. intros a b. zero_or_not b. apply Z.mod_opp_r_z; auto. Qed. Lemma Z_mod_nz_opp_r : forall a b:Z, a mod b <> 0 -> a mod (-b) = (a mod b) - b. -Proof. intros. zero_or_not b. apply Z.mod_opp_r_nz; auto. Qed. +Proof. intros a b ?. zero_or_not b. apply Z.mod_opp_r_nz; auto. Qed. Lemma Z_div_zero_opp_full : forall a b:Z, a mod b = 0 -> (-a)/b = -(a/b). -Proof. intros. zero_or_not b. apply Z.div_opp_l_z; auto. Qed. +Proof. intros a b ?. zero_or_not b. apply Z.div_opp_l_z; auto. Qed. Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 -> (-a)/b = -(a/b)-1. Proof. intros a b. zero_or_not b. easy. intros; rewrite Z.div_opp_l_nz; auto. Qed. Lemma Z_div_zero_opp_r : forall a b:Z, a mod b = 0 -> a/(-b) = -(a/b). -Proof. intros. zero_or_not b. apply Z.div_opp_r_z; auto. Qed. +Proof. intros a b ?. zero_or_not b. apply Z.div_opp_r_z; auto. Qed. Lemma Z_div_nz_opp_r : forall a b:Z, a mod b <> 0 -> a/(-b) = -(a/b)-1. @@ -375,19 +377,19 @@ Proof. intros a b. zero_or_not b. easy. intros; rewrite Z.div_opp_r_nz; auto. Qe Lemma Zdiv_mult_cancel_r : forall a b c:Z, c <> 0 -> (a*c)/(b*c) = a/b. -Proof. intros. zero_or_not b. apply Z.div_mul_cancel_r; auto. Qed. +Proof. intros a b c ?. zero_or_not b. apply Z.div_mul_cancel_r; auto. Qed. Lemma Zdiv_mult_cancel_l : forall a b c:Z, c<>0 -> (c*a)/(c*b) = a/b. Proof. - intros. rewrite (Z.mul_comm c b); zero_or_not b. + intros a b c ?. rewrite (Z.mul_comm c b); zero_or_not b. rewrite (Z.mul_comm b c). apply Z.div_mul_cancel_l; auto. Qed. Lemma Zmult_mod_distr_l: forall a b c, (c*a) mod (c*b) = c * (a mod b). Proof. - intros. zero_or_not c. rewrite (Z.mul_comm c b); zero_or_not b. + intros a b c. zero_or_not c. rewrite (Z.mul_comm c b); zero_or_not b. + now rewrite Z.mul_0_r. + rewrite (Z.mul_comm b c). apply Z.mul_mod_distr_l; auto. Qed. @@ -395,7 +397,7 @@ Qed. Lemma Zmult_mod_distr_r: forall a b c, (a*c) mod (b*c) = (a mod b) * c. Proof. - intros. zero_or_not b. rewrite (Z.mul_comm b c); zero_or_not c. + intros a b c. zero_or_not b. rewrite (Z.mul_comm b c); zero_or_not c. + now rewrite Z.mul_0_r. + rewrite (Z.mul_comm c b). apply Z.mul_mod_distr_r; auto. Qed. @@ -403,27 +405,27 @@ Qed. (** Operations modulo. *) Theorem Zmod_mod: forall a n, (a mod n) mod n = a mod n. -Proof. intros. zero_or_not n. apply Z.mod_mod; auto. Qed. +Proof. intros a n. zero_or_not n. apply Z.mod_mod; auto. Qed. Theorem Zmult_mod: forall a b n, (a * b) mod n = ((a mod n) * (b mod n)) mod n. -Proof. intros. zero_or_not n. apply Z.mul_mod; auto. Qed. +Proof. intros a b n. zero_or_not n. apply Z.mul_mod; auto. Qed. Theorem Zplus_mod: forall a b n, (a + b) mod n = (a mod n + b mod n) mod n. -Proof. intros. zero_or_not n. apply Z.add_mod; auto. Qed. +Proof. intros a b n. zero_or_not n. apply Z.add_mod; auto. Qed. Theorem Zminus_mod: forall a b n, (a - b) mod n = (a mod n - b mod n) mod n. Proof. - intros. + intros a b n. replace (a - b) with (a + (-1) * b); auto with zarith. replace (a mod n - b mod n) with (a mod n + (-1) * (b mod n)); auto with zarith. rewrite Zplus_mod. rewrite Zmult_mod. - rewrite Zplus_mod with (b:=(-1) * (b mod n)). + rewrite (Zplus_mod _ ((-1) * (b mod n))). rewrite Zmult_mod. - rewrite Zmult_mod with (b:= b mod n). + rewrite (Zmult_mod _ (b mod n)). repeat rewrite Zmod_mod; auto. Qed. @@ -483,17 +485,20 @@ Qed. Instance Zplus_eqm : Proper (eqm ==> eqm ==> eqm) Z.add. Proof. - unfold eqm; repeat red; intros. rewrite Zplus_mod, H, H0, <- Zplus_mod; auto. + unfold eqm; repeat red; intros ? ? H ? ? H0. + rewrite Zplus_mod, H, H0, <- Zplus_mod; auto. Qed. Instance Zminus_eqm : Proper (eqm ==> eqm ==> eqm) Z.sub. Proof. - unfold eqm; repeat red; intros. rewrite Zminus_mod, H, H0, <- Zminus_mod; auto. + unfold eqm; repeat red; intros ? ? H ? ? H0. + rewrite Zminus_mod, H, H0, <- Zminus_mod; auto. Qed. Instance Zmult_eqm : Proper (eqm ==> eqm ==> eqm) Z.mul. Proof. - unfold eqm; repeat red; intros. rewrite Zmult_mod, H, H0, <- Zmult_mod; auto. + unfold eqm; repeat red; intros ? ? H ? ? H0. + rewrite Zmult_mod, H, H0, <- Zmult_mod; auto. Qed. Instance Zopp_eqm : Proper (eqm ==> eqm) Z.opp. @@ -503,7 +508,7 @@ Qed. Lemma Zmod_eqm : forall a, (a mod N) == a. Proof. - intros; exact (Zmod_mod a N). + intros a; exact (Zmod_mod a N). Qed. (* NB: Z.modulo and Z.div are not morphisms with respect to eqm. @@ -518,7 +523,7 @@ End EqualityModulo. Lemma Zdiv_Zdiv : forall a b c, 0<=b -> 0<=c -> (a/b)/c = a/(b*c). Proof. - intros. zero_or_not b. rewrite Z.mul_comm. zero_or_not c. + intros a b c ? ?. zero_or_not b. rewrite Z.mul_comm. zero_or_not c. rewrite Z.mul_comm. apply Z.div_div; auto. apply Z.le_neq; auto. Qed. @@ -538,7 +543,7 @@ Qed. Theorem Zdiv_mult_le: forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a/b) <= (c*a)/b. Proof. - intros. zero_or_not b. now rewrite Z.mul_0_r. + intros a b c ? ? ?. zero_or_not b. now rewrite Z.mul_0_r. apply Z.div_mul_le; auto. apply Z.le_neq; auto. Qed. 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/Znat.v b/theories/ZArith/Znat.v index 6a82645ba6..7f72d42d1f 100644 --- a/theories/ZArith/Znat.v +++ b/theories/ZArith/Znat.v @@ -50,7 +50,7 @@ Qed. Lemma N_nat_Z n : Z.of_nat (N.to_nat n) = Z.of_N n. Proof. - destruct n; trivial. simpl. + destruct n as [|p]; trivial. simpl. destruct (Pos2Nat.is_succ p) as (m,H). rewrite H. simpl. f_equal. now apply SuccNat2Pos.inv. Qed. @@ -668,7 +668,7 @@ Qed. Lemma inj_abs_nat z : Z.of_nat (Z.abs_nat z) = Z.abs z. Proof. - destruct z; simpl; trivial; + destruct z as [|p|p]; simpl; trivial; destruct (Pos2Nat.is_succ p) as (n,H); rewrite H; simpl; f_equal; now apply SuccNat2Pos.inv. Qed. diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index 6ba58df721..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, @@ -256,15 +260,15 @@ Qed. Lemma Zis_gcd_for_euclid : forall a b d q:Z, Zis_gcd b (a - q * b) d -> Zis_gcd a b d. Proof. - simple induction 1; constructor; intuition. + intros a b d q; simple induction 1; constructor; intuition. replace a with (a - q * b + q * b). auto with zarith. ring. Qed. Lemma Zis_gcd_for_euclid2 : forall b d q r:Z, Zis_gcd r b d -> Zis_gcd b (b * q + r) d. Proof. - simple induction 1; constructor; intuition. - apply H2; auto. + intros b d q r; destruct 1 as [? ? H]; constructor; intuition. + apply H; auto. replace r with (b * q + r - b * q). auto with zarith. ring. Qed. @@ -300,9 +304,9 @@ Section extended_euclid_algorithm. Proof. intros v3 Hv3; generalize Hv3; pattern v3. apply Zlt_0_rec. - clear v3 Hv3; intros. + clear v3 Hv3; intros x H ? ? u1 u2 u3 v1 v2 H1 H2 H3. destruct (Z_zerop x) as [Heq|Hneq]. - apply Euclid_intro with (u := u1) (v := u2) (d := u3). + apply (Euclid_intro u1 u2 u3). assumption. apply H3. rewrite Heq; auto with zarith. @@ -333,12 +337,10 @@ Section extended_euclid_algorithm. Proof. case (Z_le_gt_dec 0 b); intro. intros; - apply euclid_rec with - (u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := 1) (v3 := b); + apply (fun H => euclid_rec b H 1 0 a 0 1); auto; ring. intros; - apply euclid_rec with - (u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := -1) (v3 := - b); + apply (fun H => euclid_rec (- b) H 1 0 a 0 (-1)); auto; try ring. now apply Z.opp_nonneg_nonpos, Z.lt_le_incl, Z.gt_lt. auto with zarith. @@ -349,8 +351,8 @@ End extended_euclid_algorithm. Theorem Zis_gcd_uniqueness_apart_sign : forall a b d d':Z, Zis_gcd a b d -> Zis_gcd a b d' -> d = d' \/ d = - d'. Proof. - simple induction 1. - intros H1 H2 H3; simple induction 1; intros. + intros a b d d'; simple induction 1. + intros H1 H2 H3; destruct 1 as [H4 H5 H6]. generalize (H3 d' H4 H5); intro Hd'd. generalize (H6 d H1 H2); intro Hdd'. exact (Z.divide_antisym d d' Hdd' Hd'd). @@ -368,7 +370,7 @@ Proof. intros a b d Hgcd. elim (euclid a b); intros u v d0 e g. generalize (Zis_gcd_uniqueness_apart_sign a b d d0 Hgcd g). - intro H; elim H; clear H; intros. + intro H; elim H; clear H; intros H. apply Bezout_intro with u v. rewrite H; assumption. apply Bezout_intro with (- u) (- v). @@ -380,7 +382,7 @@ Qed. Lemma Zis_gcd_mult : forall a b c d:Z, Zis_gcd a b d -> Zis_gcd (c * a) (c * b) (c * d). Proof. - intros a b c d; simple induction 1. constructor; auto with zarith. + intros a b c d; intro H; generalize H; simple induction 1. constructor; auto with zarith. intros x Ha Hb. elim (Zis_gcd_bezout a b d H). intros u v Huv. elim Ha; intros a' Ha'. @@ -407,7 +409,7 @@ Qed. Lemma bezout_rel_prime : forall a b:Z, Bezout a b 1 -> rel_prime a b. Proof. - simple induction 1; constructor; auto with zarith. + simple induction 1; intros ? ? H0; constructor; auto with zarith. intros. rewrite <- H0; auto with zarith. Qed. @@ -416,7 +418,7 @@ Qed. Theorem Gauss : forall a b c:Z, (a | b * c) -> rel_prime a b -> (a | c). Proof. - intros. elim (rel_prime_bezout a b H0); intros. + intros a b c H H0. elim (rel_prime_bezout a b H0); intros u v H1. replace c with (c * 1); [ idtac | ring ]. rewrite <- H1. replace (c * (u * a + v * b)) with (c * u * a + v * (b * c)); @@ -429,11 +431,11 @@ Lemma rel_prime_mult : forall a b c:Z, rel_prime a b -> rel_prime a c -> rel_prime a (b * c). Proof. intros a b c Hb Hc. - elim (rel_prime_bezout a b Hb); intros. - elim (rel_prime_bezout a c Hc); intros. + elim (rel_prime_bezout a b Hb); intros u v H. + elim (rel_prime_bezout a c Hc); intros u0 v0 H0. apply bezout_rel_prime. - apply Bezout_intro with - (u := u * u0 * a + v0 * c * u + u0 * v * b) (v := v * v0). + apply (Bezout_intro _ _ _ + (u * u0 * a + v0 * c * u + u0 * v * b) (v * v0)). rewrite <- H. replace (u * a + v * b) with ((u * a + v * b) * 1); [ idtac | ring ]. rewrite <- H0. @@ -447,7 +449,7 @@ Lemma rel_prime_cross_prod : Proof. intros a b c d; intros H H0 H1 H2 H3. elim (Z.divide_antisym b d). - - split; auto with zarith. + - intros H4; split; auto with zarith. rewrite H4 in H3. rewrite Z.mul_comm in H3. apply Z.mul_reg_l with d; auto. @@ -473,9 +475,9 @@ Lemma Zis_gcd_rel_prime : Proof. intros a b g; intros H H0 H1. assert (H2 : g <> 0) by - (intro; - elim H1; intros; - elim H4; intros; + (intro H2; + elim H1; intros ? H4 ?; + elim H4; intros ? H6; rewrite H2 in H6; subst b; contradict H; rewrite Z.mul_0_r; discriminate). assert (H3 : g > 0) by @@ -578,7 +580,7 @@ Lemma prime_divisors : forall p:Z, prime p -> forall a:Z, (a | p) -> a = -1 \/ a = 1 \/ a = p \/ a = - p. Proof. - destruct 1; intros. + intros p; destruct 1 as [H H0]; intros a ?. assert (a = - p \/ - p < a < -1 \/ a = -1 \/ a = 0 \/ a = 1 \/ 1 < a < p \/ a = p). { assert (Z.abs a <= Z.abs p) as H2. @@ -602,12 +604,13 @@ Proof. } intuition idtac. (* -p < a < -1 *) - - absurd (rel_prime (- a) p). + - match goal with [hyp : a < -1 |- _] => rename hyp into H4 end. + absurd (rel_prime (- a) p). + intros [H1p H2p H3p]. assert (- a | - a) by auto with zarith. - assert (- a | p) by auto with zarith. + assert (- a | p) as H5 by auto with zarith. apply H3p, Z.divide_1_r in H5; auto with zarith. - destruct H5. + destruct H5 as [H5|H5]. * contradict H4; rewrite <- (Z.opp_involutive a), H5 . apply Z.lt_irrefl. * contradict H4; rewrite <- (Z.opp_involutive a), H5 . @@ -616,16 +619,18 @@ Proof. * now apply Z.opp_le_mono; rewrite Z.opp_involutive; apply Z.lt_le_incl. * now apply Z.opp_lt_mono; rewrite Z.opp_involutive. (* a = 0 *) - - contradict H. + - match goal with [hyp : a = 0 |- _] => rename hyp into H2 end. + contradict H. replace p with 0; try discriminate. now apply sym_equal, Z.divide_0_l; rewrite <-H2. (* 1 < a < p *) - - absurd (rel_prime a p). + - match goal with [hyp : 1 < a |- _] => rename hyp into H3 end. + absurd (rel_prime a p). + intros [H1p H2p H3p]. assert (a | a) by auto with zarith. - assert (a | p) by auto with zarith. + assert (a | p) as H5 by auto with zarith. apply H3p, Z.divide_1_r in H5; auto with zarith. - destruct H5. + destruct H5 as [H5|H5]. * contradict H3; rewrite <- (Z.opp_involutive a), H5 . apply Z.lt_irrefl. * contradict H3; rewrite <- (Z.opp_involutive a), H5 . @@ -639,12 +644,13 @@ Qed. Lemma prime_rel_prime : forall p:Z, prime p -> forall a:Z, ~ (p | a) -> rel_prime p a. Proof. - intros; constructor; intros; auto with zarith. + intros p H a H0; constructor; auto with zarith; intros ? H1 H2. apply prime_divisors in H1; intuition; subst; auto with zarith. - absurd (p | a); auto with zarith. - absurd (p | a); intuition. Qed. +#[global] Hint Resolve prime_rel_prime: zarith. (** As a consequence, a prime number is relatively prime with smaller numbers *) @@ -671,7 +677,7 @@ Qed. Lemma prime_mult : forall p:Z, prime p -> forall a b:Z, (p | a * b) -> (p | a) \/ (p | b). Proof. - intro p; simple induction 1; intros. + intro p; simple induction 1; intros ? ? a b ?. case (Zdivide_dec p a); intuition. right; apply Gauss with a; auto with zarith. Qed. @@ -743,9 +749,9 @@ Proof. + now exists 1. + elim (H x); auto. split; trivial. - apply Z.le_lt_trans with n; try intuition. + apply Z.le_lt_trans with n; try tauto. apply Z.divide_pos_le; auto with zarith. - apply Z.lt_le_trans with (2 := H0); red; auto. + apply Z.lt_le_trans with (2 := proj1 Hn); red; auto. - (* prime' -> prime *) constructor; trivial. intros n Hn Hnp. case (Zis_gcd_unique n p n 1). @@ -865,12 +871,13 @@ 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, Z.gcd a b = 1 <-> rel_prime a b. Proof. - unfold rel_prime; split; intro H. + unfold rel_prime; intros a b; split; intro H. rewrite <- H; apply Zgcd_is_gcd. case (Zis_gcd_unique a b (Z.gcd a b) 1); auto. apply Zgcd_is_gcd. @@ -894,10 +901,10 @@ Definition prime_dec_aux: Proof. intros p m. case (Z_lt_dec 1 m); intros H1; - [ | left; intros; exfalso; + [ | left; intros n ?; exfalso; contradict H1; apply Z.lt_trans with n; intuition]. pattern m; apply natlike_rec; auto with zarith. - - left; intros; exfalso. + - left; intros n ?; exfalso. absurd (1 < 0); try discriminate. apply Z.lt_trans with n; intuition. - intros x Hx IH; destruct IH as [F|E]. diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 7e33fe2b4c..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 *) @@ -354,9 +359,10 @@ Qed. Lemma Zle_0_nat : forall n:nat, 0 <= Z.of_nat n. Proof. - induction n; simpl; intros. apply Z.le_refl. easy. + 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_def.v b/theories/ZArith/Zpow_def.v index 8609a6af98..d4f58c3b04 100644 --- a/theories/ZArith/Zpow_def.v +++ b/theories/ZArith/Zpow_def.v @@ -25,9 +25,9 @@ Notation Zpower_Ppow := Pos2Z.inj_pow (only parsing). Lemma Zpower_theory : power_theory 1 Z.mul (@eq Z) Z.of_N Z.pow. Proof. - constructor. intros. - destruct n;simpl;trivial. + constructor. intros z n. + destruct n as [|p];simpl;trivial. unfold Z.pow_pos. rewrite <- (Z.mul_1_r (pow_pos _ _ _)). generalize 1. - induction p; simpl; intros; rewrite ?IHp, ?Z.mul_assoc; trivial. + induction p as [p IHp|p IHp|]; simpl; intros; rewrite ?IHp, ?Z.mul_assoc; trivial. Qed. 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/dune b/theories/dune index c2d8197ee4..18e000cfe1 100644 --- a/theories/dune +++ b/theories/dune @@ -14,10 +14,8 @@ coq.plugins.cc coq.plugins.firstorder - coq.plugins.numeral_notation - coq.plugins.string_notation + coq.plugins.number_string_notation coq.plugins.int63_syntax - coq.plugins.r_syntax coq.plugins.float_syntax coq.plugins.btauto diff --git a/theories/micromega/EnvRing.v b/theories/micromega/EnvRing.v index 7bef11e89a..bb21472e57 100644 --- a/theories/micromega/EnvRing.v +++ b/theories/micromega/EnvRing.v @@ -557,7 +557,8 @@ Section MakeRingPol. Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l. Proof. - revert P';induction P;destruct P';simpl; intros H l; try easy. + revert P';induction P as [|p P IHP|P2 IHP1 p P3 IHP2]; + intro P';destruct P' as [|p0 P'|P'1 p0 P'2];simpl; intros H l; try easy. - now apply (morph_eq CRmorph). - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. now rewrite IHP. @@ -587,7 +588,7 @@ Section MakeRingPol. Lemma env_morph p e1 e2 : (forall x, e1 x = e2 x) -> p @ e1 = p @ e2. Proof. - revert e1 e2. induction p ; simpl. + revert e1 e2. induction p as [|? ? IHp|? IHp1 ? ? IHp2]; simpl. - reflexivity. - intros e1 e2 EQ. apply IHp. intros. apply EQ. - intros e1 e2 EQ. f_equal; [f_equal|]. @@ -664,13 +665,13 @@ Qed. Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c]. Proof. - revert l;induction P;simpl;intros;Esimpl;trivial. + revert l;induction P as [| |? ? ? ? IHP2];simpl;intros;Esimpl;trivial. rewrite IHP2;rsimpl. Qed. Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c]. Proof. - revert l;induction P;simpl;intros. + revert l;induction P as [|? ? IHP|? ? ? ? IHP2];simpl;intros. - Esimpl. - rewrite IHP;rsimpl. - rewrite IHP2;rsimpl. @@ -678,7 +679,7 @@ Qed. Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c]. Proof. - revert l;induction P;simpl;intros;Esimpl;trivial. + revert l;induction P as [| |? IHP1 ? ? IHP2];simpl;intros;Esimpl;trivial. rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut. Qed. @@ -694,7 +695,7 @@ Qed. Lemma Popp_ok P l : (--P)@l == - P@l. Proof. - revert l;induction P;simpl;intros. + revert l;induction P as [|? ? IHP|? IHP1 ? ? IHP2];simpl;intros. - Esimpl. - apply IHP. - rewrite IHP1, IHP2;rsimpl. @@ -707,7 +708,7 @@ Qed. (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k. Proof. intros IHP'. - revert k l. induction P;simpl;intros. + revert k l. induction P as [|p|? IHP1];simpl;intros. - add_permut. - destruct p; simpl; rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut. @@ -719,8 +720,8 @@ Qed. Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l. Proof. - revert P l; induction P';simpl;intros;Esimpl. - - revert p l; induction P;simpl;intros. + revert P l; induction P' as [|p P' IHP'|? IHP'1 ? ? IHP'2];simpl;intros P l;Esimpl. + - revert p l; induction P as [|? P IHP|? IHP1 p ? IHP2];simpl;intros p0 l. + Esimpl; add_permut. + destr_pos_sub; intros ->;Esimpl. * now rewrite IHP'. @@ -730,7 +731,7 @@ Qed. * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl. * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl. * rewrite IHP'. rsimpl. - - destruct P;simpl. + - destruct P as [|p0|];simpl. + Esimpl. add_permut. + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. * rewrite Pjump_xO_tail. rsimpl. add_permut. @@ -749,7 +750,7 @@ Qed. (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k. Proof. intros IHP'. - revert k l. induction P;simpl;intros. + revert k l. induction P as [|p|? IHP1];simpl;intros. - rewrite Popp_ok;rsimpl; add_permut. - destruct p; simpl; rewrite Popp_ok;rsimpl; @@ -762,8 +763,8 @@ Qed. Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l. Proof. - revert P l; induction P';simpl;intros;Esimpl. - - revert p l; induction P;simpl;intros. + revert P l; induction P' as [|p P' IHP'|? IHP'1 ? ? IHP'2];simpl;intros P l;Esimpl. + - revert p l; induction P as [|? ? IHP|? IHP1 ? ? IHP2];simpl;intros p0 l. + Esimpl; add_permut. + destr_pos_sub; intros ->;Esimpl. * rewrite IHP';rsimpl. @@ -773,7 +774,7 @@ Qed. * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl. * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl. * rewrite IHP'. rsimpl. - - destruct P;simpl. + - destruct P as [|p0|];simpl. + Esimpl; add_permut. + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. * rewrite Pjump_xO_tail. rsimpl. add_permut. @@ -791,8 +792,8 @@ Qed. (forall P l, (Pmul P P') @ l == P @ l * P' @ l) -> forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). Proof. - intros IHP'. - induction P;simpl;intros. + intros IHP' P. + induction P as [|? ? IHP|? IHP1 ? ? IHP2];simpl;intros p0 l. - Esimpl; mul_permut. - destr_pos_sub; intros ->;Esimpl. + now rewrite IHP'. @@ -806,10 +807,10 @@ Qed. Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l. Proof. - revert P l;induction P';simpl;intros. + revert P l;induction P' as [| |? IHP'1 ? ? IHP'2];simpl;intros P l. - apply PmulC_ok. - apply PmulI_ok;trivial. - - destruct P. + - destruct P as [|p0|]. + rewrite (ARmul_comm ARth). Esimpl. + Esimpl. rewrite IHP'1;Esimpl. f_equiv. destruct p0;rewrite IHP'2;Esimpl. @@ -823,7 +824,7 @@ Qed. Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l. Proof. - revert l;induction P;simpl;intros;Esimpl. + revert l;induction P as [|? ? IHP|P2 IHP1 p ? IHP2];simpl;intros l;Esimpl. - apply IHP. - rewrite Padd_ok, Pmul_ok;Esimpl. rewrite IHP1, IHP2. @@ -833,7 +834,7 @@ Qed. Lemma Mphi_morph M e1 e2 : (forall x, e1 x = e2 x) -> M @@ e1 = M @@ e2. Proof. - revert e1 e2; induction M; simpl; intros e1 e2 EQ; trivial. + revert e1 e2; induction M as [|? ? IHM|? ? IHM]; simpl; intros e1 e2 EQ; trivial. - apply IHM. intros; apply EQ. - f_equal. * apply IHM. intros; apply EQ. @@ -890,7 +891,8 @@ Qed. let (Q,R) := MFactor P M in P@l == Q@l + M@@l * R@l. Proof. - revert M l; induction P; destruct M; intros l; simpl; auto; Esimpl. + revert M l; induction P as [|? ? IHP|? IHP1 ? ? IHP2]; + intros M; destruct M; intros l; simpl; auto; Esimpl. - case Pos.compare_spec; intros He; simpl. * destr_mfactor R1 S1. now rewrite IHP, He, !mkPinj_ok. * destr_mfactor R1 S1. rewrite IHP; simpl. @@ -922,7 +924,7 @@ Qed. Lemma PNSubst1_ok n P1 M1 P2 l : M1@@l == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. Proof. - revert P1. induction n; simpl; intros P1; + revert P1. induction n as [|n IHn]; simpl; intros P1; generalize (POneSubst_ok P1 M1 P2); destruct POneSubst; intros; rewrite <- ?IHn; auto; reflexivity. Qed. @@ -953,7 +955,7 @@ Qed. Lemma PSubstL_ok n LM1 P1 P2 l : PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. Proof. - revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros. + revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros P3 H **. - discriminate. - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. * injection H as [= <-]. rewrite <- PSubstL1_ok; intuition. @@ -963,7 +965,7 @@ Qed. Lemma PNSubstL_ok m n LM1 P1 l : MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. Proof. - revert LM1 P1. induction m; simpl; intros; + revert LM1 P1. induction m as [|m IHm]; simpl; intros LM1 P2 **; assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL; auto; try reflexivity. rewrite <- IHm; auto. @@ -1017,7 +1019,7 @@ Section POWER. forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. Proof. intros subst_l_ok res P p. revert res. - induction p;simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp; + induction p as [p IHp|p IHp|];simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp; mul_permut. Qed. @@ -1025,7 +1027,7 @@ Section POWER. (forall P, subst_l P@l == P@l) -> forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. Proof. - destruct n;simpl. + intros ? P n;destruct n;simpl. - reflexivity. - rewrite Ppow_pos_ok by trivial. Esimpl. Qed. @@ -1092,7 +1094,7 @@ Section POWER. PEeval l pe == (norm_aux pe)@l. Proof. intros. - induction pe. + induction pe as [| |pe1 IHpe1 pe2 IHpe2|? IHpe1 ? IHpe2|? IHpe1 ? IHpe2|? IHpe|? IHpe n0]. - reflexivity. - apply mkX_ok. - simpl PEeval. rewrite IHpe1, IHpe2. @@ -1104,8 +1106,8 @@ Section POWER. - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - simpl. rewrite IHpe. Esimpl. - simpl. rewrite Ppow_N_ok by reflexivity. - rewrite (rpow_pow_N pow_th). destruct n0; simpl; Esimpl. - induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. + rewrite (rpow_pow_N pow_th). destruct n0 as [|p]; simpl; Esimpl. + induction p as [p IHp|p IHp|];simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. End NORM_SUBST_REC. diff --git a/theories/micromega/OrderedRing.v b/theories/micromega/OrderedRing.v index ea9b20847b..5fa3740ab1 100644 --- a/theories/micromega/OrderedRing.v +++ b/theories/micromega/OrderedRing.v @@ -235,13 +235,13 @@ Qed. Theorem Rle_lt_trans : forall n m p : R, n <= m -> m < p -> n < p. Proof. intros n m p H1 H2; le_elim H1. -now apply Rlt_trans with (m := m). now rewrite H1. +now apply (Rlt_trans (m := m)). now rewrite H1. Qed. Theorem Rlt_le_trans : forall n m p : R, n < m -> m <= p -> n < p. Proof. intros n m p H1 H2; le_elim H2. -now apply Rlt_trans with (m := m). now rewrite <- H2. +now apply (Rlt_trans (m := m)). now rewrite <- H2. Qed. Theorem Rle_gt_cases : forall n m : R, n <= m \/ m < n. diff --git a/theories/micromega/Refl.v b/theories/micromega/Refl.v index 1189309af1..0f82f9e578 100644 --- a/theories/micromega/Refl.v +++ b/theories/micromega/Refl.v @@ -31,7 +31,7 @@ Fixpoint make_impl (A : Type) (eval : A -> Prop) (l : list A) (goal : Prop) {str Theorem make_impl_true : forall (A : Type) (eval : A -> Prop) (l : list A), make_impl eval l True. Proof. -induction l as [| a l IH]; simpl. +intros A eval l; induction l as [| a l IH]; simpl. trivial. intro; apply IH. Qed. @@ -42,9 +42,9 @@ Theorem make_impl_map : (EVAL : forall x, eval' x <-> eval (fst x)), make_impl eval' l r <-> make_impl eval (List.map fst l) r. Proof. -induction l as [| a l IH]; simpl. +intros A B eval eval' l; induction l as [| a l IH]; simpl. - tauto. -- intros. +- intros r EVAL. rewrite EVAL. rewrite IH. tauto. @@ -61,18 +61,18 @@ Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop Theorem make_conj_cons : forall (A : Type) (eval : A -> Prop) (a : A) (l : list A), make_conj eval (a :: l) <-> eval a /\ make_conj eval l. Proof. -intros; destruct l; simpl; tauto. +intros A eval a l; destruct l; simpl; tauto. Qed. Lemma make_conj_impl : forall (A : Type) (eval : A -> Prop) (l : list A) (g : Prop), (make_conj eval l -> g) <-> make_impl eval l g. Proof. - induction l. + intros A eval l; induction l as [|? l IHl]. simpl. tauto. simpl. - intros. + intros g. destruct l. simpl. tauto. @@ -83,11 +83,11 @@ Qed. Lemma make_conj_in : forall (A : Type) (eval : A -> Prop) (l : list A), make_conj eval l -> (forall p, In p l -> eval p). Proof. - induction l. + intros A eval l; induction l as [|? l IHl]. simpl. tauto. simpl. - intros. + intros H ? H0. destruct l. simpl in H0. destruct H0. @@ -101,10 +101,10 @@ Qed. Lemma make_conj_app : forall A eval l1 l2, @make_conj A eval (l1 ++ l2) <-> @make_conj A eval l1 /\ @make_conj A eval l2. Proof. - induction l1. + intros A eval l1; induction l1 as [|a l1 IHl1]. simpl. tauto. - intros. + intros l2. change ((a::l1) ++ l2) with (a :: (l1 ++ l2)). rewrite make_conj_cons. rewrite IHl1. @@ -116,7 +116,7 @@ Infix "+++" := rev_append (right associativity, at level 60) : list_scope. Lemma make_conj_rapp : forall A eval l1 l2, @make_conj A eval (l1 +++ l2) <-> @make_conj A eval (l1++l2). Proof. - induction l1. + intros A eval l1; induction l1 as [|? ? IHl1]. - simpl. tauto. - intros. simpl rev_append at 1. @@ -141,10 +141,10 @@ Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval (no_middle_eval : forall d, eval d \/ ~ eval d) , ~ make_conj eval (t ++ a) <-> (~ make_conj eval t) \/ (~ make_conj eval a). Proof. - induction t. + intros A t; induction t as [|a t IHt]. - simpl. tauto. - - intros. + - intros a0 **. simpl ((a::t)++a0). rewrite !not_make_conj_cons by auto. rewrite IHt by auto. diff --git a/theories/micromega/RingMicromega.v b/theories/micromega/RingMicromega.v index fb7fbcf80b..b5289b5800 100644 --- a/theories/micromega/RingMicromega.v +++ b/theories/micromega/RingMicromega.v @@ -215,7 +215,7 @@ Lemma OpMult_sound : forall (o o' om: Op1) (x y : R), eval_op1 o x -> eval_op1 o' y -> OpMult o o' = Some om -> eval_op1 om (x * y). Proof. -unfold eval_op1; destruct o; simpl; intros o' om x y H1 H2 H3. +unfold eval_op1; intros o; destruct o; simpl; intros o' om x y H1 H2 H3. (* x == 0 *) inversion H3. rewrite H1. now rewrite (Rtimes_0_l sor). (* x ~= 0 *) @@ -246,9 +246,9 @@ Lemma OpAdd_sound : forall (o o' oa : Op1) (e e' : R), eval_op1 o e -> eval_op1 o' e' -> OpAdd o o' = Some oa -> eval_op1 oa (e + e'). Proof. -unfold eval_op1; destruct o; simpl; intros o' oa e e' H1 H2 Hoa. +unfold eval_op1; intros o; destruct o; simpl; intros o' oa e e' H1 H2 Hoa. (* e == 0 *) -inversion Hoa. rewrite <- H0. +inversion Hoa as [H0]. rewrite <- H0. destruct o' ; rewrite H1 ; now rewrite (Rplus_0_l sor). (* e ~= 0 *) destruct o'. @@ -373,8 +373,8 @@ Lemma pexpr_times_nformula_correct : forall (env: PolEnv) (e: PolC) (f f' : NFor eval_nformula env f'. Proof. unfold pexpr_times_nformula. - destruct f. - intros. destruct o ; inversion H0 ; try discriminate. + intros env e f; destruct f as [? o]. + intros f' H H0. destruct o ; inversion H0 ; try discriminate. simpl in *. unfold eval_pol in *. rewrite (Pmul_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). @@ -388,9 +388,9 @@ Lemma nformula_times_nformula_correct : forall (env:PolEnv) eval_nformula env f. Proof. unfold nformula_times_nformula. - destruct f1 ; destruct f2. + intros env f1 f2; destruct f1 as [? o]; destruct f2 as [? o0]. case_eq (OpMult o o0) ; simpl ; try discriminate. - intros. inversion H2 ; simpl. + intros o1 H ? H0 H1 H2. inversion H2 ; simpl. unfold eval_pol. destruct o1; simpl; rewrite (Pmul_ok (SORsetoid sor) Rops_wd @@ -405,9 +405,9 @@ Lemma nformula_plus_nformula_correct : forall (env:PolEnv) eval_nformula env f. Proof. unfold nformula_plus_nformula. - destruct f1 ; destruct f2. + intros env f1 f2; destruct f1 as [? o] ; destruct f2 as [? o0]. case_eq (OpAdd o o0) ; simpl ; try discriminate. - intros. inversion H2 ; simpl. + intros o1 H ? H0 H1 H2. inversion H2 ; simpl. unfold eval_pol. destruct o1; simpl; rewrite (Padd_ok (SORsetoid sor) Rops_wd @@ -421,9 +421,10 @@ Lemma eval_Psatz_Sound : forall (e : Psatz) (f : NFormula), eval_Psatz l e = Some f -> eval_nformula env f. Proof. - induction e. + intros l env H e; + induction e as [n|?|? e IHe|e1 IHe1 e2 IHe2|e1 IHe1 e2 IHe2|c|]. (* PsatzIn *) - simpl ; intros. + simpl ; intros f H0. destruct (nth_in_or_default n l (Pc cO, Equal)) as [Hin|Heq]. (* index is in bounds *) apply H. congruence. @@ -432,7 +433,7 @@ Proof. rewrite Heq. simpl. now apply (morph0 (SORrm addon)). (* PsatzSquare *) - simpl. intros. inversion H0. + simpl. intros ? H0. inversion H0. simpl. unfold eval_pol. rewrite (Psquare_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)); @@ -440,7 +441,7 @@ Proof. (* PsatzMulC *) simpl. intro. - case_eq (eval_Psatz l e) ; simpl ; intros. + case_eq (eval_Psatz l e) ; simpl ; intros ? H0; [intros H1|]. apply IHe in H0. apply pexpr_times_nformula_correct with (1:=H0) (2:= H1). discriminate. @@ -448,24 +449,24 @@ Proof. simpl ; intro. case_eq (eval_Psatz l e1) ; simpl ; try discriminate. case_eq (eval_Psatz l e2) ; simpl ; try discriminate. - intros. + intros n H0 n0 H1 ?. apply IHe1 in H1. apply IHe2 in H0. apply (nformula_times_nformula_correct env n0 n) ; assumption. (* PsatzAdd *) simpl ; intro. case_eq (eval_Psatz l e1) ; simpl ; try discriminate. case_eq (eval_Psatz l e2) ; simpl ; try discriminate. - intros. + intros n H0 n0 H1 ?. apply IHe1 in H1. apply IHe2 in H0. apply (nformula_plus_nformula_correct env n0 n) ; assumption. (* PsatzC *) simpl. intro. case_eq (cO [<] c). - intros. inversion H1. simpl. + intros H0 H1. inversion H1. simpl. rewrite <- (morph0 (SORrm addon)). now apply cltb_sound. discriminate. (* PsatzZ *) - simpl. intros. inversion H0. + simpl. intros ? H0. inversion H0. simpl. apply (morph0 (SORrm addon)). Qed. @@ -484,7 +485,8 @@ Fixpoint ge_bool (n m : nat) : bool := Lemma ge_bool_cases : forall n m, (if ge_bool n m then n >= m else n < m)%nat. Proof. - induction n; destruct m ; simpl; auto with arith. + intros n; induction n as [|n IHn]; + intros m; destruct m as [|m]; simpl; auto with arith. specialize (IHn m). destruct (ge_bool); auto with arith. Qed. @@ -511,26 +513,27 @@ Fixpoint extract_hyps (l: list NFormula) (ln : list nat) : list NFormula := | nil => nil | n::ln => nth n l (Pc cO, Equal) :: extract_hyps l ln end. - + Lemma extract_hyps_app : forall l ln1 ln2, extract_hyps l (ln1 ++ ln2) = (extract_hyps l ln1) ++ (extract_hyps l ln2). Proof. - induction ln1. + intros l ln1; induction ln1 as [|? ln1 IHln1]. reflexivity. simpl. intros. rewrite IHln1. reflexivity. Qed. - + Ltac inv H := inversion H ; try subst ; clear H. Lemma nhyps_of_psatz_correct : forall (env : PolEnv) (e:Psatz) (l : list NFormula) (f: NFormula), - eval_Psatz l e = Some f -> + eval_Psatz l e = Some f -> ((forall f', In f' (extract_hyps l (nhyps_of_psatz e)) -> eval_nformula env f') -> eval_nformula env f). Proof. - induction e ; intros. + intros env e; induction e as [n|?|? e IHe|e1 IHe1 e2 IHe2|e1 IHe1 e2 IHe2|c|]; + intros l f H H0. (*PsatzIn*) - simpl in *. + simpl in *. apply H0. intuition congruence. (* PsatzSquare *) simpl in *. @@ -543,15 +546,15 @@ Proof. (* PsatzMulC *) simpl in *. case_eq (eval_Psatz l e). - intros. rewrite H1 in H. simpl in H. + intros ? H1. rewrite H1 in H. simpl in H. apply pexpr_times_nformula_correct with (2:= H). apply IHe with (1:= H1); auto. - intros. rewrite H1 in H. simpl in H ; discriminate. + intros H1. rewrite H1 in H. simpl in H ; discriminate. (* PsatzMulE *) simpl in *. revert H. case_eq (eval_Psatz l e1). - case_eq (eval_Psatz l e2) ; simpl ; intros. + case_eq (eval_Psatz l e2) ; simpl ; intros ? H ? H1; [intros H2|]. apply nformula_times_nformula_correct with (3:= H2). apply IHe1 with (1:= H1) ; auto. intros. apply H0. rewrite extract_hyps_app. @@ -564,7 +567,7 @@ Proof. simpl in *. revert H. case_eq (eval_Psatz l e1). - case_eq (eval_Psatz l e2) ; simpl ; intros. + case_eq (eval_Psatz l e2) ; simpl ; intros ? H ? H1; [intros H2|]. apply nformula_plus_nformula_correct with (3:= H2). apply IHe1 with (1:= H1) ; auto. intros. apply H0. rewrite extract_hyps_app. @@ -576,16 +579,16 @@ Proof. (* PsatzC *) simpl in H. case_eq (cO [<] c). - intros. rewrite H1 in H. inv H. + intros H1. rewrite H1 in H. inv H. unfold eval_nformula. simpl. rewrite <- (morph0 (SORrm addon)). now apply cltb_sound. - intros. rewrite H1 in H. discriminate. + intros H1. rewrite H1 in H. discriminate. (* PsatzZ *) simpl in *. inv H. unfold eval_nformula. simpl. apply (morph0 (SORrm addon)). Qed. - + @@ -663,8 +666,8 @@ intros l cm H env. unfold check_normalised_formulas in H. revert H. case_eq (eval_Psatz l cm) ; [|discriminate]. -intros nf. intros. -rewrite <- make_conj_impl. intro. +intros nf. intros H H0. +rewrite <- make_conj_impl. intro H1. assert (H1' := make_conj_in _ _ H1). assert (Hnf := @eval_Psatz_Sound _ _ H1' _ _ H). destruct nf. @@ -861,7 +864,7 @@ Proof. set (F := (fun (x : NFormula) (acc : list (list (NFormula * T))) => if check_inconsistent x then acc else ((x, tg) :: nil) :: acc)). set (G := ((fun x : NFormula => eval_nformula env x -> False))). - induction l. + induction l as [|a l IHl]. - compute. tauto. - rewrite make_conj_cons. @@ -896,13 +899,13 @@ Definition cnf_negate {T: Type} (t: Formula C) (tg: T) : cnf NFormula T := Lemma eq0_cnf : forall x, (0 < x -> False) /\ (0 < - x -> False) <-> x == 0. Proof. - split ; intros. + intros x; split ; intros H. + apply (SORle_antisymm sor). * now rewrite (Rle_ngt sor). * rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). setoid_replace (0 - x) with (-x) by ring. tauto. - + split; intro. + + split; intro H0. * rewrite (SORlt_le_neq sor) in H0. apply (proj2 H0). now rewrite H. @@ -918,7 +921,7 @@ Proof. destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; repeat rewrite eval_pol_opp; - generalize (eval_pol env e) as x; intro. + generalize (eval_pol env e) as x; intro x. - apply eq0_cnf. - unfold not. tauto. - symmetry. rewrite (Rlt_nge sor). @@ -955,7 +958,7 @@ Proof. intros T env t tg. unfold cnf_normalise. rewrite normalise_sound. - generalize (normalise t) as f;intro. + generalize (normalise t) as f;intro f. destruct (check_inconsistent f) eqn:U. - destruct f as [e op]. assert (US := check_inconsistent_sound _ _ U env). @@ -970,7 +973,7 @@ Proof. intros T env t tg. rewrite normalise_sound. unfold cnf_negate. - generalize (normalise t) as f;intro. + generalize (normalise t) as f;intro f. destruct (check_inconsistent f) eqn:U. - destruct f as [e o]. @@ -983,9 +986,9 @@ Qed. Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). Proof. - intros. - destruct d ; simpl. - generalize (eval_pol env p); intros. + intros env d. + destruct d as [p o]; simpl. + generalize (eval_pol env p); intros r. destruct o ; simpl. apply (Req_em sor r 0). destruct (Req_em sor r 0) ; tauto. @@ -1008,7 +1011,7 @@ Lemma xdenorm_correct : forall p i env, eval_pol (jump i env) p == eval_pexpr env (xdenorm (Pos.succ i) p). Proof. unfold eval_pol. - induction p. + intros p; induction p as [|? p IHp|p2 IHp1 ? p3 IHp2]. simpl. reflexivity. (* Pinj *) simpl. @@ -1037,7 +1040,7 @@ Definition denorm := xdenorm xH. Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p). Proof. unfold denorm. - induction p. + intros p; induction p as [| |? IHp1 ? ? IHp2]. reflexivity. simpl. rewrite Pos.add_1_r. @@ -1092,7 +1095,9 @@ Definition eval_sformula (env : PolEnv) (f : Formula S) : Prop := Lemma eval_pexprSC : forall env s, eval_sexpr env s = eval_pexpr env (map_PExpr s). Proof. unfold eval_pexpr, eval_sexpr. - induction s ; simpl ; try (rewrite IHs1 ; rewrite IHs2) ; try reflexivity. + intros env s; + induction s as [| |? IHs1 ? IHs2|? IHs1 ? IHs2|? IHs1 ? IHs2|? IHs|? IHs ?]; + simpl ; try (rewrite IHs1 ; rewrite IHs2) ; try reflexivity. apply phi_C_of_S. rewrite IHs. reflexivity. rewrite IHs. reflexivity. @@ -1101,7 +1106,7 @@ Qed. (** equality might be (too) strong *) Lemma eval_formulaSC : forall env f, eval_sformula env f = eval_formula env (map_Formula f). Proof. - destruct f. + intros env f; destruct f. simpl. repeat rewrite eval_pexprSC. reflexivity. @@ -1122,8 +1127,8 @@ Definition simpl_cone (e:Psatz) : Psatz := end | PsatzMulE t1 t2 => match t1 , t2 with - | PsatzZ , x => PsatzZ - | x , PsatzZ => PsatzZ + | PsatzZ , _ => PsatzZ + | _ , PsatzZ => PsatzZ | PsatzC c , PsatzC c' => PsatzC (ctimes c c') | PsatzC p1 , PsatzMulE (PsatzC p2) x => PsatzMulE (PsatzC (ctimes p1 p2)) x | PsatzC p1 , PsatzMulE x (PsatzC p2) => PsatzMulE (PsatzC (ctimes p1 p2)) x diff --git a/theories/micromega/Tauto.v b/theories/micromega/Tauto.v index dddced5739..ce12b02359 100644 --- a/theories/micromega/Tauto.v +++ b/theories/micromega/Tauto.v @@ -185,7 +185,7 @@ Section S. | EQ f1 f2 => (eval_f f1) = (eval_f f2) end. Proof. - destruct f ; reflexivity. + intros k f; destruct f ; reflexivity. Qed. End EVAL. @@ -197,23 +197,23 @@ Section S. Definition eiff (k: kind) : rtyp k -> rtyp k -> Prop := if k as k' return rtyp k' -> rtyp k' -> Prop then iff else @eq bool. - Lemma eiff_refl : forall (k: kind) (x : rtyp k), + Lemma eiff_refl (k: kind) (x : rtyp k) : eiff k x x. Proof. destruct k ; simpl; tauto. Qed. - Lemma eiff_sym : forall k (x y : rtyp k), eiff k x y -> eiff k y x. + Lemma eiff_sym k (x y : rtyp k) : eiff k x y -> eiff k y x. Proof. destruct k ; simpl; intros ; intuition. Qed. - Lemma eiff_trans : forall k (x y z : rtyp k), eiff k x y -> eiff k y z -> eiff k x z. + Lemma eiff_trans k (x y z : rtyp k) : eiff k x y -> eiff k y z -> eiff k x z. Proof. destruct k ; simpl; intros ; intuition congruence. Qed. - Lemma hold_eiff : forall (k: kind) (x y : rtyp k), + Lemma hold_eiff (k: kind) (x y : rtyp k) : (hold k x <-> hold k y) <-> eiff k x y. Proof. destruct k ; simpl. @@ -266,7 +266,10 @@ Section S. forall (k: kind)(f : GFormula k), (eiff k (eval_f ev f) (eval_f ev' f)). Proof. - induction f ; simpl. + intros ev ev' H k f; + induction f as [| | | |? ? IHf1 ? IHf2|? ? IHf1 ? IHf2|? ? IHf + |? ? IHf1 ? ? IHf2|? ? IHf1 ? IHf2|]; + simpl. - reflexivity. - reflexivity. - reflexivity. @@ -319,7 +322,7 @@ Lemma map_simpl : forall A B f l, @map A B f l = match l with | a :: l=> (f a) :: (@map A B f l) end. Proof. - destruct l ; reflexivity. + intros A B f l; destruct l ; reflexivity. Qed. @@ -469,7 +472,7 @@ Section S. Lemma is_bool_inv : forall {TX : kind -> Type} {AF: Type} (k: kind) (f : TFormula TX AF k) res, is_bool f = Some res -> f = if res then TT _ else FF _. Proof. - intros. + intros TX AF k f res H. destruct f ; inversion H; reflexivity. Qed. @@ -689,7 +692,7 @@ Section S. Definition is_X_inv : forall (k: kind) (f: TFormula TX AF k) x, is_X f = Some x -> f = X k x. Proof. - destruct f ; simpl ; try congruence. + intros k f; destruct f ; simpl ; try congruence. Qed. Variable needA : Annot -> bool. @@ -786,7 +789,7 @@ Section S. Lemma if_same : forall {A: Type} (b: bool) (t:A), (if b then t else t) = t. Proof. - destruct b ; reflexivity. + intros A b; destruct b ; reflexivity. Qed. Lemma is_cnf_tt_cnf_ff : @@ -806,14 +809,14 @@ Section S. is_cnf_tt f1 = true -> f1 = cnf_tt. Proof. unfold cnf_tt. - destruct f1 ; simpl ; try congruence. + intros f1; destruct f1 ; simpl ; try congruence. Qed. Lemma is_cnf_ff_inv : forall f1, is_cnf_ff f1 = true -> f1 = cnf_ff. Proof. unfold cnf_ff. - destruct f1 ; simpl ; try congruence. + intros f1 ; destruct f1 as [|c f1] ; simpl ; try congruence. destruct c ; simpl ; try congruence. destruct f1 ; try congruence. reflexivity. @@ -822,7 +825,7 @@ Section S. Lemma if_cnf_tt : forall f, (if is_cnf_tt f then cnf_tt else f) = f. Proof. - intros. + intros f. destruct (is_cnf_tt f) eqn:EQ. apply is_cnf_tt_inv in EQ;auto. reflexivity. @@ -831,7 +834,7 @@ Section S. Lemma or_cnf_opt_cnf_ff : forall f, or_cnf_opt cnf_ff f = f. Proof. - intros. + intros f. unfold or_cnf_opt. rewrite is_cnf_tt_cnf_ff. simpl. @@ -848,7 +851,7 @@ Section S. and_cnf_opt (xcnf pol f1) (xcnf pol f2) = xcnf pol (abs_and f1 f2 (if pol then AND else OR)). Proof. - unfold abs_and; intros. + unfold abs_and; intros k f1 f2 pol. destruct (is_X f1) eqn:EQ1. apply is_X_inv in EQ1. subst. @@ -868,7 +871,7 @@ Section S. or_cnf_opt (xcnf pol f1) (xcnf pol f2) = xcnf pol (abs_or f1 f2 (if pol then OR else AND)). Proof. - unfold abs_or; intros. + unfold abs_or; intros k f1 f2 pol. destruct (is_X f1) eqn:EQ1. apply is_X_inv in EQ1. subst. @@ -889,7 +892,7 @@ Section S. Lemma xcnf_true_mk_arrow_l : forall b o t (f:TFormula TX AF b), xcnf true (mk_arrow o (X b t) f) = xcnf true f. Proof. - destruct o ; simpl; auto. + intros b o; destruct o ; simpl; auto. intros. rewrite or_cnf_opt_cnf_ff. reflexivity. Qed. @@ -907,8 +910,8 @@ Section S. Lemma xcnf_true_mk_arrow_r : forall b o t (f:TFormula TX AF b), xcnf true (mk_arrow o f (X b t)) = xcnf false f. Proof. - destruct o ; simpl; auto. - - intros. + intros b o; destruct o ; simpl; auto. + - intros t f. destruct (is_X f) eqn:EQ. apply is_X_inv in EQ. subst. reflexivity. simpl. @@ -939,7 +942,7 @@ Section S. Lemma and_cnf_opt_cnf_tt : forall f, and_cnf_opt f cnf_tt = f. Proof. - intros. + intros f. unfold and_cnf_opt. simpl. rewrite orb_comm. simpl. @@ -951,7 +954,7 @@ Section S. Lemma is_bool_abst_simpl : forall b (f:TFormula TX AF b), is_bool (abst_simpl f) = is_bool f. Proof. - induction f ; simpl ; auto. + intros b f; induction f ; simpl ; auto. rewrite needA_all. reflexivity. Qed. @@ -959,7 +962,10 @@ Section S. Lemma abst_simpl_correct : forall b (f:TFormula TX AF b) pol, xcnf pol f = xcnf pol (abst_simpl f). Proof. - induction f; simpl;intros; + intros b f; + induction f as [| | | |? ? IHf1 f2 IHf2|? ? IHf1 f2 IHf2 + |? ? IHf|? ? IHf1 ? f2 IHf2|? ? IHf1 f2 IHf2|f1 IHf1 f2 IHf2]; + simpl;intros; unfold mk_and,mk_or,mk_impl, mk_iff; rewrite <- ?IHf; try (rewrite <- !IHf1; rewrite <- !IHf2); @@ -972,11 +978,11 @@ Section S. destruct (is_bool f2); auto. Qed. - Ltac is_X := + Ltac is_X t := match goal with | |-context[is_X ?X] => let f := fresh "EQ" in - destruct (is_X X) eqn:f ; + destruct (is_X X) as [t|] eqn:f ; [apply is_X_inv in f|] end. @@ -995,10 +1001,10 @@ Section S. Proof. unfold or_is_X. intros k f1 f2. - repeat is_X. - exists t ; intuition. + is_X t; is_X t0. exists t ; intuition. exists t ; intuition. + exists t0 ; intuition. congruence. Qed. @@ -1008,8 +1014,8 @@ Section S. | None => mk_iff xcnf pol f1 f2 end = mk_iff xcnf pol f1 f2. Proof. - intros. - destruct (is_bool f2) eqn:EQ; auto. + intros k f1 f2 pol. + destruct (is_bool f2) as [b|] eqn:EQ; auto. apply is_bool_inv in EQ. subst. unfold mk_iff. @@ -1024,7 +1030,7 @@ Section S. (pol : bool), xcnf pol (IFF f1 f2) = xcnf pol (abst_iff abst_form pol f1 f2). Proof. - intros; simpl. + intros k f1 f2 IHf1 IHf2 pol; simpl. assert (D1 :mk_iff xcnf pol f1 f2 = mk_iff xcnf pol (abst_simpl f1) (abst_simpl f2)). { simpl. @@ -1066,7 +1072,7 @@ Section S. (pol : bool), xcnf pol (EQ f1 f2) = xcnf pol (abst_form pol (EQ f1 f2)). Proof. - intros. + intros f1 f2 IHf1 IHf2 pol. change (xcnf pol (IFF f1 f2) = xcnf pol (abst_form pol (EQ f1 f2))). rewrite abst_iff_correct by assumption. simpl. unfold abst_iff, abst_eq. @@ -1080,7 +1086,10 @@ Section S. Lemma abst_form_correct : forall b (f:TFormula TX AF b) pol, xcnf pol f = xcnf pol (abst_form pol f). Proof. - induction f;intros. + intros b f; + induction f as [| | | |? ? IHf1 ? IHf2|? ? IHf1 ? IHf2|? f IHf + |? f1 IHf1 o f2 IHf2|? IHf1 ? IHf2|]; + intros pol. - simpl. destruct pol ; reflexivity. - simpl. destruct pol ; reflexivity. - simpl. reflexivity. @@ -1178,14 +1187,14 @@ Section S. Lemma radd_term_term : forall a' a cl, radd_term a a' = inl cl -> add_term a a' = Some cl. Proof. - induction a' ; simpl. - - intros. - destruct (deduce (fst a) (fst a)). + intros a'; induction a' as [|a a' IHa']; simpl. + - intros a cl H. + destruct (deduce (fst a) (fst a)) as [t|]. destruct (unsat t). congruence. inversion H. reflexivity. inversion H ;reflexivity. - - intros. - destruct (deduce (fst a0) (fst a)). + - intros a0 cl H. + destruct (deduce (fst a0) (fst a)) as [t|]. destruct (unsat t). congruence. destruct (radd_term a0 a') eqn:RADD; try congruence. inversion H. subst. @@ -1201,14 +1210,14 @@ Section S. Lemma radd_term_term' : forall a' a cl, add_term a a' = Some cl -> radd_term a a' = inl cl. Proof. - induction a' ; simpl. - - intros. - destruct (deduce (fst a) (fst a)). + intros a'; induction a' as [|a a' IHa']; simpl. + - intros a cl H. + destruct (deduce (fst a) (fst a)) as [t|]. destruct (unsat t). congruence. inversion H. reflexivity. inversion H ;reflexivity. - - intros. - destruct (deduce (fst a0) (fst a)). + - intros a0 cl H. + destruct (deduce (fst a0) (fst a)) as [t|]. destruct (unsat t). congruence. destruct (add_term a0 a') eqn:RADD; try congruence. inversion H. subst. @@ -1229,7 +1238,7 @@ Section S. unfold xor_clause_cnf. assert (ACC: fst (@nil clause,@nil Annot) = nil). reflexivity. - intros. + intros a f. set (F1:= (fun '(acc, tg) (e : clause) => match ror_clause a e with | inl cl => (cl :: acc, tg) @@ -1243,15 +1252,15 @@ Section S. revert ACC. generalize (@nil clause,@nil Annot). generalize (@nil clause). - induction f ; simpl ; auto. - intros. + induction f as [|a0 f IHf]; simpl ; auto. + intros ? p ?. apply IHf. unfold F1 , F2. destruct p ; simpl in * ; subst. clear. revert a0. - induction a; simpl; auto. - intros. + induction a as [|a a0 IHa]; simpl; auto. + intros a1. destruct (radd_term a a1) eqn:RADD. apply radd_term_term in RADD. rewrite RADD. @@ -1266,14 +1275,14 @@ Section S. fst (ror_clause_cnf a f) = or_clause_cnf a f. Proof. unfold ror_clause_cnf,or_clause_cnf. - destruct a ; auto. + intros a; destruct a ; auto. apply xror_clause_clause. Qed. Lemma ror_cnf_cnf : forall f1 f2, fst (ror_cnf f1 f2) = or_cnf f1 f2. Proof. - induction f1 ; simpl ; auto. - intros. + intros f1; induction f1 as [|a f1 IHf1] ; simpl ; auto. + intros f2. specialize (IHf1 f2). destruct(ror_cnf f1 f2). rewrite <- ror_clause_clause. @@ -1286,7 +1295,7 @@ Section S. Lemma ror_opt_cnf_cnf : forall f1 f2, fst (ror_cnf_opt f1 f2) = or_cnf_opt f1 f2. Proof. unfold ror_cnf_opt, or_cnf_opt. - intros. + intros f1 f2. destruct (is_cnf_tt f1). - simpl ; auto. - simpl. destruct (is_cnf_tt f2) ; simpl ; auto. @@ -1299,7 +1308,7 @@ Section S. fst (ratom f a) = f. Proof. unfold ratom. - intros. + intros f a. destruct (is_cnf_ff f || is_cnf_tt f); auto. Qed. @@ -1308,7 +1317,7 @@ Section S. (IHf2 : forall pol : bool, fst (rxcnf pol f2) = xcnf pol f2), forall pol : bool, fst (rxcnf_and rxcnf pol f1 f2) = mk_and xcnf pol f1 f2. Proof. - intros. + intros TX AF k f1 f2 IHf1 IHf2 pol. unfold mk_and, rxcnf_and. specialize (IHf1 pol). specialize (IHf2 pol). @@ -1327,7 +1336,7 @@ Section S. (IHf2 : forall pol : bool, fst (rxcnf pol f2) = xcnf pol f2), forall pol : bool, fst (rxcnf_or rxcnf pol f1 f2) = mk_or xcnf pol f1 f2. Proof. - intros. + intros TX AF k f1 f2 IHf1 IHf2 pol. unfold rxcnf_or, mk_or. specialize (IHf1 pol). specialize (IHf2 pol). @@ -1346,7 +1355,7 @@ Section S. (IHf2 : forall pol : bool, fst (rxcnf pol f2) = xcnf pol f2), forall pol : bool, fst (rxcnf_impl rxcnf pol f1 f2) = mk_impl xcnf pol f1 f2. Proof. - intros. + intros TX AF k f1 f2 IHf1 IHf2 pol. unfold rxcnf_impl, mk_impl, mk_or. specialize (IHf1 (negb pol)). specialize (IHf2 pol). @@ -1359,7 +1368,7 @@ Section S. destruct pol;auto. generalize (is_cnf_ff_inv (xcnf (negb true) f1)). destruct (is_cnf_ff (xcnf (negb true) f1)). - + intros. + + intros H. rewrite H by auto. unfold or_cnf_opt. simpl. @@ -1384,18 +1393,18 @@ Section S. (IHf2 : forall pol : bool, fst (rxcnf pol f2) = xcnf pol f2), forall pol : bool, fst (rxcnf_iff rxcnf pol f1 f2) = mk_iff xcnf pol f1 f2. Proof. - intros. + intros TX AF k f1 f2 IHf1 IHf2 pol. unfold rxcnf_iff. unfold mk_iff. rewrite <- (IHf1 (negb pol)). rewrite <- (IHf1 pol). rewrite <- (IHf2 false). rewrite <- (IHf2 true). - destruct (rxcnf (negb pol) f1). - destruct (rxcnf false f2). - destruct (rxcnf pol f1). - destruct (rxcnf true f2). - destruct (ror_cnf_opt (and_cnf_opt c c0) (and_cnf_opt c1 c2)) eqn:EQ. + destruct (rxcnf (negb pol) f1) as [c ?]. + destruct (rxcnf false f2) as [c0 ?]. + destruct (rxcnf pol f1) as [c1 ?]. + destruct (rxcnf true f2) as [c2 ?]. + destruct (ror_cnf_opt (and_cnf_opt c c0) (and_cnf_opt c1 c2)) as [c3 l3] eqn:EQ. simpl. change c3 with (fst (c3,l3)). rewrite <- EQ. rewrite ror_opt_cnf_cnf. @@ -1405,7 +1414,7 @@ Section S. Lemma rxcnf_xcnf : forall {TX : kind -> Type} {AF:Type} (k: kind) (f:TFormula TX AF k) pol, fst (rxcnf pol f) = xcnf pol f. Proof. - induction f ; simpl ; auto. + intros TX AF k f; induction f ; simpl ; auto; intros pol. - destruct pol; simpl ; auto. - destruct pol; simpl ; auto. - destruct pol ; simpl ; auto. @@ -1463,7 +1472,7 @@ Section S. Lemma eval_cnf_and_opt : forall env x y, eval_cnf env (and_cnf_opt x y) <-> eval_cnf env (and_cnf x y). Proof. unfold and_cnf_opt. - intros. + intros env x y. destruct (is_cnf_ff x) eqn:F1. { apply is_cnf_ff_inv in F1. simpl. subst. @@ -1501,14 +1510,14 @@ Section S. Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) <-> eval_clause env (t::cl). Proof. - induction cl. + intros env t cl; induction cl as [|a cl IHcl]. - (* BC *) simpl. case_eq (deduce (fst t) (fst t)) ; try tauto. - intros. + intros t0 H. generalize (@deduce_prop _ _ _ H env). case_eq (unsat t0) ; try tauto. - { intros. + { intros H0 ?. generalize (@unsat_prop _ H0 env). unfold eval_clause. rewrite make_conj_cons. @@ -1518,9 +1527,9 @@ Section S. - (* IC *) simpl. case_eq (deduce (fst t) (fst a)); - intros. + intros t0; [intros H|]. generalize (@deduce_prop _ _ _ H env). - case_eq (unsat t0); intros. + case_eq (unsat t0); intros H0 H1. { generalize (@unsat_prop _ H0 env). simpl. @@ -1553,13 +1562,14 @@ 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'. Proof. - induction cl. + intros cl; induction cl as [|a cl IHcl]. - simpl. unfold eval_clause at 2. simpl. tauto. - - intros *. + - intros cl' env. simpl. assert (HH := add_term_correct env a cl'). assert (eval_tt env a \/ ~ eval_tt env a) by (apply no_middle_eval'). @@ -1579,17 +1589,17 @@ Section S. Proof. unfold eval_cnf. unfold or_clause_cnf. - intros until t. + intros env t. set (F := (fun (acc : list clause) (e : clause) => match or_clause t e with | Some cl => cl :: acc | None => acc end)). intro f. - assert ( make_conj (eval_clause env) (fold_left F f nil) <-> (eval_clause env t \/ make_conj (eval_clause env) f) /\ make_conj (eval_clause env) nil). + assert ( make_conj (eval_clause env) (fold_left F f nil) <-> (eval_clause env t \/ make_conj (eval_clause env) f) /\ make_conj (eval_clause env) nil) as H. { generalize (@nil clause) as acc. - induction f. + induction f as [|a f IHf]. - simpl. intros ; tauto. - intros. @@ -1634,7 +1644,7 @@ Section S. Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') <-> (eval_cnf env f) \/ (eval_cnf env f'). Proof. - induction f. + intros env f; induction f as [|a f IHf]. unfold eval_cnf. simpl. tauto. @@ -1652,7 +1662,7 @@ Section S. Lemma or_cnf_opt_correct : forall env f f', eval_cnf env (or_cnf_opt f f') <-> eval_cnf env (or_cnf f f'). Proof. unfold or_cnf_opt. - intros. + intros env f f'. destruct (is_cnf_tt f) eqn:TF. { simpl. apply is_cnf_tt_inv in TF. @@ -1690,23 +1700,25 @@ Section S. Lemma hold_eTT : forall k, hold k (eTT k). Proof. - destruct k ; simpl; auto. + intros k; destruct k ; simpl; auto. Qed. + #[local] Hint Resolve hold_eTT : tauto. Lemma hold_eFF : forall k, hold k (eNOT k (eFF k)). Proof. - destruct k ; simpl;auto. + intros k; destruct k ; simpl;auto. Qed. + #[local] Hint Resolve hold_eFF : tauto. Lemma hold_eAND : forall k r1 r2, hold k (eAND k r1 r2) <-> (hold k r1 /\ hold k r2). Proof. - destruct k ; simpl. + intros k; destruct k ; simpl. - intros. apply iff_refl. - apply andb_true_iff. Qed. @@ -1714,7 +1726,7 @@ Section S. Lemma hold_eOR : forall k r1 r2, hold k (eOR k r1 r2) <-> (hold k r1 \/ hold k r2). Proof. - destruct k ; simpl. + intros k; destruct k ; simpl. - intros. apply iff_refl. - apply orb_true_iff. Qed. @@ -1722,9 +1734,9 @@ Section S. Lemma hold_eNOT : forall k e, hold k (eNOT k e) <-> not (hold k e). Proof. - destruct k ; simpl. + intros k; destruct k ; simpl. - intros. apply iff_refl. - - intros. unfold is_true. + - intros e. unfold is_true. rewrite negb_true_iff. destruct e ; intuition congruence. Qed. @@ -1732,9 +1744,9 @@ Section S. Lemma hold_eIMPL : forall k e1 e2, hold k (eIMPL k e1 e2) <-> (hold k e1 -> hold k e2). Proof. - destruct k ; simpl. + intros k; destruct k ; simpl. - intros. apply iff_refl. - - intros. + - intros e1 e2. unfold is_true. destruct e1,e2 ; simpl ; intuition congruence. Qed. @@ -1742,9 +1754,9 @@ Section S. Lemma hold_eIFF : forall k e1 e2, hold k (eIFF k e1 e2) <-> (hold k e1 <-> hold k e2). Proof. - destruct k ; simpl. + intros k; destruct k ; simpl. - intros. apply iff_refl. - - intros. + - intros e1 e2. unfold is_true. rewrite eqb_true_iff. destruct e1,e2 ; simpl ; intuition congruence. @@ -1768,7 +1780,7 @@ Section S. eval_cnf env (xcnf pol (IMPL f1 o f2)) -> hold k (eval_f e_rtyp (eval env) (if pol then IMPL f1 o f2 else NOT (IMPL f1 o f2))). Proof. - simpl; intros. unfold mk_impl in H. + simpl; intros k f1 o f2 IHf1 IHf2 pol env H. unfold mk_impl in H. destruct pol. + simpl. rewrite hold_eIMPL. @@ -1810,7 +1822,7 @@ Section S. hold isBool (eIFF isBool e1 e2) <-> e1 = e2. Proof. simpl. - destruct e1,e2 ; simpl ; intuition congruence. + intros e1 e2; destruct e1,e2 ; simpl ; intuition congruence. Qed. @@ -1828,7 +1840,7 @@ Section S. hold k (eval_f e_rtyp (eval env) (if pol then IFF f1 f2 else NOT (IFF f1 f2))). Proof. simpl. - intros. + intros k f1 f2 IHf1 IHf2 pol env H. rewrite mk_iff_is_bool in H. unfold mk_iff in H. destruct pol; @@ -1858,7 +1870,10 @@ Section S. Lemma xcnf_correct : forall (k: kind) (f : @GFormula Term rtyp Annot unit k) pol env, eval_cnf env (xcnf pol f) -> hold k (eval_f e_rtyp (eval env) (if pol then f else NOT f)). Proof. - induction f. + intros k f; + induction f as [| | | |? ? IHf1 ? IHf2|? ? IHf1 ? IHf2|? ? IHf + |? ? IHf1 ? ? IHf2|? ? IHf1 f2 IHf2|f1 IHf1 f2 IHf2]; + intros pol env H. - (* TT *) unfold eval_cnf. simpl. @@ -1881,13 +1896,13 @@ Section S. intros. eapply negate_correct ; eauto. - (* AND *) - destruct pol ; simpl. + destruct pol ; simpl in H. + (* pol = true *) intros. rewrite eval_cnf_and_opt in H. unfold and_cnf in H. rewrite eval_cnf_app in H. - destruct H. + destruct H as [H H0]. apply hold_eAND; split. apply (IHf1 _ _ H). apply (IHf2 _ _ H0). @@ -1907,7 +1922,7 @@ Section S. rewrite hold_eNOT. tauto. - (* OR *) - simpl. + simpl in H. destruct pol. + (* pol = true *) intros. unfold mk_or in H. @@ -1947,8 +1962,8 @@ Section S. - (* IMPL *) apply xcnf_impl; auto. - apply xcnf_iff ; auto. - - simpl. - destruct (is_bool f2) eqn:EQ. + - simpl in H. + destruct (is_bool f2) as [b|] eqn:EQ. + apply is_bool_inv in EQ. destruct b; subst; intros; apply IHf1 in H; @@ -1996,17 +2011,17 @@ Section S. Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf env t. Proof. unfold eval_cnf. - induction t. + intros t; induction t as [|a t IHt]. (* bc *) simpl. auto. (* ic *) simpl. - destruct w. + intros w; destruct w as [|w ?]. intros ; discriminate. - case_eq (checker a w) ; intros ; try discriminate. + case_eq (checker a w) ; intros H H0 env ** ; try discriminate. generalize (@checker_sound _ _ H env). - generalize (IHt _ H0 env) ; intros. + generalize (IHt _ H0 env) ; intros H1 H2. destruct t. red ; intro. rewrite <- make_conj_impl in H2. @@ -2021,7 +2036,7 @@ Section S. Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f e_rtyp (eval env) t. Proof. unfold tauto_checker. - intros. + intros t w H env. change (eval_f e_rtyp (eval env) t) with (eval_f e_rtyp (eval env) (if true then t else TT isProp)). apply (xcnf_correct t true). eapply cnf_checker_sound ; eauto. @@ -2032,7 +2047,10 @@ Section S. Lemma eval_bf_map : forall T U (fct: T-> U) env (k: kind) (f:BFormula T k) , eval_bf env (map_bformula fct f) = eval_bf (fun b x => env b (fct x)) f. Proof. - induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto. + intros T U fct env k f; + induction f as [| | | |? ? IHf1 ? IHf2|? ? IHf1 ? IHf2|? ? IHf + |? ? IHf1 ? ? IHf2|? ? IHf1 ? IHf2|? IHf1 ? IHf2]; + simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto. rewrite <- IHf. auto. Qed. 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/micromega/ZCoeff.v b/theories/micromega/ZCoeff.v index 4e04adaddb..aaaeb9e118 100644 --- a/theories/micromega/ZCoeff.v +++ b/theories/micromega/ZCoeff.v @@ -121,7 +121,7 @@ Qed. Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x. Proof. -induction x as [x IH | x IH |]; simpl; +intros x; induction x as [x IH | x IH |]; simpl; try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_pos_pos sor); try apply (Rlt_0_1 sor); assumption. Qed. diff --git a/theories/micromega/ZifyClasses.v b/theories/micromega/ZifyClasses.v index 37eef12381..f6ade67c5f 100644 --- a/theories/micromega/ZifyClasses.v +++ b/theories/micromega/ZifyClasses.v @@ -210,7 +210,7 @@ Qed. Lemma eq_iff : forall (P Q : Prop), P = Q -> (P <-> Q). Proof. - intros. + intros P Q H. rewrite H. apply iff_refl. Defined. diff --git a/theories/micromega/ZifyInst.v b/theories/micromega/ZifyInst.v index 0e135ba793..9881e73f76 100644 --- a/theories/micromega/ZifyInst.v +++ b/theories/micromega/ZifyInst.v @@ -139,7 +139,7 @@ Add Zify BinRel Op_pos_le. Lemma eq_pos_inj : forall (x y:positive), x = y <-> Z.pos x = Z.pos y. Proof. - intros. + intros x y. apply (iff_sym (Pos2Z.inj_iff x y)). Qed. @@ -186,7 +186,7 @@ Add Zify UnOp Op_pos_pred. Instance Op_pos_predN : UnOp Pos.pred_N := { TUOp := fun x => x - 1 ; - TUOpInj := ltac: (now destruct x; rewrite N.pos_pred_spec) }. + TUOpInj x := ltac: (now destruct x; rewrite N.pos_pred_spec) }. Add Zify UnOp Op_pos_predN. Instance Op_pos_of_succ_nat : UnOp Pos.of_succ_nat := @@ -195,7 +195,7 @@ Add Zify UnOp Op_pos_of_succ_nat. Instance Op_pos_of_nat : UnOp Pos.of_nat := { TUOp := fun x => Z.max 1 x ; - TUOpInj := ltac: (now destruct x; + TUOpInj x := ltac: (now destruct x; [|rewrite <- Pos.of_nat_succ, <- (Nat2Z.inj_max 1)]) }. Add Zify UnOp Op_pos_of_nat. @@ -445,7 +445,7 @@ Add Zify UnOp Op_Z_quot2. Lemma of_nat_to_nat_eq : forall x, Z.of_nat (Z.to_nat x) = Z.max 0 x. Proof. - destruct x. + intros x; destruct x. - reflexivity. - rewrite Z2Nat.id. reflexivity. diff --git a/theories/micromega/Ztac.v b/theories/micromega/Ztac.v index 5fb92aba44..a97ea85ceb 100644 --- a/theories/micromega/Ztac.v +++ b/theories/micromega/Ztac.v @@ -26,7 +26,7 @@ Qed. Lemma elim_concl_eq : forall x y, (x < y \/ y < x -> False) -> x = y. Proof. - intros. + intros x y H. destruct (Z_lt_le_dec x y). exfalso. apply H ; auto. destruct (Zle_lt_or_eq y x);auto. @@ -37,7 +37,7 @@ Qed. Lemma elim_concl_le : forall x y, (y < x -> False) -> x <= y. Proof. - intros. + intros x y H. destruct (Z_lt_le_dec y x). exfalso ; auto. auto. @@ -46,7 +46,7 @@ Qed. Lemma elim_concl_lt : forall x y, (y <= x -> False) -> x < y. Proof. - intros. + intros x y H. destruct (Z_lt_le_dec x y). auto. exfalso ; auto. @@ -93,7 +93,7 @@ Qed. Lemma mul_le : forall e1 e2, 0 <= e1 -> 0 <= e2 -> 0 <= e1*e2. Proof. - intros. + intros e1 e2 H H0. change 0 with (0* e2). apply Zmult_le_compat_r; auto. Qed. 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/setoid_ring/InitialRing.v b/theories/setoid_ring/InitialRing.v index bb98a447dc..c33beaf8cd 100644 --- a/theories/setoid_ring/InitialRing.v +++ b/theories/setoid_ring/InitialRing.v @@ -104,7 +104,7 @@ Section ZMORPHISM. Lemma get_signZ_th : sign_theory Z.opp Zeq_bool get_signZ. Proof. constructor. - destruct c;intros;try discriminate. + intros c;destruct c;intros ? H;try discriminate. injection H as [= <-]. simpl. unfold Zeq_bool. rewrite Z.compare_refl. trivial. Qed. @@ -119,7 +119,7 @@ Section ZMORPHISM. Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. Proof. - induction x;simpl. + intros x;induction x as [x IHx|x IHx|];simpl. rewrite IHx;destruct x;simpl;norm. rewrite IHx;destruct x;simpl;norm. rrefl. @@ -128,7 +128,7 @@ Section ZMORPHISM. Lemma ARgen_phiPOS_Psucc : forall x, gen_phiPOS1 (Pos.succ x) == 1 + (gen_phiPOS1 x). Proof. - induction x;simpl;norm. + intros x;induction x as [x IHx|x IHx|];simpl;norm. rewrite IHx;norm. add_push 1;rrefl. Qed. @@ -136,7 +136,8 @@ Section ZMORPHISM. Lemma ARgen_phiPOS_add : forall x y, gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y). Proof. - induction x;destruct y;simpl;norm. + intros x;induction x as [x IHx|x IHx|]; + intros y;destruct y as [y|y|];simpl;norm. rewrite Pos.add_carry_spec. rewrite ARgen_phiPOS_Psucc. rewrite IHx;norm. @@ -152,7 +153,7 @@ Section ZMORPHISM. Lemma ARgen_phiPOS_mult : forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y. Proof. - induction x;intros;simpl;norm. + intros x;induction x as [x IHx|x IHx|];intros;simpl;norm. rewrite ARgen_phiPOS_add;simpl;rewrite IHx;norm. rewrite IHx;rrefl. Qed. @@ -169,7 +170,7 @@ Section ZMORPHISM. (*morphisms are extensionally equal*) Lemma same_genZ : forall x, [x] == gen_phiZ1 x. Proof. - destruct x;simpl; try rewrite (same_gen ARth);rrefl. + intros x;destruct x;simpl; try rewrite (same_gen ARth);rrefl. Qed. Lemma gen_Zeqb_ok : forall x y, @@ -198,7 +199,7 @@ Section ZMORPHISM. Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y]. Proof. intros x y; repeat rewrite same_genZ; generalize x y;clear x y. - destruct x, y; simpl; norm. + intros x y;destruct x, y; simpl; norm. apply (ARgen_phiPOS_add ARth). apply gen_phiZ1_pos_sub. rewrite gen_phiZ1_pos_sub. apply (Radd_comm Rth). @@ -301,7 +302,7 @@ Section NMORPHISM. Lemma same_genN : forall x, [x] == gen_phiN1 x. Proof. - destruct x;simpl. reflexivity. + intros x;destruct x;simpl. reflexivity. now rewrite (same_gen Rsth Reqe ARth). Qed. @@ -421,7 +422,7 @@ Section NWORDMORPHISM. Lemma gen_phiNword0_ok : forall w, Nw_is0 w = true -> gen_phiNword w == 0. Proof. -induction w; simpl; intros; auto. +intros w; induction w as [|a w IHw]; simpl; intros; auto. reflexivity. destruct a. @@ -436,17 +437,17 @@ Qed. Lemma gen_phiNword_cons : forall w n, gen_phiNword (n::w) == gen_phiN rO rI radd rmul n - gen_phiNword w. -induction w. - destruct n; simpl; norm. +intros w; induction w. + intros n; destruct n; simpl; norm. - intros. + intros n. destruct n; norm. Qed. Lemma gen_phiNword_Nwcons : forall w n, gen_phiNword (Nwcons n w) == gen_phiN rO rI radd rmul n - gen_phiNword w. -destruct w; intros. - destruct n; norm. +intros w; destruct w; intros n0. + destruct n0; norm. unfold Nwcons. rewrite gen_phiNword_cons. @@ -455,13 +456,13 @@ Qed. Lemma gen_phiNword_ok : forall w1 w2, Nweq_bool w1 w2 = true -> gen_phiNword w1 == gen_phiNword w2. -induction w1; intros. +intros w1; induction w1 as [|a w1 IHw1]; intros w2 H. simpl. rewrite (gen_phiNword0_ok _ H). reflexivity. rewrite gen_phiNword_cons. - destruct w2. + destruct w2 as [|n w2]. simpl in H. destruct a; try discriminate. rewrite (gen_phiNword0_ok _ H). @@ -481,7 +482,7 @@ Qed. Lemma Nwadd_ok : forall x y, gen_phiNword (Nwadd x y) == gen_phiNword x + gen_phiNword y. -induction x; intros. +intros x; induction x as [|n x IHx]; intros y. simpl. norm. @@ -507,7 +508,7 @@ Qed. Lemma Nwscal_ok : forall n x, gen_phiNword (Nwscal n x) == gen_phiN rO rI radd rmul n * gen_phiNword x. -induction x; intros. +intros n x; induction x as [|a x IHx]; intros. norm. simpl Nwscal. @@ -521,7 +522,7 @@ Qed. Lemma Nwmul_ok : forall x y, gen_phiNword (Nwmul x y) == gen_phiNword x * gen_phiNword y. -induction x; intros. +intros x; induction x as [|a x IHx]; intros. norm. destruct a. @@ -626,7 +627,7 @@ Qed. Lemma Ztriv_div_th : div_theory req Z.add Z.mul zphi Z.quotrem. Proof. constructor. - intros; generalize (Z.quotrem_eq a b); case Z.quotrem; intros; subst. + intros a b; generalize (Z.quotrem_eq a b); case Z.quotrem; intros; subst. rewrite Z.mul_comm; rsimpl. Qed. @@ -634,7 +635,7 @@ Qed. Lemma Ntriv_div_th : div_theory req N.add N.mul nphi N.div_eucl. constructor. - intros; generalize (N.div_eucl_spec a b); case N.div_eucl; intros; subst. + intros a b; generalize (N.div_eucl_spec a b); case N.div_eucl; intros; subst. rewrite N.mul_comm; rsimpl. Qed. diff --git a/theories/setoid_ring/Ring.v b/theories/setoid_ring/Ring.v index a66037a956..25b79d1fb2 100644 --- a/theories/setoid_ring/Ring.v +++ b/theories/setoid_ring/Ring.v @@ -17,22 +17,22 @@ Require Export Ring_tac. Lemma BoolTheory : ring_theory false true xorb andb xorb (fun b:bool => b) (eq(A:=bool)). split; simpl. -destruct x; reflexivity. -destruct x; destruct y; reflexivity. -destruct x; destruct y; destruct z; reflexivity. +intros x; destruct x; reflexivity. +intros x y; destruct x; destruct y; reflexivity. +intros x y z; destruct x; destruct y; destruct z; reflexivity. reflexivity. -destruct x; destruct y; reflexivity. -destruct x; destruct y; reflexivity. -destruct x; destruct y; destruct z; reflexivity. +intros x y; destruct x; destruct y; reflexivity. +intros x y; destruct x; destruct y; reflexivity. +intros x y z; destruct x; destruct y; destruct z; reflexivity. reflexivity. -destruct x; reflexivity. +intros x; destruct x; reflexivity. Qed. Definition bool_eq (b1 b2:bool) := if b1 then b2 else negb b2. Lemma bool_eq_ok : forall b1 b2, bool_eq b1 b2 = true -> b1 = b2. -destruct b1; destruct b2; auto. +intros b1 b2; destruct b1; destruct b2; auto. Qed. Ltac bool_cst t := diff --git a/theories/setoid_ring/Ring_polynom.v b/theories/setoid_ring/Ring_polynom.v index a13b1fc738..0efd82c9bd 100644 --- a/theories/setoid_ring/Ring_polynom.v +++ b/theories/setoid_ring/Ring_polynom.v @@ -559,7 +559,9 @@ Section MakeRingPol. Lemma Peq_ok P P' : (P ?== P') = true -> P === P'. Proof. unfold Pequiv. - revert P';induction P;destruct P';simpl; intros H l; try easy. + revert P';induction P as [|p P IHP|P2 IHP1 p P3 IHP2]; + intros P';destruct P' as [|p0 P'|P'1 p0 P'2];simpl; + intros H l; try easy. - now apply (morph_eq CRmorph). - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. now rewrite IHP. @@ -643,13 +645,13 @@ Section MakeRingPol. Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c]. Proof. - revert l;induction P;simpl;intros;Esimpl;trivial. + revert l;induction P as [| |P2 IHP1 p P3 IHP2];simpl;intros;Esimpl;trivial. rewrite IHP2;rsimpl. Qed. Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c]. Proof. - revert l;induction P;simpl;intros. + revert l;induction P as [|p P IHP|P2 IHP1 p P3 IHP2];simpl;intros. - Esimpl. - rewrite IHP;rsimpl. - rewrite IHP2;rsimpl. @@ -657,7 +659,7 @@ Section MakeRingPol. Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c]. Proof. - revert l;induction P;simpl;intros;Esimpl;trivial. + revert l;induction P as [| |P2 IHP1 p P3 IHP2];simpl;intros;Esimpl;trivial. rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut. Qed. @@ -673,7 +675,7 @@ Section MakeRingPol. Lemma Popp_ok P l : (--P)@l == - P@l. Proof. - revert l;induction P;simpl;intros. + revert l;induction P as [|p P IHP|P2 IHP1 p P3 IHP2];simpl;intros. - Esimpl. - apply IHP. - rewrite IHP1, IHP2;rsimpl. @@ -686,7 +688,7 @@ Section MakeRingPol. (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k. Proof. intros IHP'. - revert k l. induction P;simpl;intros. + revert k l. induction P as [|p P IHP|P2 IHP1 p P3 IHP2];simpl;intros. - add_permut. - destruct p; simpl; rewrite ?jump_pred_double; add_permut. @@ -698,8 +700,9 @@ Section MakeRingPol. Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l. Proof. - revert P l; induction P';simpl;intros;Esimpl. - - revert p l; induction P;simpl;intros. + revert P l; induction P' as [|p P' IHP'|P'1 IHP'1 p P'2 IHP'2]; + simpl;intros P l;Esimpl. + - revert p l; induction P as [|p P IHP|P2 IHP1 p P3 IHP2];simpl;intros p0 l. + Esimpl; add_permut. + destr_pos_sub; intros ->;Esimpl. * now rewrite IHP'. @@ -709,7 +712,7 @@ Section MakeRingPol. * rewrite IHP2;simpl. rsimpl. * rewrite IHP2;simpl. rewrite jump_pred_double. rsimpl. * rewrite IHP'. rsimpl. - - destruct P;simpl. + - destruct P as [|p0 ?|? ? ?];simpl. + Esimpl. add_permut. + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. * rsimpl. add_permut. @@ -725,14 +728,15 @@ Section MakeRingPol. Lemma Psub_opp P' P : P -- P' === P ++ (--P'). Proof. - revert P; induction P'; simpl; intros. + revert P; induction P' as [|p P' IHP'|P'1 IHP'1 p P'2 IHP'2]; simpl; intros P. - intro l; Esimpl. - - revert p; induction P; simpl; intros; try reflexivity. + - revert p; induction P; simpl; intros p0; try reflexivity. + destr_pos_sub; intros ->; now apply mkPinj_ext. + destruct p0; now apply PX_ext. - - destruct P; simpl; try reflexivity. + - destruct P as [|p0 P|P2 p0 P3]; simpl; try reflexivity. + destruct p0; now apply PX_ext. + destr_pos_sub; intros ->; apply mkPX_ext; auto. + let p1 := match goal with |- PsubX _ _ ?p1 _ === _ => p1 end in revert p1. induction P2; simpl; intros; try reflexivity. destr_pos_sub; intros ->; now apply mkPX_ext. Qed. @@ -746,8 +750,8 @@ Section MakeRingPol. (forall P l, (Pmul P P') @ l == P @ l * P' @ l) -> forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). Proof. - intros IHP'. - induction P;simpl;intros. + intros IHP' P. + induction P as [|p P IHP|? IHP1 ? ? IHP2];simpl;intros p0 l. - Esimpl; mul_permut. - destr_pos_sub; intros ->;Esimpl. + now rewrite IHP'. @@ -761,10 +765,10 @@ Section MakeRingPol. Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l. Proof. - revert P l;induction P';simpl;intros. + revert P l;induction P' as [| |? IHP'1 ? ? IHP'2];simpl;intros P l. - apply PmulC_ok. - apply PmulI_ok;trivial. - - destruct P. + - destruct P as [|p0|]. + rewrite (ARmul_comm ARth). Esimpl. + Esimpl. f_equiv. rewrite IHP'1; Esimpl. destruct p0;rewrite IHP'2;Esimpl. @@ -821,7 +825,8 @@ Section MakeRingPol. P@l == Q@l + [c] * M@@l * R@l. Proof. destruct cM as (c,M). revert M l. - induction P; destruct M; intros l; simpl; auto; + induction P as [c0|p P ?|P2 ? ? P3 ?]; intros M; destruct M; intros l; + simpl; auto; try (case ceqb_spec; intro He); try (case Pos.compare_spec; intros He); rewrite ?He; @@ -858,7 +863,7 @@ Section MakeRingPol. [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == (PNSubst1 P1 cM1 P2 n)@l. Proof. - revert P1. induction n; simpl; intros P1; + revert P1. induction n as [|n IHn]; simpl; intros P1; generalize (POneSubst_ok P1 cM1 P2); destruct POneSubst; intros; rewrite <- ?IHn; auto; reflexivity. Qed. @@ -890,7 +895,7 @@ Section MakeRingPol. Lemma PSubstL_ok n LM1 P1 P2 l : PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. Proof. - revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros. + revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros P3 H **. - discriminate. - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. * injection H as [= <-]. rewrite <- PSubstL1_ok; intuition. @@ -900,7 +905,7 @@ Section MakeRingPol. Lemma PNSubstL_ok m n LM1 P1 l : MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. Proof. - revert LM1 P1. induction m; simpl; intros; + revert LM1 P1. induction m as [|m IHm]; simpl; intros LM1 P2 H; assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL; auto; try reflexivity. rewrite <- IHm; auto. @@ -979,7 +984,8 @@ Section POWER. forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. Proof. intros subst_l_ok res P p. revert res. - induction p;simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp; + induction p as [p IHp|p IHp|];simpl;intros; + rewrite ?subst_l_ok, ?Pmul_ok, ?IHp; mul_permut. Qed. @@ -987,7 +993,7 @@ Section POWER. (forall P, subst_l P@l == P@l) -> forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. Proof. - destruct n;simpl. + intros ? P n; destruct n;simpl. - reflexivity. - rewrite Ppow_pos_ok by trivial. Esimpl. Qed. @@ -1057,8 +1063,9 @@ Section POWER. PEeval l pe == (norm_aux pe)@l. Proof. intros. - induction pe; cbn. - - now rewrite (morph0 CRmorph). + induction pe as [| |c|p|pe1 IHpe1 pe2 IHpe2|? IHpe1 ? IHpe2|? IHpe1 ? IHpe2 + |? IHpe|? IHpe n0]; cbn. + - now rewrite (morph0 CRmorph). - now rewrite (morph1 CRmorph). - reflexivity. - apply mkX_ok. @@ -1071,8 +1078,9 @@ Section POWER. - rewrite IHpe1, IHpe2. now rewrite Pmul_ok. - rewrite IHpe. Esimpl. - rewrite Ppow_N_ok by reflexivity. - rewrite (rpow_pow_N pow_th). destruct n0; simpl; Esimpl. - induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. + rewrite (rpow_pow_N pow_th). destruct n0 as [|p]; simpl; Esimpl. + induction p as [p IHp|p IHp|];simpl; + now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. Lemma norm_subst_spec : @@ -1125,7 +1133,7 @@ Section POWER. Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m -> forall l, [fst m] * Mphi l (snd m) == P@l. Proof. - induction P;simpl;intros;Esimpl. + intros P; induction P as [c|p P IHP|P2 IHP1 ? P3 ?];simpl;intros m H l;Esimpl. assert (H1 := (morph_eq CRmorph) c cO). destruct (c ?=! cO). discriminate. @@ -1142,7 +1150,7 @@ Section POWER. end with (P3 ?== P0). assert (H := Peq_ok P3 P0). destruct (P3 ?== P0). - case_eq (mon_of_pol P2);try intros (cc, pp); intros. + case_eq (mon_of_pol P2);try intros (cc, pp); intros H0 H1. inversion H1. simpl. rewrite mkVmon_ok;simpl. @@ -1155,16 +1163,16 @@ Section POWER. Lemma interp_PElist_ok : forall l lpe, interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l. Proof. - induction lpe;simpl. trivial. - destruct a;simpl;intros. + intros l lpe; induction lpe as [|a lpe IHlpe];simpl. trivial. + destruct a as [p p0];simpl;intros H. assert (HH:=mon_of_pol_ok (norm_subst 0 nil p)); destruct (mon_of_pol (norm_subst 0 nil p)). split. rewrite <- norm_subst_spec by exact I. - destruct lpe;try destruct H;rewrite <- H; + destruct lpe;try destruct H as [H H0];rewrite <- H; rewrite (norm_subst_spec 0 nil); try exact I;apply HH;trivial. - apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0. - apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0. + apply IHlpe. destruct lpe;simpl;trivial. destruct H as [H H0]. exact H0. + apply IHlpe. destruct lpe;simpl;trivial. destruct H as [H H0]. exact H0. Qed. Lemma norm_subst_ok : forall n l lpe pe, @@ -1180,7 +1188,7 @@ Section POWER. norm_subst n lmp pe1 ?== norm_subst n lmp pe2) = true -> PEeval l pe1 == PEeval l pe2. Proof. - simpl;intros. + simpl;intros n l lpe pe1 pe2 **. do 2 (rewrite (norm_subst_ok n l lpe);trivial). apply Peq_ok;trivial. Qed. @@ -1285,36 +1293,36 @@ Section POWER. Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm. Proof. - induction lm;intros;simpl;Esimpl. + intros lm; induction lm as [|a lm IHlm];intros;simpl;Esimpl. destruct a as (x,p);Esimpl. rewrite IHlm. rewrite mkmult_pow_spec. Esimpl. Qed. Lemma mkmult1_ok : forall lm, mkmult1 lm == r_list_pow lm. Proof. - destruct lm;simpl;Esimpl. + intros lm; destruct lm as [|p lm];simpl;Esimpl. destruct p. rewrite mkmult_rec_ok;rewrite mkpow_spec;Esimpl. Qed. Lemma mkmultm1_ok : forall lm, mkmultm1 lm == - r_list_pow lm. Proof. - destruct lm;simpl;Esimpl. + intros lm; destruct lm as [|p lm];simpl;Esimpl. destruct p;rewrite mkmult_rec_ok. rewrite mkopp_pow_spec;Esimpl. Qed. Lemma r_list_pow_rev : forall l, r_list_pow (rev' l) == r_list_pow l. Proof. assert - (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l). - induction l;intros;simpl;Esimpl. - destruct a;rewrite IHl;Esimpl. + (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l) as H. + intros l; induction l as [|a l IHl];intros;simpl;Esimpl. + destruct a as [r p];rewrite IHl;Esimpl. rewrite (ARmul_comm ARth (pow_pos rmul r p)). reflexivity. intros;unfold rev'. rewrite H;simpl;Esimpl. Qed. Lemma mkmult_c_pos_ok : forall c lm, mkmult_c_pos c lm == [c]* r_list_pow lm. Proof. - intros;unfold mkmult_c_pos;simpl. + intros c lm;unfold mkmult_c_pos;simpl. assert (H := (morph_eq CRmorph) c cI). rewrite <- r_list_pow_rev; destruct (c ?=! cI). rewrite H;trivial;Esimpl. @@ -1323,8 +1331,8 @@ Section POWER. Lemma mkmult_c_ok : forall c lm, mkmult_c c lm == [c] * r_list_pow lm. Proof. - intros;unfold mkmult_c;simpl. - case_eq (get_sign c);intros. + intros c lm;unfold mkmult_c;simpl. + case_eq (get_sign c);intros c0; try intros H. assert (H1 := (morph_eq CRmorph) c0 cI). destruct (c0 ?=! cI). rewrite (morph_eq CRmorph _ _ (sign_spec get_sign_spec _ H)). Esimpl. rewrite H1;trivial. @@ -1336,8 +1344,8 @@ Qed. Lemma mkadd_mult_ok : forall rP c lm, mkadd_mult rP c lm == rP + [c]*r_list_pow lm. Proof. - intros;unfold mkadd_mult. - case_eq (get_sign c);intros. + intros rP c lm;unfold mkadd_mult. + case_eq (get_sign c);intros c0; try intros H. rewrite (morph_eq CRmorph _ _ (sign_spec get_sign_spec _ H));Esimpl. rewrite mkmult_c_pos_ok;Esimpl. rewrite mkmult_c_pos_ok;Esimpl. @@ -1346,13 +1354,13 @@ Qed. Lemma add_pow_list_ok : forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l. Proof. - destruct n;simpl;intros;Esimpl. + intros r n; destruct n;simpl;intros;Esimpl. Qed. Lemma add_mult_dev_ok : forall P rP fv n lm, add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd fv) n * r_list_pow lm. Proof. - induction P;simpl;intros. + intros P; induction P as [|p P IHP|P2 IHP1 p P3 IHP2];simpl;intros rP fv n lm. rewrite mkadd_mult_ok. rewrite add_pow_list_ok; Esimpl. rewrite IHP. simpl. rewrite add_pow_list_ok; Esimpl. change (match P3 with @@ -1377,7 +1385,7 @@ Qed. Lemma mult_dev_ok : forall P fv n lm, mult_dev P fv n lm == P@fv * pow_N rI rmul (hd fv) n * r_list_pow lm. Proof. - induction P;simpl;intros;Esimpl. + intros P; induction P as [|p P IHP|P2 IHP1 p P3 IHP2];simpl;intros fv n lm;Esimpl. rewrite mkmult_c_ok;rewrite add_pow_list_ok;Esimpl. rewrite IHP. simpl;rewrite add_pow_list_ok;Esimpl. change (match P3 with @@ -1463,7 +1471,7 @@ Qed. Lemma mkmult_pow_ok p r x : mkmult_pow r x p == r * x^p. Proof. - revert r; induction p;intros;simpl;Esimpl;rewrite !IHp;Esimpl. + revert r; induction p as [p IHp|p IHp|];intros;simpl;Esimpl;rewrite !IHp;Esimpl. Qed. Lemma mkpow_ok p x : mkpow x p == x^p. 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/coqargs.ml b/toplevel/coqargs.ml index d587e57fd8..c6ccf2a427 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -266,8 +266,7 @@ let get_compat_file = function | "8.13" -> "Coq.Compat.Coq813" | "8.12" -> "Coq.Compat.Coq812" | "8.11" -> "Coq.Compat.Coq811" - | "8.10" -> "Coq.Compat.Coq810" - | ("8.9" | "8.8" | "8.7" | "8.6" | "8.5" | "8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> + | ("8.10" | "8.9" | "8.8" | "8.7" | "8.6" | "8.5" | "8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> CErrors.user_err ~hdr:"get_compat_file" Pp.(str "Compatibility with version " ++ str s ++ str " not supported.") | s -> diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 9faa455657..501047c520 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -56,14 +56,21 @@ let build_stdlib_vo_path ~unix_path ~coq_path = let open Loadpath in { unix_path; coq_path ; has_ml = false; implicit = true; recursive = true } +(* Note we don't use has_ml=true due to #12771 , we need to see if we + should just remove that option *) let build_userlib_path ~unix_path = let open Loadpath in - { unix_path - ; coq_path = Libnames.default_root_prefix - ; has_ml = true - ; implicit = false - ; recursive = true - } + if Sys.file_exists unix_path then + let ml_path = System.all_subdirs ~unix_path |> List.map fst in + let vo_path = + { unix_path + ; coq_path = Libnames.default_root_prefix + ; has_ml = false + ; implicit = false + ; recursive = true + } in + ml_path, [vo_path] + else [], [] (* LoadPath for Coq user libraries *) let libs_init_load_path ~coqlib = @@ -75,24 +82,30 @@ let libs_init_load_path ~coqlib = let coq_path = Names.DirPath.make [Libnames.coq_root] in (* ML includes *) - let plugins_dirs = System.all_subdirs ~unix_path:(coqlib/"plugins") in - List.map fst plugins_dirs, - - (* current directory (not recursively!) *) - [ { unix_path = "." - ; coq_path = Libnames.default_root_prefix - ; implicit = false - ; has_ml = true - ; recursive = false - } ] @ - - (* then standard library *) - [build_stdlib_vo_path ~unix_path:(coqlib/"theories") ~coq_path] @ - - (* then user-contrib *) - (if Sys.file_exists user_contrib then - [build_userlib_path ~unix_path:user_contrib] else [] - ) @ - - (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME and COQPATH *) - List.map (fun s -> build_userlib_path ~unix_path:s) (xdg_dirs @ coqpath) + let plugins_dirs = System.all_subdirs ~unix_path:(coqlib/"plugins") |> List.map fst in + + let contrib_ml, contrib_vo = build_userlib_path ~unix_path:user_contrib in + + let misc_ml, misc_vo = + List.map (fun s -> build_userlib_path ~unix_path:s) (xdg_dirs @ coqpath) |> List.split in + + let ml_loadpath = plugins_dirs @ contrib_ml @ List.concat misc_ml in + let vo_loadpath = + (* current directory (not recursively!) *) + [ { unix_path = "." + ; coq_path = Libnames.default_root_prefix + ; implicit = false + ; has_ml = true + ; recursive = false + } ] @ + + (* then standard library *) + [build_stdlib_vo_path ~unix_path:(coqlib/"theories") ~coq_path] @ + + (* then user-contrib *) + contrib_vo @ + + (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME and COQPATH *) + List.concat misc_vo + in + ml_loadpath, vo_loadpath diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli index 2bfbbde50e..b96a0ef162 100644 --- a/toplevel/coqinit.mli +++ b/toplevel/coqinit.mli @@ -14,7 +14,9 @@ val set_debug : unit -> unit val load_rcfile : rcfile:(string option) -> state:Vernac.State.t -> Vernac.State.t -(* LoadPath for Coq user libraries *) +(** Standard LoadPath for Coq user libraries; in particular it + includes (in-order) Coq's standard library, Coq's [user-contrib] + folder, and directories specified in [COQPATH] and [XDG_DIRS] *) val libs_init_load_path : coqlib:CUnix.physical_path -> CUnix.physical_path list * Loadpath.vo_path list 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/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 5ae8f4ae6e..65b61a0d93 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -71,8 +71,9 @@ let test_ltac1_env = lk_ident_list >> lk_kw "|-" end -let tac2expr = Tac2entries.Pltac.tac2expr -let tac2type = Entry.create "tac2type" +let ltac2_expr = Tac2entries.Pltac.ltac2_expr +let _ltac2_expr = ltac2_expr +let ltac2_type = Entry.create "ltac2_type" let tac2def_val = Entry.create "tac2def_val" let tac2def_typ = Entry.create "tac2def_typ" let tac2def_ext = Entry.create "tac2def_ext" @@ -80,7 +81,7 @@ let tac2def_syn = Entry.create "tac2def_syn" let tac2def_mut = Entry.create "tac2def_mut" let tac2mode = Entry.create "ltac2_command" -let ltac1_expr = Pltac.tactic_expr +let ltac_expr = Pltac.ltac_expr let tac2expr_in_env = Tac2entries.Pltac.tac2expr_in_env let inj_wit wit loc x = CAst.make ~loc @@ CTacExt (wit, x) @@ -101,7 +102,7 @@ let pattern_of_qualid qid = } GRAMMAR EXTEND Gram - GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn + GLOBAL: ltac2_expr ltac2_type tac2def_val tac2def_typ tac2def_ext tac2def_syn tac2def_mut tac2expr_in_env; tac2pat: [ "1" LEFTA @@ -125,7 +126,7 @@ GRAMMAR EXTEND Gram atomic_tac2pat: [ [ -> { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) } - | p = tac2pat; ":"; t = tac2type -> + | p = tac2pat; ":"; t = ltac2_type -> { CAst.make ~loc @@ CPatCnv (p, t) } | p = tac2pat; ","; pl = LIST0 tac2pat SEP "," -> { let pl = p :: pl in @@ -133,43 +134,45 @@ GRAMMAR EXTEND Gram | p = tac2pat -> { p } ] ] ; - tac2expr: + ltac2_expr: [ "6" RIGHTA [ e1 = SELF; ";"; e2 = SELF -> { CAst.make ~loc @@ CTacSeq (e1, e2) } ] | "5" - [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "6" -> + [ "fun"; it = LIST1 input_fun ; "=>"; body = ltac2_expr LEVEL "6" -> { CAst.make ~loc @@ CTacFun (it, body) } | "let"; isrec = rec_flag; lc = LIST1 let_clause SEP "with"; "in"; - e = tac2expr LEVEL "6" -> + e = ltac2_expr LEVEL "6" -> { CAst.make ~loc @@ CTacLet (isrec, lc, e) } - | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches; "end" -> + | "match"; e = ltac2_expr LEVEL "5"; "with"; bl = branches; "end" -> { CAst.make ~loc @@ CTacCse (e, bl) } + | "if"; e = ltac2_expr LEVEL "5"; "then"; e1 = ltac2_expr LEVEL "5"; "else"; e2 = ltac2_expr LEVEL "5" -> + { CAst.make ~loc @@ CTacIft (e, e1, e2) } ] | "4" LEFTA [ ] | "3" [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> { let el = e0 :: el in CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) } ] | "2" RIGHTA - [ e1 = tac2expr; "::"; e2 = tac2expr -> + [ e1 = ltac2_expr; "::"; e2 = ltac2_expr -> { CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) } ] | "1" LEFTA - [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> + [ e = ltac2_expr; el = LIST1 ltac2_expr LEVEL "0" -> { CAst.make ~loc @@ CTacApp (e, el) } | e = SELF; ".("; qid = Prim.qualid; ")" -> { CAst.make ~loc @@ CTacPrj (e, RelId qid) } - | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "5" -> + | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = ltac2_expr LEVEL "5" -> { CAst.make ~loc @@ CTacSet (e, RelId qid, r) } ] | "0" [ "("; a = SELF; ")" -> { a } - | "("; a = SELF; ":"; t = tac2type; ")" -> + | "("; a = SELF; ":"; t = ltac2_type; ")" -> { CAst.make ~loc @@ CTacCnv (a, t) } | "()" -> { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } | "("; ")" -> { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } - | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> + | "["; a = LIST0 ltac2_expr LEVEL "5" SEP ";"; "]" -> { Tac2quote.of_list ~loc (fun x -> x) a } | "{"; a = tac2rec_fieldexprs; "}" -> { CAst.make ~loc @@ CTacRec a } @@ -183,7 +186,7 @@ GRAMMAR EXTEND Gram ] ; branch: - [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "6" -> { (pat, e) } ] ] + [ [ pat = tac2pat LEVEL "1"; "=>"; e = ltac2_expr LEVEL "6" -> { (pat, e) } ] ] ; rec_flag: [ [ IDENT "rec" -> { true } @@ -193,7 +196,7 @@ GRAMMAR EXTEND Gram [ [ IDENT "mutable" -> { true } | -> { false } ] ] ; - typ_param: + ltac2_typevar: [ [ "'"; id = Prim.ident -> { id } ] ] ; tactic_atom: @@ -210,19 +213,19 @@ GRAMMAR EXTEND Gram | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_constr c } | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_open_constr c } | IDENT "ident"; ":"; "("; c = lident; ")" -> { Tac2quote.of_ident c } - | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> { inj_pattern loc c } + | IDENT "pattern"; ":"; "("; c = Constr.cpattern; ")" -> { inj_pattern loc c } | IDENT "reference"; ":"; "("; c = globref; ")" -> { inj_reference loc c } | IDENT "ltac1"; ":"; "("; qid = ltac1_expr_in_env; ")" -> { inj_ltac1 loc qid } | IDENT "ltac1val"; ":"; "("; qid = ltac1_expr_in_env; ")" -> { inj_ltac1val loc qid } ] ] ; ltac1_expr_in_env: - [ [ test_ltac1_env; ids = LIST0 locident; "|-"; e = ltac1_expr -> { ids, e } - | e = ltac1_expr -> { [], e } + [ [ test_ltac1_env; ids = LIST0 locident; "|-"; e = ltac_expr -> { ids, e } + | e = ltac_expr -> { [], e } ] ] ; tac2expr_in_env : - [ [ test_ltac1_env; ids = LIST0 locident; "|-"; e = tac2expr -> + [ [ test_ltac1_env; ids = LIST0 locident; "|-"; e = ltac2_expr -> { let check { CAst.v = id; CAst.loc = loc } = if Tac2env.is_constructor (Libnames.qualid_of_ident ?loc id) then CErrors.user_err ?loc Pp.(str "Invalid bound Ltac2 identifier " ++ Id.print id) @@ -230,11 +233,11 @@ GRAMMAR EXTEND Gram let () = List.iter check ids in (ids, e) } - | tac = tac2expr -> { [], tac } + | tac = ltac2_expr -> { [], tac } ] ] ; let_clause: - [ [ binder = let_binder; ":="; te = tac2expr -> + [ [ binder = let_binder; ":="; te = ltac2_expr -> { let (pat, fn) = binder in let te = match fn with | None -> te @@ -252,23 +255,23 @@ GRAMMAR EXTEND Gram | _ -> CErrors.user_err ~loc (str "Invalid pattern") } ] ] ; - tac2type: + ltac2_type: [ "5" RIGHTA - [ t1 = tac2type; "->"; t2 = tac2type -> { CAst.make ~loc @@ CTypArrow (t1, t2) } ] + [ t1 = ltac2_type; "->"; t2 = ltac2_type -> { CAst.make ~loc @@ CTypArrow (t1, t2) } ] | "2" - [ t = tac2type; "*"; tl = LIST1 tac2type LEVEL "1" SEP "*" -> + [ t = ltac2_type; "*"; tl = LIST1 ltac2_type LEVEL "1" SEP "*" -> { let tl = t :: tl in CAst.make ~loc @@ CTypRef (AbsKn (Tuple (List.length tl)), tl) } ] | "1" LEFTA [ t = SELF; qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, [t]) } ] | "0" - [ "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = OPT Prim.qualid -> + [ "("; p = LIST1 ltac2_type LEVEL "5" SEP ","; ")"; qid = OPT Prim.qualid -> { match p, qid with | [t], None -> t | _, None -> CErrors.user_err ~loc (Pp.str "Syntax error") | ts, Some qid -> CAst.make ~loc @@ CTypRef (RelId qid, p) } - | id = typ_param -> { CAst.make ~loc @@ CTypVar (Name id) } + | id = ltac2_typevar -> { CAst.make ~loc @@ CTypVar (Name id) } | "_" -> { CAst.make ~loc @@ CTypVar Anonymous } | qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, []) } ] @@ -284,7 +287,7 @@ GRAMMAR EXTEND Gram [ [ b = tac2pat LEVEL "0" -> { b } ] ] ; tac2def_body: - [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> + [ [ name = binder; it = LIST0 input_fun; ":="; e = ltac2_expr -> { let e = if List.is_empty it then e else CAst.make ~loc @@ CTacFun (it, e) in (name, e) } ] ] @@ -295,10 +298,10 @@ GRAMMAR EXTEND Gram ] ] ; tac2def_mut: - [ [ "Set"; qid = Prim.qualid; old = OPT [ "as"; id = locident -> { id } ]; ":="; e = tac2expr -> { StrMut (qid, old, e) } ] ] + [ [ "Set"; qid = Prim.qualid; old = OPT [ "as"; id = locident -> { id } ]; ":="; e = ltac2_expr -> { StrMut (qid, old, e) } ] ] ; tac2typ_knd: - [ [ t = tac2type -> { CTydDef (Some t) } + [ [ t = ltac2_type -> { CTydDef (Some t) } | "["; ".."; "]" -> { CTydOpn } | "["; t = tac2alg_constructors; "]" -> { CTydAlg t } | "{"; t = tac2rec_fields; "}"-> { CTydRec t } ] ] @@ -309,7 +312,7 @@ GRAMMAR EXTEND Gram ; tac2alg_constructor: [ [ c = Prim.ident -> { (c, []) } - | c = Prim.ident; "("; args = LIST0 tac2type SEP ","; ")"-> { (c, args) } ] ] + | c = Prim.ident; "("; args = LIST0 ltac2_type SEP ","; ")"-> { (c, args) } ] ] ; tac2rec_fields: [ [ f = tac2rec_field; ";"; l = tac2rec_fields -> { f :: l } @@ -318,7 +321,7 @@ GRAMMAR EXTEND Gram | -> { [] } ] ] ; tac2rec_field: - [ [ mut = mut_flag; id = Prim.ident; ":"; t = tac2type -> { (id, mut, t) } ] ] + [ [ mut = mut_flag; id = Prim.ident; ":"; t = ltac2_type -> { (id, mut, t) } ] ] ; tac2rec_fieldexprs: [ [ f = tac2rec_fieldexpr; ";"; l = tac2rec_fieldexprs -> { f :: l } @@ -327,12 +330,12 @@ GRAMMAR EXTEND Gram | -> { [] } ] ] ; tac2rec_fieldexpr: - [ [ qid = Prim.qualid; ":="; e = tac2expr LEVEL "1" -> { RelId qid, e } ] ] + [ [ qid = Prim.qualid; ":="; e = ltac2_expr LEVEL "1" -> { RelId qid, e } ] ] ; tac2typ_prm: [ [ -> { [] } - | id = typ_param -> { [CAst.make ~loc id] } - | "("; ids = LIST1 [ id = typ_param -> { CAst.make ~loc id } ] SEP "," ;")" -> { ids } + | id = ltac2_typevar -> { [CAst.make ~loc id] } + | "("; ids = LIST1 [ id = ltac2_typevar -> { CAst.make ~loc id } ] SEP "," ;")" -> { ids } ] ] ; tac2typ_def: @@ -350,7 +353,7 @@ GRAMMAR EXTEND Gram ] ] ; tac2def_ext: - [ [ "@"; IDENT "external"; id = locident; ":"; t = tac2type LEVEL "5"; ":="; + [ [ "@"; IDENT "external"; id = locident; ":"; t = ltac2_type LEVEL "5"; ":="; plugin = Prim.string; name = Prim.string -> { let ml = { mltac_plugin = plugin; mltac_tactic = name } in StrPrm (id, t, ml) } @@ -361,11 +364,11 @@ GRAMMAR EXTEND Gram | id = Prim.ident -> { CAst.make ~loc (Some id) } ] ] ; - sexpr: + ltac2_scope: [ [ s = Prim.string -> { SexprStr (CAst.make ~loc s) } | n = Prim.integer -> { SexprInt (CAst.make ~loc n) } | id = syn_node -> { SexprRec (loc, id, []) } - | id = syn_node; "("; tok = LIST1 sexpr SEP "," ; ")" -> + | id = syn_node; "("; tok = LIST1 ltac2_scope SEP "," ; ")" -> { SexprRec (loc, id, tok) } ] ] ; @@ -375,8 +378,8 @@ GRAMMAR EXTEND Gram ] ] ; tac2def_syn: - [ [ "Notation"; toks = LIST1 sexpr; n = syn_level; ":="; - e = tac2expr -> + [ [ "Notation"; toks = LIST1 ltac2_scope; n = syn_level; ":="; + e = ltac2_expr -> { StrSyn (toks, n, e) } ] ] ; @@ -497,7 +500,7 @@ GRAMMAR EXTEND Gram ; simple_intropattern: [ [ pat = simple_intropattern_closed -> -(* l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> *) +(* l = LIST0 ["%"; c = term LEVEL "0" -> c] -> *) (** TODO: handle %pat *) { pat } ] ] @@ -654,26 +657,26 @@ GRAMMAR EXTEND Gram [ [ r = oriented_rewriter -> { r } ] ] ; tactic_then_last: - [ [ "|"; lta = LIST0 (OPT tac2expr LEVEL "6") SEP "|" -> { lta } + [ [ "|"; lta = LIST0 (OPT ltac2_expr LEVEL "6") SEP "|" -> { lta } | -> { [] } ] ] ; - tactic_then_gen: - [ [ ta = tac2expr; "|"; tg = tactic_then_gen -> { let (first,last) = tg in (Some ta :: first, last) } - | ta = tac2expr; ".."; l = tactic_then_last -> { ([], Some (Some ta, l)) } + for_each_goal: + [ [ ta = ltac2_expr; "|"; tg = for_each_goal -> { let (first,last) = tg in (Some ta :: first, last) } + | ta = ltac2_expr; ".."; l = tactic_then_last -> { ([], Some (Some ta, l)) } | ".."; l = tactic_then_last -> { ([], Some (None, l)) } - | ta = tac2expr -> { ([Some ta], None) } - | "|"; tg = tactic_then_gen -> { let (first,last) = tg in (None :: first, last) } + | ta = ltac2_expr -> { ([Some ta], None) } + | "|"; tg = for_each_goal -> { let (first,last) = tg in (None :: first, last) } | -> { ([None], None) } ] ] ; q_dispatch: - [ [ d = tactic_then_gen -> { CAst.make ~loc d } ] ] + [ [ d = for_each_goal -> { CAst.make ~loc d } ] ] ; q_occurrences: [ [ occs = occs -> { occs } ] ] ; - red_flag: + ltac2_red_flag: [ [ IDENT "beta" -> { CAst.make ~loc @@ QBeta } | IDENT "iota" -> { CAst.make ~loc @@ QIota } | IDENT "match" -> { CAst.make ~loc @@ QMatch } @@ -702,7 +705,7 @@ GRAMMAR EXTEND Gram ] ] ; strategy_flag: - [ [ s = LIST1 red_flag -> { CAst.make ~loc s } + [ [ s = LIST1 ltac2_red_flag -> { CAst.make ~loc s } | d = delta_flag -> { CAst.make ~loc [CAst.make ~loc QBeta; CAst.make ~loc QIota; CAst.make ~loc QZeta; d] } @@ -721,11 +724,11 @@ GRAMMAR EXTEND Gram ; match_pattern: [ [ IDENT "context"; id = OPT Prim.ident; - "["; pat = Constr.lconstr_pattern; "]" -> { CAst.make ~loc @@ QConstrMatchContext (id, pat) } - | pat = Constr.lconstr_pattern -> { CAst.make ~loc @@ QConstrMatchPattern pat } ] ] + "["; pat = Constr.cpattern; "]" -> { CAst.make ~loc @@ QConstrMatchContext (id, pat) } + | pat = Constr.cpattern -> { CAst.make ~loc @@ QConstrMatchPattern pat } ] ] ; match_rule: - [ [ mp = match_pattern; "=>"; tac = tac2expr -> + [ [ mp = match_pattern; "=>"; tac = ltac2_expr -> { CAst.make ~loc @@ (mp, tac) } ] ] ; @@ -748,16 +751,16 @@ GRAMMAR EXTEND Gram ] ] ; gmatch_rule: - [ [ mp = gmatch_pattern; "=>"; tac = tac2expr -> + [ [ mp = gmatch_pattern; "=>"; tac = ltac2_expr -> { CAst.make ~loc @@ (mp, tac) } ] ] ; - gmatch_list: + goal_match_list: [ [ mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } | "|"; mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ] ; q_goal_matching: - [ [ m = gmatch_list -> { m } ] ] + [ [ m = goal_match_list -> { m } ] ] ; move_location: [ [ "at"; IDENT "top" -> { CAst.make ~loc @@ QMoveFirst } @@ -789,7 +792,7 @@ GRAMMAR EXTEND Gram ] ] ; by_tactic: - [ [ "by"; tac = tac2expr -> { Some tac } + [ [ "by"; tac = ltac2_expr -> { Some tac } | -> { None } ] ] ; @@ -812,8 +815,8 @@ END (* GRAMMAR EXTEND Gram - Pcoq.Constr.operconstr: LEVEL "0" - [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> + Pcoq.Constr.term: LEVEL "0" + [ [ IDENT "ltac2"; ":"; "("; tac = ltac2_expr; ")" -> { let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } | test_ampersand_ident; "&"; id = Prim.ident -> @@ -858,7 +861,7 @@ let rules = [ Pcoq.( Production.make (Rule.stop ++ Symbol.token (PIDENT (Some "ltac2")) ++ Symbol.token (PKEYWORD ":") ++ - Symbol.token (PKEYWORD "(") ++ Symbol.nterm tac2expr ++ Symbol.token (PKEYWORD ")")) + Symbol.token (PKEYWORD "(") ++ Symbol.nterm ltac2_expr ++ Symbol.token (PKEYWORD ")")) begin fun _ tac _ _ _ loc -> let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) @@ -867,7 +870,7 @@ let rules = [ ] in Hook.set Tac2entries.register_constr_quotations begin fun () -> - Pcoq.grammar_extend Pcoq.Constr.operconstr {pos=Some (Gramlib.Gramext.Level "0"); data=[(None, None, rules)]} + Pcoq.grammar_extend Pcoq.Constr.term {pos=Some (Gramlib.Gramext.Level "0"); data=[(None, None, rules)]} end } @@ -890,7 +893,7 @@ END VERNAC ARGUMENT EXTEND ltac2_expr PRINTED BY { pr_ltac2expr } -| [ tac2expr(e) ] -> { e } +| [ _ltac2_expr(e) ] -> { e } END { @@ -920,10 +923,10 @@ open Vernacextend } VERNAC { tac2mode } EXTEND VernacLtac2 -| ![proof] [ ltac2_expr(t) ltac_use_default(default) ] => +| ![proof] [ ltac2_expr(t) ltac_use_default(with_end_tac) ] => { classify_as_proofstep } -> { (* let g = Option.default (Proof_global.get_default_goal_selector ()) g in *) - fun ~pstate -> Tac2entries.call ~pstate ~default t } + fun ~pstate -> Tac2entries.call ~pstate ~with_end_tac t } END GRAMMAR EXTEND Gram diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 3ce50865c0..5d49d1635c 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -1541,12 +1541,12 @@ end let () = add_scope "tactic" begin function | [] -> (* Default to level 5 parsing *) - let scope = Pcoq.Symbol.nterml tac2expr "5" in + let scope = Pcoq.Symbol.nterml ltac2_expr "5" in let act tac = tac in Tac2entries.ScopeRule (scope, act) | [SexprInt {loc;v=n}] as arg -> let () = if n < 0 || n > 6 then scope_fail "tactic" arg in - let scope = Pcoq.Symbol.nterml tac2expr (string_of_int n) in + let scope = Pcoq.Symbol.nterml ltac2_expr (string_of_int n) in let act tac = tac in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "tactic" arg diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 30340cd632..eebd6635fa 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -24,7 +24,8 @@ open Tac2intern module Pltac = struct -let tac2expr = Pcoq.Entry.create "tac2expr" +let ltac2_expr = Pcoq.Entry.create "ltac2_expr" +let tac2expr = ltac2_expr let tac2expr_in_env = Pcoq.Entry.create "tac2expr_in_env" let q_ident = Pcoq.Entry.create "q_ident" @@ -643,7 +644,7 @@ let perform_notation syn st = | Some lev -> Some (string_of_int lev) in let rule = (lev, None, [rule]) in - ([Pcoq.ExtendRule (Pltac.tac2expr, {Pcoq.pos=None; data=[rule]})], st) + ([Pcoq.ExtendRule (Pltac.ltac2_expr, {Pcoq.pos=None; data=[rule]})], st) let ltac2_notation = Pcoq.create_grammar_command "ltac2-notation" perform_notation @@ -911,25 +912,19 @@ let print_ltac qid = (** Calling tactics *) -let solve ~pstate default tac = - let pstate, status = Declare.Proof.map_fold_endline pstate ~f:(fun etac p -> - let with_end_tac = if default then Some etac else None in - let g = Goal_select.get_default_goal_selector () in - let (p, status) = Proof.solve g None tac ?with_end_tac p in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p, status) - in - if not status then Feedback.feedback Feedback.AddedAxiom; - pstate - -let call ~pstate ~default e = +let ltac2_interp e = let loc = e.loc in let (e, t) = intern ~strict:false [] e in let () = check_unit ?loc t in let tac = Tac2interp.interp Tac2interp.empty_environment e in - solve ~pstate default (Proofview.tclIGNORE tac) + Proofview.tclIGNORE tac + +let ComTactic.Interpreter ltac2_interp = ComTactic.register_tactic_interpreter "ltac2" ltac2_interp + +let call ~pstate ~with_end_tac tac = + ComTactic.solve ~pstate ~with_end_tac + (Goal_select.get_default_goal_selector()) + ~info:None (ltac2_interp tac) (** Primitive algebraic types than can't be defined Coq-side *) diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli index fc56a54e3a..782968c6e1 100644 --- a/user-contrib/Ltac2/tac2entries.mli +++ b/user-contrib/Ltac2/tac2entries.mli @@ -53,7 +53,7 @@ val print_ltac : Libnames.qualid -> unit (** {5 Eval loop} *) (** Evaluate a tactic expression in the current environment *) -val call : pstate:Declare.Proof.t -> default:bool -> raw_tacexpr -> Declare.Proof.t +val call : pstate:Declare.Proof.t -> with_end_tac:bool -> raw_tacexpr -> Declare.Proof.t (** {5 Toplevel exceptions} *) @@ -63,7 +63,9 @@ val backtrace : backtrace Exninfo.t module Pltac : sig +val ltac2_expr : raw_tacexpr Pcoq.Entry.t val tac2expr : raw_tacexpr Pcoq.Entry.t + [@@deprecated "Deprecated in 8.13; use 'ltac2_expr' instead"] val tac2expr_in_env : (Id.t CAst.t list * raw_tacexpr) Pcoq.Entry.t (** Quoted entries. To be used for complex notations. *) diff --git a/user-contrib/Ltac2/tac2expr.mli b/user-contrib/Ltac2/tac2expr.mli index 548655f561..0ae016265a 100644 --- a/user-contrib/Ltac2/tac2expr.mli +++ b/user-contrib/Ltac2/tac2expr.mli @@ -105,6 +105,7 @@ type raw_tacexpr_r = | CTacLet of rec_flag * (raw_patexpr * raw_tacexpr) list * raw_tacexpr | CTacCnv of raw_tacexpr * raw_typexpr | CTacSeq of raw_tacexpr * raw_tacexpr +| CTacIft of raw_tacexpr * raw_tacexpr * raw_tacexpr | CTacCse of raw_tacexpr * raw_taccase list | CTacRec of raw_recexpr | CTacPrj of raw_tacexpr * ltac_projection or_relid diff --git a/user-contrib/Ltac2/tac2intern.ml b/user-contrib/Ltac2/tac2intern.ml index 797f72702d..ddf70a5a65 100644 --- a/user-contrib/Ltac2/tac2intern.ml +++ b/user-contrib/Ltac2/tac2intern.ml @@ -29,6 +29,7 @@ let t_string = coq_type "string" let t_constr = coq_type "constr" let t_ltac1 = ltac1_type "t" let t_preterm = coq_type "preterm" +let t_bool = coq_type "bool" (** Union find *) @@ -749,6 +750,15 @@ let rec intern_rec env {loc;v=e} = match e with let (e2, t2) = intern_rec env e2 in let () = check_elt_unit loc1 env t1 in (GTacLet (false, [Anonymous, e1], e2), t2) +| CTacIft (e, e1, e2) -> + let loc = e.loc in + let loc1 = e1.loc in + let (e, t) = intern_rec env e in + let (e1, t1) = intern_rec env e1 in + let (e2, t2) = intern_rec env e2 in + let () = unify ?loc env t (GTypRef (Other t_bool, [])) in + let () = unify ?loc:loc1 env t1 t2 in + (GTacCse (e, Other t_bool, [|e1; e2|], [||]), t2) | CTacCse (e, pl) -> intern_case env loc e pl | CTacRec fs -> @@ -1271,6 +1281,11 @@ let rec globalize ids ({loc;v=er} as e) = match er with let e1 = globalize ids e1 in let e2 = globalize ids e2 in CAst.make ?loc @@ CTacSeq (e1, e2) +| CTacIft (e, e1, e2) -> + let e = globalize ids e in + let e1 = globalize ids e1 in + let e2 = globalize ids e2 in + CAst.make ?loc @@ CTacIft (e, e1, e2) | CTacCse (e, bl) -> let e = globalize ids e in let bl = List.map (fun b -> globalize_case ids b) bl in @@ -1486,6 +1501,11 @@ let rec subst_rawexpr subst ({loc;v=tr} as t) = match tr with let e1' = subst_rawexpr subst e1 in let e2' = subst_rawexpr subst e2 in if e1' == e1 && e2' == e2 then t else CAst.make ?loc @@ CTacSeq (e1', e2') +| CTacIft (e, e1, e2) -> + let e' = subst_rawexpr subst e in + let e1' = subst_rawexpr subst e1 in + let e2' = subst_rawexpr subst e2 in + if e' == e && e1' == e1 && e2' == e2 then t else CAst.make ?loc @@ CTacIft (e', e1', e2') | CTacCse (e, bl) -> let map (p, e as x) = let p' = subst_rawpattern subst p in diff --git a/vernac/attributes.ml b/vernac/attributes.ml index fb308fd316..efba6d332a 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -224,3 +224,11 @@ let canonical_field = enable_attribute ~key:"canonical" ~default:(fun () -> true) let canonical_instance = enable_attribute ~key:"canonical" ~default:(fun () -> false) + +let uses_parser : string key_parser = fun orig args -> + assert_once ~name:"using" orig; + match args with + | VernacFlagLeaf str -> str + | _ -> CErrors.user_err (Pp.str "Ill formed \"using\" attribute") + +let using = attribute_of_list ["using",uses_parser] diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 51bab79938..1969665082 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -51,6 +51,7 @@ val option_locality : Goptions.option_locality attribute val deprecation : Deprecation.t option attribute val canonical_field : bool attribute val canonical_instance : bool attribute +val using : string option attribute val program_mode_option_name : string list (** For internal use when messing with the global option. *) diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 7a7e7d6e35..f715459616 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -145,7 +145,7 @@ let build_beq_scheme_deps kn = | Cast (x,_,_) -> aux accu (Term.applist (x,a)) | App _ -> assert false | Ind ((kn', _), _) -> - if MutInd.equal kn kn' then accu + if Environ.QMutInd.equal env kn kn' then accu else let eff = SchemeMutualDep (kn', !beq_scheme_kind_aux ()) in List.fold_left aux (eff :: accu) a @@ -253,7 +253,7 @@ let build_beq_scheme mode kn = | Cast (x,_,_) -> aux (Term.applist (x,a)) | App _ -> assert false | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> - if MutInd.equal kn kn' then mkRel(eqA-nlist-i+nb_ind-1) + if Environ.QMutInd.equal env kn kn' then mkRel(eqA-nlist-i+nb_ind-1) else begin try let eq = match lookup_scheme (!beq_scheme_kind_aux()) ind' with @@ -496,7 +496,7 @@ let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let u,v = try destruct_ind env sigma tt1 (* trick so that the good sequence is returned*) with e when CErrors.noncritical e -> indu,[||] - in if eq_ind (fst u) ind + in if Ind.CanOrd.equal (fst u) ind then Tacticals.New.tclTHENLIST [Equality.replace t1 t2; Auto.default_auto ; aux q1 q2 ] else ( find_scheme bl_scheme_key (fst u) (*FIXME*) >>= fun c -> @@ -539,7 +539,8 @@ let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = with DestKO -> Tacticals.New.tclZEROMSG (str "The expected type is an inductive one.") end end >>= fun (sp2,i2) -> - if not (MutInd.equal sp1 sp2) || not (Int.equal i1 i2) + Proofview.tclENV >>= fun env -> + if not (Environ.QMutInd.equal env sp1 sp2) || not (Int.equal i1 i2) then Tacticals.New.tclZEROMSG (str "Eq should be on the same type") else aux (Array.to_list ca1) (Array.to_list ca2) diff --git a/vernac/classes.ml b/vernac/classes.ml index d5509e2697..062cc90f8f 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -57,7 +57,7 @@ let is_local_for_hint i = let add_instance_base inst = let locality = if is_local_for_hint inst then Goptions.OptLocal else Goptions.OptGlobal in - add_instance_hint (Hints.IsGlobRef inst.is_impl) [inst.is_impl] ~locality + add_instance_hint (Hints.hint_globref inst.is_impl) [inst.is_impl] ~locality inst.is_info let mk_instance cl info glob impl = @@ -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 c1dbf0a1ea..81154bbea9 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -110,32 +110,42 @@ let interp_definition ~program_mode env evd impl_env bl red_option c ctypopt = let tyopt = Option.map (fun ty -> EConstr.it_mkProd_or_LetIn ty ctx) tyopt in evd, (c, tyopt), imps -let do_definition ?hook ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = +let do_definition ?hook ~name ~scope ~poly ~kind ?using udecl bl red_option c ctypopt = 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 + let using = using |> Option.map (fun expr -> + let terms = body :: match types with Some x -> [x] | None -> [] in + let l = Proof_using.process_expr (Global.env()) evd expr terms in + Names.Id.Set.(List.fold_right add l empty)) + in let kind = Decls.IsDefinition kind in - let cinfo = Declare.CInfo.make ~name ~impargs ~typ:types () in + let cinfo = Declare.CInfo.make ~name ~impargs ~typ:types ?using () in let info = Declare.Info.make ~scope ~kind ?hook ~udecl ~poly () in let _ : Names.GlobRef.t = Declare.declare_definition ~info ~cinfo ~opaque:false ~body evd in () -let do_definition_program ?hook ~pm ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = +let do_definition_program ?hook ~pm ~name ~scope ~poly ~kind ?using udecl bl red_option c ctypopt = 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 + let using = using |> Option.map (fun expr -> + let terms = body :: match types with Some x -> [x] | None -> [] in + let l = Proof_using.process_expr (Global.env()) evd expr terms in + Names.Id.Set.(List.fold_right add l empty)) + in let term, typ, uctx, obls = Declare.Obls.prepare_obligation ~name ~body ~types evd in let pm, _ = - let cinfo = Declare.CInfo.make ~name ~typ ~impargs () in + let cinfo = Declare.CInfo.make ~name ~typ ~impargs ?using () in let info = Declare.Info.make ~udecl ~scope ~poly ~kind ?hook () in Declare.Obls.add_definition ~pm ~cinfo ~info ~term ~uctx obls in pm diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 7420235449..5e1b705ae4 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -31,6 +31,7 @@ val do_definition -> scope:Locality.locality -> poly:bool -> kind:Decls.definition_object_kind + -> ?using:Vernacexpr.section_subset_expr -> universe_decl_expr option -> local_binder_expr list -> red_expr option @@ -45,6 +46,7 @@ val do_definition_program -> scope:Locality.locality -> poly:bool -> kind:Decls.logical_kind + -> ?using:Vernacexpr.section_subset_expr -> universe_decl_expr option -> local_binder_expr list -> red_expr option diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 78572c6aa6..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 @@ -251,15 +251,22 @@ let interp_fixpoint ?(check_recursivity=true) ~cofix l : let uctx,fix = ground_fixpoint env evd fix in (fix,pl,uctx,info) -let build_recthms ~indexes fixnames fixtypes fiximps = +let build_recthms ~indexes ?using fixnames fixtypes fiximps = let fix_kind, cofix = match indexes with | Some indexes -> Decls.Fixpoint, false | None -> Decls.CoFixpoint, true in let thms = List.map3 (fun name typ (ctx,impargs,_) -> + let using = using |> Option.map (fun expr -> + let terms = [EConstr.of_constr typ] in + let env = Global.env() in + let sigma = Evd.from_env env in + let l = Proof_using.process_expr env sigma expr terms in + Names.Id.Set.(List.fold_right add l empty)) + in let args = List.map Context.Rel.Declaration.get_name ctx in - Declare.CInfo.make ~name ~typ ~args ~impargs () + Declare.CInfo.make ~name ~typ ~args ~impargs ?using () ) fixnames fixtypes fiximps in fix_kind, cofix, thms @@ -277,9 +284,9 @@ let declare_fixpoint_interactive_generic ?indexes ~scope ~poly ((fixnames,_fixrs List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; lemma -let declare_fixpoint_generic ?indexes ~scope ~poly ((fixnames,fixrs,fixdefs,fixtypes),udecl,uctx,fiximps) ntns = +let declare_fixpoint_generic ?indexes ~scope ~poly ?using ((fixnames,fixrs,fixdefs,fixtypes),udecl,uctx,fiximps) ntns = (* We shortcut the proof process *) - let fix_kind, cofix, fixitems = build_recthms ~indexes fixnames fixtypes fiximps in + let fix_kind, cofix, fixitems = build_recthms ~indexes ?using fixnames fixtypes fiximps in let fixdefs = List.map Option.get fixdefs in let rec_declaration = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in let fix_kind = Decls.IsDefinition fix_kind in @@ -328,9 +335,9 @@ let do_fixpoint_interactive ~scope ~poly l : Declare.Proof.t = let lemma = declare_fixpoint_interactive_generic ~indexes:possible_indexes ~scope ~poly fix ntns in lemma -let do_fixpoint ~scope ~poly l = +let do_fixpoint ~scope ~poly ?using l = let fixl, ntns, fix, possible_indexes = do_fixpoint_common l in - declare_fixpoint_generic ~indexes:possible_indexes ~scope ~poly fix ntns + declare_fixpoint_generic ~indexes:possible_indexes ~scope ~poly ?using fix ntns let do_cofixpoint_common (fixl : Vernacexpr.cofixpoint_expr list) = let fixl = List.map (fun fix -> {fix with Vernacexpr.rec_order = None}) fixl in @@ -342,6 +349,6 @@ let do_cofixpoint_interactive ~scope ~poly l = let lemma = declare_fixpoint_interactive_generic ~scope ~poly cofix ntns in lemma -let do_cofixpoint ~scope ~poly l = +let do_cofixpoint ~scope ~poly ?using l = let cofix, ntns = do_cofixpoint_common l in - declare_fixpoint_generic ~scope ~poly cofix ntns + declare_fixpoint_generic ~scope ~poly ?using cofix ntns diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index aa5446205c..a36aba7672 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -19,13 +19,13 @@ val do_fixpoint_interactive : scope:Locality.locality -> poly:bool -> fixpoint_expr list -> Declare.Proof.t val do_fixpoint : - scope:Locality.locality -> poly:bool -> fixpoint_expr list -> unit + scope:Locality.locality -> poly:bool -> ?using:Vernacexpr.section_subset_expr -> fixpoint_expr list -> unit val do_cofixpoint_interactive : scope:Locality.locality -> poly:bool -> cofixpoint_expr list -> Declare.Proof.t val do_cofixpoint : - scope:Locality.locality -> poly:bool -> cofixpoint_expr list -> unit + scope:Locality.locality -> poly:bool -> ?using:Vernacexpr.section_subset_expr -> cofixpoint_expr list -> unit (************************************************************************) (** Internal API *) diff --git a/vernac/comHints.ml b/vernac/comHints.ml index 9eac558908..f642411fa4 100644 --- a/vernac/comHints.ml +++ b/vernac/comHints.ml @@ -62,7 +62,7 @@ let project_hint ~poly pri l2r r = cb in let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in - (info, true, Hints.PathAny, Hints.IsGlobRef (GlobRef.ConstRef c)) + (info, true, Hints.PathAny, Hints.hint_globref (GlobRef.ConstRef c)) let warn_deprecated_hint_constr = CWarnings.create ~name:"fragile-hint-constr" ~category:"automation" @@ -84,16 +84,6 @@ let soft_evaluable = let interp_hints ~poly h = let env = Global.env () in let sigma = Evd.from_env env in - let f poly c = - let evd, c = Constrintern.interp_open_constr env sigma c in - let env = Global.env () in - let sigma = Evd.from_env env in - let c, diff = Hints.prepare_hint true env sigma (evd, c) in - if poly then (Hints.IsConstr (c, Some diff) [@ocaml.warning "-3"]) - else - let () = DeclareUctx.declare_universe_context ~poly:false diff in - (Hints.IsConstr (c, None) [@ocaml.warning "-3"]) - in let fref r = let gr = Smartlocate.global_with_alias r in Dumpglob.add_glob ?loc:r.CAst.loc gr; @@ -106,10 +96,22 @@ let interp_hints ~poly h = match c with | HintsReference c -> let gr = Smartlocate.global_with_alias c in - (PathHints [gr], IsGlobRef gr) + (PathHints [gr], hint_globref gr) | HintsConstr c -> let () = warn_deprecated_hint_constr () in - (PathAny, f poly c) + let env = Global.env () in + let sigma = Evd.from_env env in + let c, uctx = Constrintern.interp_constr env sigma c in + let subst, uctx = UState.normalize_variables uctx in + let c = EConstr.Vars.subst_univs_constr subst c in + let diff = UState.context_set uctx in + let c = + if poly then (c, Some diff) + else + let () = DeclareUctx.declare_universe_context ~poly:false diff in + (c, None) + in + (PathAny, Hints.hint_constr c) [@ocaml.warning "-3"] in let fp = Constrintern.intern_constr_pattern env sigma in let fres (info, b, r) = @@ -149,7 +151,7 @@ let interp_hints ~poly h = ( empty_hint_info , true , PathHints [gr] - , IsGlobRef gr )) + , hint_globref gr )) in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) | HintsExtern (pri, patcom, tacexp) -> 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 55901fd604..31f91979d3 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -109,13 +109,13 @@ let telescope env sigma l = let nf_evar_context sigma ctx = List.map (map_constr (fun c -> Evarutil.nf_evar sigma c)) ctx -let build_wellfounded pm (recname,pl,bl,arityc,body) poly r measure notation = +let build_wellfounded pm (recname,pl,bl,arityc,body) poly ?using r measure notation = let open EConstr in let open Vars in 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 @@ -259,8 +259,13 @@ let build_wellfounded pm (recname,pl,bl,arityc,body) poly r measure notation = let evars, _, evars_def, evars_typ = RetrieveObl.retrieve_obligations env recname sigma 0 def typ in + let using = using |> Option.map (fun expr -> + let terms = List.map EConstr.of_constr [evars_def; evars_typ] in + let l = Proof_using.process_expr env sigma expr terms in + Names.Id.Set.(List.fold_right add l empty)) + in let uctx = Evd.evar_universe_context sigma in - let cinfo = Declare.CInfo.make ~name:recname ~typ:evars_typ () in + let cinfo = Declare.CInfo.make ~name:recname ~typ:evars_typ ?using () in let info = Declare.Info.make ~udecl ~poly ~hook () in let pm, _ = Declare.Obls.add_definition ~pm ~cinfo ~info ~term:evars_def ~uctx evars in @@ -275,7 +280,7 @@ let collect_evars_of_term evd c ty = Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) evars (Evd.from_ctx (Evd.evar_universe_context evd)) -let do_program_recursive ~pm ~scope ~poly fixkind fixl = +let do_program_recursive ~pm ~scope ~poly ?using fixkind fixl = let cofix = fixkind = Declare.Obls.IsCoFixpoint in let (env, rec_sign, udecl, evd), fix, info = interp_recursive ~cofix ~program_mode:true fixl @@ -287,13 +292,18 @@ let do_program_recursive ~pm ~scope ~poly fixkind fixl = let evd = nf_evar_map_undefined evd in let collect_evars name def typ impargs = (* Generalize by the recursive prototypes *) + let using = using |> Option.map (fun expr -> + let terms = [def; typ] in + let l = Proof_using.process_expr env evd expr terms in + Names.Id.Set.(List.fold_right add l empty)) + in let def = nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) in let typ = nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign) in let evm = collect_evars_of_term evd def typ in let evars, _, def, typ = RetrieveObl.retrieve_obligations env name evm (List.length rec_sign) def typ in - let cinfo = Declare.CInfo.make ~name ~typ ~impargs () in + let cinfo = Declare.CInfo.make ~name ~typ ~impargs ?using () in (cinfo, def, evars) in let (fixnames,fixrs,fixdefs,fixtypes) = fix in @@ -325,13 +335,13 @@ let do_program_recursive ~pm ~scope ~poly fixkind fixl = let info = Declare.Info.make ~poly ~scope ~kind ~udecl () in Declare.Obls.add_mutual_definitions ~pm defs ~info ~uctx ~ntns fixkind -let do_fixpoint ~pm ~scope ~poly l = +let do_fixpoint ~pm ~scope ~poly ?using l = let g = List.map (fun { Vernacexpr.rec_order } -> rec_order) l in match g, l with | [Some { CAst.v = CWfRec (n,r) }], [ Vernacexpr.{fname={CAst.v=id}; univs; binders; rtype; body_def; notations} ] -> let recarg = mkIdentC n.CAst.v in - build_wellfounded pm (id, univs, binders, rtype, out_def body_def) poly r recarg notations + build_wellfounded pm (id, univs, binders, rtype, out_def body_def) poly ?using r recarg notations | [Some { CAst.v = CMeasureRec (n, m, r) }], [Vernacexpr.{fname={CAst.v=id}; univs; binders; rtype; body_def; notations }] -> @@ -344,7 +354,7 @@ let do_fixpoint ~pm ~scope ~poly l = user_err Pp.(str"Measure takes only two arguments in Program Fixpoint.") | _, _ -> r in - build_wellfounded pm (id, univs, binders, rtype, out_def body_def) poly + build_wellfounded pm (id, univs, binders, rtype, out_def body_def) poly ?using (Option.default (CAst.make @@ CRef (lt_ref,None)) r) m notations | _, _ when List.for_all (fun ro -> match ro with None | Some { CAst.v = CStructRec _} -> true | _ -> false) g -> @@ -352,11 +362,11 @@ let do_fixpoint ~pm ~scope ~poly l = Vernacexpr.(ComFixpoint.adjust_rec_order ~structonly:true fix.binders fix.rec_order)) l in let fixkind = Declare.Obls.IsFixpoint annots in let l = List.map2 (fun fix rec_order -> { fix with Vernacexpr.rec_order }) l annots in - do_program_recursive ~pm ~scope ~poly fixkind l + do_program_recursive ~pm ~scope ~poly ?using fixkind l | _, _ -> CErrors.user_err ~hdr:"do_fixpoint" (str "Well-founded fixpoints not allowed in mutually recursive blocks") -let do_cofixpoint ~pm ~scope ~poly fixl = +let do_cofixpoint ~pm ~scope ~poly ?using fixl = let fixl = List.map (fun fix -> { fix with Vernacexpr.rec_order = None }) fixl in - do_program_recursive ~pm ~scope ~poly Declare.Obls.IsCoFixpoint fixl + do_program_recursive ~pm ~scope ~poly ?using Declare.Obls.IsCoFixpoint fixl diff --git a/vernac/comProgramFixpoint.mli b/vernac/comProgramFixpoint.mli index 7935cf27fb..30bf3ae8f8 100644 --- a/vernac/comProgramFixpoint.mli +++ b/vernac/comProgramFixpoint.mli @@ -15,6 +15,7 @@ val do_fixpoint : pm:Declare.OblState.t -> scope:Locality.locality -> poly:bool + -> ?using:Vernacexpr.section_subset_expr -> fixpoint_expr list -> Declare.OblState.t @@ -22,5 +23,6 @@ val do_cofixpoint : pm:Declare.OblState.t -> scope:Locality.locality -> poly:bool + -> ?using:Vernacexpr.section_subset_expr -> cofixpoint_expr list -> Declare.OblState.t diff --git a/vernac/comSearch.ml b/vernac/comSearch.ml index 9de8d6fbc3..af51f4fafb 100644 --- a/vernac/comSearch.ml +++ b/vernac/comSearch.ml @@ -53,9 +53,19 @@ let kind_searcher = Decls.(function let interp_search_item env sigma = function | SearchSubPattern ((where,head),pat) -> - let _,pat = Constrintern.intern_constr_pattern env sigma pat in + let expected_type = Pretyping.(if head then IsType else WithoutTypeConstraint) in + let pat = + try Constrintern.interp_constr_pattern env sigma ~expected_type pat + with e when CErrors.noncritical e -> + (* We cannot ensure (yet?) that a typable pattern will + actually be typed, consider e.g. (forall A, A -> A /\ A) + which fails, not seeing that A can be Prop; so we use an + untyped pattern as a fallback (i.e w/o no insertion of + 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/comTactic.ml b/vernac/comTactic.ml index 8a9a412362..2252d46e58 100644 --- a/vernac/comTactic.ml +++ b/vernac/comTactic.ml @@ -16,13 +16,13 @@ module DMap = Dyn.Map(struct type 'a t = 'a -> unit Proofview.tactic end) let interp_map = ref DMap.empty -type 'a tactic_interpreter = 'a Dyn.tag -type interpretable = I : 'a tactic_interpreter * 'a -> interpretable +type interpretable = I : 'a Dyn.tag * 'a -> interpretable +type 'a tactic_interpreter = Interpreter of ('a -> interpretable) let register_tactic_interpreter na f = let t = Dyn.create na in interp_map := DMap.add t f !interp_map; - t + Interpreter (fun x -> I (t,x)) let interp_tac (I (tag,t)) = let f = DMap.find tag !interp_map in diff --git a/vernac/comTactic.mli b/vernac/comTactic.mli index f1a75e1b6a..72e71d013a 100644 --- a/vernac/comTactic.mli +++ b/vernac/comTactic.mli @@ -9,10 +9,13 @@ (************************************************************************) (** Tactic interpreters have to register their interpretation function *) -type 'a tactic_interpreter -type interpretable = I : 'a tactic_interpreter * 'a -> interpretable +type interpretable -(** ['a] should be marshallable if ever used with [par:] *) +type 'a tactic_interpreter = private Interpreter of ('a -> interpretable) + +(** ['a] should be marshallable if ever used with [par:]. Must be + called no more than once per process with a particular string: make + sure to use partial application. *) val register_tactic_interpreter : string -> ('a -> unit Proofview.tactic) -> 'a tactic_interpreter diff --git a/vernac/declare.ml b/vernac/declare.ml index 5274a6da3b..1e8771b641 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -55,11 +55,13 @@ module CInfo = struct (** Names to pre-introduce *) ; impargs : Impargs.manual_implicits (** Explicitily declared implicit arguments *) + ; using : Names.Id.Set.t option + (** Explicit declaration of section variables used by the constant *) } - let make ~name ~typ ?(args=[]) ?(impargs=[]) () = - { name; typ; args; impargs } + let make ~name ~typ ?(args=[]) ?(impargs=[]) ?using () = + { name; typ; args; impargs; using } let to_constr sigma thm = { thm with typ = EConstr.to_constr sigma thm.typ } @@ -108,10 +110,10 @@ let default_univ_entry = Entries.Monomorphic_entry Univ.ContextSet.empty (** [univsbody] are universe-constraints attached to the body-only, used in vio-delayed opaque constants and private poly universes *) -let definition_entry_core ?(opaque=false) ?(inline=false) ?feedback_id ?section_vars ?types +let definition_entry_core ?(opaque=false) ?using ?(inline=false) ?feedback_id ?types ?(univs=default_univ_entry) ?(eff=Evd.empty_side_effects) ?(univsbody=Univ.ContextSet.empty) body = { proof_entry_body = Future.from_val ((body,univsbody), eff); - proof_entry_secctx = section_vars; + proof_entry_secctx = using; proof_entry_type = types; proof_entry_universes = univs; proof_entry_opaque = opaque; @@ -119,7 +121,7 @@ let definition_entry_core ?(opaque=false) ?(inline=false) ?feedback_id ?section_ proof_entry_inline_code = inline} let definition_entry = - definition_entry_core ?eff:None ?univsbody:None ?feedback_id:None ?section_vars:None + definition_entry_core ?eff:None ?univsbody:None ?feedback_id:None type 'a constant_entry = | DefinitionEntry of 'a proof_entry @@ -162,7 +164,7 @@ let cache_constant ((sp,kn), obj) = then Constant.make1 kn else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(Libnames.basename sp) ++ str".") in - assert (Constant.equal kn' (Constant.make1 kn)); + assert (Environ.QConstant.equal (Global.env ()) kn' (Constant.make1 kn)); Nametab.push (Nametab.Until 1) sp (GlobRef.ConstRef (Constant.make1 kn)); Dumpglob.add_constant_kind (Constant.make1 kn) obj.cst_kind @@ -236,9 +238,9 @@ let pure_definition_entry ?(opaque=false) ?(inline=false) ?types proof_entry_feedback = None; proof_entry_inline_code = inline} -let delayed_definition_entry ~opaque ?feedback_id ~section_vars ~univs ?types body = +let delayed_definition_entry ~opaque ?feedback_id ~using ~univs ?types body = { proof_entry_body = body - ; proof_entry_secctx = section_vars + ; proof_entry_secctx = using ; proof_entry_type = types ; proof_entry_universes = univs ; proof_entry_opaque = opaque @@ -608,8 +610,8 @@ let declare_mutually_recursive_core ~info ~cinfo ~opaque ~ntns ~uctx ~rec_declar uctx, univs in let csts = CList.map2 - (fun CInfo.{ name; typ; impargs } body -> - let entry = definition_entry ~opaque ~types:typ ~univs body in + (fun CInfo.{ name; typ; impargs; using } body -> + let entry = definition_entry ~opaque ~types:typ ~univs ?using body in declare_entry ~name ~scope ~kind ~impargs ~uctx entry) cinfo fixdecls in @@ -660,7 +662,7 @@ let check_evars_are_solved env sigma t = let evars = Evarutil.undefined_evars_of_term sigma t in if not (Evar.Set.is_empty evars) then error_unresolved_evars env sigma t evars -let prepare_definition ~info ~opaque ~body ~typ sigma = +let prepare_definition ~info ~opaque ?using ~body ~typ sigma = let { Info.poly; udecl; inline; _ } = info in let env = Global.env () in let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:false @@ -669,13 +671,13 @@ let prepare_definition ~info ~opaque ~body ~typ sigma = Option.iter (check_evars_are_solved env sigma) types; check_evars_are_solved env sigma body; let univs = Evd.check_univ_decl ~poly sigma udecl in - let entry = definition_entry ~opaque ~inline ?types ~univs body in + let entry = definition_entry ~opaque ?using ~inline ?types ~univs body in let uctx = Evd.evar_universe_context sigma in entry, uctx let declare_definition_core ~info ~cinfo ~opaque ~obls ~body sigma = - let { CInfo.name; impargs; typ; _ } = cinfo in - let entry, uctx = prepare_definition ~info ~opaque ~body ~typ sigma in + let { CInfo.name; impargs; typ; using; _ } = cinfo in + let entry, uctx = prepare_definition ~info ~opaque ?using ~body ~typ sigma in let { Info.scope; kind; hook; _ } = info in declare_entry_core ~name ~scope ~kind ~impargs ~obls ?hook ~uctx entry, uctx @@ -803,6 +805,7 @@ module ProgramDecl = struct let set_uctx ~uctx prg = {prg with prg_uctx = uctx} let get_poly prg = prg.prg_info.Info.poly let get_obligations prg = prg.prg_obligations + let get_using prg = prg.prg_cinfo.CInfo.using end end @@ -1137,7 +1140,7 @@ let declare_mutual_definition ~pm l = in let term = EConstr.to_constr sigma term in let typ = EConstr.to_constr sigma typ in - let def = (x.prg_reduce term, r, x.prg_reduce typ, x.prg_cinfo.CInfo.impargs) in + let def = (x.prg_reduce term, r, x.prg_reduce typ, x.prg_cinfo.CInfo.impargs, x.prg_cinfo.CInfo.using) in let oblsubst = List.map (fun (id, (_, c)) -> (id, c)) oblsubst in (def, oblsubst) in @@ -1151,11 +1154,11 @@ let declare_mutual_definition ~pm l = (* let fixdefs = List.map reduce_fix fixdefs in *) let fixdefs, fixrs, fixtypes, fixitems = List.fold_right2 - (fun (d, r, typ, impargs) name (a1, a2, a3, a4) -> + (fun (d, r, typ, impargs, using) name (a1, a2, a3, a4) -> ( d :: a1 , r :: a2 , typ :: a3 - , CInfo.{name; typ; impargs; args = []} :: a4 )) + , CInfo.{name; typ; impargs; args = []; using } :: a4 )) defs first.prg_deps ([], [], [], []) in let fixkind = Option.get first.prg_fixkind in @@ -1288,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 @@ -1300,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 @@ -1376,7 +1379,7 @@ end type t = { endline_tactic : Genarg.glob_generic_argument option - ; section_vars : Id.Set.t option + ; using : Id.Set.t option ; proof : Proof.t ; initial_euctx : UState.t (** The initial universe context (for the statement) *) @@ -1435,7 +1438,7 @@ let start_proof_core ~name ~typ ~pinfo ?(sign=initialize_named_context_for_proof let initial_euctx = Evd.evar_universe_context Proof.((data proof).sigma) in { proof ; endline_tactic = None - ; section_vars = None + ; using = None ; initial_euctx ; pinfo } @@ -1458,7 +1461,7 @@ let start_dependent ~info ~name ~proof_ending goals = let pinfo = Proof_info.make ~info ~cinfo ~proof_ending () in { proof ; endline_tactic = None - ; section_vars = None + ; using = None ; initial_euctx ; pinfo } @@ -1523,7 +1526,7 @@ let start_mutual_with_initialization ~info ~cinfo ~mutual_info sigma snl = map lemma ~f:(fun p -> pi1 @@ Proof.run_tactic Global.(env ()) init_tac p) -let get_used_variables pf = pf.section_vars +let get_used_variables pf = pf.using let get_universe_decl pf = pf.pinfo.Proof_info.info.Info.udecl let set_used_variables ps l = @@ -1547,9 +1550,9 @@ let set_used_variables ps l = else (ctx, all_safe) in let ctx, _ = Environ.fold_named_context aux env ~init:(ctx,ctx_set) in - if not (Option.is_empty ps.section_vars) then + if not (Option.is_empty ps.using) then CErrors.user_err Pp.(str "Used section variables can be declared only once"); - ctx, { ps with section_vars = Some (Context.Named.to_vars ctx) } + ctx, { ps with using = Some (Context.Named.to_vars ctx) } let get_open_goals ps = let Proof.{ goals; stack; sigma } = Proof.data ps.proof in @@ -1624,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 @@ -1640,13 +1643,13 @@ 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 = - let { section_vars; proof; initial_euctx; pinfo } = ps in + let { using; proof; initial_euctx; pinfo } = ps in let { Proof_info.info = { Info.udecl } } = pinfo in let { Proof.name; poly } = Proof.data proof in let unsafe_typ = keep_body_ucst_separate && not poly in @@ -1667,7 +1670,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ps = then make_univs_private_poly ~poly ~uctx ~udecl t b else make_univs ~poly ~uctx ~udecl t b in - definition_entry_core ~opaque ?section_vars ~univs:utyp ~univsbody:ubody ~types:typ ~eff body + definition_entry_core ~opaque ?using ~univs:utyp ~univsbody:ubody ~types:typ ~eff body in let entries = CList.map make_entry elist in { name; entries; uctx } @@ -1675,7 +1678,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ps = type closed_proof_output = (Constr.t * Evd.side_effects) list * UState.t let close_proof_delayed ~feedback_id ps (fpl : closed_proof_output Future.computation) = - let { section_vars; proof; initial_euctx; pinfo } = ps in + let { using; proof; initial_euctx; pinfo } = ps in let { Proof_info.info = { Info.udecl } } = pinfo in let { Proof.name; poly; entry; sigma } = Proof.data proof in @@ -1709,10 +1712,10 @@ 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) - |> delayed_definition_entry ~opaque ~feedback_id ~section_vars ~univs ~types + 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 { name; entries; uctx = initial_euctx } @@ -2206,26 +2209,60 @@ let warn_solve_errored = ; fnl () ; str "This will become an error in the future" ]) -let solve_by_tac ?loc name evi t ~poly ~uctx = - (* the status is dropped. *) +let solve_by_tac prg obls i tac = + let obl = obls.(i) in + let obl = subst_deps_obl obls obl in + let tac = Option.(default !default_tactic (append tac obl.obl_tac)) in + let uctx = Internal.get_uctx prg in + let uctx = UState.update_sigma_univs uctx (Global.universes ()) in + let poly = Internal.get_poly prg in + let evi = evar_of_obligation obl in + (* the status of [build_by_tactic] is dropped. *) try let env = Global.env () in let body, types, _univs, _, uctx = - build_by_tactic env ~uctx ~poly ~typ:evi.evar_concl t in + build_by_tactic env ~uctx ~poly ~typ:evi.evar_concl tac in Inductiveops.control_only_guard env (Evd.from_ctx uctx) (EConstr.of_constr body); Some (body, types, uctx) with | Tacticals.FailError (_, s) as exn -> let _ = Exninfo.capture exn in + let loc = fst obl.obl_location in CErrors.user_err ?loc ~hdr:"solve_obligation" (Lazy.force s) (* If the proof is open we absorb the error and leave the obligation open *) | Proof_.OpenProof _ -> None | e when CErrors.noncritical e -> let err = CErrors.print e in + let loc = fst obl.obl_location in warn_solve_errored ?loc err; None +let solve_and_declare_by_tac prg obls i tac = + match solve_by_tac prg obls i tac with + | None -> None + | Some (t, ty, uctx) -> + let obl = obls.(i) in + let poly = Internal.get_poly prg in + let prg = ProgramDecl.Internal.set_uctx ~uctx prg in + let def, obl', _cst = declare_obligation prg obl ~body:t ~types:ty ~uctx in + obls.(i) <- obl'; + if def && not poly then ( + (* Declare the term constraints with the first obligation only *) + let uctx_global = UState.from_env (Global.env ()) in + let uctx = UState.merge_subst uctx_global (UState.subst uctx) in + Some (ProgramDecl.Internal.set_uctx ~uctx prg)) + else Some prg + +let solve_obligation_by_tac prg obls i tac = + let obl = obls.(i) in + match obl.obl_body with + | Some _ -> None + | None -> + if List.is_empty (deps_remaining obls obl.obl_deps) + then solve_and_declare_by_tac prg obls i tac + else None + let get_unique_prog ~pm prg = match State.get_unique_open_prog pm prg with | Ok prg -> prg @@ -2255,7 +2292,8 @@ let rec solve_obligation prg num tac = let name = Internal.get_name prg in Proof_ending.End_obligation {name; num; auto} in - let cinfo = CInfo.make ~name:obl.obl_name ~typ:(EConstr.of_constr obl.obl_type) () in + let using = Internal.get_using prg in + let cinfo = CInfo.make ~name:obl.obl_name ~typ:(EConstr.of_constr obl.obl_type) ?using () in let poly = Internal.get_poly prg in let info = Info.make ~scope ~kind ~poly () in let lemma = Proof.start_core ~cinfo ~info ~proof_ending evd in @@ -2263,49 +2301,6 @@ let rec solve_obligation prg num tac = let lemma = Option.cata (fun tac -> Proof.set_endline_tactic tac lemma) lemma tac in lemma -and obligation (user_num, name, typ) ~pm tac = - let num = pred user_num in - let prg = get_unique_prog ~pm name in - let { obls; remaining } = Internal.get_obligations prg in - if num >= 0 && num < Array.length obls then - let obl = obls.(num) in - match obl.obl_body with - | None -> solve_obligation prg num tac - | Some r -> Error.already_solved num - else Error.unknown_obligation num - -and solve_obligation_by_tac prg obls i tac = - let obl = obls.(i) in - match obl.obl_body with - | Some _ -> None - | None -> - if List.is_empty (deps_remaining obls obl.obl_deps) then - let obl = subst_deps_obl obls obl in - let tac = - match tac with - | Some t -> t - | None -> - match obl.obl_tac with - | Some t -> t - | None -> !default_tactic - in - let uctx = Internal.get_uctx prg in - let uctx = UState.update_sigma_univs uctx (Global.universes ()) in - let poly = Internal.get_poly prg in - match solve_by_tac ?loc:(fst obl.obl_location) obl.obl_name (evar_of_obligation obl) tac ~poly ~uctx with - | None -> None - | Some (t, ty, uctx) -> - let prg = ProgramDecl.Internal.set_uctx ~uctx prg in - let def, obl', _cst = declare_obligation prg obl ~body:t ~types:ty ~uctx in - obls.(i) <- obl'; - if def && not poly then ( - (* Declare the term constraints with the first obligation only *) - let uctx_global = UState.from_env (Global.env ()) in - let uctx = UState.merge_subst uctx_global (UState.subst uctx) in - Some (ProgramDecl.Internal.set_uctx ~uctx prg)) - else Some prg - else None - and solve_prg_obligations ~pm prg ?oblset tac = let { obls; remaining } = Internal.get_obligations prg in let rem = ref remaining in @@ -2332,15 +2327,21 @@ and solve_prg_obligations ~pm prg ?oblset tac = in update_obls ~pm prg obls' !rem -and solve_obligations ~pm n tac = +and auto_solve_obligations ~pm n ?oblset tac : State.t * progress = + Flags.if_verbose Feedback.msg_info + (str "Solving obligations automatically..."); + let prg = get_unique_prog ~pm n in + solve_prg_obligations ~pm prg ?oblset tac + +let solve_obligations ~pm n tac = let prg = get_unique_prog ~pm n in solve_prg_obligations ~pm prg tac -and solve_all_obligations ~pm tac = +let solve_all_obligations ~pm tac = State.fold pm ~init:pm ~f:(fun k v pm -> solve_prg_obligations ~pm v tac |> fst) -and try_solve_obligation ~pm n prg tac = +let try_solve_obligation ~pm n prg tac = let prg = get_unique_prog ~pm prg in let {obls; remaining} = Internal.get_obligations prg in let obls' = Array.copy obls in @@ -2350,14 +2351,19 @@ and try_solve_obligation ~pm n prg tac = pm | None -> pm -and try_solve_obligations ~pm n tac = +let try_solve_obligations ~pm n tac = solve_obligations ~pm n tac |> fst -and auto_solve_obligations ~pm n ?oblset tac : State.t * progress = - Flags.if_verbose Feedback.msg_info - (str "Solving obligations automatically..."); - let prg = get_unique_prog ~pm n in - solve_prg_obligations ~pm prg ?oblset tac +let obligation (user_num, name, typ) ~pm tac = + let num = pred user_num in + let prg = get_unique_prog ~pm name in + let { obls; remaining } = Internal.get_obligations prg in + if num >= 0 && num < Array.length obls then + let obl = obls.(num) in + match obl.obl_body with + | None -> solve_obligation prg num tac + | Some r -> Error.already_solved num + else Error.unknown_obligation num let show_single_obligation i n obls x = let x = subst_deps_obl obls x in @@ -2493,7 +2499,12 @@ let admit_obligations ~pm n = let next_obligation ~pm n tac = let prg = match n with - | None -> State.first_pending pm |> Option.get + | None -> + begin match State.first_pending pm with + | Some prg -> prg + | None -> + Error.no_obligations None + end | Some _ -> get_unique_prog ~pm n in let {obls; remaining} = Internal.get_obligations prg in diff --git a/vernac/declare.mli b/vernac/declare.mli index 1ad79928d5..0520bf8717 100644 --- a/vernac/declare.mli +++ b/vernac/declare.mli @@ -79,6 +79,7 @@ module CInfo : sig -> typ:'constr -> ?args:Name.t list -> ?impargs:Impargs.manual_implicits + -> ?using:Names.Id.Set.t -> unit -> 'constr t @@ -244,6 +245,12 @@ module Proof : sig * (w.r.t. type dependencies and let-ins covered by it) *) val set_used_variables : t -> Names.Id.t list -> Constr.named_context * t + (** Gets the set of variables declared to be used by the proof. None means + no "Proof using" or #[using] was given *) + val get_used_variables : t -> Id.Set.t option + + (** Compacts the representation of the proof by pruning all intermediate + terms *) val compact : t -> t (** Update the proof's universe information typically after a @@ -333,6 +340,7 @@ type 'a proof_entry val definition_entry : ?opaque:bool + -> ?using:Names.Id.Set.t -> ?inline:bool -> ?types:Constr.types -> ?univs:Entries.universes_entry diff --git a/vernac/declaremods.mli b/vernac/declaremods.mli index 9ca2ca5593..a1b98e4d9c 100644 --- a/vernac/declaremods.mli +++ b/vernac/declaremods.mli @@ -86,7 +86,7 @@ val start_library : library_name -> unit val end_library : ?except:Future.UUIDSet.t -> output_native_objects:bool -> library_name -> - Safe_typing.compiled_library * library_objects * Safe_typing.native_library + Safe_typing.compiled_library * library_objects * Nativelib.native_library (** append a function to be executed at end_library *) val append_end_library_hook : (unit -> unit) -> unit diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index b134f7b82b..efe4e17d0b 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -300,13 +300,13 @@ let interp_constr_entry_key : type r. _ -> r target -> int -> r Entry.t * int op match forpat with | ForConstr -> if level = 200 then Constr.binder_constr, None - else Constr.operconstr, Some level + else Constr.term, Some level | ForPattern -> Constr.pattern, Some level let target_entry : type s. notation_entry -> s target -> s Entry.t = function | InConstrEntry -> (function - | ForConstr -> Constr.operconstr + | ForConstr -> Constr.term | ForPattern -> Constr.pattern) | InCustomEntry s -> let (entry_for_constr, entry_for_patttern) = find_custom_entry s in @@ -408,8 +408,8 @@ match e with | TTClosedBinderList _ -> { subst with binderlists = List.flatten v :: subst.binderlists } | TTBigint -> begin match forpat with - | ForConstr -> push_constr subst (CAst.make @@ CPrim (Numeral (NumTok.Signed.of_int_string v))) - | ForPattern -> push_constr subst (CAst.make @@ CPatPrim (Numeral (NumTok.Signed.of_int_string v))) + | ForConstr -> push_constr subst (CAst.make @@ CPrim (Number (NumTok.Signed.of_int_string v))) + | ForPattern -> push_constr subst (CAst.make @@ CPatPrim (Number (NumTok.Signed.of_int_string v))) end | TTReference -> begin match forpat with 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 dfc7b05b51..1aff76114b 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -48,7 +48,7 @@ let assumption_token = Entry.create "assumption_token" let def_body = Entry.create "def_body" let decl_notations = Entry.create "decl_notations" let record_field = Entry.create "record_field" -let of_type_with_opt_coercion = Entry.create "of_type_with_opt_coercion" +let of_type = Entry.create "of_type" let section_subset_expr = Entry.create "section_subset_expr" let scope_delimiter = Entry.create "scope_delimiter" let syntax_modifiers = Entry.create "syntax_modifiers" @@ -113,10 +113,12 @@ GRAMMAR EXTEND Gram ] ; attribute: - [ [ k = ident ; v = attribute_value -> { Names.Id.to_string k, v } ] + [ [ k = ident ; v = attr_value -> { Names.Id.to_string k, v } + (* Required because "ident" is declared a keyword when loading Ltac. *) + | IDENT "using" ; v = attr_value -> { "using", v } ] ] ; - attribute_value: + attr_value: [ [ "=" ; v = string -> { VernacFlagLeaf v } | "(" ; a = attribute_list ; ")" -> { VernacFlagList a } | -> { VernacFlagEmpty } ] @@ -192,12 +194,18 @@ 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 *) GRAMMAR EXTEND Gram - GLOBAL: gallina gallina_ext thm_token def_token assumption_token def_body of_type_with_opt_coercion - record_field decl_notations rec_definition ident_decl univ_decl; + GLOBAL: gallina gallina_ext thm_token def_token assumption_token def_body of_type + record_field decl_notations fix_definition ident_decl univ_decl; gallina: (* Definition, Theorem, Variable, Axiom, ... *) @@ -219,13 +227,13 @@ GRAMMAR EXTEND Gram (* Gallina inductive declarations *) | f = finite_token; indl = LIST1 inductive_definition SEP "with" -> { VernacInductive (f, indl) } - | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> + | "Fixpoint"; recs = LIST1 fix_definition SEP "with" -> { VernacFixpoint (NoDischarge, recs) } - | IDENT "Let"; "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> + | IDENT "Let"; "Fixpoint"; recs = LIST1 fix_definition SEP "with" -> { VernacFixpoint (DoDischarge, recs) } - | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> + | "CoFixpoint"; corecs = LIST1 cofix_definition SEP "with" -> { VernacCoFixpoint (NoDischarge, corecs) } - | IDENT "Let"; "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> + | IDENT "Let"; "CoFixpoint"; corecs = LIST1 cofix_definition SEP "with" -> { VernacCoFixpoint (DoDischarge, corecs) } | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> { VernacScheme l } | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from"; @@ -281,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) } @@ -294,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 } @@ -339,17 +377,17 @@ GRAMMAR EXTEND Gram ; (* Inductives and records *) opt_constructors_or_fields: - [ [ ":="; lc = constructor_list_or_record_decl -> { lc } + [ [ ":="; lc = constructors_or_record -> { lc } | -> { 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 -> { (((oc,id),(indpar,extrapar),c,lc),ntn) } ] ] ; - constructor_list_or_record_decl: + constructors_or_record: [ [ "|"; l = LIST1 constructor SEP "|" -> { Constructors l } | id = identref ; c = constructor_type; "|"; l = LIST1 constructor SEP "|" -> { Constructors ((c id)::l) } @@ -369,7 +407,7 @@ GRAMMAR EXTEND Gram | -> { false } ] ] ; (* (co)-fixpoints *) - rec_definition: + fix_definition: [ [ id_decl = ident_decl; bl = binders_fixannot; rtype = type_cstr; @@ -378,7 +416,7 @@ GRAMMAR EXTEND Gram {fname = fst id_decl; univs = snd id_decl; rec_order; binders; rtype; body_def; notations} } ] ] ; - corec_definition: + cofix_definition: [ [ id_decl = ident_decl; binders = binders; rtype = type_cstr; body_def = OPT [":="; def = lconstr -> { def }]; notations = decl_notations -> { {fname = fst id_decl; univs = snd id_decl; rec_order = (); binders; rtype; body_def; notations} @@ -427,10 +465,10 @@ GRAMMAR EXTEND Gram | -> { [] } ] ] ; - record_binder_body: - [ [ l = binders; oc = of_type_with_opt_coercion; + field_body: + [ [ l = binders; oc = of_type; t = lconstr -> { fun id -> (oc,AssumExpr (id,l,t)) } - | l = binders; oc = of_type_with_opt_coercion; + | l = binders; oc = of_type; t = lconstr; ":="; b = lconstr -> { fun id -> (oc,DefExpr (id,l,b,Some t)) } | l = binders; ":="; b = lconstr -> { fun id -> @@ -442,22 +480,22 @@ GRAMMAR EXTEND Gram ; record_binder: [ [ id = name -> { (NoInstance,AssumExpr(id, [], CAst.make ~loc @@ CHole (None, IntroAnonymous, None))) } - | id = name; f = record_binder_body -> { f id } ] ] + | id = name; f = field_body -> { f id } ] ] ; assum_list: - [ [ bl = LIST1 assum_coe -> { bl } | b = simple_assum_coe -> { [b] } ] ] + [ [ bl = LIST1 assum_coe -> { bl } | b = assumpt -> { [b] } ] ] ; assum_coe: - [ [ "("; a = simple_assum_coe; ")" -> { a } ] ] + [ [ "("; a = assumpt; ")" -> { a } ] ] ; - simple_assum_coe: - [ [ idl = LIST1 ident_decl; oc = of_type_with_opt_coercion; c = lconstr -> + assumpt: + [ [ idl = LIST1 ident_decl; oc = of_type; c = lconstr -> { (oc <> NoInstance,(idl,c)) } ] ] ; constructor_type: [[ l = binders; - t= [ coe = of_type_with_opt_coercion; c = lconstr -> + t= [ coe = of_type; c = lconstr -> { fun l id -> (coe <> NoInstance,(id,mkProdCN ~loc l c)) } | -> { fun l id -> (false,(id,mkProdCN ~loc l (CAst.make ~loc @@ CHole (None, IntroAnonymous, None)))) } ] @@ -468,7 +506,7 @@ GRAMMAR EXTEND Gram constructor: [ [ id = identref; c=constructor_type -> { c id } ] ] ; - of_type_with_opt_coercion: + of_type: [ [ ":>" -> { BackInstance } | ":"; ">" -> { BackInstance } | ":" -> { NoInstance } ] ] @@ -687,7 +725,7 @@ GRAMMAR EXTEND Gram { VernacContext (List.flatten c) } | IDENT "Instance"; namesup = instance_name; ":"; - t = operconstr LEVEL "200"; + t = term LEVEL "200"; info = hint_info ; props = [ ":="; "{"; r = record_declaration; "}" -> { Some (true,r) } | ":="; c = lconstr -> { Some (false,c) } | -> { None } ] -> @@ -707,13 +745,13 @@ GRAMMAR EXTEND Gram (* Arguments *) | IDENT "Arguments"; qid = smart_global; - args = LIST0 argument_spec_block; + args = LIST0 arg_specs; more_implicits = OPT [ ","; impl = LIST1 - [ impl = LIST0 more_implicits_block -> { List.flatten impl } ] + [ impl = LIST0 implicits_alt -> { List.flatten impl } ] SEP "," -> { impl } ]; - mods = OPT [ ":"; l = LIST1 arguments_modifier SEP "," -> { l } ] -> + mods = OPT [ ":"; l = LIST1 args_modifier SEP "," -> { l } ] -> { let mods = match mods with None -> [] | Some l -> List.flatten l in let more_implicits = Option.default [] more_implicits in VernacArguments (qid, List.flatten args, more_implicits, mods) } @@ -732,7 +770,7 @@ GRAMMAR EXTEND Gram idl = LIST1 identref -> { Some idl } ] -> { VernacGeneralizable gen } ] ] ; - arguments_modifier: + args_modifier: [ [ IDENT "simpl"; IDENT "nomatch" -> { [`ReductionDontExposeCase] } | IDENT "simpl"; IDENT "never" -> { [`ReductionNeverUnfold] } | IDENT "default"; IDENT "implicits" -> { [`DefaultImplicits] } @@ -757,7 +795,7 @@ GRAMMAR EXTEND Gram ] ]; (* List of arguments implicit status, scope, modifiers *) - argument_spec_block: [ + arg_specs: [ [ item = argument_spec -> { let name, recarg_like, notation_scope = item in [RealArg { name=name; recarg_like=recarg_like; @@ -791,8 +829,8 @@ GRAMMAR EXTEND Gram implicit_status = MaxImplicit}) items } ] ]; - (* Same as [argument_spec_block], but with only implicit status and names *) - more_implicits_block: [ + (* Same as [arg_specs], but with only implicit status and names *) + implicits_alt: [ [ name = name -> { [(name.CAst.v, Explicit)] } | "["; items = LIST1 name; "]" -> { List.map (fun name -> (name.CAst.v, NonMaxImplicit)) items } @@ -826,9 +864,9 @@ GRAMMAR EXTEND Gram GLOBAL: command query_command class_rawexpr gallina_ext search_query search_queries; gallina_ext: - [ [ IDENT "Export"; "Set"; table = option_table; v = option_setting -> + [ [ IDENT "Export"; "Set"; table = setting_name; v = option_setting -> { VernacSetOption (true, table, v) } - | IDENT "Export"; IDENT "Unset"; table = option_table -> + | IDENT "Export"; IDENT "Unset"; table = setting_name -> { VernacSetOption (true, table, OptionUnset) } ] ]; @@ -837,7 +875,7 @@ GRAMMAR EXTEND Gram (* Hack! Should be in grammar_ext, but camlp5 factorizes badly *) | IDENT "Declare"; IDENT "Instance"; id = ident_decl; bl = binders; ":"; - t = operconstr LEVEL "200"; + t = term LEVEL "200"; info = hint_info -> { VernacDeclareInstance (id, bl, t, info) } @@ -885,12 +923,12 @@ GRAMMAR EXTEND Gram { VernacAddMLPath dir } (* For acting on parameter tables *) - | "Set"; table = option_table; v = option_setting -> + | "Set"; table = setting_name; v = option_setting -> { VernacSetOption (false, table, v) } - | IDENT "Unset"; table = option_table -> + | IDENT "Unset"; table = setting_name -> { VernacSetOption (false, table, OptionUnset) } - | IDENT "Print"; IDENT "Table"; table = option_table -> + | IDENT "Print"; IDENT "Table"; table = setting_name -> { VernacPrintOption table } | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 table_value @@ -902,9 +940,9 @@ GRAMMAR EXTEND Gram | IDENT "Add"; table = IDENT; v = LIST1 table_value -> { VernacAddOption ([table], v) } - | IDENT "Test"; table = option_table; "for"; v = LIST1 table_value + | IDENT "Test"; table = setting_name; "for"; v = LIST1 table_value -> { VernacMemOption (table, v) } - | IDENT "Test"; table = option_table -> + | IDENT "Test"; table = setting_name -> { VernacPrintOption table } | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 table_value @@ -1006,7 +1044,7 @@ GRAMMAR EXTEND Gram [ [ id = global -> { Goptions.QualidRefValue id } | s = STRING -> { Goptions.StringRefValue s } ] ] ; - option_table: + setting_name: [ [ fl = LIST1 [ x = IDENT -> { x } ] -> { fl } ]] ; ne_in_or_out_modules: @@ -1191,10 +1229,10 @@ GRAMMAR EXTEND Gram | s, None -> SetFormat ("text",s) end } | x = IDENT; ","; l = LIST1 [id = IDENT -> { id } ] SEP ","; "at"; lev = level -> { SetItemLevel (x::l,None,lev) } - | x = IDENT; "at"; lev = level; b = OPT constr_as_binder_kind -> + | x = IDENT; "at"; lev = level; b = OPT binder_interp -> { SetItemLevel ([x],b,lev) } - | x = IDENT; b = constr_as_binder_kind -> { SetItemLevel ([x],Some b,DefaultLevel) } - | x = IDENT; typ = syntax_extension_type -> { SetEntryType (x,typ) } + | x = IDENT; b = binder_interp -> { SetItemLevel ([x],Some b,DefaultLevel) } + | x = IDENT; typ = explicit_subentry -> { SetEntryType (x,typ) } ] ] ; syntax_modifiers: @@ -1202,18 +1240,18 @@ GRAMMAR EXTEND Gram | -> { [] } ] ] ; - syntax_extension_type: + explicit_subentry: [ [ IDENT "ident" -> { ETIdent } | IDENT "global" -> { ETGlobal } | IDENT "bigint" -> { ETBigint } | IDENT "binder" -> { ETBinder true } | IDENT "constr" -> { ETConstr (InConstrEntry,None,DefaultLevel) } - | IDENT "constr"; n = at_level_opt; b = OPT constr_as_binder_kind -> { ETConstr (InConstrEntry,b,n) } + | IDENT "constr"; n = at_level_opt; b = OPT binder_interp -> { ETConstr (InConstrEntry,b,n) } | IDENT "pattern" -> { ETPattern (false,None) } | IDENT "pattern"; "at"; IDENT "level"; n = natural -> { ETPattern (false,Some n) } | IDENT "strict"; IDENT "pattern" -> { ETPattern (true,None) } | IDENT "strict"; IDENT "pattern"; "at"; IDENT "level"; n = natural -> { ETPattern (true,Some n) } | IDENT "closed"; IDENT "binder" -> { ETBinder false } - | IDENT "custom"; x = IDENT; n = at_level_opt; b = OPT constr_as_binder_kind -> + | IDENT "custom"; x = IDENT; n = at_level_opt; b = OPT binder_interp -> { ETConstr (InCustomEntry x,b,n) } ] ] ; @@ -1221,7 +1259,7 @@ GRAMMAR EXTEND Gram [ [ "at"; n = level -> { n } | -> { DefaultLevel } ] ] ; - constr_as_binder_kind: + binder_interp: [ [ "as"; IDENT "ident" -> { Notation_term.AsIdent } | "as"; IDENT "pattern" -> { Notation_term.AsIdentOrPattern } | "as"; IDENT "strict"; IDENT "pattern" -> { Notation_term.AsStrictPattern } ] ] diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 5f7eb78a40..9d86ea90e6 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -656,7 +656,7 @@ let explain_evar_not_found env sigma id = let explain_wrong_case_info env (ind,u) ci = let pi = pr_inductive env ind in - if eq_ind ci.ci_ind ind then + if Ind.CanOrd.equal ci.ci_ind ind then str "Pattern-matching expression on an object of inductive type" ++ spc () ++ pi ++ spc () ++ str "has invalid information." else @@ -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 @@ -1232,7 +1238,7 @@ let error_not_allowed_dependent_analysis env isrec i = pr_inductive env i ++ str "." let error_not_mutual_in_scheme env ind ind' = - if eq_ind ind ind' then + if Ind.CanOrd.equal ind ind' then str "The inductive type " ++ pr_inductive env ind ++ str " occurs twice." else diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 356ccef06b..de72a30f18 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -405,7 +405,7 @@ let do_mutual_induction_scheme ?(force_mutual=false) lnamedepindsort = let get_common_underlying_mutual_inductive env = function | [] -> assert false | (id,(mind,i as ind))::l as all -> - match List.filter (fun (_,(mind',_)) -> not (MutInd.equal mind mind')) l with + match List.filter (fun (_,(mind',_)) -> not (Environ.QMutInd.equal env mind mind')) l with | (_,ind')::_ -> raise (RecursionSchemeError (env, NotMutualInScheme (ind,ind'))) | [] -> diff --git a/vernac/library.ml b/vernac/library.ml index e580927bfd..8a9b1fd68d 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -160,7 +160,7 @@ let register_loaded_library m = let prefix = Nativecode.mod_uid_of_dirpath libname ^ "." in let f = prefix ^ "cmo" in let f = Dynlink.adapt_filename f in - Nativelib.link_library (Global.env()) ~prefix ~dirname ~basename:f + Nativelib.link_library ~prefix ~dirname ~basename:f in let rec aux = function | [] -> @@ -502,7 +502,7 @@ let save_library_to todo_proofs ~output_native_objects dir f otab = (* Writing native code files *) if output_native_objects then let fn = Filename.dirname f ^"/"^ Nativecode.mod_uid_of_dirpath dir in - Nativelib.compile_library dir ast fn + Nativelib.compile_library ast fn let save_library_raw f sum lib univs proofs = save_library_base f sum lib (Some univs) None proofs diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 8ce59c40c3..dc2b2e889e 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -61,15 +61,15 @@ let pr_registered_grammar name = prlist pr_one entries let pr_grammar = function - | "constr" | "operconstr" | "binder_constr" -> + | "constr" | "term" | "binder_constr" -> str "Entry constr is" ++ fnl () ++ pr_entry Pcoq.Constr.constr ++ str "and lconstr is" ++ fnl () ++ pr_entry Pcoq.Constr.lconstr ++ str "where binder_constr is" ++ fnl () ++ pr_entry Pcoq.Constr.binder_constr ++ - str "and operconstr is" ++ fnl () ++ - pr_entry Pcoq.Constr.operconstr + str "and term is" ++ fnl () ++ + pr_entry Pcoq.Constr.term | "pattern" -> pr_entry Pcoq.Constr.pattern | "vernac" -> @@ -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" @@ -1042,6 +988,13 @@ let interp_non_syntax_modifiers mods = in List.fold_left (fun st modif -> Option.bind st @@ set modif) (Some (false,false,InConstrEntry)) mods +(* Check if an interpretation can be used for printing a cases printing *) +let has_no_binders_type = + List.for_all (fun (_,(_,typ)) -> + match typ with + | NtnTypeBinder _ | NtnTypeBinderList -> false + | NtnTypeConstr | NtnTypeConstrList -> true) + (* Compute precedences from modifiers (or find default ones) *) let set_entry_type from n etyps (x,typ) = @@ -1226,6 +1179,9 @@ let find_precedence custom lev etyps symbols onlyprint = | _ -> user_err Pp.(str "A notation starting with an atomic expression must be at level 0.") end + | (ETPattern _ | ETBinder _), InConstrEntry when not onlyprint -> + (* Don't know exactly if we can make sense of this case *) + user_err Pp.(str "Binders or patterns not supported in leftmost position.") | (ETPattern _ | ETBinder _ | ETConstr _), _ -> (* Give a default ? *) if Option.is_empty lev then @@ -1416,6 +1372,7 @@ type notation_obj = { notobj_deprecation : Deprecation.t option; notobj_notation : notation * notation_location; notobj_specific_pp_rules : syntax_printing_extension option; + notobj_also_in_cases_pattern : bool; } let load_notation_common silently_define_scope_if_undefined _ (_, nobj) = @@ -1438,9 +1395,10 @@ let open_notation i (_, nobj) = let pat = nobj.notobj_interp in let deprecation = nobj.notobj_deprecation in let scope = match scope with None -> LastLonelyNotation | Some sc -> NotationInScope sc in + let also_in_cases_pattern = nobj.notobj_also_in_cases_pattern in (* Declare the notation *) (match nobj.notobj_use with - | Some use -> Notation.declare_notation (scope,ntn) pat df ~use nobj.notobj_coercion deprecation + | Some use -> Notation.declare_notation (scope,ntn) pat df ~use ~also_in_cases_pattern nobj.notobj_coercion deprecation | None -> ()); (* Declare specific format if any *) (match nobj.notobj_specific_pp_rules with @@ -1621,19 +1579,21 @@ let add_notation_in_scope ~local deprecation df env c mods scope = let (acvars, ac, reversibility) = interp_notation_constr env nenv c in let interp = make_interpretation_vars sd.recvars (pi2 sd.level) acvars (fst sd.pa_syntax_data) in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in + let vars = List.map_filter map i_vars in (* Order of elements is important here! *) + let also_in_cases_pattern = has_no_binders_type vars in let onlyparse,coe = printability (Some sd.level) sd.subentries sd.only_parsing reversibility ac in let notation, location = sd.info in let use = make_use true onlyparse sd.only_printing in let notation = { notobj_local = local; notobj_scope = scope; - notobj_interp = (List.map_filter map i_vars, ac); - (* Order is important here! *) notobj_use = use; + notobj_interp = (vars, ac); notobj_coercion = coe; notobj_deprecation = sd.deprecation; notobj_notation = (notation, location); notobj_specific_pp_rules = sy_pp_rules; + notobj_also_in_cases_pattern = also_in_cases_pattern; } in (* Ready to change the global state *) List.iter (fun f -> f ()) sd.msgs; @@ -1665,18 +1625,20 @@ let add_notation_interpretation_core ~local df env ?(impls=empty_internalization let plevel = match level with Some (from,level,l) -> level | None (* numeral: irrelevant )*) -> 0 in let interp = make_interpretation_vars recvars plevel acvars (List.combine mainvars i_typs) in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in + let vars = List.map_filter map i_vars in (* Order of elements is important here! *) + let also_in_cases_pattern = has_no_binders_type vars in let onlyparse,coe = printability level i_typs onlyparse reversibility ac in let use = make_use false onlyparse onlyprint in let notation = { notobj_local = local; notobj_scope = scope; - notobj_interp = (List.map_filter map i_vars, ac); - (* Order is important here! *) notobj_use = use; + notobj_interp = (vars, ac); notobj_coercion = coe; notobj_deprecation = deprecation; notobj_notation = df'; notobj_specific_pp_rules = pp_sy; + notobj_also_in_cases_pattern = also_in_cases_pattern; } in Lib.add_anonymous_leaf (inNotation notation); df' @@ -1850,8 +1812,9 @@ let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing let in_pat id = (id,ETConstr (Constrexpr.InConstrEntry,None,(NextLevel,InternalProd))) in let interp = make_interpretation_vars ~default_if_binding:AsIdentOrPattern [] 0 acvars (List.map in_pat vars) in let vars = List.map (fun x -> (x, Id.Map.find x interp)) vars in + let also_in_cases_pattern = has_no_binders_type vars in let onlyparsing = onlyparsing || fst (printability None [] false reversibility pat) in - Syntax_def.declare_syntactic_definition ~local deprecation ident ~onlyparsing (vars,pat) + Syntax_def.declare_syntactic_definition ~local ~also_in_cases_pattern deprecation ident ~onlyparsing (vars,pat) (**********************************************************************) (* Declaration of custom entry *) 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/proof_using.ml b/vernac/proof_using.ml index 95680c2a4e..bdb0cabacf 100644 --- a/vernac/proof_using.ml +++ b/vernac/proof_using.ml @@ -18,30 +18,30 @@ module NamedDecl = Context.Named.Declaration let known_names = Summary.ref [] ~name:"proofusing-nameset" -let rec close_fwd e s = +let rec close_fwd env sigma s = let s' = List.fold_left (fun s decl -> let vb = match decl with | LocalAssum _ -> Id.Set.empty - | LocalDef (_,b,_) -> global_vars_set e b + | LocalDef (_,b,_) -> Termops.global_vars_set env sigma b in - let vty = global_vars_set e (NamedDecl.get_type decl) in + let vty = Termops.global_vars_set env sigma (NamedDecl.get_type decl) in let vbty = Id.Set.union vb vty in if Id.Set.exists (fun v -> Id.Set.mem v s) vbty then Id.Set.add (NamedDecl.get_id decl) (Id.Set.union s vbty) else s) - s (named_context e) + s (EConstr.named_context env) in - if Id.Set.equal s s' then s else close_fwd e s' + if Id.Set.equal s s' then s else close_fwd env sigma s' -let set_of_type env ty = +let set_of_type env sigma ty = List.fold_left (fun acc ty -> - Id.Set.union (global_vars_set env ty) acc) + Id.Set.union (Termops.global_vars_set env sigma ty) acc) Id.Set.empty ty let full_set env = List.fold_right Id.Set.add (List.map NamedDecl.get_id (named_context env)) Id.Set.empty -let process_expr env e v_ty = +let process_expr env sigma e v_ty = let rec aux = function | SsEmpty -> Id.Set.empty | SsType -> v_ty @@ -49,7 +49,7 @@ let process_expr env e v_ty = | SsUnion(e1,e2) -> Id.Set.union (aux e1) (aux e2) | SsSubstr(e1,e2) -> Id.Set.diff (aux e1) (aux e2) | SsCompl e -> Id.Set.diff (full_set env) (aux e) - | SsFwdClose e -> close_fwd env (aux e) + | SsFwdClose e -> close_fwd env sigma (aux e) and set_of_id id = if Id.to_string id = "All" then full_set env @@ -59,9 +59,9 @@ let process_expr env e v_ty = in aux e -let process_expr env e ty = - let v_ty = set_of_type env ty in - let s = Id.Set.union v_ty (process_expr env e v_ty) in +let process_expr env sigma e ty = + let v_ty = set_of_type env sigma ty in + let s = Id.Set.union v_ty (process_expr env sigma e v_ty) in Id.Set.elements s let name_set id expr = known_names := (id,expr) :: !known_names @@ -110,7 +110,7 @@ let suggest_common env ppid used ids_typ skip = S.empty (named_context env) in let all = S.diff all skip in - let fwd_typ = close_fwd env ids_typ in + let fwd_typ = close_fwd env (Evd.from_env env) ids_typ in if !Flags.debug then begin print (str "All " ++ pr_set false all); print (str "Type " ++ pr_set false ids_typ); diff --git a/vernac/proof_using.mli b/vernac/proof_using.mli index dfc233e8fa..93dbd33ae4 100644 --- a/vernac/proof_using.mli +++ b/vernac/proof_using.mli @@ -11,7 +11,8 @@ (** Utility code for section variables handling in Proof using... *) val process_expr : - Environ.env -> Vernacexpr.section_subset_expr -> Constr.types list -> + Environ.env -> Evd.evar_map -> + Vernacexpr.section_subset_expr -> EConstr.types list -> Names.Id.t list val name_set : Names.Id.t -> Vernacexpr.section_subset_expr -> unit @@ -24,3 +25,5 @@ val get_default_proof_using : unit -> Vernacexpr.section_subset_expr option val proof_using_opt_name : string list (** For the stm *) + +val using_from_string : string -> Vernacexpr.section_subset_expr diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index c9f68eed57..a7de34dd09 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -43,7 +43,8 @@ module Vernac_ = let command = Entry.create "command" let syntax = Entry.create "syntax_command" let vernac_control = Entry.create "Vernac.vernac_control" - let rec_definition = Entry.create "Vernac.rec_definition" + let fix_definition = Entry.create "Vernac.fix_definition" + let rec_definition = fix_definition let red_expr = Entry.create "red_expr" let hint_info = Entry.create "hint_info" (* Main vernac entry *) diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index 8ab4af7d48..dac6877cb3 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -25,7 +25,9 @@ module Vernac_ : val command : vernac_expr Entry.t val syntax : vernac_expr Entry.t val vernac_control : vernac_control Entry.t + val fix_definition : fixpoint_expr Entry.t val rec_definition : fixpoint_expr Entry.t + [@@deprecated "Deprecated in 8.13; use 'fix_definition' instead"] val noedit_mode : vernac_expr Entry.t val command_entry : vernac_expr Entry.t val main_entry : vernac_control option Entry.t diff --git a/vernac/recLemmas.ml b/vernac/recLemmas.ml index 534c358a3f..af72c01758 100644 --- a/vernac/recLemmas.ml +++ b/vernac/recLemmas.ml @@ -44,7 +44,7 @@ let find_mutually_recursive_statements sigma thms = [] in ind_hyps,ind_ccl) thms in let inds_hyps,ind_ccls = List.split inds in - let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> Names.MutInd.equal kn kn' in + let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> Environ.QMutInd.equal (Global.env ()) kn kn' in (* Check if all conclusions are coinductive in the same type *) (* (degenerated cartesian product since there is at most one coind ccl) *) let same_indccl = @@ -70,7 +70,7 @@ let find_mutually_recursive_statements sigma thms = | [], _::_ -> let () = match same_indccl with | ind :: _ -> - if List.distinct_f Names.ind_ord (List.map pi1 ind) + if List.distinct_f Names.Ind.CanOrd.compare (List.map pi1 ind) then Flags.if_verbose Feedback.msg_info (Pp.strbrk 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/search.ml b/vernac/search.ml index abefeab779..501e5b1a91 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -216,18 +216,16 @@ let name_of_reference ref = Id.to_string (Nametab.basename_of_global ref) let search_filter query gr kind env sigma typ = match query with | GlobSearchSubPattern (where,head,pat) -> let open Context.Rel.Declaration in - let collect_hyps ctx = - List.fold_left (fun acc d -> match get_value d with - | None -> get_type d :: acc - | Some b -> b :: get_type d :: acc) [] ctx in + let rec collect env hyps typ = + match Constr.kind typ with + | LetIn (na,b,t,c) -> collect (push_rel (LocalDef (na,b,t)) env) ((env,b) :: (env,t) :: hyps) c + | Prod (na,t,c) -> collect (push_rel (LocalAssum (na,t)) env) ((env,t) :: hyps) c + | _ -> (hyps,(env,typ)) in let typl= match where with - | InHyp -> collect_hyps (fst (Term.decompose_prod_assum typ)) - | InConcl -> [snd (Term.decompose_prod_assum typ)] - | Anywhere -> - if head then - let ctx, ccl = Term.decompose_prod_assum typ in ccl :: collect_hyps ctx - else [typ] in - List.exists (fun typ -> + | InHyp -> fst (collect env [] typ) + | InConcl -> [snd (collect env [] typ)] + | Anywhere -> if head then let hyps, ccl = collect env [] typ in ccl :: hyps else [env,typ] in + List.exists (fun (env,typ) -> let f = if head then Constr_matching.is_matching_head else Constr_matching.is_matching_appsubterm ~closed:false in diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 3ced38d6ea..4e52af7959 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -57,14 +57,16 @@ module DefAttributes = struct program : bool; deprecated : Deprecation.t option; canonical_instance : bool; + using : Vernacexpr.section_subset_expr option; } let parse f = let open Attributes in - let (((locality, deprecated), polymorphic), program), canonical_instance = - parse Notations.(locality ++ deprecation ++ polymorphic ++ program ++ canonical_instance) f + let ((((locality, deprecated), polymorphic), program), canonical_instance), using = + parse Notations.(locality ++ deprecation ++ polymorphic ++ program ++ canonical_instance ++ using) f in - { polymorphic; program; locality; deprecated; canonical_instance } + let using = Option.map Proof_using.using_from_string using in + { polymorphic; program; locality; deprecated; canonical_instance; using } end let module_locality = Attributes.Notations.(locality >>= fun l -> return (make_module_locality l)) @@ -496,6 +498,25 @@ let program_inference_hook env sigma ev = user_err Pp.(str "The statement obligations could not be resolved \ automatically, write a statement definition first.") +let vernac_set_used_variables ~pstate e : Declare.Proof.t = + let env = Global.env () in + let sigma, _ = Declare.Proof.get_current_context pstate in + let initial_goals pf = Proofview.initial_goals Proof.((data pf).entry) in + let tys = List.map snd (initial_goals (Declare.Proof.get pstate)) in + let l = Proof_using.process_expr env sigma e tys in + let vars = Environ.named_context env in + List.iter (fun id -> + if not (List.exists (NamedDecl.get_id %> Id.equal id) vars) then + user_err ~hdr:"vernac_set_used_variables" + (str "Unknown variable: " ++ Id.print id)) + l; + let _, pstate = Declare.Proof.set_used_variables pstate l in + pstate +let vernac_set_used_variables_opt ?using pstate = + match using with + | None -> pstate + | Some expr -> vernac_set_used_variables ~pstate expr + (* XXX: Interpretation of lemma command, duplication with ComFixpoint / ComDefinition ? *) let interp_lemma ~program_mode ~flags ~scope env0 evd thms = @@ -525,25 +546,28 @@ let post_check_evd ~udecl ~poly evd = else (* We fix the variables to ensure they won't be lowered to Set *) Evd.fix_undefined_variables evd -let start_lemma_com ~program_mode ~poly ~scope ~kind ?hook thms = +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 - match mut_analysis with - | RecLemmas.NonMutual thm -> - let thm = Declare.CInfo.to_constr evd thm in - let evd = post_check_evd ~udecl ~poly evd in - let info = Declare.Info.make ?hook ~poly ~scope ~kind ~udecl () in - Declare.Proof.start_with_initialization ~info ~cinfo:thm evd - | RecLemmas.Mutual { mutual_info; cinfo ; possible_guards } -> - let cinfo = List.map (Declare.CInfo.to_constr evd) cinfo in - let evd = post_check_evd ~udecl ~poly evd in - let info = Declare.Info.make ?hook ~poly ~scope ~kind ~udecl () in - Declare.Proof.start_mutual_with_initialization ~info ~cinfo evd ~mutual_info (Some possible_guards) + let pstate = + match mut_analysis with + | RecLemmas.NonMutual thm -> + let thm = Declare.CInfo.to_constr evd thm in + let evd = post_check_evd ~udecl ~poly evd in + let info = Declare.Info.make ?hook ~poly ~scope ~kind ~udecl () in + Declare.Proof.start_with_initialization ~info ~cinfo:thm evd + | RecLemmas.Mutual { mutual_info; cinfo ; possible_guards } -> + let cinfo = List.map (Declare.CInfo.to_constr evd) cinfo in + let evd = post_check_evd ~udecl ~poly evd in + let info = Declare.Info.make ?hook ~poly ~scope ~kind ~udecl () in + Declare.Proof.start_mutual_with_initialization ~info ~cinfo evd ~mutual_info (Some possible_guards) + in + vernac_set_used_variables_opt ?using pstate let vernac_definition_hook ~canonical_instance ~local ~poly = let open Decls in function | Coercion -> @@ -583,7 +607,7 @@ let vernac_definition_interactive ~atts (discharge, kind) (lid, pl) bl t = let program_mode = atts.program in let poly = atts.polymorphic in let name = vernac_definition_name lid local in - start_lemma_com ~program_mode ~poly ~scope:local ~kind:(Decls.IsDefinition kind) ?hook [(name, pl), (bl, t)] + start_lemma_com ~program_mode ~poly ~scope:local ~kind:(Decls.IsDefinition kind) ?using:atts.using ?hook [(name, pl), (bl, t)] let vernac_definition ~atts ~pm (discharge, kind) (lid, pl) bl red_option c typ_opt = let open DefAttributes in @@ -604,7 +628,7 @@ let vernac_definition ~atts ~pm (discharge, kind) (lid, pl) bl red_option c typ_ else let () = ComDefinition.do_definition ~name:name.v - ~poly:atts.polymorphic ~scope ~kind pl bl red_option c typ_opt ?hook in + ~poly:atts.polymorphic ~scope ~kind ?using:atts.using pl bl red_option c typ_opt ?hook in pm (* NB: pstate argument to use combinators easily *) @@ -613,7 +637,7 @@ let vernac_start_proof ~atts kind l = let scope = enforce_locality_exp atts.locality NoDischarge in if Dumpglob.dump () then List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; - start_lemma_com ~program_mode:atts.program ~poly:atts.polymorphic ~scope ~kind:(Decls.IsProof kind) l + start_lemma_com ~program_mode:atts.program ~poly:atts.polymorphic ~scope ~kind:(Decls.IsProof kind) ?using:atts.using l let vernac_end_proof ~lemma ~pm = let open Vernacexpr in function | Admitted -> @@ -639,6 +663,8 @@ let vernac_assumption ~atts discharge kind l nl = match scope with | Global _ -> Dumpglob.dump_definition lid false "ax" | Discharge -> Dumpglob.dump_definition lid true "var") idl) l; + if Option.has_some atts.using then + Attributes.unsupported_attributes ["using",VernacFlagEmpty]; ComAssumption.do_assumptions ~poly:atts.polymorphic ~program_mode:atts.program ~scope ~kind nl l let is_polymorphic_inductive_cumulativity = @@ -689,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" @@ -706,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) @@ -842,16 +868,17 @@ let vernac_fixpoint_interactive ~atts discharge l = let scope = vernac_fixpoint_common ~atts discharge l in if atts.program then CErrors.user_err Pp.(str"Program Fixpoint requires a body"); - ComFixpoint.do_fixpoint_interactive ~scope ~poly:atts.polymorphic l + vernac_set_used_variables_opt ?using:atts.using + (ComFixpoint.do_fixpoint_interactive ~scope ~poly:atts.polymorphic l) let vernac_fixpoint ~atts ~pm discharge l = let open DefAttributes in let scope = vernac_fixpoint_common ~atts discharge l in if atts.program then (* XXX: Switch to the attribute system and match on ~atts *) - ComProgramFixpoint.do_fixpoint ~pm ~scope ~poly:atts.polymorphic l + ComProgramFixpoint.do_fixpoint ~pm ~scope ~poly:atts.polymorphic ?using:atts.using l else - let () = ComFixpoint.do_fixpoint ~scope ~poly:atts.polymorphic l in + let () = ComFixpoint.do_fixpoint ~scope ~poly:atts.polymorphic ?using:atts.using l in pm let vernac_cofixpoint_common ~atts discharge l = @@ -864,15 +891,16 @@ let vernac_cofixpoint_interactive ~atts discharge l = let scope = vernac_cofixpoint_common ~atts discharge l in if atts.program then CErrors.user_err Pp.(str"Program CoFixpoint requires a body"); - ComFixpoint.do_cofixpoint_interactive ~scope ~poly:atts.polymorphic l + vernac_set_used_variables_opt ?using:atts.using + (ComFixpoint.do_cofixpoint_interactive ~scope ~poly:atts.polymorphic l) let vernac_cofixpoint ~atts ~pm discharge l = let open DefAttributes in let scope = vernac_cofixpoint_common ~atts discharge l in if atts.program then - ComProgramFixpoint.do_cofixpoint ~pm ~scope ~poly:atts.polymorphic l + ComProgramFixpoint.do_cofixpoint ~pm ~scope ~poly:atts.polymorphic ?using:atts.using l else - let () = ComFixpoint.do_cofixpoint ~scope ~poly:atts.polymorphic l in + let () = ComFixpoint.do_cofixpoint ~scope ~poly:atts.polymorphic ?using:atts.using l in pm let vernac_scheme l = @@ -957,9 +985,15 @@ let interp_filter_in m = function let vernac_import export refl = let import_mod (qid,f) = - let m = try Nametab.locate_module qid + let loc = qid.loc in + let m = try + let m = Nametab.locate_module qid in + let () = if Modops.is_functor (Global.lookup_module m).Declarations.mod_type + then CErrors.user_err ?loc Pp.(str "Cannot import functor " ++ pr_qualid qid ++ str".") + in + m with Not_found -> - CErrors.user_err Pp.(str "Cannot find module " ++ pr_qualid qid) + CErrors.user_err ?loc Pp.(str "Cannot find module " ++ pr_qualid qid) in let f = interp_filter_in m f in Declaremods.import_module f ~export m @@ -1223,21 +1257,6 @@ let vernac_set_end_tac ~pstate tac = (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) Declare.Proof.set_endline_tactic tac pstate -let vernac_set_used_variables ~pstate e : Declare.Proof.t = - let env = Global.env () in - let initial_goals pf = Proofview.initial_goals Proof.(data pf).Proof.entry in - let tys = List.map snd (initial_goals (Declare.Proof.get pstate)) in - let tys = List.map EConstr.Unsafe.to_constr tys in - let l = Proof_using.process_expr env e tys in - let vars = Environ.named_context env in - List.iter (fun id -> - if not (List.exists (NamedDecl.get_id %> Id.equal id) vars) then - user_err ~hdr:"vernac_set_used_variables" - (str "Unknown variable: " ++ Id.print id)) - l; - let _, pstate = Declare.Proof.set_used_variables pstate l in - pstate - (*****************************) (* Auxiliary file management *) @@ -1295,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 = @@ -1310,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 = @@ -2165,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 |
