diff options
154 files changed, 3534 insertions, 3218 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 7c9a5c9a31..ce0c1d9af7 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -2,10 +2,15 @@ image: "$IMAGE" stages: - docker - - build - - test + - stage-1 # No dependencies + - stage-2 # Only dependencies in stage 1 + - stage-3 # Only dependencies in stage 1 and 2 + - stage-4 # Only dependencies in stage 1, 2 and 3 - deploy +# When a job has no dependencies, it goes to stage 1. +# Otherwise, we set "needs" and "dependencies" to the same value. + # some default values variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here @@ -53,7 +58,7 @@ before_script: # TODO figure out how to build doc for installed Coq .build-template: - stage: build + stage: stage-1 artifacts: name: "$CI_JOB_NAME" paths: @@ -91,7 +96,7 @@ before_script: # Template for building Coq + stdlib, typical use: overload the switch .dune-template: - stage: build + stage: stage-1 dependencies: [] script: - set -e @@ -107,7 +112,9 @@ before_script: expire_in: 1 week .dune-ci-template: - stage: test + stage: stage-2 + needs: + - build:edge+flambda:dune:dev dependencies: - build:edge+flambda:dune:dev script: @@ -129,7 +136,7 @@ before_script: # overridden otherwise the CI will fail. .doc-template: - stage: test + stage: stage-2 dependencies: - not-a-real-job script: @@ -144,7 +151,7 @@ before_script: # set dependencies when using .test-suite-template: - stage: test + stage: stage-2 dependencies: - not-a-real-job script: @@ -167,7 +174,7 @@ before_script: # set dependencies when using .validate-template: - stage: test + stage: stage-2 dependencies: - not-a-real-job script: @@ -183,18 +190,22 @@ before_script: expire_in: 2 months .ci-template: - stage: test + stage: stage-2 script: - set -e - echo 'start:coq.test' - make -f Makefile.ci -j "$NJOBS" "${CI_JOB_NAME#*:}" - echo 'end:coq.test' - set +e + needs: + - build:base dependencies: - build:base .ci-template-flambda: extends: .ci-template + needs: + - build:edge+flambda dependencies: - build:edge+flambda variables: @@ -202,7 +213,7 @@ before_script: OPAM_VARIANT: "+flambda" .windows-template: - stage: test + stage: stage-1 artifacts: name: "%CI_JOB_NAME%" paths: @@ -261,7 +272,7 @@ build:edge+flambda:dune:dev: build:base+async: extends: .build-template - stage: test + stage: stage-1 variables: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" COQUSERFLAGS: "-async-proofs on" @@ -295,7 +306,7 @@ windows32: - /^pr-.*$/ lint: - stage: test + stage: stage-1 script: dev/lint-repository.sh dependencies: [] variables: @@ -303,7 +314,7 @@ lint: OPAM_SWITCH: base pkg:opam: - stage: test + stage: stage-1 # OPAM will build out-of-tree so no point in importing artifacts dependencies: [] script: @@ -320,7 +331,7 @@ pkg:opam: .nix-template: image: nixorg/nix:latest # Minimal NixOS image which doesn't even contain git - stage: test + stage: stage-1 variables: # By default we use coq.cachix.org as an extra substituter but this can be overridden EXTRA_SUBSTITUTERS: https://coq.cachix.org @@ -367,7 +378,8 @@ pkg:nix:deploy:channel: only: variables: - $CACHIX_DEPLOYMENT_KEY - dependencies: + dependencies: [] + needs: - pkg:nix:deploy script: - echo "$CACHIX_DEPLOYMENT_KEY" | tr -d '\r' | ssh-add - > /dev/null @@ -385,6 +397,8 @@ doc:refman: extends: .doc-template dependencies: - build:base + needs: + - build:base doc:refman:dune: extends: .dune-ci-template @@ -414,6 +428,10 @@ doc:refman:deploy: - doc:ml-api:odoc - doc:refman:dune - doc:stdlib:dune + needs: + - doc:ml-api:odoc + - doc:refman:dune + - doc:stdlib:dune script: - echo "$DOCUMENTATION_DEPLOY_KEY" | tr -d '\r' | ssh-add - > /dev/null - git clone git@github.com:coq/doc.git _deploy @@ -441,11 +459,15 @@ test-suite:base: extends: .test-suite-template dependencies: - build:base + needs: + - build:base test-suite:base+32bit: extends: .test-suite-template dependencies: - build:base+32bit + needs: + - build:base+32bit variables: OPAM_VARIANT: "+32bit" only: *full-ci @@ -454,15 +476,19 @@ test-suite:edge+flambda: extends: .test-suite-template dependencies: - build:edge+flambda + needs: + - build:edge+flambda variables: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" only: *full-ci test-suite:egde:dune:dev: - stage: test + stage: stage-2 dependencies: - build:edge+flambda:dune:dev + needs: + - build:edge+flambda:dune:dev script: make -f Makefile.dune test-suite variables: OPAM_SWITCH: edge @@ -476,7 +502,7 @@ test-suite:egde:dune:dev: # expire_in: never test-suite:edge+trunk+make: - stage: test + stage: stage-1 dependencies: [] script: - opam switch create 4.09.0 --empty @@ -503,7 +529,7 @@ test-suite:edge+trunk+make: only: *full-ci test-suite:edge+trunk+dune: - stage: test + stage: stage-1 dependencies: [] script: - opam switch create 4.09.0 --empty @@ -535,6 +561,8 @@ test-suite:base+async: extends: .test-suite-template dependencies: - build:base + needs: + - build:base variables: COQFLAGS: "-async-proofs on -async-proofs-cache force" timeout: "timeout 100m" @@ -547,11 +575,15 @@ validate:base: extends: .validate-template dependencies: - build:base + needs: + - build:base validate:base+32bit: extends: .validate-template dependencies: - build:base+32bit + needs: + - build:base+32bit variables: OPAM_VARIANT: "+32bit" only: *full-ci @@ -560,6 +592,8 @@ validate:edge+flambda: extends: .validate-template dependencies: - build:edge+flambda + needs: + - build:edge+flambda variables: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" @@ -569,6 +603,8 @@ validate:quick: extends: .validate-template dependencies: - build:quick + needs: + - build:quick only: variables: - $UNRELIABLE =~ /enabled/ @@ -584,6 +620,13 @@ library:ci-bedrock2: library:ci-color: extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - plugin:ci-bignums + dependencies: + - build:edge+flambda + - plugin:ci-bignums library:ci-compcert: extends: .ci-template-flambda @@ -608,6 +651,13 @@ library:ci-flocq: library:ci-corn: extends: .ci-template-flambda + stage: stage-4 + needs: + - build:edge+flambda + - library:ci-math-classes + dependencies: + - build:edge+flambda + - library:ci-math-classes library:ci-geocoq: extends: .ci-template-flambda @@ -618,6 +668,20 @@ library:ci-hott: library:ci-iris-lambda-rust: extends: .ci-template-flambda +library:ci-math-classes: + extends: .ci-template-flambda + stage: stage-3 + artifacts: + name: "$CI_JOB_NAME" + paths: + - _build_ci + needs: + - build:edge+flambda + - plugin:ci-bignums + dependencies: + - build:edge+flambda + - plugin:ci-bignums + library:ci-math-comp: extends: .ci-template-flambda @@ -642,7 +706,11 @@ plugin:ci-aac_tactics: extends: .ci-template plugin:ci-bignums: - extends: .ci-template + extends: .ci-template-flambda + artifacts: + name: "$CI_JOB_NAME" + paths: + - _build_ci plugin:ci-coq_dpdgraph: extends: .ci-template @@ -666,7 +734,7 @@ plugin:ci-paramcoq: extends: .ci-template plugin:plugin-tutorial: - stage: test + stage: stage-1 dependencies: [] script: - ./configure -local -warn-error yes @@ -108,7 +108,7 @@ GRAMMLFILES := $(addsuffix .ml, $(GRAMFILES)) $(addsuffix .mli, $(GRAMFILES)) GENGRAMFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) ide/coqide_os_specific.ml kernel/copcodes.ml kernel/uint63.ml GENHFILES:=kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h -GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) +GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) kernel/genOpcodeFiles.exe COQ_EXPORTED += GRAMFILES GRAMMLFILES GENGRAMFILES GENMLFILES GENHFILES GENFILES ## More complex file lists @@ -263,7 +263,7 @@ clean-ide: rm -f ide/input_method_lexer.ml rm -f ide/highlight.ml ide/config_lexer.ml ide/config_parser.mli ide/config_parser.ml rm -f ide/utf8_convert.ml - rm -f ide/default.bindings + rm -f ide/default.bindings ide/default_bindings_src.exe rm -rf $(COQIDEAPP) mlgclean: diff --git a/Makefile.ci b/Makefile.ci index 677fd734bf..de03ee8e84 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -18,7 +18,6 @@ CI_TARGETS= \ ci-coq_dpdgraph \ ci-coquelicot \ ci-corn \ - ci-cpdt \ ci-cross-crypto \ ci-elpi \ ci-ext-lib \ @@ -41,7 +40,6 @@ CI_TARGETS= \ ci-sf \ ci-simple-io \ ci-stdlib2 \ - ci-tlc \ ci-unimath \ ci-verdi-raft \ ci-vst diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index f2df99dcd6..d20eea7874 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -142,8 +142,12 @@ let check_inductive env mind mb = mind_universes; mind_variance; mind_private; mind_typing_flags; } = - (* Locally set the oracle for further typechecking *) - let env = Environ.set_oracle env mb.mind_typing_flags.conv_oracle in + (* Locally set typing flags for further typechecking *) + let mb_flags = mb.mind_typing_flags in + let env = Environ.set_typing_flags {env.env_typing_flags with check_guarded = mb_flags.check_guarded; + check_positive = mb_flags.check_positive; + check_universes = mb_flags.check_universes; + conv_oracle = mb_flags.conv_oracle} env in Indtypes.check_inductive env mind entry in let check = check mind in diff --git a/checker/check_stat.ml b/checker/check_stat.ml index 62f72c8edc..a67945ae94 100644 --- a/checker/check_stat.ml +++ b/checker/check_stat.ml @@ -31,14 +31,31 @@ let pr_engagement env = | PredicativeSet -> str "Theory: Set is predicative" end -let is_ax _ cb = not (Declareops.constant_has_body cb) -let pr_ax env = - let axs = fold_constants (fun c ce acc -> if is_ax c ce then c::acc else acc) env [] in +let pr_assumptions ass axs = if axs = [] then - str "Axioms: <none>" + str ass ++ str ": <none>" else - hv 2 (str "Axioms:" ++ fnl() ++ prlist_with_sep fnl Constant.print axs) + hv 2 (str ass ++ str ":" ++ fnl() ++ prlist_with_sep fnl str axs) + +let pr_axioms env = + let csts = fold_constants (fun c cb acc -> if not (Declareops.constant_has_body cb) then Constant.to_string c :: acc else acc) env [] in + pr_assumptions "Axioms" csts + +let pr_type_in_type env = + let csts = fold_constants (fun c cb acc -> if not cb.const_typing_flags.check_universes then Constant.to_string c :: acc else acc) env [] in + let csts = fold_inductives (fun c cb acc -> if not cb.mind_typing_flags.check_universes then MutInd.to_string c :: acc else acc) env csts in + pr_assumptions "Constants/Inductives relying on type-in-type" csts + +let pr_unguarded env = + let csts = fold_constants (fun c cb acc -> if not cb.const_typing_flags.check_guarded then Constant.to_string c :: acc else acc) env [] in + let csts = fold_inductives (fun c cb acc -> if not cb.mind_typing_flags.check_guarded then MutInd.to_string c :: acc else acc) env csts in + pr_assumptions "Constants/Inductives relying on unsafe (co)fixpoints" csts + +let pr_nonpositive env = + let inds = fold_inductives (fun c cb acc -> if not cb.mind_typing_flags.check_positive then MutInd.to_string c :: acc else acc) env [] in + pr_assumptions "Inductives whose positivity is assumed" inds + let print_context env = if !output_context then begin @@ -47,7 +64,10 @@ let print_context env = (fnl() ++ str"CONTEXT SUMMARY" ++ fnl() ++ str"===============" ++ fnl() ++ fnl() ++ str "* " ++ hov 0 (pr_engagement env ++ fnl()) ++ fnl() ++ - str "* " ++ hov 0 (pr_ax env))); + str "* " ++ hov 0 (pr_axioms env ++ fnl()) ++ fnl() ++ + str "* " ++ hov 0 (pr_type_in_type env ++ fnl()) ++ fnl() ++ + str "* " ++ hov 0 (pr_unguarded env ++ fnl()) ++ fnl() ++ + str "* " ++ hov 0 (pr_nonpositive env))) end let stats env = diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 9b41fbcb7a..09b8c48c15 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -17,9 +17,12 @@ let set_indirect_accessor f = indirect_accessor := f let check_constant_declaration env kn cb = Flags.if_verbose Feedback.msg_notice (str " checking cst:" ++ Constant.print kn); - (* Locally set the oracle for further typechecking *) - let oracle = env.env_typing_flags.conv_oracle in - let env = Environ.set_oracle env cb.const_typing_flags.conv_oracle in + (* Locally set typing flags for further typechecking *) + let orig_flags = env.env_typing_flags in + let cb_flags = cb.const_typing_flags in + let env = Environ.set_typing_flags {orig_flags with check_guarded = cb_flags.check_guarded; + check_universes = cb_flags.check_universes; + conv_oracle = cb_flags.conv_oracle} env in (* [env'] contains De Bruijn universe variables *) let poly, env' = match cb.const_universes with @@ -57,8 +60,8 @@ let check_constant_declaration env kn cb = if poly then add_constant kn cb env else add_constant kn cb env' in - (* Reset the value of the oracle *) - Environ.set_oracle env oracle + (* Reset the value of the typing flags *) + Environ.set_typing_flags orig_flags env (** {6 Checking modules } *) diff --git a/checker/values.ml b/checker/values.ml index 8dc09aed87..ac9bc26344 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -219,7 +219,7 @@ let v_cst_def = [|[|Opt Int|]; [|v_cstr_subst|]; [|v_lazy_constr|]; [|v_primitive|]|] let v_typing_flags = - v_tuple "typing_flags" [|v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool; v_bool|] + v_tuple "typing_flags" [|v_bool; v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool; v_bool|] let v_univs = v_sum "universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] @@ -20,7 +20,7 @@ license: "LGPL-2.1" depends: [ "ocaml" { >= "4.05.0" } - "dune" { build & >= "1.6.0" } + "dune" { build & >= "1.10.0" } "ocamlfind" { build } "num" ] diff --git a/coqide-server.opam b/coqide-server.opam index 0325d2549c..5712ca08c2 100644 --- a/coqide-server.opam +++ b/coqide-server.opam @@ -19,7 +19,7 @@ dev-repo: "git+https://github.com/coq/coq.git" license: "LGPL-2.1" depends: [ - "dune" { build & >= "1.6.0" } + "dune" { build & >= "1.10.0" } "coq" { = version } ] diff --git a/coqide.opam b/coqide.opam index 2507acbb26..d680ebb5f4 100644 --- a/coqide.opam +++ b/coqide.opam @@ -17,7 +17,7 @@ dev-repo: "git+https://github.com/coq/coq.git" license: "LGPL-2.1" depends: [ - "dune" { build & >= "1.6.0" } + "dune" { build & >= "1.10.0" } "coqide-server" { = version } "lablgtk3" { >= "3.0.beta5" } "lablgtk3-sourceview3" { >= "3.0.beta5" } diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 0c8213b8f5..78c0b4b2c7 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1132,7 +1132,7 @@ function make_findlib { function make_dune { make_ocaml - if build_prep https://github.com/ocaml/dune/archive/ 1.6.3 tar.gz 1 dune-1.6.3 ; then + if build_prep https://github.com/ocaml/dune/archive/ 1.10.0 tar.gz 1 dune-1.10.0 ; then log2 make release log2 make install diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md index 408d36df7f..9ed7180807 100644 --- a/dev/ci/README-developers.md +++ b/dev/ci/README-developers.md @@ -120,15 +120,18 @@ Currently available artifacts are: Additionally, an experimental Dune build is provided: https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_build/?job=build:edge:dune:dev -- the Coq documentation, built in the `doc:*` jobs. When submitting - a documentation PR, this can help reviewers checking the rendered result: - - + Coq's Reference Manual [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/sphinx/html/index.html?job=doc:refman - + Coq's Standard Library Documentation [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/html/stdlib/index.html?job=build:base - + Coq's ML API Documentation [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_build/default/_doc/_html/index.html?job=doc:ml-api:odoc +- the Coq documentation, built in the `doc:*` jobs. When submitting a + documentation PR, this can help reviewers checking the rendered + result. **@coqbot** will automatically post links to these + artifacts in the PR checks section. Furthemore, these artifacts are + automatically deployed at: + + + Coq's Reference Manual [master branch]: + <https://coq.github.io/doc/master/refman/> + + Coq's Standard Library Documentation [master branch]: + <https://coq.github.io/doc/master/stdlib/> + + Coq's ML API Documentation [master branch]: + <https://coq.github.io/doc/master/api/> ### GitLab and Windows diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index ad22c394d8..3923fea30e 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -56,14 +56,14 @@ # NB: stdpp and Iris refs are gotten from the opam files in the Iris # and lambdaRust repos respectively. -: "${stdpp_CI_GITURL:=https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp}" +: "${stdpp_CI_GITURL:=https://gitlab.mpi-sws.org/iris/stdpp}" : "${stdpp_CI_ARCHIVEURL:=${stdpp_CI_GITURL}/-/archive}" -: "${Iris_CI_GITURL:=https://gitlab.mpi-sws.org/FP/iris-coq}" +: "${Iris_CI_GITURL:=https://gitlab.mpi-sws.org/iris/iris}" : "${Iris_CI_ARCHIVEURL:=${Iris_CI_GITURL}/-/archive}" : "${lambdaRust_CI_REF:=master}" -: "${lambdaRust_CI_GITURL:=https://gitlab.mpi-sws.org/FP/LambdaRust-coq}" +: "${lambdaRust_CI_GITURL:=https://gitlab.mpi-sws.org/iris/lambda-rust}" : "${lambdaRust_CI_ARCHIVEURL:=${lambdaRust_CI_GITURL}/-/archive}" ######################################################################## diff --git a/dev/ci/ci-cpdt.sh b/dev/ci/ci-cpdt.sh deleted file mode 100755 index ca759c7b39..0000000000 --- a/dev/ci/ci-cpdt.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -wget http://adam.chlipala.net/cpdt/cpdt.tgz -tar xvfz cpdt.tgz - -( cd cpdt && make clean && make ) diff --git a/dev/ci/ci-tlc.sh b/dev/ci/ci-tlc.sh deleted file mode 100755 index a2f0bea555..0000000000 --- a/dev/ci/ci-tlc.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -FORCE_GIT=1 -git_download tlc - -( cd "${CI_BUILD_DIR}/tlc" && make ) diff --git a/dev/ci/user-overlays/10642-SkySkimmer-feedback-added-axiom.sh b/dev/ci/user-overlays/10642-SkySkimmer-feedback-added-axiom.sh new file mode 100644 index 0000000000..413805e8e9 --- /dev/null +++ b/dev/ci/user-overlays/10642-SkySkimmer-feedback-added-axiom.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10642" ] || [ "$CI_BRANCH" = "feedback-added-axiom" ]; then + + elpi_CI_REF=feedback-added-axiom + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + +fi diff --git a/dev/ci/user-overlays/10665-ejgallego-api+varkind.sh b/dev/ci/user-overlays/10665-ejgallego-api+varkind.sh new file mode 100644 index 0000000000..0c47f6a60b --- /dev/null +++ b/dev/ci/user-overlays/10665-ejgallego-api+varkind.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "10665" ] || [ "$CI_BRANCH" = "api+varkind" ]; then + + elpi_CI_REF=api+varkind + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + + quickchick_CI_REF=api+varkind + quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick + +fi diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index 372e40a0b7..37c6e2f619 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -52,7 +52,7 @@ order to use them, do: ``` $ make -f Makefile.dune voboot # Only once per session -$ dune exec dev/shim/coqtop-prelude +$ dune exec -- dev/shim/coqtop-prelude ``` or `quickide` / `dev/shim/coqide-prelude` for CoqIDE. These targets @@ -108,14 +108,14 @@ automatically. You can use `ocamldebug` with Dune; after a build, do: ``` -dune exec dev/dune-dbg /path/to/foo.v +dune exec -- dev/dune-dbg /path/to/foo.v (ocd) source dune_db ``` or ``` -dune exec dev/dune-dbg checker Foo +dune exec -- dev/dune-dbg checker Foo (ocd) source dune_db ``` @@ -130,7 +130,7 @@ For running in emacs, use `coqdev-ocamldebug` from `coqdev.el`. After doing `make -f Makefile.dune voboot`, the following commands should work: ``` -dune exec dev/shim/coqbyte-prelude +dune exec -- dev/shim/coqbyte-prelude > Drop. # #directory "dev";; # #use "include_dune";; diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index 8dfe1e7833..8736c0f9b8 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/bc9df0f66110039e495b6debe3a6cda4a1bb0fed.tar.gz"; - sha256 = "0y2w259j0vqiwjhjvlbsaqnp1nl2zwz6sbwwhkrqn7k7fmhmxnq1"; + url = "https://github.com/NixOS/nixpkgs/archive/31c38894c90429c9554eab1b416e59e3b6e054df.tar.gz"; + sha256 = "1fv14rj5zslzm14ak4lvwqix94gm18h28376h4hsmrqqpnfqwsdw"; }) diff --git a/doc/changelog/05-tactic-language/10324-ltac2-ssr-ampersand.rst b/doc/changelog/05-tactic-language/10324-ltac2-ssr-ampersand.rst new file mode 100644 index 0000000000..fba09f5e87 --- /dev/null +++ b/doc/changelog/05-tactic-language/10324-ltac2-ssr-ampersand.rst @@ -0,0 +1,5 @@ +- White spaces are forbidden in the “&ident” syntax for ltac2 references + that are described in :ref:`ltac2_built-in-quotations` + (`#10324 <https://github.com/coq/coq/pull/10324>`_, + fixes `#10088 <https://github.com/coq/coq/issues/10088>`_, + authored by Pierre-Marie Pédrot). diff --git a/doc/changelog/07-commands-and-options/10291-typing-flags.rst b/doc/changelog/07-commands-and-options/10291-typing-flags.rst new file mode 100644 index 0000000000..ef7adde801 --- /dev/null +++ b/doc/changelog/07-commands-and-options/10291-typing-flags.rst @@ -0,0 +1,4 @@ +- Adding unsafe commands to enable/disable guard checking, positivity checking + and universes checking (providing a local `-type-in-type`). + See :ref:`controlling-typing-flags`. + (`#10291 <https://github.com/coq/coq/pull/10291>`_ by Simon Boulier). diff --git a/doc/plugin_tutorial/tuto0/src/dune b/doc/plugin_tutorial/tuto0/src/dune index 79d561061d..ab9b4dd531 100644 --- a/doc/plugin_tutorial/tuto0/src/dune +++ b/doc/plugin_tutorial/tuto0/src/dune @@ -3,7 +3,4 @@ (public_name coq.plugins.tutorial.p0) (libraries coq.plugins.ltac)) -(rule - (targets g_tuto0.ml) - (deps (:pp-file g_tuto0.mlg) ) - (action (run coqpp %{pp-file}))) +(coq.pp (modules g_tuto0)) diff --git a/doc/plugin_tutorial/tuto1/src/dune b/doc/plugin_tutorial/tuto1/src/dune index cf9c674b14..054d5ecd26 100644 --- a/doc/plugin_tutorial/tuto1/src/dune +++ b/doc/plugin_tutorial/tuto1/src/dune @@ -3,7 +3,4 @@ (public_name coq.plugins.tutorial.p1) (libraries coq.plugins.ltac)) -(rule - (targets g_tuto1.ml) - (deps (:pp-file g_tuto1.mlg) ) - (action (run coqpp %{pp-file}))) +(coq.pp (modules g_tuto1)) diff --git a/doc/plugin_tutorial/tuto2/src/dune b/doc/plugin_tutorial/tuto2/src/dune index 68ddd13947..8c4b04b1ae 100644 --- a/doc/plugin_tutorial/tuto2/src/dune +++ b/doc/plugin_tutorial/tuto2/src/dune @@ -3,7 +3,4 @@ (public_name coq.plugins.tutorial.p2) (libraries coq.plugins.ltac)) -(rule - (targets g_tuto2.ml) - (deps (:pp-file g_tuto2.mlg) ) - (action (run coqpp %{pp-file}))) +(coq.pp (modules g_tuto2)) diff --git a/doc/plugin_tutorial/tuto3/src/dune b/doc/plugin_tutorial/tuto3/src/dune index ba6d8b288f..678dd71328 100644 --- a/doc/plugin_tutorial/tuto3/src/dune +++ b/doc/plugin_tutorial/tuto3/src/dune @@ -4,7 +4,4 @@ (flags :standard -warn-error -3) (libraries coq.plugins.ltac)) -(rule - (targets g_tuto3.ml) - (deps (:pp-file g_tuto3.mlg)) - (action (run coqpp %{pp-file}))) +(coq.pp (modules g_tuto3)) diff --git a/doc/sphinx/addendum/parallel-proof-processing.rst b/doc/sphinx/addendum/parallel-proof-processing.rst index 903ee115c9..cdb7ea834f 100644 --- a/doc/sphinx/addendum/parallel-proof-processing.rst +++ b/doc/sphinx/addendum/parallel-proof-processing.rst @@ -162,7 +162,7 @@ need to process all the proofs of the ``.v`` file. The asynchronous processing of proofs can decouple the generation of a compiled file (like the ``.vo`` one) that can be loaded by ``Require`` from the generation and checking of the proof objects. The ``-quick`` flag can be -passed to ``coqc`` or ``coqtop`` to produce, quickly, ``.vio`` files. +passed to ``coqc`` to produce, quickly, ``.vio`` files. Alternatively, when using a Makefile produced by ``coq_makefile``, the ``quick`` target can be used to compile all files using the ``-quick`` flag. @@ -182,7 +182,7 @@ running ``coqc`` as usual. Alternatively one can turn each ``.vio`` into the corresponding ``.vo``. All .vio files can be processed in parallel, hence this alternative might -be faster. The command ``coqtop -schedule-vio2vo 2 a b c`` can be used to +be faster. The command ``coqc -schedule-vio2vo 2 a b c`` can be used to obtain a good scheduling for two workers to produce ``a.vo``, ``b.vo``, and ``c.vo``. When using a Makefile produced by ``coq_makefile``, the ``vio2vo`` target can be used for that purpose. Variable ``J`` should be set to the number @@ -197,7 +197,7 @@ There is an extra, possibly even faster, alternative: just check the proof tasks stored in ``.vio`` files without producing the ``.vo`` files. This is possibly faster because all the proof tasks are independent, hence one can further partition the job to be done between workers. The -``coqtop -schedule-vio-checking 6 a b c`` command can be used to obtain a +``coqc -schedule-vio-checking 6 a b c`` command can be used to obtain a good scheduling for 6 workers to check all the proof tasks of ``a.vio``, ``b.vio``, and ``c.vio``. Auxiliary files are used to predict how long a proof task will take, assuming it will take the same amount of time it took diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 6ac55e7bf4..c591a1f1de 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -894,8 +894,8 @@ Standard Library and other packages. They are still delimited by `%int` and `%uint`. - Syntax notations for `string`, `ascii`, `Z`, `positive`, `N`, `R`, - and `int31` are no longer available merely by `Require`ing the files - that define the inductives. You must `Import` `Coq.Strings.String.StringSyntax` + and `int31` are no longer available merely by :cmd:`Require`\ing the files + that define the inductives. You must :cmd:`Import` `Coq.Strings.String.StringSyntax` (after `Require` `Coq.Strings.String`), `Coq.Strings.Ascii.AsciiSyntax` (after `Require` `Coq.Strings.Ascii`), `Coq.ZArith.BinIntDef`, `Coq.PArith.BinPosDef`, `Coq.NArith.BinNatDef`, `Coq.Reals.Rdefinitions`, and diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index acf68e9fd2..dc4f91e66b 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -260,10 +260,7 @@ To eliminate the (co-)inductive type, one must use its defined primitive project For compatibility, the parameters still appear to the user when printing terms even though they are absent in the actual AST manipulated by the kernel. This can be changed by unsetting the -:flag:`Printing Primitive Projection Parameters` flag. Further compatibility -printing can be deactivated thanks to the ``Printing Primitive Projection -Compatibility`` option which governs the printing of pattern matching -over primitive records. +:flag:`Printing Primitive Projection Parameters` flag. There are currently two ways to introduce primitive records types: diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 91dfa34494..2cbd41af8b 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -778,7 +778,8 @@ Simple inductive types The types of the constructors have to satisfy a *positivity condition* (see Section :ref:`positivity`). This condition ensures the soundness of - the inductive definition. + the inductive definition. The positivity checking can be disabled using + the option :flag:`Positivity Checking` (see :ref:`controlling-typing-flags`). .. exn:: The conclusion of @type is not valid; it must be built from @ident. diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 554f6bf230..47ecfb9db0 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -522,10 +522,7 @@ of your project. (flags :standard -warn-error -3-9-27-32-33-50) (libraries coq.plugins.cc coq.plugins.extraction)) - (rule - (targets g_equations.ml) - (deps (:pp-file g_equations.mlg)) - (action (run coqpp %{pp-file}))) + (coq.pp (modules g_equations)) And a Coq-specific part that depends on it via the ``libraries`` field: diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index ceaa2775bf..045d028d02 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -17,16 +17,16 @@ Coq, yet it is at the same time its Achilles' heel. Indeed, Ltac: - is error-prone and fragile - has an intricate implementation -Following the need of users that start developing huge projects relying +Following the need of users who are developing huge projects relying critically on Ltac, we believe that we should offer a proper modern language that features at least the following: - at least informal, predictable semantics -- a typing system -- standard programming facilities (i.e. datatypes) +- a type system +- standard programming facilities (e.g., datatypes) This new language, called Ltac2, is described in this chapter. It is still -experimental but we encourage nonetheless users to start testing it, +experimental but we nonetheless encourage users to start testing it, especially wherever an advanced tactic language is needed. The previous implementation of Ltac, described in the previous chapter, will be referred to as Ltac1. @@ -36,9 +36,9 @@ as Ltac1. General design -------------- -There are various alternatives to Ltac1, such that Mtac or Rtac for instance. -While those alternatives can be quite distinct from Ltac1, we designed -Ltac2 to be closest as reasonably possible to Ltac1, while fixing the +There are various alternatives to Ltac1, such as Mtac or Rtac for instance. +While those alternatives can be quite different from Ltac1, we designed +Ltac2 to be as close as reasonably possible to Ltac1, while fixing the aforementioned defects. In particular, Ltac2 is: @@ -47,11 +47,11 @@ In particular, Ltac2 is: * a call-by-value functional language * with effects - * together with Hindley-Milner type system + * together with the Hindley-Milner type system - a language featuring meta-programming facilities for the manipulation of Coq-side terms -- a language featuring notation facilities to help writing palatable scripts +- a language featuring notation facilities to help write palatable scripts We describe more in details each point in the remainder of this document. @@ -77,7 +77,7 @@ Sticking to a standard ML type system can be considered somewhat weak for a meta-language designed to manipulate Coq terms. In particular, there is no way to statically guarantee that a Coq term resulting from an Ltac2 computation will be well-typed. This is actually a design choice, motivated -by retro-compatibility with Ltac1. Instead, well-typedness is deferred to +by backward compatibility with Ltac1. Instead, well-typedness is deferred to dynamic checks, allowing many primitive functions to fail whenever they are provided with an ill-typed term. @@ -92,7 +92,7 @@ Type Syntax ~~~~~~~~~~~ At the level of terms, we simply elaborate on Ltac1 syntax, which is quite -close to e.g. the one of OCaml. Types follow the simply-typed syntax of OCaml. +close to OCaml. Types follow the simply-typed syntax of OCaml. The non-terminal :production:`lident` designates identifiers starting with a lowercase. @@ -122,7 +122,7 @@ Built-in types include: Type declarations ~~~~~~~~~~~~~~~~~ -One can define new types by the following commands. +One can define new types with the following commands. .. cmd:: Ltac2 Type {? @ltac2_typeparams } @lident :name: Ltac2 Type @@ -149,7 +149,7 @@ One can define new types by the following commands. Variants are sum types defined by constructors and eliminated by pattern-matching. They can be recursive, but the `rec` flag must be - explicitly set. Pattern-maching must be exhaustive. + explicitly set. Pattern matching must be exhaustive. Records are product types with named fields and eliminated by projection. Likewise they can be recursive if the `rec` flag is set. @@ -158,15 +158,15 @@ One can define new types by the following commands. Open variants are a special kind of variant types whose constructors are not statically defined, but can instead be extended dynamically. A typical example - is the standard `exn` type. Pattern-matching must always include a catch-all - clause. They can be extended by this command. + is the standard `exn` type. Pattern matching on open variants must always include a catch-all + clause. They can be extended with this command. Term Syntax ~~~~~~~~~~~ The syntax of the functional fragment is very close to the one of Ltac1, except that it adds a true pattern-matching feature, as well as a few standard -constructions from ML. +constructs from ML. .. productionlist:: coq ltac2_var : `lident` @@ -202,7 +202,7 @@ constructions from ML. In practice, there is some additional syntactic sugar that allows e.g. to bind a variable and match on it at the same time, in the usual ML style. -There is a dedicated syntax for list and array literals. +There is dedicated syntax for list and array literals. .. note:: @@ -217,7 +217,7 @@ Ltac Definitions This command defines a new global Ltac2 value. For semantic reasons, the body of the Ltac2 definition must be a syntactical - value, i.e. a function, a constant or a pure constructor recursively applied to + value, that is, a function, a constant or a pure constructor recursively applied to values. If ``rec`` is set, the tactic is expanded into a recursive binding. @@ -247,7 +247,7 @@ if ever we implement native compilation. The expected equations are as follows:: (t any term, V values, C constructor) Note that call-by-value reduction is already a departure from Ltac1 which uses -heuristics to decide when evaluating an expression. For instance, the following +heuristics to decide when to evaluate an expression. For instance, the following expressions do not evaluate the same way in Ltac1. :n:`foo (idtac; let x := 0 in bar)` @@ -255,7 +255,7 @@ expressions do not evaluate the same way in Ltac1. :n:`foo (let x := 0 in bar)` Instead of relying on the :n:`idtac` idiom, we would now require an explicit thunk -not to compute the argument, and :n:`foo` would have e.g. type +to not compute the argument, and :n:`foo` would have e.g. type :n:`(unit -> unit) -> unit`. :n:`foo (fun () => let x := 0 in bar)` @@ -263,19 +263,19 @@ not to compute the argument, and :n:`foo` would have e.g. type Typing ~~~~~~ -Typing is strict and follows Hindley-Milner system. Unlike Ltac1, there +Typing is strict and follows the Hindley-Milner system. Unlike Ltac1, there are no type casts at runtime, and one has to resort to conversion functions. See notations though to make things more palatable. -In this setting, all usual argument-free tactics have type :n:`unit -> unit`, but -one can return as well a value of type :n:`t` thanks to terms of type :n:`unit -> t`, +In this setting, all the usual argument-free tactics have type :n:`unit -> unit`, but +one can return a value of type :n:`t` thanks to terms of type :n:`unit -> t`, or take additional arguments. Effects ~~~~~~~ Effects in Ltac2 are straightforward, except that instead of using the -standard IO monad as the ambient effectful world, Ltac2 is going to use the +standard IO monad as the ambient effectful world, Ltac2 is has a tactic monad. Note that the order of evaluation of application is *not* specified and is @@ -288,15 +288,15 @@ Intuitively a thunk of type :n:`unit -> 'a` can do the following: - It can perform non-backtracking IO like printing and setting mutable variables - It can fail in a non-recoverable way -- It can use first-class backtrack. The proper way to figure that is that we - morally have the following isomorphism: +- It can use first-class backtracking. One way to think about this is that + thunks are isomorphic to this type: :n:`(unit -> 'a) ~ (unit -> exn + ('a * (exn -> 'a)))` i.e. thunks can produce a lazy list of results where each tail is waiting for a continuation exception. -- It can access a backtracking proof state, made out amongst other things of +- It can access a backtracking proof state, consisting among other things of the current evar assignation and the list of goals under focus. -We describe more thoroughly the various effects existing in Ltac2 hereafter. +We now describe more thoroughly the various effects in Ltac2. Standard IO +++++++++++ @@ -315,28 +315,28 @@ Fatal errors ++++++++++++ The Ltac2 language provides non-backtracking exceptions, also known as *panics*, -through the following primitive in module `Control`.:: +through the following primitive in module `Control`:: val throw : exn -> 'a Unlike backtracking exceptions from the next section, this kind of error is never caught by backtracking primitives, that is, throwing an exception -destroys the stack. This is materialized by the following equation, where `E` -is an evaluation context.:: +destroys the stack. This is codified by the following equation, where `E` +is an evaluation context:: E[throw e] ≡ throw e (e value) -There is currently no way to catch such an exception and it is a design choice. -There might be at some future point a way to catch it in a brutal way, -destroying all backtrack and return values. +There is currently no way to catch such an exception, which is a deliberate design choice. +Eventually there might be a way to catch it and +destroy all backtrack and return values. -Backtrack -+++++++++ +Backtracking +++++++++++++ In Ltac2, we have the following backtracking primitives, defined in the -`Control` module.:: +`Control` module:: Ltac2 Type 'a result := [ Val ('a) | Err (exn) ]. @@ -344,7 +344,7 @@ In Ltac2, we have the following backtracking primitives, defined in the val plus : (unit -> 'a) -> (exn -> 'a) -> 'a val case : (unit -> 'a) -> ('a * (exn -> 'a)) result -If one sees thunks as lazy lists, then `zero` is the empty list and `plus` is +If one views thunks as lazy lists, then `zero` is the empty list and `plus` is list concatenation, while `case` is pattern-matching. The backtracking is first-class, i.e. one can write @@ -376,8 +376,8 @@ represent several goals, including none. Thus, there is no such thing as *the current goal*. Goals are naturally ordered, though. It is natural to do the same in Ltac2, but we must provide a way to get access -to a given goal. This is the role of the `enter` primitive, that applies a -tactic to each currently focused goal in turn.:: +to a given goal. This is the role of the `enter` primitive, which applies a +tactic to each currently focused goal in turn:: val enter : (unit -> unit) -> unit @@ -427,6 +427,8 @@ In general, quotations can be introduced in terms using the following syntax, wh .. prodn:: ltac2_term += @ident : ( @quotentry ) +.. _ltac2_built-in-quotations: + Built-in quotations +++++++++++++++++++ @@ -439,10 +441,11 @@ The current implementation recognizes the following built-in quotations: holes at runtime (type ``Init.constr`` as well). - ``pattern``, which parses Coq patterns and produces a pattern used for term matching (type ``Init.pattern``). -- ``reference``, which parses either a :n:`@qualid` or :n:`& @ident`. Qualified names +- ``reference``, which parses either a :n:`@qualid` or :n:`&@ident`. Qualified names are globalized at internalization into the corresponding global reference, while ``&id`` is turned into ``Std.VarRef id``. This produces at runtime a - ``Std.reference``. + ``Std.reference``. There shall be no white space between the ampersand + symbol (``&``) and the identifier (:n:`@ident`). The following syntactic sugar is provided for two common cases. @@ -452,9 +455,9 @@ The following syntactic sugar is provided for two common cases. Strict vs. non-strict mode ++++++++++++++++++++++++++ -Depending on the context, quotations producing terms (i.e. ``constr`` or +Depending on the context, quotation-producing terms (i.e. ``constr`` or ``open_constr``) are not internalized in the same way. There are two possible -modes, respectively called the *strict* and the *non-strict* mode. +modes, the *strict* and the *non-strict* mode. - In strict mode, all simple identifiers appearing in a term quotation are required to be resolvable statically. That is, they must be the short name of @@ -467,7 +470,7 @@ modes, respectively called the *strict* and the *non-strict* mode. of the term at runtime will fail if there is no such variable in the dynamic context. -Strict mode is enforced by default, e.g. for all Ltac2 definitions. Non-strict +Strict mode is enforced by default, such as for all Ltac2 definitions. Non-strict mode is only set when evaluating Ltac2 snippets in interactive proof mode. The rationale is that it is cumbersome to explicitly add ``&`` interactively, while it is expected that global tactics enforce more invariants on their code. @@ -490,12 +493,12 @@ for their side-effects. Semantics +++++++++ -Interpretation of a quoted Coq term is done in two phases, internalization and +A quoted Coq term is interpreted in two phases, internalization and evaluation. -- Internalization is part of the static semantics, i.e. it is done at Ltac2 +- Internalization is part of the static semantics, that is, it is done at Ltac2 typing time. -- Evaluation is part of the dynamic semantics, i.e. it is done when +- Evaluation is part of the dynamic semantics, that is, it is done when a term gets effectively computed by Ltac2. Note that typing of Coq terms is a *dynamic* process occurring at Ltac2 @@ -672,7 +675,7 @@ at parsing time. Scopes are described using a form of S-expression. .. prodn:: ltac2_scope ::= {| @string | @int | @lident ({+, @ltac2_scope}) } -A few scopes contain antiquotation features. For sake of uniformity, all +A few scopes contain antiquotation features. For the sake of uniformity, all antiquotations are introduced by the syntax :n:`$@lident`. The following scopes are built-in. @@ -713,15 +716,15 @@ The following scopes are built-in. - :n:`self`: - + parses a Ltac2 expression at the current level and return it as is. + + parses a Ltac2 expression at the current level and returns it as is. - :n:`next`: - + parses a Ltac2 expression at the next level and return it as is. + + parses a Ltac2 expression at the next level and returns it as is. - :n:`tactic(n = @int)`: - + parses a Ltac2 expression at the provided level :n:`n` and return it as is. + + parses a Ltac2 expression at the provided level :n:`n` and returns it as is. - :n:`thunk(@ltac2_scope)`: @@ -747,7 +750,7 @@ The following scopes are built-in. out of the parsed values in the same order. As an optimization, all subscopes of the form :n:`STRING` are left out of the returned tuple, instead of returning a useless unit value. It is forbidden for the various - subscopes to refer to the global entry using self or next. + subscopes to refer to the global entry using :n:`self` or :n:`next`. A few other specific scopes exist to handle Ltac1-like syntax, but their use is discouraged and they are thus not documented. @@ -758,7 +761,7 @@ planned. Notations ~~~~~~~~~ -The Ltac2 parser can be extended by syntactic notations. +The Ltac2 parser can be extended with syntactic notations. .. cmd:: Ltac2 Notation {+ {| @lident (@ltac2_scope) | @string } } {? : @int} := @ltac2_term :name: Ltac2 Notation @@ -793,10 +796,10 @@ Abbreviations .. cmdv:: Ltac2 Notation @lident := @ltac2_term - This command introduces a special kind of notations, called abbreviations, + This command introduces a special kind of notation, called an abbreviation, that is designed so that it does not add any parsing rules. It is similar in spirit to Coq abbreviations, insofar as its main purpose is to give an - absolute name to a piece of pure syntax, which can be transparently referred + absolute name to a piece of pure syntax, which can be transparently referred to by this name as if it were a proper definition. The abbreviation can then be manipulated just as a normal Ltac2 definition, @@ -851,7 +854,7 @@ corresponding code for its side effects. In particular, it cannot return values, and the quotation has type :n:`unit`. Ltac1 **cannot** implicitly access variables from the Ltac2 scope, but this can -be done via an explicit annotation to the :n:`ltac1` quotation. +be done with an explicit annotation on the :n:`ltac1` quotation. .. productionlist:: coq ltac2_term : ltac1 : ( `ident` ... `ident` |- `ltac_expr` ) @@ -888,7 +891,7 @@ Same as above by switching Ltac1 by Ltac2 and using the `ltac2` quotation instead. Note that the tactic expression is evaluated eagerly, if one wants to use it as -an argument to a Ltac1 function, she has to resort to the good old +an argument to a Ltac1 function, one has to resort to the good old :n:`idtac; ltac2:(foo)` trick. For instance, the code below will fail immediately and won't print anything. @@ -923,8 +926,8 @@ Due to conflicts, a few syntactic rules have changed. - The dispatch tactical :n:`tac; [foo|bar]` is now written :n:`tac > [foo|bar]`. - Levels of a few operators have been revised. Some tacticals now parse as if - they were a normal function, i.e. one has to put parentheses around the - argument when it is complex, e.g an abstraction. List of affected tacticals: + they were normal functions. Parentheses are now required around complex + arguments, such as abstractions. The tacticals affected are: :n:`try`, :n:`repeat`, :n:`do`, :n:`once`, :n:`progress`, :n:`time`, :n:`abstract`. - :n:`idtac` is no more. Either use :n:`()` if you expect nothing to happen, :n:`(fun () => ())` if you want a thunk (see next section), or use printing @@ -1010,4 +1013,4 @@ Exception catching Ltac2 features a proper exception-catching mechanism. For this reason, the Ltac1 mechanism relying on `fail` taking integers, and tacticals decreasing it, has been removed. Now exceptions are preserved by all tacticals, and it is -your duty to catch them and reraise them depending on your use. +your duty to catch them and re-raise them as needed. diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 774732825a..c391cc949d 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1204,6 +1204,79 @@ Controlling the locality of commands occurs in a section. The :cmd:`Set` and :cmd:`Unset` commands belong to this category. +.. _controlling-typing-flags: + +Controlling Typing Flags +---------------------------- + +.. flag:: Guard Checking + + This option can be used to enable/disable the guard checking of + fixpoints. Warning: this can break the consistency of the system, use at your + own risk. Decreasing argument can still be specified: the decrease is not checked + anymore but it still affects the reduction of the term. Unchecked fixpoints are + printed by :cmd:`Print Assumptions`. + +.. flag:: Positivity Checking + + This option can be used to enable/disable the positivity checking of inductive + types and the productivity checking of coinductive types. Warning: this can + break the consistency of the system, use at your own risk. Unchecked + (co)inductive types are printed by :cmd:`Print Assumptions`. + +.. flag:: Universe Checking + + This option can be used to enable/disable the checking of universes, providing a + form of "type in type". Warning: this breaks the consistency of the system, use + at your own risk. Constants relying on "type in type" are printed by + :cmd:`Print Assumptions`. It has the same effect as `-type-in-type` command line + argument (see :ref:`command-line-options`). + +.. cmd:: Print Typing Flags + + Print the status of the three typing flags: guard checking, positivity checking + and universe checking. + +.. example:: + + .. coqtop:: all reset + + Unset Guard Checking. + + Print Typing Flags. + + Fixpoint f (n : nat) : False + := f n. + + Fixpoint ackermann (m n : nat) {struct m} : nat := + match m with + | 0 => S n + | S m => + match n with + | 0 => ackermann m 1 + | S n => ackermann m (ackermann (S m) n) + end + end. + + Print Assumptions ackermann. + + Note that the proper way to define the Ackermann function is to use + an inner fixpoint: + + .. coqtop:: all reset + + Fixpoint ack m := + fix ackm n := + match m with + | 0 => S n + | S m' => + match n with + | 0 => ack m' 1 + | S n' => ack m' (ackm n') + end + end. + + .. _internal-registration-commands: Internal registration commands diff --git a/dune-project b/dune-project index f0ac11ba61..45d9d06314 100644 --- a/dune-project +++ b/dune-project @@ -1,2 +1,8 @@ -(lang dune 1.6) +(lang dune 1.10) (name coq) +(using coq 0.1) + +; We cannot set this to true until as long as the build is not +; properly bootstrapped [that is, we remove the voboot target] +; +; (generate_opam_files true) diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index f96cfebed5..f86cb0f6f2 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -23,7 +23,7 @@ module type S = val create : string -> 'a e val parse : 'a e -> parsable -> 'a val name : 'a e -> string - val of_parser : string -> (te Stream.t -> 'a) -> 'a e + val of_parser : string -> (Plexing.location_function -> te Stream.t -> 'a) -> 'a e val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit end @@ -112,7 +112,7 @@ type 'a ty_entry = { and 'a ty_desc = | Dlevels of 'a ty_level list -| Dparser of 'a parser_t +| Dparser of (Plexing.location_function -> 'a parser_t) and 'a ty_level = Level : (_, _, 'a) ty_rec_level -> 'a ty_level @@ -1449,7 +1449,7 @@ let start_parser_of_entry entry = match entry.edesc with Dlevels [] -> empty_entry entry.ename | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> fun levn strm -> p strm + | Dparser p -> fun levn strm -> p !floc strm (* Extend syntax *) @@ -1549,9 +1549,9 @@ let clear_entry e = let parse_token_stream (e : 'a e) ts : 'a = e.estart 0 ts let name e = e.ename - let of_parser n (p : te Stream.t -> 'a) : 'a e = + let of_parser n (p : Plexing.location_function -> te Stream.t -> 'a) : 'a e = { ename = n; - estart = (fun _ -> p); + estart = (fun _ -> p !floc); econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); edesc = Dparser p} diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli index ec4ec62409..658baf1de9 100644 --- a/gramlib/grammar.mli +++ b/gramlib/grammar.mli @@ -32,7 +32,7 @@ module type S = val create : string -> 'a e val parse : 'a e -> parsable -> 'a val name : 'a e -> string - val of_parser : string -> (te Stream.t -> 'a) -> 'a e + val of_parser : string -> (Plexing.location_function -> te Stream.t -> 'a) -> 'a e val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit end diff --git a/ide/coqide.ml b/ide/coqide.ml index 00168a06b1..9cdfd0dc21 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -110,7 +110,13 @@ let make_coqtop_args fname = | None -> args | Some fname -> if List.exists (String.equal "-top") args then args - else "-topfile"::fname::args + else + (* We basically copy the code of Names.check_valid since it is not exported *) + (* to coqide. This is to prevent a possible failure of parsing "-topfile" *) + (* at initialization of coqtop (see #10286) *) + match Unicode.ident_refutation (Filename.chop_extension (Filename.basename fname)) with + | Some (_,x) -> output_string stderr (x^"\n"); exit 1 + | None -> "-topfile"::fname::args in proj, args diff --git a/ide/idetop.ml b/ide/idetop.ml index 7c6fa8951b..7e55eb4d13 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -56,7 +56,7 @@ let coqide_known_option table = List.mem table [ ["Printing";"Unfocused"]; ["Diffs"]] -let is_known_option cmd = match Vernacprop.under_control cmd with +let is_known_option cmd = match cmd with | VernacSetOption (_, o, OptionSetTrue) | VernacSetOption (_, o, OptionSetString _) | VernacSetOption (_, o, OptionUnset) -> coqide_known_option o @@ -64,7 +64,7 @@ let is_known_option cmd = match Vernacprop.under_control cmd with (** Check whether a command is forbidden in the IDE *) -let ide_cmd_checks ~last_valid ({ CAst.loc; _ } as cmd) = +let ide_cmd_checks ~last_valid { CAst.loc; v } = let user_error s = try CErrors.user_err ?loc ~hdr:"IDE" (str s) with e -> @@ -72,14 +72,14 @@ let ide_cmd_checks ~last_valid ({ CAst.loc; _ } as cmd) = let info = Stateid.add info ~valid:last_valid Stateid.dummy in Exninfo.raise ~info e in - if is_debug cmd then + if is_debug v.expr then user_error "Debug mode not available in the IDE" -let ide_cmd_warns ~id ({ CAst.loc; _ } as cmd) = +let ide_cmd_warns ~id { CAst.loc; v } = let warn msg = Feedback.(feedback ~id (Message (Warning, loc, strbrk msg))) in - if is_known_option cmd then + if is_known_option v.expr then warn "Set this option from the IDE menu instead"; - if is_navigation_vernac cmd || is_undo cmd then + if is_navigation_vernac v.expr || is_undo v.expr then warn "Use IDE navigation instead" (** Interpretation (cf. [Ide_intf.interp]) *) diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index e4af0fcee0..49b9149675 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -10,7 +10,6 @@ open Names open Libnames -open Decl_kinds (** {6 Concrete syntax for terms } *) @@ -39,8 +38,8 @@ type explicitation = | ExplByName of Id.t type binder_kind = - | Default of binding_kind - | Generalized of binding_kind * bool + | Default of Glob_term.binding_kind + | Generalized of Glob_term.binding_kind * bool (** (Inner binding always Implicit) Outer bindings, typeclass-specific flag for implicit generalization of superclasses *) @@ -121,7 +120,7 @@ and constr_expr_r = | CSort of Glob_term.glob_sort | CCast of constr_expr * constr_expr Glob_term.cast_type | CNotation of notation * constr_notation_substitution - | CGeneralization of binding_kind * abstraction_kind option * constr_expr + | CGeneralization of Glob_term.binding_kind * abstraction_kind option * constr_expr | CPrim of prim_token | CDelimiters of string * constr_expr and constr_expr = constr_expr_r CAst.t diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 8fce24249c..3f216b0d63 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -17,25 +17,19 @@ open Namegen open Glob_term open Constrexpr open Notation -open Decl_kinds (***********************) (* For binders parsing *) -let binding_kind_eq bk1 bk2 = match bk1, bk2 with -| Explicit, Explicit -> true -| Implicit, Implicit -> true -| _ -> false - let abstraction_kind_eq ak1 ak2 = match ak1, ak2 with | AbsLambda, AbsLambda -> true | AbsPi, AbsPi -> true | _ -> false let binder_kind_eq b1 b2 = match b1, b2 with -| Default bk1, Default bk2 -> binding_kind_eq bk1 bk2 +| Default bk1, Default bk2 -> Glob_ops.binding_kind_eq bk1 bk2 | Generalized (ck1, b1), Generalized (ck2, b2) -> - binding_kind_eq ck1 ck2 && + Glob_ops.binding_kind_eq ck1 ck2 && (if b1 then b2 else not b2) | _ -> false @@ -172,7 +166,7 @@ let rec constr_expr_eq e1 e2 = | CPrim i1, CPrim i2 -> prim_token_eq i1 i2 | CGeneralization (bk1, ak1, e1), CGeneralization (bk2, ak2, e2) -> - binding_kind_eq bk1 bk2 && + Glob_ops.binding_kind_eq bk1 bk2 && Option.equal abstraction_kind_eq ak1 ak2 && constr_expr_eq e1 e2 | CDelimiters(s1,e1), CDelimiters(s2,e2) -> diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index 3ed240d356..a05a9cb999 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -26,9 +26,6 @@ val constr_expr_eq : constr_expr -> constr_expr -> bool val local_binder_eq : local_binder_expr -> local_binder_expr -> bool (** Equality on [local_binder_expr]. Same properties as [constr_expr_eq]. *) -val binding_kind_eq : Decl_kinds.binding_kind -> Decl_kinds.binding_kind -> bool -(** Equality on [binding_kind] *) - val binder_kind_eq : binder_kind -> binder_kind -> bool (** Equality on [binder_kind] *) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 96392edb11..217381d854 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -27,7 +27,6 @@ open Glob_ops open Pattern open Notation open Detyping -open Decl_kinds module NamedDecl = Context.Named.Declaration (*i*) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index f341071728..f2cb4ae5c7 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -31,7 +31,6 @@ open Notation_term open Notation_ops open Notation open Inductiveops -open Decl_kinds open Context.Rel.Declaration (** constr_expr -> glob_constr translation: diff --git a/interp/impargs.ml b/interp/impargs.ml index 0466efa991..5f41c2a366 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -15,7 +15,6 @@ open Names open Constr open Globnames open Declarations -open Decl_kinds open Lib open Libobject open EConstr @@ -486,12 +485,19 @@ let subst_implicits_decl subst (r,imps as o) = let subst_implicits (subst,(req,l)) = (ImplLocal,List.Smart.map (subst_implicits_decl subst) l) +(* This was moved out of lib.ml, however it is not stored with regular + implicit data *) +let sec_implicits = + Summary.ref Id.Map.empty ~name:"section-implicits" + let impls_of_context ctx = - let map (decl, impl) = match impl with - | Implicit -> Some (NamedDecl.get_id decl, Manual, (true, true)) - | _ -> None + let map decl = + let id = NamedDecl.get_id decl in + match Id.Map.get id !sec_implicits with + | Glob_term.Implicit -> Some (id, Manual, (true, true)) + | Glob_term.Explicit -> None in - List.rev_map map (List.filter (fst %> NamedDecl.is_local_assum) ctx) + List.rev_map map (List.filter (NamedDecl.is_local_assum) ctx) let adjust_side_condition p = function | LessArgsThan n -> LessArgsThan (n+p) @@ -577,9 +583,10 @@ let declare_implicits local ref = if is_local local ref then ImplLocal else ImplInteractive(flags,ImplAuto) in declare_implicits_gen req flags ref -let declare_var_implicits id = +let declare_var_implicits id ~impl = let flags = !implicit_args in - declare_implicits_gen ImplLocal flags (GlobRef.VarRef id) + sec_implicits := Id.Map.add id impl !sec_implicits; + declare_implicits_gen ImplLocal flags (GlobRef.VarRef id) let declare_constant_implicits con = let flags = !implicit_args in diff --git a/interp/impargs.mli b/interp/impargs.mli index 90a7944642..2751b9d40b 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -93,7 +93,7 @@ val compute_implicits_names : env -> Evd.evar_map -> types -> Name.t list (** {6 Computation of implicits (done using the global environment). } *) -val declare_var_implicits : variable -> unit +val declare_var_implicits : variable -> impl:Glob_term.binding_kind -> unit val declare_constant_implicits : Constant.t -> unit val declare_mib_implicits : MutInd.t -> unit diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 9f6281ae15..455471a472 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -11,7 +11,6 @@ (*i*) open Names open Context -open Decl_kinds open CErrors open Util open Glob_term diff --git a/interp/notation.ml b/interp/notation.ml index d88182241b..a78bc60e83 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1533,7 +1533,7 @@ let discharge_arguments_scope (_,(req,r,n,l,_)) = let n = try let vars = Lib.variable_section_segment_of_reference r in - vars |> List.map fst |> List.filter is_local_assum |> List.length + vars |> List.filter is_local_assum |> List.length with Not_found (* Not a ref defined in this section *) -> 0 in Some (req,r,n,l,[]) diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 2fa78bb9f3..f30a874426 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -15,7 +15,6 @@ open Names open Nameops open Constr open Globnames -open Decl_kinds open Namegen open Glob_term open Glob_ops diff --git a/kernel/declarations.ml b/kernel/declarations.ml index dff19dee5e..8d32684b09 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -66,6 +66,10 @@ type typing_flags = { (** If [false] then fixed points and co-fixed points are assumed to be total. *) + check_positive : bool; + (** If [false] then inductive types are assumed positive and co-inductive + types are assumed productive. *) + check_universes : bool; (** If [false] universe constraints are not checked *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 7a553700e8..391b139496 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -19,6 +19,7 @@ module RelDecl = Context.Rel.Declaration let safe_flags oracle = { check_guarded = true; + check_positive = true; check_universes = true; conv_oracle = oracle; share_reduction = true; diff --git a/kernel/environ.ml b/kernel/environ.ml index 9a75f0b682..655094e88b 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -216,6 +216,9 @@ let lookup_named_ctxt id ctxt = let fold_constants f env acc = Cmap_env.fold (fun c (body,_) acc -> f c body acc) env.env_globals.env_constants acc +let fold_inductives f env acc = + Mindmap_env.fold (fun c (body,_) acc -> f c body acc) env.env_globals.env_inductives acc + (* Global constants *) let lookup_constant_key kn env = @@ -418,6 +421,7 @@ let set_engagement c env = (* Unsafe *) (* It's convenient to use [{flags with foo = bar}] so we're smart wrt to it. *) let same_flags { check_guarded; + check_positive; check_universes; conv_oracle; indices_matter; @@ -426,6 +430,7 @@ let same_flags { enable_native_compiler; } alt = check_guarded == alt.check_guarded && + check_positive == alt.check_positive && check_universes == alt.check_universes && conv_oracle == alt.conv_oracle && indices_matter == alt.indices_matter && diff --git a/kernel/environ.mli b/kernel/environ.mli index 6cd4f96645..e6d814ac7d 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -176,6 +176,7 @@ val pop_rel_context : int -> env -> env (** Useful for printing *) val fold_constants : (Constant.t -> Opaqueproof.opaque constant_body -> 'a -> 'a) -> env -> 'a -> 'a +val fold_inductives : (MutInd.t -> Declarations.mutual_inductive_body -> 'a -> 'a) -> env -> 'a -> 'a (** {5 Global constants } {6 Add entries to global environment } *) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index b0366d6ec0..aa3ef715db 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -546,7 +546,7 @@ let check_inductive env kn mie = (* First type-check the inductive definition *) let (env_ar_par, univs, variance, record, paramsctxt, inds) = IndTyping.typecheck_inductive env mie in (* Then check positivity conditions *) - let chkpos = (Environ.typing_flags env).check_guarded in + let chkpos = (Environ.typing_flags env).check_positive in let names = Array.map_of_list (fun entry -> entry.mind_entry_typename, entry.mind_entry_consnames) mie.mind_entry_inds in diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index ea45f699ce..6970a11e72 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -194,6 +194,18 @@ let set_typing_flags c senv = if env == senv.env then senv else { senv with env } +let set_check_guarded b senv = + let flags = Environ.typing_flags senv.env in + set_typing_flags { flags with check_guarded = b } senv + +let set_check_positive b senv = + let flags = Environ.typing_flags senv.env in + set_typing_flags { flags with check_positive = b } senv + +let set_check_universes b senv = + let flags = Environ.typing_flags senv.env in + set_typing_flags { flags with check_universes = b } senv + let set_indices_matter indices_matter senv = set_typing_flags { (Environ.typing_flags senv.env) with indices_matter } senv diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 2406b6add1..fa53fa33fa 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -130,6 +130,9 @@ val set_engagement : Declarations.engagement -> safe_transformer0 val set_indices_matter : bool -> safe_transformer0 val set_typing_flags : Declarations.typing_flags -> safe_transformer0 val set_share_reduction : bool -> safe_transformer0 +val set_check_guarded : bool -> safe_transformer0 +val set_check_positive : bool -> safe_transformer0 +val set_check_universes : bool -> safe_transformer0 val set_VM : bool -> safe_transformer0 val set_native_compiler : bool -> safe_transformer0 val make_sprop_cumulative : safe_transformer0 diff --git a/lib/system.ml b/lib/system.ml index 46b358f825..b1a9efccfc 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -53,8 +53,14 @@ module StrSet = Set.Make(StrMod) let dirmap = ref StrMap.empty let make_dir_table dir = + let entries = + try + Sys.readdir dir + with Sys_error _ -> + warn_cannot_open_dir dir; + [||] in let filter_dotfiles s f = if f.[0] = '.' then s else StrSet.add f s in - Array.fold_left filter_dotfiles StrSet.empty (Sys.readdir dir) + Array.fold_left filter_dotfiles StrSet.empty entries (** Don't trust in interactive mode (the default) *) let trust_file_cache = ref false diff --git a/library/global.ml b/library/global.ml index ca774dbd74..0fc9e11364 100644 --- a/library/global.ml +++ b/library/global.ml @@ -89,6 +89,9 @@ let push_context_set b c = globalize0 (Safe_typing.push_context_set b c) let set_engagement c = globalize0 (Safe_typing.set_engagement c) let set_indices_matter b = globalize0 (Safe_typing.set_indices_matter b) let set_typing_flags c = globalize0 (Safe_typing.set_typing_flags c) +let set_check_guarded c = globalize0 (Safe_typing.set_check_guarded c) +let set_check_positive c = globalize0 (Safe_typing.set_check_positive c) +let set_check_universes c = globalize0 (Safe_typing.set_check_universes c) let typing_flags () = Environ.typing_flags (env ()) let make_sprop_cumulative () = globalize0 Safe_typing.make_sprop_cumulative let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) diff --git a/library/global.mli b/library/global.mli index d034bc4208..b089b7dd80 100644 --- a/library/global.mli +++ b/library/global.mli @@ -31,6 +31,9 @@ val named_context : unit -> Constr.named_context val set_engagement : Declarations.engagement -> unit val set_indices_matter : bool -> unit val set_typing_flags : Declarations.typing_flags -> unit +val set_check_guarded : bool -> unit +val set_check_positive : bool -> unit +val set_check_universes : bool -> unit val typing_flags : unit -> Declarations.typing_flags val make_sprop_cumulative : unit -> unit val set_allow_sprop : bool -> unit diff --git a/library/lib.ml b/library/lib.ml index 59b55cc16b..3f51826315 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -413,11 +413,8 @@ let find_opening_node id = - the list of substitution to do at section closing *) -type variable_info = Constr.named_declaration * Decl_kinds.binding_kind - -type variable_context = variable_info list type abstr_info = { - abstr_ctx : variable_context; + abstr_ctx : Constr.named_context; abstr_subst : Univ.Instance.t; abstr_uctx : Univ.AUContext.t; } @@ -426,21 +423,17 @@ type abstr_list = abstr_info Names.Cmap.t * abstr_info Names.Mindmap.t type secentry = | Variable of { id:Names.Id.t; - kind:Decl_kinds.binding_kind; - univs:Univ.ContextSet.t; } | Context of Univ.ContextSet.t type section_data = { sec_entry : secentry list; - sec_workl : Opaqueproof.work_list; sec_abstr : abstr_list; sec_poly : bool; } let empty_section_data ~poly = { sec_entry = []; - sec_workl = (Names.Cmap.empty,Names.Mindmap.empty); sec_abstr = (Names.Cmap.empty,Names.Mindmap.empty); sec_poly = poly; } @@ -456,12 +449,12 @@ let add_section ~poly () = List.iter (fun tab -> check_same_poly poly tab) !sectab; sectab := empty_section_data ~poly :: !sectab -let add_section_variable ~name ~kind ~poly univs = +let add_section_variable ~name ~poly = match !sectab with | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) | s :: sl -> List.iter (fun tab -> check_same_poly poly tab) !sectab; - let s = { s with sec_entry = Variable {id=name;kind;univs} :: s.sec_entry } in + let s = { s with sec_entry = Variable {id=name} :: s.sec_entry } in sectab := s :: sl let add_section_context ctx = @@ -472,38 +465,45 @@ let add_section_context ctx = let s = { s with sec_entry = Context ctx :: s.sec_entry } in sectab := s :: sl -exception PolyFound of bool (* make this a let exception once possible *) +exception PolyFound (* make this a let exception once possible *) let is_polymorphic_univ u = try let open Univ in List.iter (fun s -> let vars = s.sec_entry in List.iter (function - | Variable {univs=(univs,_)} -> - if LSet.mem u univs then raise (PolyFound s.sec_poly) + | Variable _ -> () | Context (univs,_) -> - if LSet.mem u univs then raise (PolyFound true) + if LSet.mem u univs then raise PolyFound ) vars ) !sectab; false - with PolyFound b -> b + with PolyFound -> true let extract_hyps poly (secs,ohyps) = let rec aux = function - | (Variable {id;kind;univs}::idl, decl::hyps) when Names.Id.equal id (NamedDecl.get_id decl) -> + | (Variable {id}::idl, decl::hyps) when Names.Id.equal id (NamedDecl.get_id decl) -> let l, r = aux (idl,hyps) in - (decl,kind) :: l, if poly then Univ.ContextSet.union r univs else r - | (Variable {univs}::idl,hyps) -> + decl :: l, r + | (Variable _::idl,hyps) -> let l, r = aux (idl,hyps) in - l, if poly then Univ.ContextSet.union r univs else r + l, r | (Context ctx :: idl, hyps) -> + let () = assert poly in let l, r = aux (idl, hyps) in l, Univ.ContextSet.union r ctx | [], _ -> [],Univ.ContextSet.empty in aux (secs,ohyps) let instance_from_variable_context = - List.map fst %> List.filter is_local_assum %> List.map NamedDecl.get_id %> Array.of_list + List.rev %> List.filter is_local_assum %> List.map NamedDecl.get_id %> Array.of_list + +let extract_worklist info = + let args = instance_from_variable_context info.abstr_ctx in + info.abstr_subst, args + +let make_worklist (cmap, mmap) = + Cmap.map extract_worklist cmap, Mindmap.map extract_worklist mmap let name_instance inst = (* FIXME: this should probably be done at an upper level, by storing the @@ -522,37 +522,34 @@ let name_instance inst = in Array.map map (Univ.Instance.to_array inst) -let add_section_replacement f g poly hyps = +let add_section_replacement g poly hyps = match !sectab with | [] -> () | s :: sl -> let () = check_same_poly poly s in let sechyps,ctx = extract_hyps s.sec_poly (s.sec_entry, hyps) in let ctx = Univ.ContextSet.to_context ctx in - let inst = Univ.UContext.instance ctx in - let nas = name_instance inst in + let nas = name_instance (Univ.UContext.instance ctx) in let subst, ctx = Univ.abstract_universes nas ctx in - let args = instance_from_variable_context (List.rev sechyps) in let info = { abstr_ctx = sechyps; abstr_subst = subst; abstr_uctx = ctx; } in let s = { s with - sec_workl = f (inst, args) s.sec_workl; sec_abstr = g info s.sec_abstr; } in sectab := s :: sl let add_section_kn ~poly kn = let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in - add_section_replacement f f poly + add_section_replacement f poly let add_section_constant ~poly kn = let f x (l1,l2) = (Names.Cmap.add kn x l1,l2) in - add_section_replacement f f poly + add_section_replacement f poly -let replacement_context () = (List.hd !sectab).sec_workl +let replacement_context () = make_worklist (List.hd !sectab).sec_abstr let section_segment_of_constant con = Names.Cmap.find con (fst (List.hd !sectab).sec_abstr) @@ -585,9 +582,11 @@ let section_instance = let open GlobRef in function then Univ.Instance.empty, [||] else raise Not_found | ConstRef con -> - Names.Cmap.find con (fst (List.hd !sectab).sec_workl) + let data = Names.Cmap.find con (fst (List.hd !sectab).sec_abstr) in + extract_worklist data | IndRef (kn,_) | ConstructRef ((kn,_),_) -> - Names.Mindmap.find kn (snd (List.hd !sectab).sec_workl) + let data = Names.Mindmap.find kn (snd (List.hd !sectab).sec_abstr) in + extract_worklist data let is_in_section ref = try ignore (section_instance ref); true with Not_found -> false diff --git a/library/lib.mli b/library/lib.mli index fe6bf69ec4..9ffa69ef93 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -163,10 +163,8 @@ val drop_objects : frozen -> frozen val init : unit -> unit (** {6 Section management for discharge } *) -type variable_info = Constr.named_declaration * Decl_kinds.binding_kind -type variable_context = variable_info list type abstr_info = private { - abstr_ctx : variable_context; + abstr_ctx : Constr.named_context; (** Section variables of this prefix *) abstr_subst : Univ.Instance.t; (** Actual names of the abstracted variables *) @@ -174,18 +172,16 @@ type abstr_info = private { (** Universe quantification, same length as the substitution *) } -val instance_from_variable_context : variable_context -> Id.t array - val section_segment_of_constant : Constant.t -> abstr_info val section_segment_of_mutual_inductive: MutInd.t -> abstr_info val section_segment_of_reference : GlobRef.t -> abstr_info -val variable_section_segment_of_reference : GlobRef.t -> variable_context +val variable_section_segment_of_reference : GlobRef.t -> Constr.named_context val section_instance : GlobRef.t -> Univ.Instance.t * Id.t array val is_in_section : GlobRef.t -> bool -val add_section_variable : name:Id.t -> kind:Decl_kinds.binding_kind -> poly:bool -> Univ.ContextSet.t -> unit +val add_section_variable : name:Id.t -> poly:bool -> unit val add_section_context : Univ.ContextSet.t -> unit val add_section_constant : poly:bool -> Constant.t -> Constr.named_context -> unit val add_section_kn : poly:bool -> MutInd.t -> Constr.named_context -> unit diff --git a/library/library.mllib b/library/library.mllib index 35af5fa43b..3b75438ccd 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -1,4 +1,3 @@ -Decl_kinds Libnames Globnames Libobject @@ -11,5 +10,4 @@ Library States Kindops Goptions -Keys Coqlib diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index a27d6450b7..de23f05a9e 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -785,12 +785,14 @@ let next_token ~diff_mode loc s = (* Location table system for creating tables associating a token count to its location in a char stream (the source) *) -let locerr () = invalid_arg "Lexer: location function" +let locerr i = + let m = "Lexer: location function called on token "^string_of_int i in + invalid_arg m let loct_create () = Hashtbl.create 207 let loct_func loct i = - try Hashtbl.find loct i with Not_found -> locerr () + try Hashtbl.find loct i with Not_found -> locerr i let loct_add loct i loc = Hashtbl.add loct i loc diff --git a/parsing/dune b/parsing/dune index 2bb8611e09..8a31434101 100644 --- a/parsing/dune +++ b/parsing/dune @@ -4,12 +4,4 @@ (wrapped false) (libraries coq.gramlib interp)) -(rule - (targets g_prim.ml) - (deps (:mlg-file g_prim.mlg)) - (action (run coqpp %{mlg-file}))) - -(rule - (targets g_constr.ml) - (deps (:mlg-file g_constr.mlg)) - (action (run coqpp %{mlg-file}))) +(coq.pp (modules g_prim g_constr)) diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 8fdec7d1a8..ea44e748c9 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -19,7 +19,6 @@ open Constrexpr_ops open Util open Tok open Namegen -open Decl_kinds open Pcoq open Pcoq.Prim @@ -84,7 +83,7 @@ let err () = raise Stream.Failure (* admissible notation "(x t)" *) let lpar_id_coloneq = Pcoq.Entry.of_parser "test_lpar_id_coloneq" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | KEYWORD "(" -> (match stream_nth 1 strm with @@ -99,7 +98,7 @@ let lpar_id_coloneq = let impl_ident_head = Pcoq.Entry.of_parser "impl_ident_head" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | KEYWORD "{" -> (match stream_nth 1 strm with @@ -112,7 +111,7 @@ let impl_ident_head = let name_colon = Pcoq.Entry.of_parser "name_colon" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | IDENT s -> (match stream_nth 1 strm with diff --git a/parsing/g_prim.mlg b/parsing/g_prim.mlg index c1f52c5b39..020501aedf 100644 --- a/parsing/g_prim.mlg +++ b/parsing/g_prim.mlg @@ -31,10 +31,35 @@ let my_int_of_string loc s = with Failure _ -> CErrors.user_err ~loc (Pp.str "This number is too large.") -let check_nospace loc expected = - let (bp, ep) = Loc.unloc loc in - if ep = bp + String.length expected then () else - Gramlib.Ploc.raise loc (Stream.Error ("'" ^ expected ^ "' expected")) +let rec contiguous tok n m = + n == m + || + let (_, ep) = Loc.unloc (tok n) in + let (bp, _) = Loc.unloc (tok (n + 1)) in + Int.equal ep bp && contiguous tok (succ n) m + +let rec lookahead_kwds strm n = function + | [] -> () + | x :: xs -> + let toks = Stream.npeek (n+1) strm in + match List.nth toks n with + | Tok.KEYWORD y -> + if String.equal x y then lookahead_kwds strm (succ n) xs + else raise Stream.Failure + | _ -> raise Stream.Failure + | exception (Failure _) -> raise Stream.Failure + +(* [test_nospace m] fails if the next m tokens are not contiguous keywords *) +let test_nospace m = assert(m <> []); Pcoq.Entry.of_parser "test_nospace" + (fun tok strm -> + let n = Stream.count strm in + lookahead_kwds strm 0 m; + if contiguous tok n (n + List.length m - 1) then () + else raise Stream.Failure) + +let test_nospace_pipe_closedcurly = + test_nospace ["|"; "}"] + } @@ -130,6 +155,6 @@ GRAMMAR EXTEND Gram [ [ i = NUMERAL -> { check_int loc i } ] ] ; bar_cbrace: - [ [ "|"; "}" -> { check_nospace loc "|}" } ] ] + [ [ test_nospace_pipe_closedcurly; "|"; "}" -> { () } ] ] ; END diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index cde867d2ef..7efeab6ba0 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -29,7 +29,7 @@ module Entry : sig val create : string -> 'a t val parse : 'a t -> Parsable.t -> 'a val print : Format.formatter -> 'a t -> unit - val of_parser : string -> (Tok.t Stream.t -> 'a) -> 'a t + val of_parser : string -> (Gramlib.Plexing.location_function -> Tok.t Stream.t -> 'a) -> 'a t val parse_token_stream : 'a t -> Tok.t Stream.t -> 'a val name : 'a t -> string end diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 08298bf02c..5a939b4adf 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -18,77 +18,6 @@ open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration -(* let msgnl = Pp.msgnl *) - -(* -let observe strm = - if do_observe () - then Pp.msg_debug strm - else () - -let do_observe_tac s tac g = - try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v - with e -> - let e = ExplainErr.process_vernac_interp_error e in - let goal = begin try (Printer.pr_goal g) with _ -> assert false end in - msg_debug (str "observation "++ s++str " raised exception " ++ - Errors.print e ++ str " on goal " ++ goal ); - raise e;; - -let observe_tac_stream s tac g = - if do_observe () - then do_observe_tac s tac g - else tac g - -let observe_tac s tac g = observe_tac_stream (str s) tac g - *) - - -let debug_queue = Stack.create () - -let rec print_debug_queue e = - if not (Stack.is_empty debug_queue) - then - begin - let lmsg,goal = Stack.pop debug_queue in - let _ = - match e with - | Some e -> - Feedback.msg_debug (hov 0 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) - | None -> - begin - Feedback.msg_debug (str " from " ++ lmsg ++ str " on goal" ++ fnl() ++ goal); - end in - print_debug_queue None ; - end - -let observe strm = - if do_observe () - then Feedback.msg_debug strm - else () - -let do_observe_tac s tac g = - let goal = Printer.pr_goal g in - let lmsg = (str "observation : ") ++ s in - Stack.push (lmsg,goal) debug_queue; - try - let v = tac g in - ignore(Stack.pop debug_queue); - v - with reraise -> - let reraise = CErrors.push reraise in - if not (Stack.is_empty debug_queue) - then print_debug_queue (Some (fst reraise)); - iraise reraise - -let observe_tac_stream s tac g = - if do_observe () - then do_observe_tac s tac g - else tac g - -let observe_tac s = observe_tac_stream (str s) - - let list_chop ?(msg="") n l = try List.chop n l @@ -120,6 +49,7 @@ type 'a dynamic_info = type body_info = constr dynamic_info +let observe_tac s = observe_tac (fun _ _ -> Pp.str s) let finish_proof dynamic_infos g = observe_tac "finish" @@ -171,7 +101,7 @@ let is_incompatible_eq env sigma t = | _ -> false with e when CErrors.noncritical e -> false in - if res then observe (str "is_incompatible_eq " ++ pr_leconstr_env env sigma t); + if res then observe (str "is_incompatible_eq " ++ pr_leconstr_env env sigma t); res let change_hyp_with_using msg hyp_id t tac : tactic = @@ -843,7 +773,8 @@ let build_proof | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - observe_tac_stream (str "build_proof with " ++ pr_leconstr_env (pf_env g) (project g) dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g + Indfun_common.observe_tac (fun env sigma -> + str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g and build_proof_args env sigma do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> let (f_args',args) = dyn_infos.info in @@ -1232,7 +1163,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam if this_fix_info.idx + 1 = 0 then tclIDTAC (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) else - observe_tac_stream (str "h_fix " ++ int (this_fix_info.idx +1) ) (Proofview.V82.of_tactic (fix this_fix_info.name (this_fix_info.idx +1))) + Indfun_common.observe_tac (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx +1)) + (Proofview.V82.of_tactic (fix this_fix_info.name (this_fix_info.idx +1))) else Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) other_fix_infos 0) @@ -1476,13 +1408,14 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = (observe_tac "finishing using" ( tclCOMPLETE( - Eauto.eauto_with_bases - (true,5) - [(fun _ sigma -> (sigma, Lazy.force refl_equal))] - [Hints.Hint_db.empty TransparentState.empty false] - ) - ) - ) + Proofview.V82.of_tactic @@ + Eauto.eauto_with_bases + (true,5) + [(fun _ sigma -> (sigma, Lazy.force refl_equal))] + [Hints.Hint_db.empty TransparentState.empty false] + ) + ) + ) ] ) ] @@ -1538,7 +1471,9 @@ let prove_principle_for_gen let wf_tac = if is_mes then - (fun b -> Recdef.tclUSER_if_not_mes tclIDTAC b None) + (fun b -> + Proofview.V82.of_tactic @@ + Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None) else fun _ -> prove_with_tcc tcc_lemma_ref [] in let real_rec_arg_num = rec_arg_num - princ_info.nparams in diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index d34faa22fa..797d421c56 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -11,18 +11,15 @@ open Printer open CErrors open Term -open Sorts open Util open Constr open Context open Vars -open Namegen open Names open Pp open Tactics open Context.Rel.Declaration open Indfun_common -open Functional_principles_proofs module RelDecl = Context.Rel.Declaration @@ -258,449 +255,3 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = new_predicates) ) (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_type_info.params) - - - -let change_property_sort evd toSort princ princName = - let open Context.Rel.Declaration in - let princ = EConstr.of_constr princ in - let princ_info = compute_elim_sig evd princ in - let change_sort_in_predicate decl = - LocalAssum - (get_annot decl, - let args,ty = decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) in - let s = destSort ty in - Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty); - Term.compose_prod args (mkSort toSort) - ) - in - let evd,princName_as_constr = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in - let init = - let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in - mkApp(EConstr.Unsafe.to_constr princName_as_constr, - Array.init nargs - (fun i -> mkRel (nargs - i ))) - in - evd, it_mkLambda_or_LetIn - (it_mkLambda_or_LetIn init - (List.map change_sort_in_predicate princ_info.predicates) - ) - (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.params) - -let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook = - (* First we get the type of the old graph principle *) - let mutr_nparams = (compute_elim_sig !evd (EConstr.of_constr old_princ_type)).nparams in - (* let time1 = System.get_time () in *) - let new_principle_type = - compute_new_princ_type_from_rel - (Array.map mkConstU funs) - sorts - old_princ_type - in - (* let time2 = System.get_time () in *) - (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) - let new_princ_name = - next_ident_away_in_goal (Id.of_string "___________princ_________") Id.Set.empty - in - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in - evd := sigma; - let hook = DeclareDef.Hook.make (hook new_principle_type) in - let lemma = - Lemmas.start_lemma - ~name:new_princ_name - ~poly:false - !evd - (EConstr.of_constr new_principle_type) - in - (* let _tim1 = System.get_time () in *) - let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - let lemma,_ = Lemmas.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) lemma in - (* let _tim2 = System.get_time () in *) - (* begin *) - (* let dur1 = System.time_difference tim1 tim2 in *) - (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) - (* end; *) - - let open Proof_global in - let { name; entries } = Lemmas.pf_fold (close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x)) lemma in - match entries with - | [entry] -> - name, entry, hook - | _ -> - CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") - -let generate_functional_principle (evd: Evd.evar_map ref) - interactive_proof - old_princ_type sorts new_princ_name funs i proof_tac - = - try - - let f = funs.(i) in - let sigma, type_sort = Evd.fresh_sort_in_family !evd InType in - evd := sigma; - let new_sorts = - match sorts with - | None -> Array.make (Array.length funs) (type_sort) - | Some a -> a - in - let base_new_princ_name,new_princ_name = - match new_princ_name with - | Some (id) -> id,id - | None -> - let id_of_f = Label.to_id (Constant.label (fst f)) in - id_of_f,Indrec.make_elimination_ident id_of_f (Sorts.family type_sort) - in - let names = ref [new_princ_name] in - let hook = - fun new_principle_type _ -> - if Option.is_empty sorts - then - (* let id_of_f = Label.to_id (con_label f) in *) - let register_with_sort fam_sort = - let evd' = Evd.from_env (Global.env ()) in - let evd',s = Evd.fresh_sort_in_family evd' fam_sort in - let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in - let evd',value = change_property_sort evd' s new_principle_type new_princ_name in - let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in - (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let univs = Evd.univ_entry ~poly:false evd' in - let ce = Declare.definition_entry ~univs value in - ignore( - Declare.declare_constant - ~name - ~kind:Decls.(IsDefinition Scheme) - (Declare.DefinitionEntry ce) - ); - Declare.definition_message name; - names := name :: !names - in - register_with_sort InProp; - register_with_sort InSet - in - let id,entry,hook = - build_functional_principle evd interactive_proof old_princ_type new_sorts funs i - proof_tac hook - in - (* Pr 1278 : - Don't forget to close the goal if an error is raised !!!! - *) - let uctx = Evd.evar_universe_context sigma in - save new_princ_name entry ~hook uctx (DeclareDef.Global Declare.ImportDefaultBehavior) Decls.(IsProof Theorem) - with e when CErrors.noncritical e -> - raise (Defining_principle e) - -exception Not_Rec - -let get_funs_constant mp = - let get_funs_constant const e : (Names.Constant.t*int) array = - match Constr.kind ((strip_lam e)) with - | Fix((_,(na,_,_))) -> - Array.mapi - (fun i na -> - match na.binder_name with - | Name id -> - let const = Constant.make2 mp (Label.of_id id) in - const,i - | Anonymous -> - anomaly (Pp.str "Anonymous fix.") - ) - na - | _ -> [|const,0|] - in - function const -> - let find_constant_body const = - match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _, _) -> - let body = Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - (Global.env ()) - (Evd.from_env (Global.env ())) - (EConstr.of_constr body) - in - let body = EConstr.Unsafe.to_constr body in - body - | None -> user_err Pp.(str ( "Cannot define a principle over an axiom ")) - in - let f = find_constant_body const in - let l_const = get_funs_constant const f in - (* - We need to check that all the functions found are in the same block - to prevent Reset strange thing - *) - let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in - let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in - (* all the parameters must be equal*) - let _check_params = - let first_params = List.hd l_params in - List.iter - (fun params -> - if not (List.equal (fun (n1, c1) (n2, c2) -> - eq_annot Name.equal n1 n2 && Constr.equal c1 c2) first_params params) - then user_err Pp.(str "Not a mutal recursive block") - ) - l_params - in - (* The bodies has to be very similar *) - let _check_bodies = - try - let extract_info is_first body = - match Constr.kind body with - | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) - | _ -> - if is_first && Int.equal (List.length l_bodies) 1 - then raise Not_Rec - else user_err Pp.(str "Not a mutal recursive block") - in - let first_infos = extract_info true (List.hd l_bodies) in - let check body = (* Hope this is correct *) - let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = - Array.equal Int.equal ia1 ia2 && Array.equal (eq_annot Name.equal) na1 na2 && - Array.equal Constr.equal ta1 ta2 && Array.equal Constr.equal ca1 ca2 - in - if not (eq_infos first_infos (extract_info false body)) - then user_err Pp.(str "Not a mutal recursive block") - in - List.iter check l_bodies - with Not_Rec -> () - in - l_const - -exception No_graph_found -exception Found_type of int - -let make_scheme evd (fas : (pconstant*Sorts.family) list) : Evd.side_effects Proof_global.proof_entry list = - let env = Global.env () in - let funs = List.map fst fas in - let first_fun = List.hd funs in - let funs_mp = KerName.modpath (Constant.canonical (fst first_fun)) in - let first_fun_kn = - try - fst (find_Function_infos (fst first_fun)).graph_ind - with Not_found -> raise No_graph_found - in - let this_block_funs_indexes = get_funs_constant funs_mp (fst first_fun) in - let this_block_funs = Array.map (fun (c,_) -> (c,snd first_fun)) this_block_funs_indexes in - let prop_sort = InProp in - let funs_indexes = - let this_block_funs_indexes = Array.to_list this_block_funs_indexes in - List.map - (function cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) - funs - in - let ind_list = - List.map - (fun (idx) -> - let ind = first_fun_kn,idx in - (ind,snd first_fun),true,prop_sort - ) - funs_indexes - in - let sigma, schemes = - Indrec.build_mutual_induction_scheme env !evd ind_list - in - let _ = evd := sigma in - let l_schemes = - List.map (EConstr.of_constr %> Typing.unsafe_type_of env sigma %> EConstr.Unsafe.to_constr) schemes - in - let i = ref (-1) in - let sorts = - List.rev_map (fun (_,x) -> - let sigma, fs = Evd.fresh_sort_in_family !evd x in - evd := sigma; fs - ) - fas - in - (* We create the first principle by tactic *) - let first_type,other_princ_types = - match l_schemes with - s::l_schemes -> s,l_schemes - | _ -> anomaly (Pp.str "") - in - let _,const,_ = - try - build_functional_principle evd false - first_type - (Array.of_list sorts) - this_block_funs - 0 - (prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) - (fun _ _ -> ()) - with e when CErrors.noncritical e -> - raise (Defining_principle e) - - in - incr i; - let opacity = - let finfos = find_Function_infos (fst first_fun) in - try - let equation = Option.get finfos.equation_lemma in - Declareops.is_opaque (Global.lookup_constant equation) - with Option.IsNone -> (* non recursive definition *) - false - in - let const = {const with Proof_global.proof_entry_opaque = opacity } in - (* The others are just deduced *) - if List.is_empty other_princ_types - then - [const] - else - let other_fun_princ_types = - let funs = Array.map mkConstU this_block_funs in - let sorts = Array.of_list sorts in - List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types - in - let open Proof_global in - let first_princ_body,first_princ_type = const.proof_entry_body, const.proof_entry_type in - let ctxt,fix = decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) - let (idxs,_),(_,ta,_ as decl) = destFix fix in - let other_result = - List.map (* we can now compute the other principles *) - (fun scheme_type -> - incr i; - observe (Printer.pr_lconstr_env env sigma scheme_type); - let type_concl = (strip_prod_assum scheme_type) in - let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in - let f = fst (decompose_app applied_f) in - try (* we search the number of the function in the fix block (name of the function) *) - Array.iteri - (fun j t -> - let t = (strip_prod_assum t) in - let applied_g = List.hd (List.rev (snd (decompose_app t))) in - let g = fst (decompose_app applied_g) in - if Constr.equal f g - then raise (Found_type j); - observe (Printer.pr_lconstr_env env sigma f ++ str " <> " ++ - Printer.pr_lconstr_env env sigma g) - - ) - ta; - (* If we reach this point, the two principle are not mutually recursive - We fall back to the previous method - *) - let _,const,_ = - build_functional_principle - evd - false - (List.nth other_princ_types (!i - 1)) - (Array.of_list sorts) - this_block_funs - !i - (prove_princ_for_struct evd false !i (Array.of_list (List.map fst funs))) - (fun _ _ -> ()) - in - const - with Found_type i -> - let princ_body = - Termops.it_mkLambda_or_LetIn (mkFix((idxs,i),decl)) ctxt - in - {const with - proof_entry_body = - (Future.from_val ((princ_body, Univ.ContextSet.empty), Evd.empty_side_effects)); - proof_entry_type = Some scheme_type - } - ) - other_fun_princ_types - in - const::other_result - -let build_scheme fas = - let evd = (ref (Evd.from_env (Global.env ()))) in - let pconstants = (List.map - (fun (_,f,sort) -> - let f_as_constant = - try - Smartlocate.global_with_alias f - with Not_found -> - user_err ~hdr:"FunInd.build_scheme" - (str "Cannot find " ++ Libnames.pr_qualid f) - in - let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in - let _ = evd := evd' in - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in - evd := sigma; - let c, u = - try EConstr.destConst !evd f - with DestKO -> - user_err Pp.(pr_econstr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function") - in - (c, EConstr.EInstance.kind !evd u), sort - ) - fas - ) in - let bodies_types = - make_scheme evd pconstants - in - - List.iter2 - (fun (princ_id,_,_) def_entry -> - ignore - (Declare.declare_constant - ~name:princ_id - ~kind:Decls.(IsProof Theorem) - (Declare.DefinitionEntry def_entry)); - Declare.definition_message princ_id - ) - fas - bodies_types - -let build_case_scheme fa = - let env = Global.env () - and sigma = (Evd.from_env (Global.env ())) in -(* let id_to_constr id = *) -(* Constrintern.global_reference id *) -(* in *) - let funs = - let (_,f,_) = fa in - try (let open GlobRef in - match Smartlocate.global_with_alias f with - | ConstRef c -> c - | IndRef _ | ConstructRef _ | VarRef _ -> assert false) - with Not_found -> - user_err ~hdr:"FunInd.build_case_scheme" - (str "Cannot find " ++ Libnames.pr_qualid f) in - let sigma, (_,u) = Evd.fresh_constant_instance env sigma funs in - let first_fun = funs in - let funs_mp = Constant.modpath first_fun in - let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in - let this_block_funs_indexes = get_funs_constant funs_mp first_fun in - let this_block_funs = Array.map (fun (c,_) -> (c,u)) this_block_funs_indexes in - let prop_sort = 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 - in - let (ind, sf) = - let ind = first_fun_kn,funs_indexes in - (ind,Univ.Instance.empty)(*FIXME*),prop_sort - in - let (sigma, scheme) = - Indrec.build_case_analysis_scheme_default env sigma ind sf - in - let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in - let sorts = - (fun (_,_,x) -> - fst @@ UnivGen.fresh_sort_in_family x - ) - fa - in - let princ_name = (fun (x,_,_) -> x) fa in - let _ = - (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ - pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs - ); - *) - generate_functional_principle - (ref (Evd.from_env (Global.env ()))) - false - scheme_type - (Some ([|sorts|])) - (Some princ_name) - this_block_funs - 0 - (prove_princ_for_struct (ref (Evd.from_env (Global.env ()))) false 0 [|funs|]) - in - () - - diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index 7cadd4396d..6f060b0146 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -8,35 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Names -open Constr - -val generate_functional_principle : - Evd.evar_map ref -> - (* do we accept interactive proving *) - bool -> - (* induction principle on rel *) - types -> - (* *) - Sorts.t array option -> - (* Name of the new principle *) - (Id.t) option -> - (* the compute functions to use *) - pconstant array -> - (* We prove the nth- principle *) - int -> - (* The tactic to use to make the proof w.r - the number of params - *) - (EConstr.constr array -> int -> Tacmach.tactic) -> - unit - -exception No_graph_found - -val make_scheme - : Evd.evar_map ref - -> (pconstant*Sorts.family) list - -> Evd.side_effects Proof_global.proof_entry list - -val build_scheme : (Id.t*Libnames.qualid*Sorts.family) list -> unit -val build_case_scheme : (Id.t*Libnames.qualid*Sorts.family) -> unit +val compute_new_princ_type_from_rel + : Constr.constr array + -> Sorts.t array + -> Constr.t + -> Constr.types diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 1b75d3d966..92a93489f4 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -64,7 +64,7 @@ END TACTIC EXTEND newfuninv | [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> { - Proofview.V82.tactic (Invfun.invfun hyp fname) + Invfun.invfun hyp fname } END @@ -180,7 +180,7 @@ let is_proof_termination_interactively_checked recsl = let classify_as_Fixpoint recsl = Vernac_classifier.classify_vernac - (Vernacexpr.(CAst.make @@ VernacExpr([], VernacFixpoint(NoDischarge, List.map snd recsl)))) + (Vernacexpr.(CAst.make @@ { control = []; attrs = []; expr = VernacFixpoint(NoDischarge, List.map snd recsl)})) let classify_funind recsl = match classify_as_Fixpoint recsl with @@ -202,10 +202,10 @@ VERNAC COMMAND EXTEND Function STATE CUSTOM -> { if is_interactive recsl then Vernacextend.VtOpenProof (fun () -> - do_generate_principle_interactive (List.map snd recsl)) + Gen_principle.do_generate_principle_interactive (List.map snd recsl)) else Vernacextend.VtDefault (fun () -> - do_generate_principle (List.map snd recsl)) } + Gen_principle.do_generate_principle (List.map snd recsl)) } END { @@ -226,15 +226,15 @@ END let warning_error names e = match e with - | Building_graph e -> - let names = pr_enum Libnames.pr_qualid names in - let error = if do_observe () then (spc () ++ CErrors.print e) else mt () in - warn_cannot_define_graph (names,error) - | Defining_principle e -> - let names = pr_enum Libnames.pr_qualid names in - let error = if do_observe () then CErrors.print e else mt () in - warn_cannot_define_principle (names,error) - | _ -> raise e + | Building_graph e -> + let names = pr_enum Libnames.pr_qualid names in + let error = if do_observe () then (spc () ++ CErrors.print e) else mt () in + Gen_principle.warn_cannot_define_graph (names,error) + | Defining_principle e -> + let names = pr_enum Libnames.pr_qualid names in + let error = if do_observe () then CErrors.print e else mt () in + Gen_principle.warn_cannot_define_principle (names,error) + | _ -> raise e } @@ -244,17 +244,17 @@ VERNAC COMMAND EXTEND NewFunctionalScheme -> { begin try - Functional_principles_types.build_scheme fas + Gen_principle.build_scheme fas with - | Functional_principles_types.No_graph_found -> + | Gen_principle.No_graph_found -> begin match fas with | (_,fun_name,_)::_ -> begin - make_graph (Smartlocate.global_with_alias fun_name); - try Functional_principles_types.build_scheme fas + Gen_principle.make_graph (Smartlocate.global_with_alias fun_name); + try Gen_principle.build_scheme fas with - | Functional_principles_types.No_graph_found -> + | Gen_principle.No_graph_found -> CErrors.user_err Pp.(str "Cannot generate induction principle(s)") | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in @@ -273,11 +273,11 @@ END VERNAC COMMAND EXTEND NewFunctionalCase | ["Functional" "Case" fun_scheme_arg(fas) ] => { Vernacextend.(VtSideff([pi1 fas], VtLater)) } - -> { Functional_principles_types.build_case_scheme fas } + -> { Gen_principle.build_case_scheme fas } END (***** debug only ***) VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY | ["Generate" "graph" "for" reference(c)] -> - { make_graph (Smartlocate.global_with_alias c) } + { Gen_principle.make_graph (Smartlocate.global_with_alias c) } END diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml new file mode 100644 index 0000000000..a836335d4d --- /dev/null +++ b/plugins/funind/gen_principle.ml @@ -0,0 +1,2069 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Names + +open Indfun_common + +module RelDecl = Context.Rel.Declaration + +let observe_tac s = observe_tac (fun _ _ -> Pp.str s) + +(* + Construct a fixpoint as a Glob_term + and not as a constr +*) +let rec abstract_glob_constr c = function + | [] -> c + | Constrexpr.CLocalDef (x,b,t)::bl -> Constrexpr_ops.mkLetInC(x,b,t,abstract_glob_constr c bl) + | Constrexpr.CLocalAssum (idl,k,t)::bl -> + List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl + (abstract_glob_constr c bl) + | Constrexpr.CLocalPattern _::bl -> assert false + +let interp_casted_constr_with_implicits env sigma impls c = + Constrintern.intern_gen Pretyping.WithoutTypeConstraint env sigma ~impls c + +let build_newrecursive lnameargsardef = + let env0 = Global.env() in + let sigma = Evd.from_env env0 in + let (rec_sign,rec_impls) = + List.fold_left + (fun (env,impls) { Vernacexpr.fname={CAst.v=recname}; binders; rtype } -> + let arityc = Constrexpr_ops.mkCProdN binders rtype in + let arity,ctx = Constrintern.interp_type env0 sigma arityc in + let evd = Evd.from_env env0 in + let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd binders in + let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in + let open Context.Named.Declaration in + let r = Sorts.Relevant in (* TODO relevance *) + (EConstr.push_named (LocalAssum (Context.make_annot recname r,arity)) env, Id.Map.add recname impl impls)) + (env0,Constrintern.empty_internalization_env) lnameargsardef in + let recdef = + (* Declare local notations *) + let f { Vernacexpr.binders; body_def } = + match body_def with + | Some body_def -> + let def = abstract_glob_constr body_def binders in + interp_casted_constr_with_implicits + rec_sign sigma rec_impls def + | None -> CErrors.user_err ~hdr:"Function" (Pp.str "Body of Function must be given") + in + States.with_state_protection (List.map f) lnameargsardef + in + recdef,rec_impls + +(* Checks whether or not the mutual bloc is recursive *) +let is_rec names = + let open Glob_term in + let names = List.fold_right Id.Set.add names Id.Set.empty in + let check_id id names = Id.Set.mem id names in + let rec lookup names gt = match DAst.get gt with + | GVar(id) -> check_id id names + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ -> false + | GCast(b,_) -> lookup names b + | GRec _ -> CErrors.user_err (Pp.str "GRec not handled") + | GIf(b,_,lhs,rhs) -> + (lookup names b) || (lookup names lhs) || (lookup names rhs) + | GProd(na,_,t,b) | GLambda(na,_,t,b) -> + lookup names t || lookup (Nameops.Name.fold_right Id.Set.remove na names) b + | GLetIn(na,b,t,c) -> + lookup names b || Option.cata (lookup names) true t || lookup (Nameops.Name.fold_right Id.Set.remove na names) c + | GLetTuple(nal,_,t,b) -> lookup names t || + lookup + (List.fold_left + (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) + names + nal + ) + b + | GApp(f,args) -> List.exists (lookup names) (f::args) + | GCases(_,_,el,brl) -> + List.exists (fun (e,_) -> lookup names e) el || + List.exists (lookup_br names) brl + and lookup_br names {CAst.v=(idl,_,rt)} = + let new_names = List.fold_right Id.Set.remove idl names in + lookup new_names rt + in + lookup names + +let rec rebuild_bl aux bl typ = + let open Constrexpr in + match bl,typ with + | [], _ -> List.rev aux,typ + | (CLocalAssum(nal,bk,_))::bl',typ -> + rebuild_nal aux bk bl' nal typ + | (CLocalDef(na,_,_))::bl',{ CAst.v = CLetIn(_,nat,ty,typ') } -> + rebuild_bl (Constrexpr.CLocalDef(na,nat,ty)::aux) + bl' typ' + | _ -> assert false +and rebuild_nal aux bk bl' nal typ = + let open Constrexpr in + match nal,typ with + | _,{ CAst.v = CProdN([],typ) } -> rebuild_nal aux bk bl' nal typ + | [], _ -> rebuild_bl aux bl' typ + | na::nal,{ CAst.v = CProdN(CLocalAssum(na'::nal',bk',nal't)::rest,typ') } -> + if Name.equal (na.CAst.v) (na'.CAst.v) || Name.is_anonymous (na'.CAst.v) + then + let assum = CLocalAssum([na],bk,nal't) in + let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in + rebuild_nal + (assum::aux) + bk + bl' + nal + (CAst.make @@ CProdN(new_rest,typ')) + else + let assum = CLocalAssum([na'],bk,nal't) in + let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in + rebuild_nal + (assum::aux) + bk + bl' + (na::nal) + (CAst.make @@ CProdN(new_rest,typ')) + | _ -> + assert false + +let rebuild_bl aux bl typ = rebuild_bl aux bl typ + +let recompute_binder_list fixpoint_exprl = + let fixl = + List.map (fun fix -> Vernacexpr.{ + fix + with rec_order = ComFixpoint.adjust_rec_order ~structonly:false fix.binders fix.rec_order }) fixpoint_exprl in + let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl in + let constr_expr_typel = + with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in + let fixpoint_exprl_with_new_bl = + List.map2 (fun ({ Vernacexpr.binders } as fp) fix_typ -> + let binders, rtype = rebuild_bl [] binders fix_typ in + { fp with Vernacexpr.binders; rtype } + ) fixpoint_exprl constr_expr_typel + in + fixpoint_exprl_with_new_bl + +let rec local_binders_length = function + (* Assume that no `{ ... } contexts occur *) + | [] -> 0 + | Constrexpr.CLocalDef _::bl -> 1 + local_binders_length bl + | Constrexpr.CLocalAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl + | Constrexpr.CLocalPattern _::bl -> assert false + +let prepare_body { Vernacexpr.binders } rt = + let n = local_binders_length binders in + (* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_glob_constr rt); *) + let fun_args,rt' = chop_rlambda_n n rt in + (fun_args,rt') + +let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook = + (* First we get the type of the old graph principle *) + let mutr_nparams = (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)).Tactics.nparams in + (* let time1 = System.get_time () in *) + let new_principle_type = + Functional_principles_types.compute_new_princ_type_from_rel + (Array.map Constr.mkConstU funs) + sorts + old_princ_type + in + (* let time2 = System.get_time () in *) + (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) + let new_princ_name = + Namegen.next_ident_away_in_goal (Id.of_string "___________princ_________") Id.Set.empty + in + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in + evd := sigma; + let hook = DeclareDef.Hook.make (hook new_principle_type) in + let lemma = + Lemmas.start_lemma + ~name:new_princ_name + ~poly:false + !evd + (EConstr.of_constr new_principle_type) + in + (* let _tim1 = System.get_time () in *) + let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in + let lemma,_ = Lemmas.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) lemma in + (* let _tim2 = System.get_time () in *) + (* begin *) + (* let dur1 = System.time_difference tim1 tim2 in *) + (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) + (* end; *) + + let open Proof_global in + let { name; entries } = Lemmas.pf_fold (close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x)) lemma in + match entries with + | [entry] -> + name, entry, hook + | _ -> + CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") + +let change_property_sort evd toSort princ princName = + let open Context.Rel.Declaration in + let princ = EConstr.of_constr princ in + let princ_info = Tactics.compute_elim_sig evd princ in + let change_sort_in_predicate decl = + LocalAssum + (get_annot decl, + let args,ty = Term.decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) in + let s = Constr.destSort ty in + Global.add_constraints (Univ.enforce_leq (Sorts.univ_of_sort toSort) (Sorts.univ_of_sort s) Univ.Constraint.empty); + Term.compose_prod args (Constr.mkSort toSort) + ) + in + let evd,princName_as_constr = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in + let init = + let nargs = (princ_info.Tactics.nparams + (List.length princ_info.Tactics.predicates)) in + Constr.mkApp(EConstr.Unsafe.to_constr princName_as_constr, + Array.init nargs + (fun i -> Constr.mkRel (nargs - i ))) + in + evd, Term.it_mkLambda_or_LetIn + (Term.it_mkLambda_or_LetIn init + (List.map change_sort_in_predicate princ_info.Tactics.predicates) + ) + (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.Tactics.params) + +let generate_functional_principle (evd: Evd.evar_map ref) + interactive_proof + old_princ_type sorts new_princ_name funs i proof_tac + = + try + + let f = funs.(i) in + let sigma, type_sort = Evd.fresh_sort_in_family !evd Sorts.InType in + evd := sigma; + let new_sorts = + match sorts with + | None -> Array.make (Array.length funs) (type_sort) + | Some a -> a + in + let base_new_princ_name,new_princ_name = + match new_princ_name with + | Some (id) -> id,id + | None -> + let id_of_f = Label.to_id (Constant.label (fst f)) in + id_of_f,Indrec.make_elimination_ident id_of_f (Sorts.family type_sort) + in + let names = ref [new_princ_name] in + let hook = + fun new_principle_type _ -> + if Option.is_empty sorts + then + (* let id_of_f = Label.to_id (con_label f) in *) + let register_with_sort fam_sort = + let evd' = Evd.from_env (Global.env ()) in + let evd',s = Evd.fresh_sort_in_family evd' fam_sort in + let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in + let evd',value = change_property_sort evd' s new_principle_type new_princ_name in + let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in + (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) + let univs = Evd.univ_entry ~poly:false evd' in + let ce = Declare.definition_entry ~univs value in + ignore( + Declare.declare_constant + ~name + ~kind:Decls.(IsDefinition Scheme) + (Declare.DefinitionEntry ce) + ); + Declare.definition_message name; + names := name :: !names + in + register_with_sort Sorts.InProp; + register_with_sort Sorts.InSet + in + let id,entry,hook = + build_functional_principle evd interactive_proof old_princ_type new_sorts funs i + proof_tac hook + in + (* Pr 1278 : + Don't forget to close the goal if an error is raised !!!! + *) + let uctx = Evd.evar_universe_context sigma in + save new_princ_name entry ~hook uctx (DeclareDef.Global Declare.ImportDefaultBehavior) Decls.(IsProof Theorem) + with e when CErrors.noncritical e -> + raise (Defining_principle e) + +let generate_principle (evd:Evd.evar_map ref) pconstants on_error + is_general do_built fix_rec_l recdefs interactive_proof + (continue_proof : int -> Names.Constant.t array -> EConstr.constr array -> int -> + Tacmach.tactic) : unit = + let names = List.map (function { Vernacexpr.fname = {CAst.v=name} } -> name) fix_rec_l in + let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in + let funs_args = List.map fst fun_bodies in + let funs_types = List.map (function { Vernacexpr.rtype } -> rtype) fix_rec_l in + try + (* We then register the Inductive graphs of the functions *) + Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types recdefs; + if do_built + then + begin + (*i The next call to mk_rel_id is valid since we have just construct the graph + Ensures by : do_built + i*) + let f_R_mut = Libnames.qualid_of_ident @@ mk_rel_id (List.nth names 0) in + let ind_kn = + fst (locate_with_msg + Pp.(Libnames.pr_qualid f_R_mut ++ str ": Not an inductive type!") + locate_ind + f_R_mut) + in + let fname_kn { Vernacexpr.fname } = + let f_ref = Libnames.qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in + locate_with_msg + Pp.(Libnames.pr_qualid f_ref++str ": Not an inductive type!") + locate_constant + f_ref + in + let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in + let _ = + List.map_i + (fun i x -> + let env = Global.env () in + let princ = Indrec.lookup_eliminator env (ind_kn,i) (Sorts.InProp) in + let evd = ref (Evd.from_env env) in + let evd',uprinc = Evd.fresh_global env !evd princ in + let _ = evd := evd' in + let sigma, princ_type = Typing.type_of ~refresh:true env !evd uprinc in + evd := sigma; + let princ_type = EConstr.Unsafe.to_constr princ_type in + generate_functional_principle + evd + interactive_proof + princ_type + None + None + (Array.of_list pconstants) + (* funs_kn *) + i + (continue_proof 0 [|funs_kn.(i)|]) + ) + 0 + fix_rec_l + in + Array.iter (add_Function is_general) funs_kn; + () + end + with e when CErrors.noncritical e -> + on_error names e + +let register_struct is_rec fixpoint_exprl = + let open EConstr in + match fixpoint_exprl with + | [{ Vernacexpr.fname; univs; binders; rtype; body_def }] when not is_rec -> + let body = + match body_def with + | Some body -> body + | None -> + CErrors.user_err ~hdr:"Function" Pp.(str "Body of Function must be given") in + ComDefinition.do_definition + ~program_mode:false + ~name:fname.CAst.v + ~poly:false + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + ~kind:Decls.Definition univs + binders None body (Some rtype); + let evd,rev_pconstants = + List.fold_left + (fun (evd,l) { Vernacexpr.fname } -> + let evd,c = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in + let (cst, u) = destConst evd c in + let u = EInstance.kind evd u in + evd,((cst, u) :: l) + ) + (Evd.from_env (Global.env ()),[]) + fixpoint_exprl + in + None, evd,List.rev rev_pconstants + | _ -> + ComFixpoint.do_fixpoint ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false fixpoint_exprl; + let evd,rev_pconstants = + List.fold_left + (fun (evd,l) { Vernacexpr.fname } -> + let evd,c = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in + let (cst, u) = destConst evd c in + let u = EInstance.kind evd u in + evd,((cst, u) :: l) + ) + (Evd.from_env (Global.env ()),[]) + fixpoint_exprl + in + None,evd,List.rev rev_pconstants + +let generate_correction_proof_wf f_ref tcc_lemma_ref + is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation + (_: int) (_:Names.Constant.t array) (_:EConstr.constr array) (_:int) : Tacmach.tactic = + Functional_principles_proofs.prove_principle_for_gen + (f_ref,functional_ref,eq_ref) + tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation + +(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] + (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. + + [generate_type true f i] returns + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, + graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion + + [generate_type false f i] returns + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, + res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion +*) + +let generate_type evd g_to_f f graph i = + let open Context.Rel.Declaration in + let open EConstr in + let open EConstr.Vars in + (*i we deduce the number of arguments of the function and its returned type from the graph i*) + let evd',graph = + Evd.fresh_global (Global.env ()) !evd (GlobRef.IndRef (fst (destInd !evd graph))) + in + evd:=evd'; + let sigma, graph_arity = Typing.type_of (Global.env ()) !evd graph in + evd := sigma; + let ctxt,_ = decompose_prod_assum !evd graph_arity in + let fun_ctxt,res_type = + match ctxt with + | [] | [_] -> CErrors.anomaly (Pp.str "Not a valid context.") + | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl + in + let rec args_from_decl i accu = function + | [] -> accu + | LocalDef _ :: l -> + args_from_decl (succ i) accu l + | _ :: l -> + let t = mkRel i in + args_from_decl (succ i) (t :: accu) l + in + (*i We need to name the vars [res] and [fv] i*) + let filter = fun decl -> match RelDecl.get_name decl with + | Name id -> Some id + | Anonymous -> None + in + let named_ctxt = Id.Set.of_list (List.map_filter filter fun_ctxt) in + let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in + let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (Id.Set.add res_id named_ctxt) in + (*i we can then type the argument to be applied to the function [f] i*) + let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in + (*i + the hypothesis [res = fv] can then be computed + We will need to lift it by one in order to use it as a conclusion + i*) + let make_eq = make_eq () in + let res_eq_f_of_args = + mkApp(make_eq ,[|lift 2 res_type;mkRel 1;mkRel 2|]) + in + (*i + The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed + We will need to lift it by one in order to use it as a conclusion + i*) + let args_and_res_as_rels = Array.of_list (args_from_decl 3 [] fun_ctxt) in + let args_and_res_as_rels = Array.append args_and_res_as_rels [|mkRel 1|] in + let graph_applied = mkApp(graph, args_and_res_as_rels) in + (*i The [pre_context] is the defined to be the context corresponding to + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] + i*) + let pre_ctxt = + LocalAssum (Context.make_annot (Name res_id) Sorts.Relevant, lift 1 res_type) :: + LocalDef (Context.make_annot (Name fv_id) Sorts.Relevant, mkApp (f,args_as_rels), res_type) :: fun_ctxt + in + (*i and we can return the solution depending on which lemma type we are defining i*) + if g_to_f + then LocalAssum (Context.make_annot Anonymous Sorts.Relevant,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph + else LocalAssum (Context.make_annot Anonymous Sorts.Relevant,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph + +(** + [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect] + + WARNING: while convertible, [type_of body] and [type] can be non equal +*) +let find_induction_principle evd f = + let f_as_constant,u = match EConstr.kind !evd f with + | Constr.Const c' -> c' + | _ -> CErrors.user_err Pp.(str "Must be used with a function") + in + let infos = find_Function_infos f_as_constant in + match infos.rect_lemma with + | None -> raise Not_found + | Some rect_lemma -> + let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) in + let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in + evd:=evd'; + rect_lemma,typ + +(* [prove_fun_correct funs_constr graphs_constr schemes lemmas_types_infos i ] + is the tactic used to prove correctness lemma. + + [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions + (resp. graphs of the functions and principles and correctness lemma types) to prove correct. + + [i] is the indice of the function to prove correct + + The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is + it looks like~: + [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, + res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res] + + + The sketch of the proof is the following one~: + \begin{enumerate} + \item intros until $x_n$ + \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i) + \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the + apply the corresponding constructor of the corresponding graph inductive. + \end{enumerate} + +*) + +let rec generate_fresh_id x avoid i = + if i == 0 + then [] + else + let id = Namegen.next_ident_away_in_goal x (Id.Set.of_list avoid) in + id::(generate_fresh_id x (id::avoid) (pred i)) + +let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = + let open Constr in + let open EConstr in + let open Context.Rel.Declaration in + let open Tacmach in + let open Tactics in + let open Tacticals in + fun g -> + (* first of all we recreate the lemmas types to be used as predicates of the induction principle + that is~: + \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] + *) + (* we the get the definition of the graphs block *) + let graph_ind,u = destInd evd graphs_constr.(i) in + let kn = fst graph_ind in + let mib,_ = Global.lookup_inductive graph_ind in + (* and the principle to use in this lemma in $\zeta$ normal form *) + let f_principle,princ_type = schemes.(i) in + let princ_type = Reductionops.nf_zeta (Global.env ()) evd princ_type in + let princ_infos = Tactics.compute_elim_sig evd princ_type in + (* The number of args of the function is then easily computable *) + let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in + let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in + let ids = args_names@(pf_ids_of_hyps g) in + (* Since we cannot ensure that the functional principle is defined in the + environment and due to the bug #1174, we will need to pose the principle + using a name + *) + let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") (Id.Set.of_list ids) in + let ids = principle_id :: ids in + (* We get the branches of the principle *) + let branches = List.rev princ_infos.Tactics.branches in + (* and built the intro pattern for each of them *) + let intro_pats = + List.map + (fun decl -> + List.map + (fun id -> CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) + ) + branches + in + (* before building the full intro pattern for the principle *) + let eq_ind = make_eq () in + let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in + (* The next to referencies will be used to find out which constructor to apply in each branch *) + let ind_number = ref 0 + and min_constr_number = ref 0 in + (* The tactic to prove the ith branch of the principle *) + let prove_branche i g = + (* We get the identifiers of this branch *) + let pre_args = + List.fold_right + (fun {CAst.v=pat} acc -> + match pat with + | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id::acc + | _ -> CErrors.anomaly (Pp.str "Not an identifier.") + ) + (List.nth intro_pats (pred i)) + [] + in + (* and get the real args of the branch by unfolding the defined constant *) + (* + We can then recompute the arguments of the constructor. + For each [hid] introduced by this branch, if [hid] has type + $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are + [ fv (hid fv (refl_equal fv)) ]. + If [hid] has another type the corresponding argument of the constructor is [hid] + *) + let constructor_args g = + List.fold_right + (fun hid acc -> + let type_of_hid = pf_unsafe_type_of g (mkVar hid) in + let sigma = project g in + match EConstr.kind sigma type_of_hid with + | Prod(_,_,t') -> + begin + match EConstr.kind sigma t' with + | Prod(_,t'',t''') -> + begin + match EConstr.kind sigma t'',EConstr.kind sigma t''' with + | App(eq,args), App(graph',_) + when + (EConstr.eq_constr sigma eq eq_ind) && + Array.exists (EConstr.eq_constr_nounivs sigma graph') graphs_constr -> + (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) + ::acc) + | _ -> mkVar hid :: acc + end + | _ -> mkVar hid :: acc + end + | _ -> mkVar hid :: acc + ) pre_args [] + in + (* in fact we must also add the parameters to the constructor args *) + let constructor_args g = + let params_id = fst (List.chop princ_infos.Tactics.nparams args_names) in + (List.map mkVar params_id)@((constructor_args g)) + in + (* We then get the constructor corresponding to this branch and + modifies the references has needed i.e. + if the constructor is the last one of the current inductive then + add one the number of the inductive to take and add the number of constructor of the previous + graph to the minimal constructor number + *) + let constructor = + let constructor_num = i - !min_constr_number in + let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in + if constructor_num <= length + then + begin + (kn,!ind_number),constructor_num + end + else + begin + incr ind_number; + min_constr_number := !min_constr_number + length ; + (kn,!ind_number),1 + end + in + (* we can then build the final proof term *) + let app_constructor g = applist((mkConstructU(constructor,u)),constructor_args g) in + (* an apply the tactic *) + let res,hres = + match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with + | [res;hres] -> res,hres + | _ -> assert false + in + (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) + ( + tclTHENLIST + [ + observe_tac ("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in + match l with + | [] -> tclIDTAC + | _ -> Proofview.V82.of_tactic (intro_patterns false l)); + (* unfolding of all the defined variables introduced by this branch *) + (* observe_tac "unfolding" pre_tac; *) + (* $zeta$ normalizing of the conclusion *) + Proofview.V82.of_tactic (reduce + (Genredexpr.Cbv + { Redops.all_flags with + Genredexpr.rDelta = false ; + Genredexpr.rConst = [] + } + ) + Locusops.onConcl); + observe_tac ("toto ") tclIDTAC; + + (* introducing the result of the graph and the equality hypothesis *) + observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); + (* replacing [res] with its value *) + observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); + (* Conclusion *) + observe_tac "exact" (fun g -> + Proofview.V82.of_tactic (exact_check (app_constructor g)) g) + ] + ) + g + in + (* end of branche proof *) + let lemmas = + Array.map + (fun ((_,(ctxt,concl))) -> + match ctxt with + | [] | [_] | [_;_] -> CErrors.anomaly (Pp.str "bad context.") + | hres::res::decl::ctxt -> + let res = EConstr.it_mkLambda_or_LetIn + (EConstr.it_mkProd_or_LetIn concl [hres;res]) + (LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) :: ctxt) + in + res) + lemmas_types_infos + in + let param_names = fst (List.chop princ_infos.nparams args_names) in + let params = List.map mkVar param_names in + let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in + (* The bindings of the principle + that is the params of the principle and the different lemma types + *) + let bindings = + let params_bindings,avoid = + List.fold_left2 + (fun (bindings,avoid) decl p -> + let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in + p::bindings,id::avoid + ) + ([],pf_ids_of_hyps g) + princ_infos.params + (List.rev params) + in + let lemmas_bindings = + List.rev (fst (List.fold_left2 + (fun (bindings,avoid) decl p -> + let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in + (Reductionops.nf_zeta (pf_env g) (project g) p)::bindings,id::avoid) + ([],avoid) + princ_infos.predicates + (lemmas))) + in + (params_bindings@lemmas_bindings) + in + tclTHENLIST + [ + observe_tac "principle" (Proofview.V82.of_tactic (assert_by + (Name principle_id) + princ_type + (exact_check f_principle))); + observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); + (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) + observe_tac "idtac" tclIDTAC; + tclTHEN_i + (observe_tac + "functional_induction" ( + (fun gl -> + let term = mkApp (mkVar principle_id,Array.of_list bindings) in + let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl term in + Proofview.V82.of_tactic (apply term) gl') + )) + (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) + ] + g + +(* [prove_fun_complete funs graphs schemes lemmas_types_infos i] + is the tactic used to prove completeness lemma. + + [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions + (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. + + [i] is the indice of the function to prove complete + + The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is + it looks like~: + [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, + graph\ x_1\ldots x_n\ res, \rightarrow res = f x_1\ldots x_n in] + + + The sketch of the proof is the following one~: + \begin{enumerate} + \item intros until $H:graph\ x_1\ldots x_n\ res$ + \item $elim\ H$ using schemes.(i) + \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has + type [x=?] with [x] a variable, then subst [x], + if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else + if [h] is a match then destruct it, else do just introduce it, + after all intros, the conclusion should be a reflexive equality. + \end{enumerate} + +*) + +let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl + +(* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis + (unfolding, substituting, destructing cases \ldots) +*) +let tauto = + let open Ltac_plugin in + let dp = List.map Id.of_string ["Tauto" ; "Init"; "Coq"] in + let mp = ModPath.MPfile (DirPath.make dp) in + let kn = KerName.make mp (Label.make "tauto") in + Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> + let body = Tacenv.interp_ltac kn in + Tacinterp.eval_tactic body + end + +(* [generalize_dependent_of x hyp g] + generalize every hypothesis which depends of [x] but [hyp] +*) +let generalize_dependent_of x hyp g = + let open Context.Named.Declaration in + let open Tacmach in + let open Tacticals in + tclMAP + (function + | LocalAssum ({Context.binder_name=id},t) when not (Id.equal id hyp) && + (Termops.occur_var (pf_env g) (project g) x t) -> + tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) (thin [id]) + | _ -> tclIDTAC + ) + (pf_hyps g) + g + +let rec intros_with_rewrite g = + observe_tac "intros_with_rewrite" intros_with_rewrite_aux g +and intros_with_rewrite_aux : Tacmach.tactic = + let open Constr in + let open EConstr in + let open Tacmach in + let open Tactics in + let open Tacticals in + fun g -> + let eq_ind = make_eq () in + let sigma = project g in + match EConstr.kind sigma (pf_concl g) with + | Prod(_,t,t') -> + begin + match EConstr.kind sigma t with + | App(eq,args) when (EConstr.eq_constr sigma eq eq_ind) -> + if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) + then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g + else if isVar sigma args.(1) && (Environ.evaluable_named (destVar sigma args.(1)) (pf_env g)) + then tclTHENLIST[ + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))] ((destVar sigma args.(1)),Locus.InHyp) ))) + (pf_ids_of_hyps g); + intros_with_rewrite + ] g + else if isVar sigma args.(2) && (Environ.evaluable_named (destVar sigma args.(2)) (pf_env g)) + then tclTHENLIST[ + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))] ((destVar sigma args.(2)),Locus.InHyp) ))) + (pf_ids_of_hyps g); + intros_with_rewrite + ] g + else if isVar sigma args.(1) + then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); + generalize_dependent_of (destVar sigma args.(1)) id; + tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); + intros_with_rewrite + ] + g + else if isVar sigma args.(2) + then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); + generalize_dependent_of (destVar sigma args.(2)) id; + tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); + intros_with_rewrite + ] + g + else + begin + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST[ + Proofview.V82.of_tactic (Simple.intro id); + tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); + intros_with_rewrite + ] g + end + | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type")) -> + Proofview.V82.of_tactic tauto g + | Case(_,_,v,_) -> + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_case v); + intros_with_rewrite + ] g + | LetIn _ -> + tclTHENLIST[ + Proofview.V82.of_tactic (reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; + }) + Locusops.onConcl) + ; + intros_with_rewrite + ] g + | _ -> + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g + end + | LetIn _ -> + tclTHENLIST[ + Proofview.V82.of_tactic (reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; + }) + Locusops.onConcl) + ; + intros_with_rewrite + ] g + | _ -> tclIDTAC g + +let rec reflexivity_with_destruct_cases g = + let open Constr in + let open EConstr in + let open Tacmach in + let open Tactics in + let open Tacticals in + let destruct_case () = + try + match EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) with + | Case(_,_,v,_) -> + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_case v); + Proofview.V82.of_tactic intros; + observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases + ] + | _ -> Proofview.V82.of_tactic reflexivity + with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity + in + let eq_ind = make_eq () in + let my_inj_flags = Some { + Equality.keep_proof_equalities = false; + injection_in_context = false; (* for compatibility, necessary *) + injection_pattern_l2r_order = false; (* probably does not matter; except maybe with dependent hyps *) + } in + let discr_inject = + Tacticals.onAllHypsAndConcl ( + fun sc g -> + match sc with + None -> tclIDTAC g + | Some id -> + match EConstr.kind (project g) (pf_unsafe_type_of g (mkVar id)) with + | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> + if Equality.discriminable (pf_env g) (project g) t1 t2 + then Proofview.V82.of_tactic (Equality.discrHyp id) g + else if Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 + then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id);thin [id];intros_with_rewrite] g + else tclIDTAC g + | _ -> tclIDTAC g + ) + in + (tclFIRST + [ observe_tac "reflexivity_with_destruct_cases : reflexivity" (Proofview.V82.of_tactic reflexivity); + observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); + (* We reach this point ONLY if + the same value is matched (at least) two times + along binding path. + In this case, either we have a discriminable hypothesis and we are done, + either at least an injectable one and we do the injection before continuing + *) + observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases) + ]) + g + +let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tactic = + let open EConstr in + let open Tacmach in + let open Tactics in + let open Tacticals in + fun g -> + (* We compute the types of the different mutually recursive lemmas + in $\zeta$ normal form + *) + let lemmas = + Array.map + (fun (_,(ctxt,concl)) -> Reductionops.nf_zeta (pf_env g) (project g) (EConstr.it_mkLambda_or_LetIn concl ctxt)) + lemmas_types_infos + in + (* We get the constant and the principle corresponding to this lemma *) + let f = funcs.(i) in + let graph_principle = Reductionops.nf_zeta (pf_env g) (project g) (EConstr.of_constr schemes.(i)) in + let princ_type = pf_unsafe_type_of g graph_principle in + let princ_infos = Tactics.compute_elim_sig (project g) princ_type in + (* Then we get the number of argument of the function + and compute a fresh name for each of them + *) + let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in + let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in + let ids = args_names@(pf_ids_of_hyps g) in + (* and fresh names for res H and the principle (cf bug bug #1174) *) + let res,hres,graph_principle_id = + match generate_fresh_id (Id.of_string "z") ids 3 with + | [res;hres;graph_principle_id] -> res,hres,graph_principle_id + | _ -> assert false + in + let ids = res::hres::graph_principle_id::ids in + (* we also compute fresh names for each hyptohesis of each branch + of the principle *) + let branches = List.rev princ_infos.branches in + let intro_pats = + List.map + (fun decl -> + List.map + (fun id -> id) + (generate_fresh_id (Id.of_string "y") ids (Termops.nb_prod (project g) (RelDecl.get_type decl))) + ) + branches + in + (* We will need to change the function by its body + using [f_equation] if it is recursive (that is the graph is infinite + or unfold if the graph is finite + *) + let rewrite_tac j ids : Tacmach.tactic = + let graph_def = graphs.(j) in + let infos = + try find_Function_infos (fst (destConst (project g) funcs.(j))) + with Not_found -> CErrors.user_err Pp.(str "No graph found") + in + if infos.is_general + || Rtree.is_infinite Declareops.eq_recarg graph_def.Declarations.mind_recargs + then + let eq_lemma = + try Option.get (infos).equation_lemma + with Option.IsNone -> CErrors.anomaly (Pp.str "Cannot find equation lemma.") + in + tclTHENLIST[ + tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; + Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); + (* Don't forget to $\zeta$ normlize the term since the principles + have been $\zeta$-normalized *) + Proofview.V82.of_tactic (reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; + }) + Locusops.onConcl) + ; + Proofview.V82.of_tactic (generalize (List.map mkVar ids)); + thin ids + ] + else + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst (project g) f)))]) + in + (* The proof of each branche itself *) + let ind_number = ref 0 in + let min_constr_number = ref 0 in + let prove_branche i g = + (* we fist compute the inductive corresponding to the branch *) + let this_ind_number = + let constructor_num = i - !min_constr_number in + let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in + if constructor_num <= length + then !ind_number + else + begin + incr ind_number; + min_constr_number := !min_constr_number + length; + !ind_number + end + in + let this_branche_ids = List.nth intro_pats (pred i) in + tclTHENLIST[ + (* we expand the definition of the function *) + observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); + (* introduce hypothesis with some rewrite *) + observe_tac "intros_with_rewrite (all)" intros_with_rewrite; + (* The proof is (almost) complete *) + observe_tac "reflexivity" (reflexivity_with_destruct_cases) + ] + g + in + let params_names = fst (List.chop princ_infos.nparams args_names) in + let open EConstr in + let params = List.map mkVar params_names in + tclTHENLIST + [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); + observe_tac "h_generalize" + (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); + Proofview.V82.of_tactic (Simple.intro graph_principle_id); + observe_tac "" (tclTHEN_i + (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres, Tactypes.NoBindings) + (Some (mkVar graph_principle_id, Tactypes.NoBindings))))) + (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) + ] + g + +exception No_graph_found + +let get_funs_constant mp = + let open Constr in + let exception Not_Rec in + let get_funs_constant const e : (Names.Constant.t*int) array = + match Constr.kind (Term.strip_lam e) with + | Fix((_,(na,_,_))) -> + Array.mapi + (fun i na -> + match na.Context.binder_name with + | Name id -> + let const = Constant.make2 mp (Label.of_id id) in + const,i + | Anonymous -> + CErrors.anomaly (Pp.str "Anonymous fix.") + ) + na + | _ -> [|const,0|] + in + function const -> + let find_constant_body const = + match Global.body_of_constant Library.indirect_accessor const with + | Some (body, _, _) -> + let body = Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + (Global.env ()) + (Evd.from_env (Global.env ())) + (EConstr.of_constr body) + in + let body = EConstr.Unsafe.to_constr body in + body + | None -> + CErrors.user_err Pp.(str ( "Cannot define a principle over an axiom ")) + in + let f = find_constant_body const in + let l_const = get_funs_constant const f in + (* + We need to check that all the functions found are in the same block + to prevent Reset strange thing + *) + let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in + let l_params,l_fixes = List.split (List.map Term.decompose_lam l_bodies) in + (* all the parameters must be equal*) + let _check_params = + let first_params = List.hd l_params in + List.iter + (fun params -> + if not (List.equal (fun (n1, c1) (n2, c2) -> + Context.eq_annot Name.equal n1 n2 && Constr.equal c1 c2) first_params params) + then CErrors.user_err Pp.(str "Not a mutal recursive block") + ) + l_params + in + (* The bodies has to be very similar *) + let _check_bodies = + try + let extract_info is_first body = + match Constr.kind body with + | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) + | _ -> + if is_first && Int.equal (List.length l_bodies) 1 + then raise Not_Rec + else CErrors.user_err Pp.(str "Not a mutal recursive block") + in + let first_infos = extract_info true (List.hd l_bodies) in + let check body = (* Hope this is correct *) + let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = + Array.equal Int.equal ia1 ia2 && Array.equal (Context.eq_annot Name.equal) na1 na2 && + Array.equal Constr.equal ta1 ta2 && Array.equal Constr.equal ca1 ca2 + in + if not (eq_infos first_infos (extract_info false body)) + then CErrors.user_err Pp.(str "Not a mutal recursive block") + in + List.iter check l_bodies + with Not_Rec -> () + in + l_const + +let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_effects Proof_global.proof_entry list = + let exception Found_type of int in + let env = Global.env () in + let funs = List.map fst fas in + let first_fun = List.hd funs in + let funs_mp = KerName.modpath (Constant.canonical (fst first_fun)) in + let first_fun_kn = + try + fst (find_Function_infos (fst first_fun)).graph_ind + with Not_found -> raise No_graph_found + in + let this_block_funs_indexes = get_funs_constant funs_mp (fst first_fun) in + let this_block_funs = Array.map (fun (c,_) -> (c,snd first_fun)) this_block_funs_indexes in + let prop_sort = Sorts.InProp in + let funs_indexes = + let this_block_funs_indexes = Array.to_list this_block_funs_indexes in + List.map + (function cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) + funs + in + let ind_list = + List.map + (fun (idx) -> + let ind = first_fun_kn,idx in + (ind,snd first_fun),true,prop_sort + ) + funs_indexes + in + let sigma, schemes = + Indrec.build_mutual_induction_scheme env !evd ind_list + in + let _ = evd := sigma in + let l_schemes = + List.map (EConstr.of_constr %> Typing.unsafe_type_of env sigma %> EConstr.Unsafe.to_constr) schemes + in + let i = ref (-1) in + let sorts = + List.rev_map (fun (_,x) -> + let sigma, fs = Evd.fresh_sort_in_family !evd x in + evd := sigma; fs + ) + fas + in + (* We create the first principle by tactic *) + let first_type,other_princ_types = + match l_schemes with + s::l_schemes -> s,l_schemes + | _ -> CErrors.anomaly (Pp.str "") + in + let _,const,_ = + try + build_functional_principle evd false + first_type + (Array.of_list sorts) + this_block_funs + 0 + (Functional_principles_proofs.prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) + (fun _ _ -> ()) + with e when CErrors.noncritical e -> + raise (Defining_principle e) + + in + incr i; + let opacity = + let finfos = find_Function_infos (fst first_fun) in + try + let equation = Option.get finfos.equation_lemma in + Declareops.is_opaque (Global.lookup_constant equation) + with Option.IsNone -> (* non recursive definition *) + false + in + let const = {const with Proof_global.proof_entry_opaque = opacity } in + (* The others are just deduced *) + if List.is_empty other_princ_types + then + [const] + else + let other_fun_princ_types = + let funs = Array.map Constr.mkConstU this_block_funs in + let sorts = Array.of_list sorts in + List.map (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) other_princ_types + in + let open Proof_global in + let first_princ_body,first_princ_type = const.proof_entry_body, const.proof_entry_type in + let ctxt,fix = Term.decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) + let (idxs,_),(_,ta,_ as decl) = Constr.destFix fix in + let other_result = + List.map (* we can now compute the other principles *) + (fun scheme_type -> + incr i; + observe (Printer.pr_lconstr_env env sigma scheme_type); + let type_concl = (Term.strip_prod_assum scheme_type) in + let applied_f = List.hd (List.rev (snd (Constr.decompose_app type_concl))) in + let f = fst (Constr.decompose_app applied_f) in + try (* we search the number of the function in the fix block (name of the function) *) + Array.iteri + (fun j t -> + let t = (Term.strip_prod_assum t) in + let applied_g = List.hd (List.rev (snd (Constr.decompose_app t))) in + let g = fst (Constr.decompose_app applied_g) in + if Constr.equal f g + then raise (Found_type j); + observe Pp.(Printer.pr_lconstr_env env sigma f ++ str " <> " ++ + Printer.pr_lconstr_env env sigma g) + + ) + ta; + (* If we reach this point, the two principle are not mutually recursive + We fall back to the previous method + *) + let _,const,_ = + build_functional_principle + evd + false + (List.nth other_princ_types (!i - 1)) + (Array.of_list sorts) + this_block_funs + !i + (Functional_principles_proofs.prove_princ_for_struct evd false !i (Array.of_list (List.map fst funs))) + (fun _ _ -> ()) + in + const + with Found_type i -> + let princ_body = + Termops.it_mkLambda_or_LetIn (Constr.mkFix((idxs,i),decl)) ctxt + in + {const with + proof_entry_body = + (Future.from_val ((princ_body, Univ.ContextSet.empty), Evd.empty_side_effects)); + proof_entry_type = Some scheme_type + } + ) + other_fun_princ_types + in + const::other_result + +(* [derive_correctness funs graphs] create correctness and completeness + lemmas for each function in [funs] w.r.t. [graphs] +*) + +let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = + let open EConstr in + assert (funs <> []); + assert (graphs <> []); + let funs = Array.of_list funs and graphs = Array.of_list graphs in + let map (c, u) = mkConstU (c, EInstance.make u) in + let funs_constr = Array.map map funs in + (* XXX STATE Why do we need this... why is the toplevel protection not enough *) + funind_purify + (fun () -> + let env = Global.env () in + let evd = ref (Evd.from_env env) in + let graphs_constr = Array.map mkInd graphs in + let lemmas_types_infos = + Util.Array.map2_i + (fun i f_constr graph -> + (* let const_of_f,u = destConst f_constr in *) + let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = + generate_type evd false f_constr graph i + in + let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in + let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in + evd := sigma; + let type_of_lemma = Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma in + observe Pp.(str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); + type_of_lemma,type_info + ) + funs_constr + graphs_constr + in + let schemes = + (* The functional induction schemes are computed and not saved if there is more that one function + if the block contains only one function we can safely reuse [f_rect] + *) + try + if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; + [| find_induction_principle evd funs_constr.(0) |] + with Not_found -> + ( + + Array.of_list + (List.map + (fun entry -> + (EConstr.of_constr (fst (fst(Future.force entry.Proof_global.proof_entry_body))), EConstr.of_constr (Option.get entry.Proof_global.proof_entry_type )) + ) + (make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs)) + ) + ) + in + let proving_tac = + prove_fun_correct !evd funs_constr graphs_constr schemes lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in + (*i The next call to mk_correct_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + let lem_id = mk_correct_id f_id in + let (typ,_) = lemmas_types_infos.(i) in + let info = Lemmas.Info.make + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + ~kind:(Decls.(IsProof Theorem)) () in + let lemma = Lemmas.start_lemma + ~name:lem_id + ~poly:false + ~info + !evd + typ in + let lemma = fst @@ Lemmas.by + (Proofview.V82.tactic (proving_tac i)) lemma in + let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in + let finfo = find_Function_infos (fst f_as_constant) in + (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) + let _,lem_cst_constr = Evd.fresh_global + (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in + let (lem_cst,_) = EConstr.destConst !evd lem_cst_constr in + update_Function {finfo with correctness_lemma = Some lem_cst}; + + ) + funs; + let lemmas_types_infos = + Util.Array.map2_i + (fun i f_constr graph -> + let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = + generate_type evd true f_constr graph i + in + let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = + EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt + in + let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in + observe Pp.(str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma); + type_of_lemma,type_info + ) + funs_constr + graphs_constr + in + + let (kn,_) as graph_ind,u = (destInd !evd graphs_constr.(0)) in + let mib,mip = Global.lookup_inductive graph_ind in + let sigma, scheme = + (Indrec.build_mutual_induction_scheme (Global.env ()) !evd + (Array.to_list + (Array.mapi + (fun i _ -> ((kn,i), EInstance.kind !evd u),true, Sorts.InType) + mib.Declarations.mind_packets + ) + ) + ) + in + let schemes = + Array.of_list scheme + in + let proving_tac = + prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in + (*i The next call to mk_complete_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + let lem_id = mk_complete_id f_id in + let info = Lemmas.Info.make + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + ~kind:Decls.(IsProof Theorem) () in + let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false ~info + sigma (fst lemmas_types_infos.(i)) in + let lemma = fst (Lemmas.by + (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") + (proving_tac i))) lemma) in + let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in + let finfo = find_Function_infos (fst f_as_constant) in + let _,lem_cst_constr = Evd.fresh_global + (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in + let (lem_cst,_) = destConst !evd lem_cst_constr in + update_Function {finfo with completeness_lemma = Some lem_cst} + ) + funs) + () + +let warn_funind_cannot_build_inversion = + CWarnings.create ~name:"funind-cannot-build-inversion" ~category:"funind" + Pp.(fun e' -> strbrk "Cannot build inversion information" ++ + if do_observe () then (fnl() ++ CErrors.print e') else mt ()) + +let derive_inversion fix_names = + try + let evd' = Evd.from_env (Global.env ()) in + (* we first transform the fix_names identifier into their corresponding constant *) + let evd',fix_names_as_constant = + List.fold_right + (fun id (evd,l) -> + let evd,c = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in + let (cst, u) = EConstr.destConst evd c in + evd, (cst, EConstr.EInstance.kind evd u) :: l + ) + fix_names + (evd',[]) + in + (* + Then we check that the graphs have been defined + If one of the graphs haven't been defined + we do nothing + *) + List.iter (fun c -> ignore (find_Function_infos (fst c))) fix_names_as_constant ; + try + let evd', lind = + List.fold_right + (fun id (evd,l) -> + let evd,id = + Evd.fresh_global + (Global.env ()) evd + (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) + in + evd,(fst (EConstr.destInd evd id))::l + ) + fix_names + (evd',[]) + in + derive_correctness + fix_names_as_constant + lind; + with e when CErrors.noncritical e -> + warn_funind_cannot_build_inversion e + with e when CErrors.noncritical e -> + warn_funind_cannot_build_inversion e + +let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body + pre_hook + = + let type_of_f = Constrexpr_ops.mkCProdN args ret_type in + let rec_arg_num = + let names = + List.map + CAst.(with_val (fun x -> x)) + (Constrexpr_ops.names_of_local_assums args) + in + List.index Name.equal (Name wf_arg) names + in + let unbounded_eq = + let f_app_args = + CAst.make @@ Constrexpr.CAppExpl( + (None, Libnames.qualid_of_ident fname,None) , + (List.map + (function + | {CAst.v=Anonymous} -> assert false + | {CAst.v=Name e} -> (Constrexpr_ops.mkIdentC e) + ) + (Constrexpr_ops.names_of_local_assums args) + ) + ) + in + CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (Libnames.qualid_of_string "Logic.eq")), + [(f_app_args,None);(body,None)]) + in + let eq = Constrexpr_ops.mkCProdN args unbounded_eq in + let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type + nb_args relation = + try + pre_hook [fconst] + (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes + functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation + ); + derive_inversion [fname] + with e when CErrors.noncritical e -> + (* No proof done *) + () + in + Recdef.recursive_definition ~interactive_proof + ~is_mes fname rec_impls + type_of_f + wf_rel_expr + rec_arg_num + eq + hook + using_lemmas + +let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas args ret_type body = + let wf_arg_type,wf_arg = + match wf_arg with + | None -> + begin + match args with + | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],k,t)] -> t,x + | _ -> CErrors.user_err (Pp.str "Recursive argument must be specified") + end + | Some wf_args -> + try + match + List.find + (function + | Constrexpr.CLocalAssum(l,k,t) -> + List.exists + (function {CAst.v=Name id} -> Id.equal id wf_args | _ -> false) + l + | _ -> false + ) + args + with + | Constrexpr.CLocalAssum(_,k,t) -> t,wf_args + | _ -> assert false + with Not_found -> assert false + in + let wf_rel_from_mes,is_mes = + match wf_rel_expr_opt with + | None -> + let ltof = + let make_dir l = DirPath.make (List.rev_map Id.of_string l) in + Libnames.qualid_of_path + (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof")) + in + let fun_from_mes = + let applied_mes = + Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in + Constrexpr_ops.mkLambdaC ([CAst.make @@ Name wf_arg],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes) + in + let wf_rel_from_mes = + Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) + in + wf_rel_from_mes,true + | Some wf_rel_expr -> + let wf_rel_with_mes = + let a = Names.Id.of_string "___a" in + let b = Names.Id.of_string "___b" in + Constrexpr_ops.mkLambdaC( + [CAst.make @@ Name a; CAst.make @@ Name b], + Constrexpr.Default Glob_term.Explicit, + wf_arg_type, + Constrexpr_ops.mkAppC(wf_rel_expr, + [ + Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]); + Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b]) + ]) + ) + in + wf_rel_with_mes,false + in + register_wf interactive_proof ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg + using_lemmas args ret_type body + +let do_generate_principle_aux pconstants on_error register_built interactive_proof fixpoint_exprl : Lemmas.t option = + List.iter (fun { Vernacexpr.notations } -> + if not (List.is_empty notations) + then CErrors.user_err (Pp.str "Function does not support notations for now")) fixpoint_exprl; + let lemma, _is_struct = + match fixpoint_exprl with + | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)} } as fixpoint_expr] -> + let { Vernacexpr.fname; univs; binders; rtype; body_def } as fixpoint_expr = + match recompute_binder_list [fixpoint_expr] with + | [e] -> e + | _ -> assert false + in + let fixpoint_exprl = [fixpoint_expr] in + let body = match body_def with | Some body -> body | None -> + CErrors.user_err ~hdr:"Function" (Pp.str "Body of Function must be given") in + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let using_lemmas = [] in + let pre_hook pconstants = + generate_principle + (ref (Evd.from_env (Global.env ()))) + pconstants + on_error + true + register_built + fixpoint_exprl + recdefs + true + in + if register_built + then register_wf interactive_proof fname.CAst.v rec_impls wf_rel wf_x.CAst.v using_lemmas binders rtype body pre_hook, false + else None, false + | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)} } as fixpoint_expr] -> + let { Vernacexpr.fname; univs; binders; rtype; body_def} as fixpoint_expr = + match recompute_binder_list [fixpoint_expr] with + | [e] -> e + | _ -> assert false + in + let fixpoint_exprl = [fixpoint_expr] in + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let using_lemmas = [] in + let body = match body_def with + | Some body -> body + | None -> + CErrors.user_err ~hdr:"Function" Pp.(str "Body of Function must be given") in + let pre_hook pconstants = + generate_principle + (ref (Evd.from_env (Global.env ()))) + pconstants + on_error + true + register_built + fixpoint_exprl + recdefs + true + in + if register_built + then register_mes interactive_proof fname.CAst.v rec_impls wf_mes wf_rel_opt + (Option.map (fun x -> x.CAst.v) wf_x) using_lemmas binders rtype body pre_hook, true + else None, true + | _ -> + List.iter (function { Vernacexpr.rec_order } -> + match rec_order with + | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> + CErrors.user_err + (Pp.str "Cannot use mutual definition with well-founded recursion or measure") + | _ -> () + ) + fixpoint_exprl; + let fixpoint_exprl = recompute_binder_list fixpoint_exprl in + let fix_names = List.map (function { Vernacexpr.fname } -> fname.CAst.v) fixpoint_exprl in + (* ok all the expressions are structural *) + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let is_rec = List.exists (is_rec fix_names) recdefs in + let lemma,evd,pconstants = + if register_built + then register_struct is_rec fixpoint_exprl + else None, Evd.from_env (Global.env ()), pconstants + in + let evd = ref evd in + generate_principle + (ref !evd) + pconstants + on_error + false + register_built + fixpoint_exprl + recdefs + interactive_proof + (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); + if register_built then + begin derive_inversion fix_names; end; + lemma, true + in + lemma + +let warn_cannot_define_graph = + CWarnings.create ~name:"funind-cannot-define-graph" ~category:"funind" + (fun (names,error) -> + Pp.(strbrk "Cannot define graph(s) for " ++ + h 1 names ++ error)) + +let warn_cannot_define_principle = + CWarnings.create ~name:"funind-cannot-define-principle" ~category:"funind" + (fun (names,error) -> + Pp.(strbrk "Cannot define induction principle(s) for "++ + h 1 names ++ error)) + +let warning_error names e = + let e_explain e = + match e with + | ToShow e -> + Pp.(spc () ++ CErrors.print e) + | _ -> + if do_observe () + then Pp.(spc () ++ CErrors.print e) + else Pp.mt () + in + match e with + | Building_graph e -> + let names = Pp.(prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) in + warn_cannot_define_graph (names,e_explain e) + | Defining_principle e -> + let names = Pp.(prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) in + warn_cannot_define_principle (names,e_explain e) + | _ -> raise e + +let error_error names e = + let e_explain e = + match e with + | ToShow e -> Pp.(spc () ++ CErrors.print e) + | _ -> if do_observe () then Pp.(spc () ++ CErrors.print e) else Pp.mt () + in + match e with + | Building_graph e -> + CErrors.user_err + Pp.(str "Cannot define graph(s) for " ++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ + e_explain e) + | _ -> raise e + +(* [chop_n_arrow n t] chops the [n] first arrows in [t] + Acts on Constrexpr.constr_expr +*) +let rec chop_n_arrow n t = + let exception Stop of Constrexpr.constr_expr in + let open Constrexpr in + if n <= 0 + then t (* If we have already removed all the arrows then return the type *) + else (* If not we check the form of [t] *) + match t.CAst.v with + | Constrexpr.CProdN(nal_ta',t') -> (* If we have a forall, two results are possible : + either we need to discard more than the number of arrows contained + in this product declaration then we just recall [chop_n_arrow] on + the remaining number of arrow to chop and [t'] we discard it and + recall [chop_n_arrow], either this product contains more arrows + than the number we need to chop and then we return the new type + *) + begin + try + let new_n = + let rec aux (n:int) = function + [] -> n + | CLocalAssum(nal,k,t'')::nal_ta' -> + let nal_l = List.length nal in + if n >= nal_l + then + aux (n - nal_l) nal_ta' + else + let new_t' = CAst.make @@ + Constrexpr.CProdN( + CLocalAssum((snd (List.chop n nal)),k,t'')::nal_ta',t') + in + raise (Stop new_t') + | _ -> CErrors.anomaly (Pp.str "Not enough products.") + in + aux n nal_ta' + in + chop_n_arrow new_n t' + with Stop t -> t + end + | _ -> CErrors.anomaly (Pp.str "Not enough products.") + +let rec add_args id new_args = + let open Libnames in + let open Constrexpr in + CAst.map (function + | CRef (qid,_) as b -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl((None,qid,None),new_args) + else b + | CFix _ | CCoFix _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "todo.") + | CProdN(nal,b1) -> + CProdN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) + | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) + | CLocalPattern _ -> + CErrors.user_err (Pp.str "pattern with quote not allowed here.")) nal, + add_args id new_args b1) + | CLambdaN(nal,b1) -> + CLambdaN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) + | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) + | CLocalPattern _ -> + CErrors.user_err (Pp.str "pattern with quote not allowed here.")) nal, + add_args id new_args b1) + | CLetIn(na,b1,t,b2) -> + CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) + | CAppExpl((pf,qid,us),exprl) -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl((pf,qid,us),new_args@(List.map (add_args id new_args) exprl)) + else CAppExpl((pf,qid,us),List.map (add_args id new_args) exprl) + | CApp((pf,b),bl) -> + CApp((pf,add_args id new_args b), + List.map (fun (e,o) -> add_args id new_args e,o) bl) + | CCases(sty,b_option,cel,cal) -> + CCases(sty,Option.map (add_args id new_args) b_option, + List.map (fun (b,na,b_option) -> + add_args id new_args b, + na, b_option) cel, + List.map CAst.(map (fun (cpl,e) -> (cpl,add_args id new_args e))) cal + ) + | CLetTuple(nal,(na,b_option),b1,b2) -> + CLetTuple(nal,(na,Option.map (add_args id new_args) b_option), + add_args id new_args b1, + add_args id new_args b2 + ) + + | CIf(b1,(na,b_option),b2,b3) -> + CIf(add_args id new_args b1, + (na,Option.map (add_args id new_args) b_option), + add_args id new_args b2, + add_args id new_args b3 + ) + | CHole _ + | CPatVar _ + | CEvar _ + | CPrim _ + | CSort _ as b -> b + | CCast(b1,b2) -> + CCast(add_args id new_args b1, + Glob_ops.map_cast_type (add_args id new_args) b2) + | CRecord pars -> + CRecord (List.map (fun (e,o) -> e, add_args id new_args o) pars) + | CNotation _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "CNotation.") + | CGeneralization _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "CGeneralization.") + | CDelimiters _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "CDelimiters.") + ) + +let rec get_args b t : Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr = + let open Constrexpr in + match b.CAst.v with + | Constrexpr.CLambdaN (CLocalAssum(nal,k,ta) as d::rest, b') -> + begin + let n = List.length nal in + let nal_tas,b'',t'' = get_args (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest,b')) (chop_n_arrow n t) in + d :: nal_tas, b'',t'' + end + | Constrexpr.CLambdaN ([], b) -> [],b,t + | _ -> [],b,t + +let make_graph (f_ref : GlobRef.t) = + let open Constrexpr in + let env = Global.env() in + let sigma = Evd.from_env env in + let c,c_body = + match f_ref with + | GlobRef.ConstRef c -> + begin + try c,Global.lookup_constant c + with Not_found -> + CErrors.user_err Pp.(str "Cannot find " ++ Printer.pr_leconstr_env env sigma (EConstr.mkConst c)) + end + | _ -> + CErrors.user_err Pp.(str "Not a function reference") + in + (match Global.body_of_constant_body Library.indirect_accessor c_body with + | None -> + CErrors.user_err (Pp.str "Cannot build a graph over an axiom!") + | Some (body, _, _) -> + let env = Global.env () in + let extern_body,extern_type = + with_full_print (fun () -> + (Constrextern.extern_constr false env sigma (EConstr.of_constr body), + Constrextern.extern_type false env sigma + (EConstr.of_constr (*FIXME*) c_body.Declarations.const_type) + ) + ) + () + in + let (nal_tas,b,t) = get_args extern_body extern_type in + let expr_list = + match b.CAst.v with + | Constrexpr.CFix(l_id,fixexprl) -> + let l = + List.map + (fun (id,recexp,bl,t,b) -> + let { CAst.loc; v=rec_id } = match Option.get recexp with + | { CAst.v = CStructRec id } -> id + | { CAst.v = CWfRec (id,_) } -> id + | { CAst.v = CMeasureRec (oid,_,_) } -> Option.get oid + in + let new_args = + List.flatten + (List.map + (function + | Constrexpr.CLocalDef (na,_,_)-> [] + | Constrexpr.CLocalAssum (nal,_,_) -> + List.map + (fun {CAst.loc;v=n} -> CAst.make ?loc @@ + CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) + nal + | Constrexpr.CLocalPattern _ -> assert false + ) + nal_tas + ) + in + let b' = add_args id.CAst.v new_args b in + { Vernacexpr.fname=id; univs=None + ; rec_order = Some (CAst.make (CStructRec (CAst.make rec_id))) + ; binders = nal_tas@bl; rtype=t; body_def=Some b'; notations = []} + ) + fixexprl + in + l + | _ -> + let fname = CAst.make (Label.to_id (Constant.label c)) in + [{ Vernacexpr.fname; univs=None; rec_order = None; binders=nal_tas; rtype=t; body_def=Some b; notations=[]}] + in + let mp = Constant.modpath c in + let pstate = do_generate_principle_aux [c,Univ.Instance.empty] error_error false false expr_list in + assert (Option.is_empty pstate); + (* We register the infos *) + List.iter + (fun { Vernacexpr.fname= {CAst.v=id} } -> + add_Function false (Constant.make2 mp (Label.of_id id))) + expr_list) + +(* *************** statically typed entrypoints ************************* *) + +let do_generate_principle_interactive fixl : Lemmas.t = + match + do_generate_principle_aux [] warning_error true true fixl + with + | Some lemma -> lemma + | None -> + CErrors.anomaly + (Pp.str"indfun: leaving no open proof in interactive mode") + +let do_generate_principle fixl : unit = + match do_generate_principle_aux [] warning_error true false fixl with + | Some _lemma -> + CErrors.anomaly + (Pp.str"indfun: leaving a goal open in non-interactive mode") + | None -> () + + +let build_scheme fas = + let evd = (ref (Evd.from_env (Global.env ()))) in + let pconstants = (List.map + (fun (_,f,sort) -> + let f_as_constant = + try + Smartlocate.global_with_alias f + with Not_found -> + CErrors.user_err ~hdr:"FunInd.build_scheme" + Pp.(str "Cannot find " ++ Libnames.pr_qualid f) + in + let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in + let _ = evd := evd' in + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in + evd := sigma; + let c, u = + try EConstr.destConst !evd f + with Constr.DestKO -> + CErrors.user_err Pp.(Printer.pr_econstr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function") + in + (c, EConstr.EInstance.kind !evd u), sort + ) + fas + ) in + let bodies_types = make_scheme evd pconstants in + + List.iter2 + (fun (princ_id,_,_) def_entry -> + ignore + (Declare.declare_constant + ~name:princ_id + ~kind:Decls.(IsProof Theorem) + (Declare.DefinitionEntry def_entry)); + Declare.definition_message princ_id + ) + fas + bodies_types + +let build_case_scheme fa = + let env = Global.env () + and sigma = (Evd.from_env (Global.env ())) in +(* let id_to_constr id = *) +(* Constrintern.global_reference id *) +(* in *) + let funs = + let (_,f,_) = fa in + try (let open GlobRef in + match Smartlocate.global_with_alias f with + | ConstRef c -> c + | IndRef _ | ConstructRef _ | VarRef _ -> assert false) + with Not_found -> + CErrors.user_err ~hdr:"FunInd.build_case_scheme" + Pp.(str "Cannot find " ++ Libnames.pr_qualid f) in + let sigma, (_,u) = Evd.fresh_constant_instance env sigma funs in + let first_fun = funs in + let funs_mp = Constant.modpath first_fun in + let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in + let this_block_funs_indexes = get_funs_constant funs_mp first_fun in + let this_block_funs = Array.map (fun (c,_) -> (c,u)) this_block_funs_indexes in + 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 + in + let (ind, sf) = + let ind = first_fun_kn,funs_indexes in + (ind,Univ.Instance.empty)(*FIXME*),prop_sort + in + let (sigma, scheme) = + Indrec.build_case_analysis_scheme_default env sigma ind sf + in + let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in + let sorts = + (fun (_,_,x) -> + fst @@ UnivGen.fresh_sort_in_family x + ) + fa + in + let princ_name = (fun (x,_,_) -> x) fa in + let _ : unit = + (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ + pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs + ); + *) + generate_functional_principle + (ref (Evd.from_env (Global.env ()))) + false + scheme_type + (Some ([|sorts|])) + (Some princ_name) + this_block_funs + 0 + (Functional_principles_proofs.prove_princ_for_struct (ref (Evd.from_env (Global.env ()))) false 0 [|funs|]) + in + () diff --git a/library/decl_kinds.ml b/plugins/funind/gen_principle.mli index 17746645ee..7eb8ca3af1 100644 --- a/library/decl_kinds.ml +++ b/plugins/funind/gen_principle.mli @@ -8,4 +8,16 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -type binding_kind = Explicit | Implicit +val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit +val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit + +val do_generate_principle_interactive : Vernacexpr.fixpoint_expr list -> Lemmas.t +val do_generate_principle : Vernacexpr.fixpoint_expr list -> unit + +val make_graph : Names.GlobRef.t -> unit + +(* Can be thrown by build_{,case}_scheme *) +exception No_graph_found + +val build_scheme : (Names.Id.t * Libnames.qualid * Sorts.family) list -> unit +val build_case_scheme : (Names.Id.t * Libnames.qualid * Sorts.family) -> unit diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 6dc01a9f8f..ddd6ecfb5c 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1300,7 +1300,7 @@ let rec rebuild_return_type rt = | Constrexpr.CLetIn(na,v,t,t') -> CAst.make ?loc @@ Constrexpr.CLetIn(na,v,t,rebuild_return_type t') | _ -> CAst.make ?loc @@ Constrexpr.CProdN([Constrexpr.CLocalAssum ([CAst.make Anonymous], - Constrexpr.Default Decl_kinds.Explicit, rt)], + Constrexpr.Default Explicit, rt)], CAst.make @@ Constrexpr.CSort(UAnonymous {rigid=true})) let do_build_inductive @@ -1517,7 +1517,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(CAst.make @@ VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(None,false,Declarations.Finite,repacked_rel_inds)}) ++ fnl () ++ msg in @@ -1532,7 +1532,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(CAst.make @@ VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac (CAst.make @@ Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(None,false,Declarations.Finite,repacked_rel_inds)}) ++ fnl () ++ CErrors.print reraise in @@ -1554,5 +1554,3 @@ let build_inductive evd funconstants funsargs returned_types rtl = Detyping.print_universes := pu; Constrextern.print_universes := cu; raise (Building_graph e) - - diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index d36d86a65b..fbf63c69dd 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -4,7 +4,6 @@ open Glob_term open CErrors open Util open Names -open Decl_kinds (* Some basic functions to rebuild glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 1987677d7d..eeb2f246c2 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -13,15 +13,10 @@ open Sorts open Util open Names open Constr -open Context open EConstr open Pp open Indfun_common -open Libnames -open Glob_term -open Declarations open Tactypes -open Decl_kinds module RelDecl = Context.Rel.Declaration @@ -150,777 +145,3 @@ let functional_induction with_clean c princl pat = subst_and_reduce g' in res - -let rec abstract_glob_constr c = function - | [] -> c - | Constrexpr.CLocalDef (x,b,t)::bl -> Constrexpr_ops.mkLetInC(x,b,t,abstract_glob_constr c bl) - | Constrexpr.CLocalAssum (idl,k,t)::bl -> - List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl - (abstract_glob_constr c bl) - | Constrexpr.CLocalPattern _::bl -> assert false - -let interp_casted_constr_with_implicits env sigma impls c = - Constrintern.intern_gen Pretyping.WithoutTypeConstraint env sigma ~impls c - -(* - Construct a fixpoint as a Glob_term - and not as a constr -*) - -let build_newrecursive lnameargsardef = - let env0 = Global.env() in - let sigma = Evd.from_env env0 in - let (rec_sign,rec_impls) = - List.fold_left - (fun (env,impls) { Vernacexpr.fname={CAst.v=recname}; binders; rtype } -> - let arityc = Constrexpr_ops.mkCProdN binders rtype in - let arity,ctx = Constrintern.interp_type env0 sigma arityc in - let evd = Evd.from_env env0 in - let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd binders in - let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in - let open Context.Named.Declaration in - let r = Sorts.Relevant in (* TODO relevance *) - (EConstr.push_named (LocalAssum (make_annot recname r,arity)) env, Id.Map.add recname impl impls)) - (env0,Constrintern.empty_internalization_env) lnameargsardef in - let recdef = - (* Declare local notations *) - let f { Vernacexpr.binders; body_def } = - match body_def with - | Some body_def -> - let def = abstract_glob_constr body_def binders in - interp_casted_constr_with_implicits - rec_sign sigma rec_impls def - | None -> user_err ~hdr:"Function" (str "Body of Function must be given") - in - States.with_state_protection (List.map f) lnameargsardef - in - recdef,rec_impls - -let error msg = user_err Pp.(str msg) - -(* Checks whether or not the mutual bloc is recursive *) -let is_rec names = - let names = List.fold_right Id.Set.add names Id.Set.empty in - let check_id id names = Id.Set.mem id names in - let rec lookup names gt = match DAst.get gt with - | GVar(id) -> check_id id names - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ -> false - | GCast(b,_) -> lookup names b - | GRec _ -> error "GRec not handled" - | GIf(b,_,lhs,rhs) -> - (lookup names b) || (lookup names lhs) || (lookup names rhs) - | GProd(na,_,t,b) | GLambda(na,_,t,b) -> - lookup names t || lookup (Nameops.Name.fold_right Id.Set.remove na names) b - | GLetIn(na,b,t,c) -> - lookup names b || Option.cata (lookup names) true t || lookup (Nameops.Name.fold_right Id.Set.remove na names) c - | GLetTuple(nal,_,t,b) -> lookup names t || - lookup - (List.fold_left - (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) - names - nal - ) - b - | GApp(f,args) -> List.exists (lookup names) (f::args) - | GCases(_,_,el,brl) -> - List.exists (fun (e,_) -> lookup names e) el || - List.exists (lookup_br names) brl - and lookup_br names {CAst.v=(idl,_,rt)} = - let new_names = List.fold_right Id.Set.remove idl names in - lookup new_names rt - in - lookup names - -let rec local_binders_length = function - (* Assume that no `{ ... } contexts occur *) - | [] -> 0 - | Constrexpr.CLocalDef _::bl -> 1 + local_binders_length bl - | Constrexpr.CLocalAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl - | Constrexpr.CLocalPattern _::bl -> assert false - -let prepare_body { Vernacexpr.binders; rtype } rt = - let n = local_binders_length binders in -(* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_glob_constr rt); *) - let fun_args,rt' = chop_rlambda_n n rt in - (fun_args,rt') - -let warn_funind_cannot_build_inversion = - CWarnings.create ~name:"funind-cannot-build-inversion" ~category:"funind" - (fun e' -> strbrk "Cannot build inversion information" ++ - if do_observe () then (fnl() ++ CErrors.print e') else mt ()) - -let derive_inversion fix_names = - try - let evd' = Evd.from_env (Global.env ()) in - (* we first transform the fix_names identifier into their corresponding constant *) - let evd',fix_names_as_constant = - List.fold_right - (fun id (evd,l) -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in - let (cst, u) = destConst evd c in - evd, (cst, EInstance.kind evd u) :: l - ) - fix_names - (evd',[]) - in - (* - Then we check that the graphs have been defined - If one of the graphs haven't been defined - we do nothing - *) - List.iter (fun c -> ignore (find_Function_infos (fst c))) fix_names_as_constant ; - try - let evd', lind = - List.fold_right - (fun id (evd,l) -> - let evd,id = - Evd.fresh_global - (Global.env ()) evd - (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) - in - evd,(fst (destInd evd id))::l - ) - fix_names - (evd',[]) - in - Invfun.derive_correctness - fix_names_as_constant - lind; - with e when CErrors.noncritical e -> - warn_funind_cannot_build_inversion e - with e when CErrors.noncritical e -> - warn_funind_cannot_build_inversion e - -let warn_cannot_define_graph = - CWarnings.create ~name:"funind-cannot-define-graph" ~category:"funind" - (fun (names,error) -> strbrk "Cannot define graph(s) for " ++ - h 1 names ++ error) - -let warn_cannot_define_principle = - CWarnings.create ~name:"funind-cannot-define-principle" ~category:"funind" - (fun (names,error) -> strbrk "Cannot define induction principle(s) for "++ - h 1 names ++ error) - -let warning_error names e = - let e_explain e = - match e with - | ToShow e -> - spc () ++ CErrors.print e - | _ -> - if do_observe () - then (spc () ++ CErrors.print e) - else mt () - in - match e with - | Building_graph e -> - let names = prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names in - warn_cannot_define_graph (names,e_explain e) - | Defining_principle e -> - let names = prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names in - warn_cannot_define_principle (names,e_explain e) - | _ -> raise e - -let error_error names e = - let e_explain e = - match e with - | ToShow e -> spc () ++ CErrors.print e - | _ -> if do_observe () then (spc () ++ CErrors.print e) else mt () - in - match e with - | Building_graph e -> - user_err - (str "Cannot define graph(s) for " ++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ - e_explain e) - | _ -> raise e - -let generate_principle (evd:Evd.evar_map ref) pconstants on_error - is_general do_built (fix_rec_l : Vernacexpr.fixpoint_expr list) recdefs interactive_proof - (continue_proof : int -> Names.Constant.t array -> EConstr.constr array -> int -> - Tacmach.tactic) : unit = - let names = List.map (function { Vernacexpr.fname = {CAst.v=name} } -> name) fix_rec_l in - let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in - let funs_args = List.map fst fun_bodies in - let funs_types = List.map (function { Vernacexpr.rtype } -> rtype) fix_rec_l in - try - (* We then register the Inductive graphs of the functions *) - Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types recdefs; - if do_built - then - begin - (*i The next call to mk_rel_id is valid since we have just construct the graph - Ensures by : do_built - i*) - let f_R_mut = qualid_of_ident @@ mk_rel_id (List.nth names 0) in - let ind_kn = - fst (locate_with_msg - (pr_qualid f_R_mut++str ": Not an inductive type!") - locate_ind - f_R_mut) - in - let fname_kn { Vernacexpr.fname } = - let f_ref = qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in - locate_with_msg - (pr_qualid f_ref++str ": Not an inductive type!") - locate_constant - f_ref - in - let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in - let _ = - List.map_i - (fun i x -> - let env = Global.env () in - let princ = Indrec.lookup_eliminator env (ind_kn,i) (InProp) in - let evd = ref (Evd.from_env env) in - let evd',uprinc = Evd.fresh_global env !evd princ in - let _ = evd := evd' in - let sigma, princ_type = Typing.type_of ~refresh:true env !evd uprinc in - evd := sigma; - let princ_type = EConstr.Unsafe.to_constr princ_type in - Functional_principles_types.generate_functional_principle - evd - interactive_proof - princ_type - None - None - (Array.of_list pconstants) - (* funs_kn *) - i - (continue_proof 0 [|funs_kn.(i)|]) - ) - 0 - fix_rec_l - in - Array.iter (add_Function is_general) funs_kn; - () - end - with e when CErrors.noncritical e -> - on_error names e - -let register_struct is_rec (fixpoint_exprl: Vernacexpr.fixpoint_expr list) = - match fixpoint_exprl with - | [ { Vernacexpr.fname; univs; binders; rtype; body_def } ] when not is_rec -> - let body = match body_def with - | Some body -> body - | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - ComDefinition.do_definition - ~program_mode:false - ~name:fname.CAst.v - ~poly:false - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.Definition univs - binders None body (Some rtype); - let evd,rev_pconstants = - List.fold_left - (fun (evd,l) { Vernacexpr.fname } -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in - let (cst, u) = destConst evd c in - let u = EInstance.kind evd u in - evd,((cst, u) :: l) - ) - (Evd.from_env (Global.env ()),[]) - fixpoint_exprl - in - None, evd,List.rev rev_pconstants - | _ -> - ComFixpoint.do_fixpoint ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false fixpoint_exprl; - let evd,rev_pconstants = - List.fold_left - (fun (evd,l) { Vernacexpr.fname } -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in - let (cst, u) = destConst evd c in - let u = EInstance.kind evd u in - evd,((cst, u) :: l) - ) - (Evd.from_env (Global.env ()),[]) - fixpoint_exprl - in - None,evd,List.rev rev_pconstants - - -let generate_correction_proof_wf f_ref tcc_lemma_ref - is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation - (_: int) (_:Names.Constant.t array) (_:EConstr.constr array) (_:int) : Tacmach.tactic = - Functional_principles_proofs.prove_principle_for_gen - (f_ref,functional_ref,eq_ref) - tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation - - -let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body - pre_hook - = - let type_of_f = Constrexpr_ops.mkCProdN args ret_type in - let rec_arg_num = - let names = - List.map - CAst.(with_val (fun x -> x)) - (Constrexpr_ops.names_of_local_assums args) - in - List.index Name.equal (Name wf_arg) names - in - let unbounded_eq = - let f_app_args = - CAst.make @@ Constrexpr.CAppExpl( - (None,qualid_of_ident fname.CAst.v,None) , - (List.map - (function - | {CAst.v=Anonymous} -> assert false - | {CAst.v=Name e} -> (Constrexpr_ops.mkIdentC e) - ) - (Constrexpr_ops.names_of_local_assums args) - ) - ) - in - CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (qualid_of_string "Logic.eq")), - [(f_app_args,None);(body,None)]) - in - let eq = Constrexpr_ops.mkCProdN args unbounded_eq in - let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type - nb_args relation = - try - pre_hook [fconst] - (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes - functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation - ); - derive_inversion [fname.CAst.v] - with e when CErrors.noncritical e -> - (* No proof done *) - () - in - Recdef.recursive_definition ~interactive_proof - ~is_mes fname.CAst.v rec_impls - type_of_f - wf_rel_expr - rec_arg_num - eq - hook - using_lemmas - - -let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas args ret_type body = - let wf_arg_type,wf_arg = - match wf_arg with - | None -> - begin - match args with - | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],k,t)] -> t,x - | _ -> error "Recursive argument must be specified" - end - | Some wf_args -> - try - match - List.find - (function - | Constrexpr.CLocalAssum(l,k,t) -> - List.exists - (function {CAst.v=Name id} -> Id.equal id wf_args | _ -> false) - l - | _ -> false - ) - args - with - | Constrexpr.CLocalAssum(_,k,t) -> t,wf_args - | _ -> assert false - with Not_found -> assert false - in - let wf_rel_from_mes,is_mes = - match wf_rel_expr_opt with - | None -> - let ltof = - let make_dir l = DirPath.make (List.rev_map Id.of_string l) in - Libnames.qualid_of_path - (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof")) - in - let fun_from_mes = - let applied_mes = - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in - Constrexpr_ops.mkLambdaC ([CAst.make @@ Name wf_arg],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes) - in - let wf_rel_from_mes = - Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) - in - wf_rel_from_mes,true - | Some wf_rel_expr -> - let wf_rel_with_mes = - let a = Names.Id.of_string "___a" in - let b = Names.Id.of_string "___b" in - Constrexpr_ops.mkLambdaC( - [CAst.make @@ Name a; CAst.make @@ Name b], - Constrexpr.Default Explicit, - wf_arg_type, - Constrexpr_ops.mkAppC(wf_rel_expr, - [ - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]); - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b]) - ]) - ) - in - wf_rel_with_mes,false - in - register_wf interactive_proof ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg - using_lemmas args ret_type body - -let map_option f = function - | None -> None - | Some v -> Some (f v) - -open Constrexpr - -let rec rebuild_bl aux bl typ = - match bl,typ with - | [], _ -> List.rev aux,typ - | (CLocalAssum(nal,bk,_))::bl',typ -> - rebuild_nal aux bk bl' nal typ - | (CLocalDef(na,_,_))::bl',{ CAst.v = CLetIn(_,nat,ty,typ') } -> - rebuild_bl (Constrexpr.CLocalDef(na,nat,ty)::aux) - bl' typ' - | _ -> assert false -and rebuild_nal aux bk bl' nal typ = - match nal,typ with - | _,{ CAst.v = CProdN([],typ) } -> rebuild_nal aux bk bl' nal typ - | [], _ -> rebuild_bl aux bl' typ - | na::nal,{ CAst.v = CProdN(CLocalAssum(na'::nal',bk',nal't)::rest,typ') } -> - if Name.equal (na.CAst.v) (na'.CAst.v) || Name.is_anonymous (na'.CAst.v) - then - let assum = CLocalAssum([na],bk,nal't) in - let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in - rebuild_nal - (assum::aux) - bk - bl' - nal - (CAst.make @@ CProdN(new_rest,typ')) - else - let assum = CLocalAssum([na'],bk,nal't) in - let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in - rebuild_nal - (assum::aux) - bk - bl' - (na::nal) - (CAst.make @@ CProdN(new_rest,typ')) - | _ -> - assert false - -let rebuild_bl aux bl typ = rebuild_bl aux bl typ - -let recompute_binder_list fixpoint_exprl = - let fixl = - List.map (fun fix -> Vernacexpr.{ - fix - with rec_order = ComFixpoint.adjust_rec_order ~structonly:false fix.binders fix.rec_order }) fixpoint_exprl in - let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl in - let constr_expr_typel = - with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in - let fixpoint_exprl_with_new_bl = - List.map2 (fun ({ Vernacexpr.binders } as fp) fix_typ -> - let binders, rtype = rebuild_bl [] binders fix_typ in - { fp with Vernacexpr.binders; rtype } - ) fixpoint_exprl constr_expr_typel - in - fixpoint_exprl_with_new_bl - - -let do_generate_principle_aux pconstants on_error register_built interactive_proof - (fixpoint_exprl : Vernacexpr.fixpoint_expr list) : Lemmas.t option = - List.iter (fun { Vernacexpr.notations } -> - if not (List.is_empty notations) - then error "Function does not support notations for now") fixpoint_exprl; - let lemma, _is_struct = - match fixpoint_exprl with - | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs; binders; rtype; body_def } as fixpoint_expr = - match recompute_binder_list [fixpoint_expr] with - | [e] -> e - | _ -> assert false - in - let fixpoint_exprl = [fixpoint_expr] in - let body = match body_def with - | Some body -> body - | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in - let using_lemmas = [] in - let pre_hook pconstants = - generate_principle - (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs - true - in - if register_built - then register_wf interactive_proof fname rec_impls wf_rel wf_x.CAst.v using_lemmas binders rtype body pre_hook, false - else None, false - |[{ Vernacexpr.rec_order=Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs; binders; rtype; body_def} as fixpoint_expr = - match recompute_binder_list [fixpoint_expr] with - | [e] -> e - | _ -> assert false - in - let fixpoint_exprl = [fixpoint_expr] in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in - let using_lemmas = [] in - let body = match body_def with - | Some body -> body - | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - let pre_hook pconstants = - generate_principle - (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs - true - in - if register_built - then register_mes interactive_proof fname rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas binders rtype body pre_hook, true - else None, true - | _ -> - List.iter (function { Vernacexpr.rec_order } -> - match rec_order with - | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> - error - ("Cannot use mutual definition with well-founded recursion or measure") - | _ -> () - ) - fixpoint_exprl; - let fixpoint_exprl = recompute_binder_list fixpoint_exprl in - let fix_names = List.map (function { Vernacexpr.fname } -> fname.CAst.v) fixpoint_exprl in - (* ok all the expressions are structural *) - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in - let is_rec = List.exists (is_rec fix_names) recdefs in - let lemma,evd,pconstants = - if register_built - then register_struct is_rec fixpoint_exprl - else None, Evd.from_env (Global.env ()), pconstants - in - let evd = ref evd in - generate_principle - (ref !evd) - pconstants - on_error - false - register_built - fixpoint_exprl - recdefs - interactive_proof - (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); - if register_built then - begin derive_inversion fix_names; end; - lemma, true - in - lemma - -let rec add_args id new_args = CAst.map (function - | CRef (qid,_) as b -> - if qualid_is_ident qid && Id.equal (qualid_basename qid) id then - CAppExpl((None,qid,None),new_args) - else b - | CFix _ | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo.") - | CProdN(nal,b1) -> - CProdN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) - | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) - | CLocalPattern _ -> user_err (Pp.str "pattern with quote not allowed here.")) nal, - add_args id new_args b1) - | CLambdaN(nal,b1) -> - CLambdaN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) - | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) - | CLocalPattern _ -> user_err (Pp.str "pattern with quote not allowed here.")) nal, - add_args id new_args b1) - | CLetIn(na,b1,t,b2) -> - CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) - | CAppExpl((pf,qid,us),exprl) -> - if qualid_is_ident qid && Id.equal (qualid_basename qid) id then - CAppExpl((pf,qid,us),new_args@(List.map (add_args id new_args) exprl)) - else CAppExpl((pf,qid,us),List.map (add_args id new_args) exprl) - | CApp((pf,b),bl) -> - CApp((pf,add_args id new_args b), - List.map (fun (e,o) -> add_args id new_args e,o) bl) - | CCases(sty,b_option,cel,cal) -> - CCases(sty,Option.map (add_args id new_args) b_option, - List.map (fun (b,na,b_option) -> - add_args id new_args b, - na, b_option) cel, - List.map CAst.(map (fun (cpl,e) -> (cpl,add_args id new_args e))) cal - ) - | CLetTuple(nal,(na,b_option),b1,b2) -> - CLetTuple(nal,(na,Option.map (add_args id new_args) b_option), - add_args id new_args b1, - add_args id new_args b2 - ) - - | CIf(b1,(na,b_option),b2,b3) -> - CIf(add_args id new_args b1, - (na,Option.map (add_args id new_args) b_option), - add_args id new_args b2, - add_args id new_args b3 - ) - | CHole _ - | CPatVar _ - | CEvar _ - | CPrim _ - | CSort _ as b -> b - | CCast(b1,b2) -> - CCast(add_args id new_args b1, - Glob_ops.map_cast_type (add_args id new_args) b2) - | CRecord pars -> - CRecord (List.map (fun (e,o) -> e, add_args id new_args o) pars) - | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation.") - | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization.") - | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters.") - ) -exception Stop of Constrexpr.constr_expr - - -(* [chop_n_arrow n t] chops the [n] first arrows in [t] - Acts on Constrexpr.constr_expr -*) -let rec chop_n_arrow n t = - if n <= 0 - then t (* If we have already removed all the arrows then return the type *) - else (* If not we check the form of [t] *) - match t.CAst.v with - | Constrexpr.CProdN(nal_ta',t') -> (* If we have a forall, two results are possible : - either we need to discard more than the number of arrows contained - in this product declaration then we just recall [chop_n_arrow] on - the remaining number of arrow to chop and [t'] we discard it and - recall [chop_n_arrow], either this product contains more arrows - than the number we need to chop and then we return the new type - *) - begin - try - let new_n = - let rec aux (n:int) = function - [] -> n - | CLocalAssum(nal,k,t'')::nal_ta' -> - let nal_l = List.length nal in - if n >= nal_l - then - aux (n - nal_l) nal_ta' - else - let new_t' = CAst.make @@ - Constrexpr.CProdN( - CLocalAssum((snd (List.chop n nal)),k,t'')::nal_ta',t') - in - raise (Stop new_t') - | _ -> anomaly (Pp.str "Not enough products.") - in - aux n nal_ta' - in - chop_n_arrow new_n t' - with Stop t -> t - end - | _ -> anomaly (Pp.str "Not enough products.") - - -let rec get_args b t : Constrexpr.local_binder_expr list * - Constrexpr.constr_expr * Constrexpr.constr_expr = - match b.CAst.v with - | Constrexpr.CLambdaN (CLocalAssum(nal,k,ta) as d::rest, b') -> - begin - let n = List.length nal in - let nal_tas,b'',t'' = get_args (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest,b')) (chop_n_arrow n t) in - d :: nal_tas, b'',t'' - end - | Constrexpr.CLambdaN ([], b) -> [],b,t - | _ -> [],b,t - - -let make_graph (f_ref : GlobRef.t) = - let env = Global.env() in - let sigma = Evd.from_env env in - let c,c_body = - match f_ref with - | GlobRef.ConstRef c -> - begin try c,Global.lookup_constant c - with Not_found -> - raise (UserError (None,str "Cannot find " ++ Printer.pr_leconstr_env env sigma (mkConst c)) ) - end - | _ -> raise (UserError (None, str "Not a function reference") ) - in - (match Global.body_of_constant_body Library.indirect_accessor c_body with - | None -> error "Cannot build a graph over an axiom!" - | Some (body, _, _) -> - let env = Global.env () in - let extern_body,extern_type = - with_full_print (fun () -> - (Constrextern.extern_constr false env sigma (EConstr.of_constr body), - Constrextern.extern_type false env sigma - (EConstr.of_constr (*FIXME*) c_body.const_type) - ) - ) () - in - let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b.CAst.v with - | Constrexpr.CFix(l_id,fixexprl) -> - let l = - List.map - (fun (id,recexp,bl,t,b) -> - let { CAst.loc; v=rec_id } = match Option.get recexp with - | { CAst.v = CStructRec id } -> id - | { CAst.v = CWfRec (id,_) } -> id - | { CAst.v = CMeasureRec (oid,_,_) } -> Option.get oid - in - let new_args = - List.flatten - (List.map - (function - | Constrexpr.CLocalDef (na,_,_)-> [] - | Constrexpr.CLocalAssum (nal,_,_) -> - List.map - (fun {CAst.loc;v=n} -> CAst.make ?loc @@ - CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) - nal - | Constrexpr.CLocalPattern _ -> assert false - ) - nal_tas - ) - in - let b' = add_args id.CAst.v new_args b in - { Vernacexpr.fname=id; univs=None - ; rec_order = Some (CAst.make (CStructRec (CAst.make rec_id))) - ; binders = nal_tas@bl; rtype=t; body_def=Some b'; notations = []} - ) fixexprl in - l - | _ -> - let fname = CAst.make (Label.to_id (Constant.label c)) in - [{ Vernacexpr.fname; univs=None; rec_order = None; binders=nal_tas; rtype=t; body_def=Some b; notations=[]}] - in - let mp = Constant.modpath c in - let pstate = do_generate_principle_aux [c,Univ.Instance.empty] error_error false false expr_list in - assert (Option.is_empty pstate); - (* We register the infos *) - List.iter - (fun { Vernacexpr.fname= {CAst.v=id} } -> - add_Function false (Constant.make2 mp (Label.of_id id))) - expr_list) - -(* *************** statically typed entrypoints ************************* *) - -let do_generate_principle_interactive fixl : Lemmas.t = - match - do_generate_principle_aux [] warning_error true true fixl - with - | Some lemma -> lemma - | None -> - CErrors.anomaly - (Pp.str"indfun: leaving no open proof in interactive mode") - -let do_generate_principle fixl : unit = - match do_generate_principle_aux [] warning_error true false fixl with - | Some _lemma -> - CErrors.anomaly - (Pp.str"indfun: leaving a goal open in non-interactive mode") - | None -> () diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index bfc9686ae5..97a840e950 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -1,19 +1,16 @@ -open Names -open Tactypes - -val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit - -val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit - -val do_generate_principle : Vernacexpr.fixpoint_expr list -> unit - -val do_generate_principle_interactive : Vernacexpr.fixpoint_expr list -> Lemmas.t +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) val functional_induction : bool -> EConstr.constr -> - (EConstr.constr * EConstr.constr bindings) option -> + (EConstr.constr * EConstr.constr Tactypes.bindings) option -> Ltac_plugin.Tacexpr.or_and_intro_pattern option -> Goal.goal Evd.sigma -> Goal.goal list Evd.sigma - -val make_graph : GlobRef.t -> unit diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index a119586f7b..52a29fb559 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -10,8 +10,7 @@ let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" let mk_equation_id id = Nameops.add_suffix id "_equation" -let msgnl m = - () +let msgnl m = () let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid) @@ -378,7 +377,73 @@ let () = declare_bool_option function_debug_sig let do_observe () = !function_debug +let observe strm = + if do_observe () + then Feedback.msg_debug strm + else () + +let debug_queue = Stack.create () + +let print_debug_queue b e = + if not (Stack.is_empty debug_queue) + then + let lmsg,goal = Stack.pop debug_queue in + (if b then + Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) + else + Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)) + (* print_debug_queue false e; *) + ) +let do_observe_tac s tac g = + let goal = Printer.pr_goal g in + let s = s (pf_env g) (project g) in + let lmsg = (str "observation : ") ++ s in + Stack.push (lmsg,goal) debug_queue; + try + let v = tac g in + ignore(Stack.pop debug_queue); + v + with reraise -> + let reraise = CErrors.push reraise in + if not (Stack.is_empty debug_queue) + then print_debug_queue true (fst reraise); + Util.iraise reraise + +let observe_tac s tac g = + if do_observe () + then do_observe_tac s tac g + else tac g + +module New = struct + +let do_observe_tac ~header s tac = + let open Proofview.Notations in + let open Proofview in + Goal.enter begin fun gl -> + let goal = Printer.pr_goal (Goal.print gl) in + let env, sigma = Goal.env gl, Goal.sigma gl in + let s = s env sigma in + let lmsg = seq [header; str " : " ++ s] in + tclLIFT (NonLogical.make (fun () -> + Feedback.msg_debug (s++fnl()))) >>= fun () -> + tclOR ( + Stack.push (lmsg, goal) debug_queue; + tac >>= fun v -> + ignore(Stack.pop debug_queue); + Proofview.tclUNIT v) + (fun (exn, info) -> + if not (Stack.is_empty debug_queue) + then print_debug_queue true exn; + tclZERO ~info exn) + end + +let observe_tac ~header s tac = + if do_observe () + then do_observe_tac ~header s tac + else tac + +end let strict_tcc = ref false let is_strict_tcc () = !strict_tcc @@ -430,6 +495,10 @@ let well_founded_ltof () = EConstr.of_constr @@ UnivGen.constr_of_monomorphic_gl let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") +let make_eq () = + try EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref "core.eq.type")) + with _ -> assert false + let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *) match r with GlobRef.ConstRef sp -> EvalConstRef sp diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index a95b1242ac..fff4711044 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -41,6 +41,7 @@ val refl_equal : EConstr.constr Lazy.t val const_of_id: Id.t -> GlobRef.t(* constantyes *) val jmeq : unit -> EConstr.constr val jmeq_refl : unit -> EConstr.constr +val make_eq : unit -> EConstr.constr val save : Id.t @@ -84,7 +85,21 @@ val update_Function : function_info -> unit val pr_info : Environ.env -> Evd.evar_map -> function_info -> Pp.t val pr_table : Environ.env -> Evd.evar_map -> Pp.t +val observe_tac + : (Environ.env -> Evd.evar_map -> Pp.t) + -> Tacmach.tactic -> Tacmach.tactic + +module New : sig + + val observe_tac + : header:Pp.t + -> (Environ.env -> Evd.evar_map -> Pp.t) + -> unit Proofview.tactic -> unit Proofview.tactic + +end + (* val function_debug : bool ref *) +val observe : Pp.t -> unit val do_observe : unit -> bool val do_rewrite_dependent : unit -> bool diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index f6b5a06cac..38fdd789a3 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -8,880 +8,15 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Ltac_plugin -open Declarations -open CErrors open Util open Names -open Term open Constr -open Context open EConstr -open Vars -open Pp -open Tacticals +open Tacmach.New open Tactics -open Indfun_common -open Tacmach -open Tactypes -open Termops -open Context.Rel.Declaration - -module RelDecl = Context.Rel.Declaration - -(* The local debugging mechanism *) -(* let msgnl = Pp.msgnl *) - -let observe strm = - if do_observe () - then Feedback.msg_debug strm - else () - -(*let observennl strm = - if do_observe () - then begin Pp.msg strm;Pp.pp_flush () end - else ()*) - - -let do_observe_tac s tac g = - let goal = - try Printer.pr_goal g - with e when CErrors.noncritical e -> assert false - in - try - let v = tac g in - msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v - with reraise -> - let reraise = CErrors.push reraise in - observe (hov 0 (str "observation "++ s++str " raised exception " ++ - CErrors.iprint reraise ++ str " on goal" ++ fnl() ++ goal )); - iraise reraise;; - -let observe_tac s tac g = - if do_observe () - then do_observe_tac (str s) tac g - else tac g - -let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl - -(* (\* [id_to_constr id] finds the term associated to [id] in the global environment *\) *) -(* let id_to_constr id = *) -(* try *) -(* Constrintern.global_reference id *) -(* with Not_found -> *) -(* raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id)) *) - - -let make_eq () = - try - EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref "core.eq.type")) - with _ -> assert false - -(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] - (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. - - [generate_type true f i] returns - \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, - graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion - - [generate_type false f i] returns - \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, - res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion - *) - -let generate_type evd g_to_f f graph i = - (*i we deduce the number of arguments of the function and its returned type from the graph i*) - let evd',graph = - Evd.fresh_global (Global.env ()) !evd (GlobRef.IndRef (fst (destInd !evd graph))) - in - evd:=evd'; - let sigma, graph_arity = Typing.type_of (Global.env ()) !evd graph in - evd := sigma; - let ctxt,_ = decompose_prod_assum !evd graph_arity in - let fun_ctxt,res_type = - match ctxt with - | [] | [_] -> anomaly (Pp.str "Not a valid context.") - | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl - in - let rec args_from_decl i accu = function - | [] -> accu - | LocalDef _ :: l -> - args_from_decl (succ i) accu l - | _ :: l -> - let t = mkRel i in - args_from_decl (succ i) (t :: accu) l - in - (*i We need to name the vars [res] and [fv] i*) - let filter = fun decl -> match RelDecl.get_name decl with - | Name id -> Some id - | Anonymous -> None - in - let named_ctxt = Id.Set.of_list (List.map_filter filter fun_ctxt) in - let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in - let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (Id.Set.add res_id named_ctxt) in - (*i we can then type the argument to be applied to the function [f] i*) - let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in - (*i - the hypothesis [res = fv] can then be computed - We will need to lift it by one in order to use it as a conclusion - i*) - let make_eq = make_eq () - in - let res_eq_f_of_args = - mkApp(make_eq ,[|lift 2 res_type;mkRel 1;mkRel 2|]) - in - (*i - The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed - We will need to lift it by one in order to use it as a conclusion - i*) - let args_and_res_as_rels = Array.of_list (args_from_decl 3 [] fun_ctxt) in - let args_and_res_as_rels = Array.append args_and_res_as_rels [|mkRel 1|] in - let graph_applied = mkApp(graph, args_and_res_as_rels) in - (*i The [pre_context] is the defined to be the context corresponding to - \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] - i*) - let pre_ctxt = - LocalAssum (make_annot (Name res_id) Sorts.Relevant, lift 1 res_type) :: - LocalDef (make_annot (Name fv_id) Sorts.Relevant, mkApp (f,args_as_rels), res_type) :: fun_ctxt - in - (*i and we can return the solution depending on which lemma type we are defining i*) - if g_to_f - then LocalAssum (make_annot Anonymous Sorts.Relevant,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph - else LocalAssum (make_annot Anonymous Sorts.Relevant,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph - - -(* - [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect] - - WARNING: while convertible, [type_of body] and [type] can be non equal -*) -let find_induction_principle evd f = - let f_as_constant,u = match EConstr.kind !evd f with - | Const c' -> c' - | _ -> user_err Pp.(str "Must be used with a function") - in - let infos = find_Function_infos f_as_constant in - match infos.rect_lemma with - | None -> raise Not_found - | Some rect_lemma -> - let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) in - let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in - evd:=evd'; - rect_lemma,typ - - -let rec generate_fresh_id x avoid i = - if i == 0 - then [] - else - let id = Namegen.next_ident_away_in_goal x (Id.Set.of_list avoid) in - id::(generate_fresh_id x (id::avoid) (pred i)) - - -(* [prove_fun_correct funs_constr graphs_constr schemes lemmas_types_infos i ] - is the tactic used to prove correctness lemma. - - [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions - (resp. graphs of the functions and principles and correctness lemma types) to prove correct. - - [i] is the indice of the function to prove correct - - The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is - it looks like~: - [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, - res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res] - - - The sketch of the proof is the following one~: - \begin{enumerate} - \item intros until $x_n$ - \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i) - \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the - apply the corresponding constructor of the corresponding graph inductive. - \end{enumerate} - -*) -let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = - fun g -> - (* first of all we recreate the lemmas types to be used as predicates of the induction principle - that is~: - \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] - *) - (* we the get the definition of the graphs block *) - let graph_ind,u = destInd evd graphs_constr.(i) in - let kn = fst graph_ind in - let mib,_ = Global.lookup_inductive graph_ind in - (* and the principle to use in this lemma in $\zeta$ normal form *) - let f_principle,princ_type = schemes.(i) in - let princ_type = Reductionops.nf_zeta (Global.env ()) evd princ_type in - let princ_infos = Tactics.compute_elim_sig evd princ_type in - (* The number of args of the function is then easily computable *) - let nb_fun_args = nb_prod (project g) (pf_concl g) - 2 in - let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names@(pf_ids_of_hyps g) in - (* Since we cannot ensure that the functional principle is defined in the - environment and due to the bug #1174, we will need to pose the principle - using a name - *) - let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") (Id.Set.of_list ids) in - let ids = principle_id :: ids in - (* We get the branches of the principle *) - let branches = List.rev princ_infos.branches in - (* and built the intro pattern for each of them *) - let intro_pats = - List.map - (fun decl -> - List.map - (fun id -> CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) - ) - branches - in - (* before building the full intro pattern for the principle *) - let eq_ind = make_eq () in - let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in - (* The next to referencies will be used to find out which constructor to apply in each branch *) - let ind_number = ref 0 - and min_constr_number = ref 0 in - (* The tactic to prove the ith branch of the principle *) - let prove_branche i g = - (* We get the identifiers of this branch *) - let pre_args = - List.fold_right - (fun {CAst.v=pat} acc -> - match pat with - | IntroNaming (Namegen.IntroIdentifier id) -> id::acc - | _ -> anomaly (Pp.str "Not an identifier.") - ) - (List.nth intro_pats (pred i)) - [] - in - (* and get the real args of the branch by unfolding the defined constant *) - (* - We can then recompute the arguments of the constructor. - For each [hid] introduced by this branch, if [hid] has type - $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are - [ fv (hid fv (refl_equal fv)) ]. - If [hid] has another type the corresponding argument of the constructor is [hid] - *) - let constructor_args g = - List.fold_right - (fun hid acc -> - let type_of_hid = pf_unsafe_type_of g (mkVar hid) in - let sigma = project g in - match EConstr.kind sigma type_of_hid with - | Prod(_,_,t') -> - begin - match EConstr.kind sigma t' with - | Prod(_,t'',t''') -> - begin - match EConstr.kind sigma t'',EConstr.kind sigma t''' with - | App(eq,args), App(graph',_) - when - (EConstr.eq_constr sigma eq eq_ind) && - Array.exists (EConstr.eq_constr_nounivs sigma graph') graphs_constr -> - (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) - ::acc) - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - ) pre_args [] - in - (* in fact we must also add the parameters to the constructor args *) - let constructor_args g = - let params_id = fst (List.chop princ_infos.nparams args_names) in - (List.map mkVar params_id)@((constructor_args g)) - in - (* We then get the constructor corresponding to this branch and - modifies the references has needed i.e. - if the constructor is the last one of the current inductive then - add one the number of the inductive to take and add the number of constructor of the previous - graph to the minimal constructor number - *) - let constructor = - let constructor_num = i - !min_constr_number in - let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then - begin - (kn,!ind_number),constructor_num - end - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length ; - (kn,!ind_number),1 - end - in - (* we can then build the final proof term *) - let app_constructor g = applist((mkConstructU(constructor,u)),constructor_args g) in - (* an apply the tactic *) - let res,hres = - match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with - | [res;hres] -> res,hres - | _ -> assert false - in - (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) - ( - tclTHENLIST - [ - observe_tac("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in - match l with - | [] -> tclIDTAC - | _ -> Proofview.V82.of_tactic (intro_patterns false l)); - (* unfolding of all the defined variables introduced by this branch *) - (* observe_tac "unfolding" pre_tac; *) - (* $zeta$ normalizing of the conclusion *) - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - { Redops.all_flags with - Genredexpr.rDelta = false ; - Genredexpr.rConst = [] - } - ) - Locusops.onConcl); - observe_tac ("toto ") tclIDTAC; - - (* introducing the result of the graph and the equality hypothesis *) - observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); - (* replacing [res] with its value *) - observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); - (* Conclusion *) - observe_tac "exact" (fun g -> - Proofview.V82.of_tactic (exact_check (app_constructor g)) g) - ] - ) - g - in - (* end of branche proof *) - let lemmas = - Array.map - (fun ((_,(ctxt,concl))) -> - match ctxt with - | [] | [_] | [_;_] -> anomaly (Pp.str "bad context.") - | hres::res::decl::ctxt -> - let res = EConstr.it_mkLambda_or_LetIn - (EConstr.it_mkProd_or_LetIn concl [hres;res]) - (LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) :: ctxt) - in - res) - lemmas_types_infos - in - let param_names = fst (List.chop princ_infos.nparams args_names) in - let params = List.map mkVar param_names in - let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in - (* The bindings of the principle - that is the params of the principle and the different lemma types - *) - let bindings = - let params_bindings,avoid = - List.fold_left2 - (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - p::bindings,id::avoid - ) - ([],pf_ids_of_hyps g) - princ_infos.params - (List.rev params) - in - let lemmas_bindings = - List.rev (fst (List.fold_left2 - (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - (Reductionops.nf_zeta (pf_env g) (project g) p)::bindings,id::avoid) - ([],avoid) - princ_infos.predicates - (lemmas))) - in - (params_bindings@lemmas_bindings) - in - tclTHENLIST - [ - observe_tac "principle" (Proofview.V82.of_tactic (assert_by - (Name principle_id) - princ_type - (exact_check f_principle))); - observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); - (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) - observe_tac "idtac" tclIDTAC; - tclTHEN_i - (observe_tac - "functional_induction" ( - (fun gl -> - let term = mkApp (mkVar principle_id,Array.of_list bindings) in - let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl term in - Proofview.V82.of_tactic (apply term) gl') - )) - (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) - ] - g - +open Tacticals.New - - -(* [generalize_dependent_of x hyp g] - generalize every hypothesis which depends of [x] but [hyp] -*) -let generalize_dependent_of x hyp g = - let open Context.Named.Declaration in - tclMAP - (function - | LocalAssum ({binder_name=id},t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) (project g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) - | _ -> tclIDTAC - ) - (pf_hyps g) - g - - -(* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis - (unfolding, substituting, destructing cases \ldots) - *) -let tauto = - let dp = List.map Id.of_string ["Tauto" ; "Init"; "Coq"] in - let mp = ModPath.MPfile (DirPath.make dp) in - let kn = KerName.make mp (Label.make "tauto") in - Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> - let body = Tacenv.interp_ltac kn in - Tacinterp.eval_tactic body - end - -let rec intros_with_rewrite g = - observe_tac "intros_with_rewrite" intros_with_rewrite_aux g -and intros_with_rewrite_aux : Tacmach.tactic = - fun g -> - let eq_ind = make_eq () in - let sigma = project g in - match EConstr.kind sigma (pf_concl g) with - | Prod(_,t,t') -> - begin - match EConstr.kind sigma t with - | App(eq,args) when (EConstr.eq_constr sigma eq eq_ind) -> - if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g - else if isVar sigma args.(1) && (Environ.evaluable_named (destVar sigma args.(1)) (pf_env g)) - then tclTHENLIST[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))] ((destVar sigma args.(1)),Locus.InHyp) ))) - (pf_ids_of_hyps g); - intros_with_rewrite - ] g - else if isVar sigma args.(2) && (Environ.evaluable_named (destVar sigma args.(2)) (pf_env g)) - then tclTHENLIST[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))] ((destVar sigma args.(2)),Locus.InHyp) ))) - (pf_ids_of_hyps g); - intros_with_rewrite - ] g - else if isVar sigma args.(1) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar sigma args.(1)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); - intros_with_rewrite - ] - g - else if isVar sigma args.(2) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar sigma args.(2)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); - intros_with_rewrite - ] - g - else - begin - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST[ - Proofview.V82.of_tactic (Simple.intro id); - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); - intros_with_rewrite - ] g - end - | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type")) -> - Proofview.V82.of_tactic tauto g - | Case(_,_,v,_) -> - tclTHENLIST[ - Proofview.V82.of_tactic (simplest_case v); - intros_with_rewrite - ] g - | LetIn _ -> - tclTHENLIST[ - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - intros_with_rewrite - ] g - | _ -> - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g - end - | LetIn _ -> - tclTHENLIST[ - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - intros_with_rewrite - ] g - | _ -> tclIDTAC g - -let rec reflexivity_with_destruct_cases g = - let destruct_case () = - try - match EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) with - | Case(_,_,v,_) -> - tclTHENLIST[ - Proofview.V82.of_tactic (simplest_case v); - Proofview.V82.of_tactic intros; - observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases - ] - | _ -> Proofview.V82.of_tactic reflexivity - with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity - in - let eq_ind = make_eq () in - let my_inj_flags = Some { - Equality.keep_proof_equalities = false; - injection_in_context = false; (* for compatibility, necessary *) - injection_pattern_l2r_order = false; (* probably does not matter; except maybe with dependent hyps *) - } in - let discr_inject = - Tacticals.onAllHypsAndConcl ( - fun sc g -> - match sc with - None -> tclIDTAC g - | Some id -> - match EConstr.kind (project g) (pf_unsafe_type_of g (mkVar id)) with - | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> - if Equality.discriminable (pf_env g) (project g) t1 t2 - then Proofview.V82.of_tactic (Equality.discrHyp id) g - else if Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 - then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id);thin [id];intros_with_rewrite] g - else tclIDTAC g - | _ -> tclIDTAC g - ) - in - (tclFIRST - [ observe_tac "reflexivity_with_destruct_cases : reflexivity" (Proofview.V82.of_tactic reflexivity); - observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); - (* We reach this point ONLY if - the same value is matched (at least) two times - along binding path. - In this case, either we have a discriminable hypothesis and we are done, - either at least an injectable one and we do the injection before continuing - *) - observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases) - ]) - g - - -(* [prove_fun_complete funs graphs schemes lemmas_types_infos i] - is the tactic used to prove completeness lemma. - - [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions - (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. - - [i] is the indice of the function to prove complete - - The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is - it looks like~: - [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, - graph\ x_1\ldots x_n\ res, \rightarrow res = f x_1\ldots x_n in] - - - The sketch of the proof is the following one~: - \begin{enumerate} - \item intros until $H:graph\ x_1\ldots x_n\ res$ - \item $elim\ H$ using schemes.(i) - \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has - type [x=?] with [x] a variable, then subst [x], - if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else - if [h] is a match then destruct it, else do just introduce it, - after all intros, the conclusion should be a reflexive equality. - \end{enumerate} - -*) - - -let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tactic = - fun g -> - (* We compute the types of the different mutually recursive lemmas - in $\zeta$ normal form - *) - let lemmas = - Array.map - (fun (_,(ctxt,concl)) -> Reductionops.nf_zeta (pf_env g) (project g) (EConstr.it_mkLambda_or_LetIn concl ctxt)) - lemmas_types_infos - in - (* We get the constant and the principle corresponding to this lemma *) - let f = funcs.(i) in - let graph_principle = Reductionops.nf_zeta (pf_env g) (project g) (EConstr.of_constr schemes.(i)) in - let princ_type = pf_unsafe_type_of g graph_principle in - let princ_infos = Tactics.compute_elim_sig (project g) princ_type in - (* Then we get the number of argument of the function - and compute a fresh name for each of them - *) - let nb_fun_args = nb_prod (project g) (pf_concl g) - 2 in - let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names@(pf_ids_of_hyps g) in - (* and fresh names for res H and the principle (cf bug bug #1174) *) - let res,hres,graph_principle_id = - match generate_fresh_id (Id.of_string "z") ids 3 with - | [res;hres;graph_principle_id] -> res,hres,graph_principle_id - | _ -> assert false - in - let ids = res::hres::graph_principle_id::ids in - (* we also compute fresh names for each hyptohesis of each branch - of the principle *) - let branches = List.rev princ_infos.branches in - let intro_pats = - List.map - (fun decl -> - List.map - (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (nb_prod (project g) (RelDecl.get_type decl))) - ) - branches - in - (* We will need to change the function by its body - using [f_equation] if it is recursive (that is the graph is infinite - or unfold if the graph is finite - *) - let rewrite_tac j ids : Tacmach.tactic = - let graph_def = graphs.(j) in - let infos = - try find_Function_infos (fst (destConst (project g) funcs.(j))) - with Not_found -> user_err Pp.(str "No graph found") - in - if infos.is_general - || Rtree.is_infinite Declareops.eq_recarg graph_def.mind_recargs - then - let eq_lemma = - try Option.get (infos).equation_lemma - with Option.IsNone -> anomaly (Pp.str "Cannot find equation lemma.") - in - tclTHENLIST[ - tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; - Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); - (* Don't forget to $\zeta$ normlize the term since the principles - have been $\zeta$-normalized *) - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - Proofview.V82.of_tactic (generalize (List.map mkVar ids)); - thin ids - ] - else - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst (project g) f)))]) - in - (* The proof of each branche itself *) - let ind_number = ref 0 in - let min_constr_number = ref 0 in - let prove_branche i g = - (* we fist compute the inductive corresponding to the branch *) - let this_ind_number = - let constructor_num = i - !min_constr_number in - let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then !ind_number - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length; - !ind_number - end - in - let this_branche_ids = List.nth intro_pats (pred i) in - tclTHENLIST[ - (* we expand the definition of the function *) - observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); - (* introduce hypothesis with some rewrite *) - observe_tac "intros_with_rewrite (all)" intros_with_rewrite; - (* The proof is (almost) complete *) - observe_tac "reflexivity" (reflexivity_with_destruct_cases) - ] - g - in - let params_names = fst (List.chop princ_infos.nparams args_names) in - let open EConstr in - let params = List.map mkVar params_names in - tclTHENLIST - [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); - observe_tac "h_generalize" - (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); - Proofview.V82.of_tactic (Simple.intro graph_principle_id); - observe_tac "" (tclTHEN_i - (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings))))) - (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) - ] - g - - -(* [derive_correctness make_scheme funs graphs] create correctness and completeness - lemmas for each function in [funs] w.r.t. [graphs] -*) - -let derive_correctness (funs: pconstant list) (graphs:inductive list) = - assert (funs <> []); - assert (graphs <> []); - let funs = Array.of_list funs and graphs = Array.of_list graphs in - let map (c, u) = mkConstU (c, EInstance.make u) in - let funs_constr = Array.map map funs in - (* XXX STATE Why do we need this... why is the toplevel protection not enough *) - funind_purify - (fun () -> - let env = Global.env () in - let evd = ref (Evd.from_env env) in - let graphs_constr = Array.map mkInd graphs in - let lemmas_types_infos = - Util.Array.map2_i - (fun i f_constr graph -> - (* let const_of_f,u = destConst f_constr in *) - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd false f_constr graph i - in - let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in - graphs_constr.(i) <- graph; - let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in - evd := sigma; - let type_of_lemma = Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr - in - let schemes = - (* The functional induction schemes are computed and not saved if there is more that one function - if the block contains only one function we can safely reuse [f_rect] - *) - try - if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; - [| find_induction_principle evd funs_constr.(0) |] - with Not_found -> - ( - - Array.of_list - (List.map - (fun entry -> - (EConstr.of_constr (fst (fst(Future.force entry.Proof_global.proof_entry_body))), EConstr.of_constr (Option.get entry.Proof_global.proof_entry_type )) - ) - (Functional_principles_types.make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs)) - ) - ) - in - let proving_tac = - prove_fun_correct !evd funs_constr graphs_constr schemes lemmas_types_infos - in - Array.iteri - (fun i f_as_constant -> - let f_id = Label.to_id (Constant.label (fst f_as_constant)) in - (*i The next call to mk_correct_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - let lem_id = mk_correct_id f_id in - let (typ,_) = lemmas_types_infos.(i) in - let info = Lemmas.Info.make - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:(Decls.(IsProof Theorem)) () in - let lemma = Lemmas.start_lemma - ~name:lem_id - ~poly:false - ~info - !evd - typ in - let lemma = fst @@ Lemmas.by - (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") - (proving_tac i))) lemma in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = find_Function_infos (fst f_as_constant) in - (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) - let _,lem_cst_constr = Evd.fresh_global - (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = destConst !evd lem_cst_constr in - update_Function {finfo with correctness_lemma = Some lem_cst}; - - ) - funs; - let lemmas_types_infos = - Util.Array.map2_i - (fun i f_constr graph -> - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd true f_constr graph i - in - let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in - graphs_constr.(i) <- graph; - let type_of_lemma = - EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt - in - let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr - in - - let (kn,_) as graph_ind,u = (destInd !evd graphs_constr.(0)) in - let mib,mip = Global.lookup_inductive graph_ind in - let sigma, scheme = - (Indrec.build_mutual_induction_scheme (Global.env ()) !evd - (Array.to_list - (Array.mapi - (fun i _ -> ((kn,i), EInstance.kind !evd u),true,InType) - mib.Declarations.mind_packets - ) - ) - ) - in - let schemes = - Array.of_list scheme - in - let proving_tac = - prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos - in - Array.iteri - (fun i f_as_constant -> - let f_id = Label.to_id (Constant.label (fst f_as_constant)) in - (*i The next call to mk_complete_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - let lem_id = mk_complete_id f_id in - let info = Lemmas.Info.make - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.(IsProof Theorem) () in - let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false ~info - sigma (fst lemmas_types_infos.(i)) in - let lemma = fst (Lemmas.by - (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") - (proving_tac i))) lemma) in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = find_Function_infos (fst f_as_constant) in - let _,lem_cst_constr = Evd.fresh_global - (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = destConst !evd lem_cst_constr in - update_Function {finfo with completeness_lemma = Some lem_cst} - ) - funs) - () +open Indfun_common (***********************************************) @@ -891,38 +26,35 @@ let derive_correctness (funs: pconstant list) (graphs:inductive list) = if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing *) -let revert_graph kn post_tac hid g = - let sigma = project g in - let typ = pf_unsafe_type_of g (mkVar hid) 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 (* We have generated a graph hypothesis so that we must change it if we can *) - let info = - try find_Function_of_graph ind' - with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) - anomaly (Pp.str "Cannot retrieve infos about a mutual block.") - in - (* if we can find a completeness lemma for this function - then we can come back to the functional form. If not, we do nothing - *) - match info.completeness_lemma with - | None -> tclIDTAC g - | Some f_complete -> - let f_args,res = Array.chop (Array.length args - 1) args in - tclTHENLIST - [ - Proofview.V82.of_tactic (generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]); - thin [hid]; - Proofview.V82.of_tactic (Simple.intro hid); - post_tac hid - ] - g - - else tclIDTAC g - | _ -> tclIDTAC g - +let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> + let sigma = project gl in + let typ = pf_unsafe_type_of gl (mkVar hid) 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 (* We have generated a graph hypothesis so that we must change it if we can *) + let info = + try find_Function_of_graph ind' + with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) + CErrors.anomaly (Pp.str "Cannot retrieve infos about a mutual block.") + in + (* if we can find a completeness lemma for this function + then we can come back to the functional form. If not, we do nothing + *) + match info.completeness_lemma with + | None -> tclIDTAC + | Some f_complete -> + let f_args,res = Array.chop (Array.length args - 1) args in + tclTHENLIST + [ generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])] + ; clear [hid] + ; Simple.intro hid + ; post_tac hid + ] + else tclIDTAC + | _ -> tclIDTAC + ) (* [functional_inversion hid fconst f_correct ] is the functional version of [inversion] @@ -941,101 +73,91 @@ let revert_graph kn post_tac hid g = \end{enumerate} *) -let functional_inversion kn hid fconst f_correct : Tacmach.tactic = - fun g -> - let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in - let sigma = project g in - let type_of_h = pf_unsafe_type_of g (mkVar hid) in - match EConstr.kind sigma type_of_h with - | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> - let pre_tac,f_args,res = - match EConstr.kind sigma args.(1),EConstr.kind sigma args.(2) with - | App(f,f_args),_ when EConstr.eq_constr sigma f fconst -> - ((fun hid -> Proofview.V82.of_tactic (intros_symmetry (Locusops.onHyp hid))),f_args,args.(2)) - |_,App(f,f_args) when EConstr.eq_constr sigma f fconst -> - ((fun hid -> tclIDTAC),f_args,args.(1)) - | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) - in - tclTHENLIST [ - pre_tac hid; - Proofview.V82.of_tactic (generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]); - thin [hid]; - Proofview.V82.of_tactic (Simple.intro hid); - Proofview.V82.of_tactic (Inv.inv Inv.FullInversion None (NamedHyp hid)); - (fun g -> - let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps g) in - tclMAP (revert_graph kn pre_tac) (hid::new_ids) g - ); - ] g - | _ -> tclFAIL 1 (mt ()) g - - -let error msg = user_err Pp.(str msg) +let functional_inversion kn hid fconst f_correct = Proofview.Goal.enter (fun gl -> + let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty in + let sigma = project gl in + let type_of_h = pf_unsafe_type_of gl (mkVar hid) in + match EConstr.kind sigma type_of_h with + | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> + let pre_tac,f_args,res = + match EConstr.kind sigma args.(1),EConstr.kind sigma args.(2) with + | App(f,f_args),_ when EConstr.eq_constr sigma f fconst -> + ((fun hid -> intros_symmetry (Locusops.onHyp hid))),f_args,args.(2) + |_,App(f,f_args) when EConstr.eq_constr sigma f fconst -> + ((fun hid -> tclIDTAC),f_args,args.(1)) + | _ -> (fun hid -> tclFAIL 1 Pp.(mt ())),[||],args.(2) + in + tclTHENLIST + [ pre_tac hid + ; generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])] + ; clear [hid] + ; Simple.intro hid + ; Inv.inv Inv.FullInversion None (Tactypes.NamedHyp hid) + ; Proofview.Goal.enter (fun gl -> + let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps gl) in + tclMAP (revert_graph kn pre_tac) (hid::new_ids) + ) + ] + | _ -> tclFAIL 1 Pp.(mt ()) + ) let invfun qhyp f = let f = match f with - | GlobRef.ConstRef f -> f - | _ -> raise (CErrors.UserError(None,str "Not a function")) + | GlobRef.ConstRef f -> f + | _ -> + CErrors.user_err Pp.(str "Not a function") in try let finfos = find_Function_infos f in let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind - in - Proofview.V82.of_tactic ( - Tactics.try_intros_until (fun hid -> Proofview.V82.tactic (functional_inversion kn hid (mkConst f) f_correct)) qhyp - ) + and kn = fst finfos.graph_ind in + Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp with - | Not_found -> error "No graph found" - | Option.IsNone -> error "Cannot use equivalence with graph!" + | Not_found -> CErrors.user_err (Pp.str "No graph found") + | Option.IsNone -> CErrors.user_err (Pp.str "Cannot use equivalence with graph!") exception NoFunction -let invfun qhyp f g = + +let invfun qhyp f = match f with - | Some f -> invfun qhyp f g - | None -> - Proofview.V82.of_tactic begin - Tactics.try_intros_until - (fun hid -> Proofview.V82.tactic begin fun g -> - let sigma = project g in - let hyp_typ = pf_unsafe_type_of g (mkVar hid) in - match EConstr.kind sigma hyp_typ with - | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> - begin - let f1,_ = decompose_app sigma args.(1) in - try - if not (isConst sigma f1) then raise NoFunction; - let finfos = find_Function_infos (fst (destConst sigma f1)) in - let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f1 f_correct g - with | NoFunction | Option.IsNone | Not_found -> - try - let f2,_ = decompose_app sigma args.(2) in - if not (isConst sigma f2) then raise NoFunction; - let finfos = find_Function_infos (fst (destConst sigma f2)) in - let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f2 f_correct g - with - | NoFunction -> - user_err (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") - | Option.IsNone -> - if do_observe () - then - error "Cannot use equivalence with graph for any side of the equality" - else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Not_found -> - if do_observe () - then - error "No graph found for any side of equality" - else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - end - | _ -> user_err (Ppconstr.pr_id hid ++ str " must be an equality ") - end) - qhyp - end - g + | Some f -> invfun qhyp f + | None -> + let tac_action hid gl = + let sigma = project gl in + let hyp_typ = pf_unsafe_type_of gl (mkVar hid) in + match EConstr.kind sigma hyp_typ with + | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> + begin + let f1,_ = decompose_app sigma args.(1) in + try + if not (isConst sigma f1) then raise NoFunction; + let finfos = find_Function_infos (fst (destConst sigma f1)) in + let f_correct = mkConst(Option.get finfos.correctness_lemma) + and kn = fst finfos.graph_ind + in + functional_inversion kn hid f1 f_correct + with | NoFunction | Option.IsNone | Not_found -> + try + let f2,_ = decompose_app sigma args.(2) in + if not (isConst sigma f2) then raise NoFunction; + let finfos = find_Function_infos (fst (destConst sigma f2)) in + let f_correct = mkConst(Option.get finfos.correctness_lemma) + and kn = fst finfos.graph_ind + in + functional_inversion kn hid f2 f_correct + with + | NoFunction -> + CErrors.user_err Pp.(str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") + | Option.IsNone -> + if do_observe () + then CErrors.user_err (Pp.str "Cannot use equivalence with graph for any side of the equality") + else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + | Not_found -> + if do_observe () + then CErrors.user_err (Pp.str "No graph found for any side of equality") + else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + end + | _ -> CErrors.user_err Pp.(Ppconstr.pr_id hid ++ str " must be an equality ") + in + try_intros_until (tac_action %> Proofview.Goal.enter) qhyp diff --git a/plugins/funind/invfun.mli b/plugins/funind/invfun.mli index c7538fae9a..6b789e1bb2 100644 --- a/plugins/funind/invfun.mli +++ b/plugins/funind/invfun.mli @@ -8,12 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val invfun : - Tactypes.quantified_hypothesis -> - Names.GlobRef.t option -> - Evar.t Evd.sigma -> Evar.t list Evd.sigma - -val derive_correctness - : Constr.pconstant list - -> Names.inductive list - -> unit +val invfun + : Tactypes.quantified_hypothesis + -> Names.GlobRef.t option + -> unit Proofview.tactic diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 937118bf57..c62aa0cf6b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -199,54 +199,24 @@ let (declare_f : Id.t -> Decls.logical_kind -> Constr.t list -> GlobRef.t -> Glo fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref);; - - -(* Debugging mechanism *) -let debug_queue = Stack.create () - -let print_debug_queue b e = - if not (Stack.is_empty debug_queue) - then - begin - let lmsg,goal = Stack.pop debug_queue in - if b then - Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.iprint e) ++ str " on goal" ++ fnl() ++ goal)) - else - begin - Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)); - end; - (* print_debug_queue false e; *) - end - -let observe strm = +let observe_tclTHENLIST s tacl = if do_observe () - then Feedback.msg_debug strm - else () + then + let rec aux n = function + | [] -> tclIDTAC + | [tac] -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac + | tac::tacl -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) + in + aux 0 tacl + else tclTHENLIST tacl +module New = struct -let do_observe_tac s tac g = - let goal = Printer.pr_goal g in - let s = s (pf_env g) (project g) in - let lmsg = (str "recdef : ") ++ s in - observe (s++fnl()); - Stack.push (lmsg,goal) debug_queue; - try - let v = tac g in - ignore(Stack.pop debug_queue); - v - with reraise -> - let reraise = CErrors.push reraise in - if not (Stack.is_empty debug_queue) - then print_debug_queue true reraise; - iraise reraise - -let observe_tac s tac g = - if do_observe () - then do_observe_tac s tac g - else tac g + open Tacticals.New + let observe_tac = New.observe_tac ~header:(Pp.mt()) -let observe_tclTHENLIST s tacl = + let observe_tclTHENLIST s tacl = if do_observe () then let rec aux n = function @@ -257,38 +227,36 @@ let observe_tclTHENLIST s tacl = aux 0 tacl else tclTHENLIST tacl +end + (* Conclusion tactics *) (* The boolean value is_mes expresses that the termination is expressed using a measure function instead of a well-founded relation. *) -let tclUSER tac is_mes l g = +let tclUSER tac is_mes l = + let open Tacticals.New in let clear_tac = match l with - | None -> tclIDTAC - | Some l -> tclMAP (fun id -> tclTRY (Proofview.V82.of_tactic (clear [id]))) (List.rev l) + | None -> tclIDTAC + | Some l -> tclMAP (fun id -> tclTRY (clear [id])) (List.rev l) in - observe_tclTHENLIST (fun _ _ -> str "tclUSER1") - [ - clear_tac; + New.observe_tclTHENLIST (fun _ _ -> str "tclUSER1") + [ clear_tac; if is_mes - then observe_tclTHENLIST (fun _ _ -> str "tclUSER2") - [ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference - (delayed_force Indfun_common.ltof_ref))]); - tac - ] + then + New.observe_tclTHENLIST (fun _ _ -> str "tclUSER2") + [ unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference + (delayed_force Indfun_common.ltof_ref))] + ; tac + ] else tac ] - g let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = if is_mes - then tclCOMPLETE (fun gl -> Proofview.V82.of_tactic (Simple.apply (delayed_force well_founded_ltof)) gl) - else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) (tclUSER concl_tac is_mes names_to_suppress) - - - - + then Tacticals.New.tclCOMPLETE (Simple.apply (delayed_force well_founded_ltof)) + else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) + (tclUSER concl_tac is_mes names_to_suppress) (* Traveling term. Both definitions of [f_terminate] and [f_equation] use the same generic @@ -330,7 +298,7 @@ let check_not_nested env sigma forbidden e = (* ['a info] contains the local information for traveling *) type 'a infos = { nb_arg : int; (* function number of arguments *) - concl_tac : tactic; (* final tactic to finish proofs *) + concl_tac : unit Proofview.tactic; (* final tactic to finish proofs *) rec_arg_id : Id.t; (*name of the declared recursive argument *) is_mes : bool; (* type of recursion *) ih : Id.t; (* induction hypothesis name *) @@ -803,6 +771,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ g = expr_info.eqs ) ); + Proofview.V82.of_tactic @@ tclUSER expr_info.concl_tac true (Some ( expr_info.ih::expr_info.acc_id:: @@ -1153,7 +1122,7 @@ let rec instantiate_lambda sigma t l = let (_, _, body) = destLambda sigma t in instantiate_lambda sigma (subst1 a body) l -let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = +let whole_start concl_tac nb_args is_mes func input_type relation rec_arg_num : tactic = begin fun g -> let sigma = project g in @@ -1195,7 +1164,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a is_final = true; (* and on leaf (more or less) *) f_terminate = delayed_force coq_O; nb_arg = nb_args; - concl_tac = concl_tac; + concl_tac; rec_arg_id = rec_arg_id; is_mes = is_mes; ih = hrec; @@ -1213,7 +1182,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a ) g ) - (tclUSER_if_not_mes concl_tac) + (fun b ids -> Proofview.V82.of_tactic (tclUSER_if_not_mes concl_tac b ids)) g end @@ -1320,50 +1289,47 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let lid = ref [] in let h_num = ref (-1) in let env = Global.env () in - let lemma = build_proof env (Evd.from_env env) - ( fun gls -> - let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in - observe_tclTHENLIST (fun _ _ -> str "") - [ - Proofview.V82.of_tactic (generalize [lemma]); - Proofview.V82.of_tactic (Simple.intro hid); - (fun g -> - let ids = pf_ids_of_hyps g in + let start_tac = + let open Tacmach.New in + let open Tacticals.New in + Proofview.Goal.enter (fun gl -> + let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gl) in + New.observe_tclTHENLIST (fun _ _ -> mt ()) + [ generalize [lemma] + ; Simple.intro hid + ; Proofview.Goal.enter (fun gl -> + let ids = pf_ids_of_hyps gl in tclTHEN - (Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid))) - (fun g -> - let ids' = pf_ids_of_hyps g in - lid := List.rev (List.subtract Id.equal ids' ids); - if List.is_empty !lid then lid := [hid]; - tclIDTAC g - ) - g - ); - ] gls) - (fun g -> - let sigma = project g in - match EConstr.kind sigma (pf_concl g) with - | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) -> - Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g - | _ -> - incr h_num; - (observe_tac (fun _ _ -> str "finishing using") - ( - tclCOMPLETE( - tclFIRST[ - tclTHEN - (Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))) - (Proofview.V82.of_tactic e_assumption); - Eauto.eauto_with_bases - (true,5) - [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] - [Hints.Hint_db.empty TransparentState.empty false] + (Elim.h_decompose_and (mkVar hid)) + (Proofview.Goal.enter (fun gl -> + let ids' = pf_ids_of_hyps gl in + lid := List.rev (List.subtract Id.equal ids' ids); + if List.is_empty !lid then lid := [hid]; + tclIDTAC))) + ]) in + let end_tac = + let open Tacmach.New in + let open Tacticals.New in + Proofview.Goal.enter (fun gl -> + let sigma = project gl in + match EConstr.kind sigma (pf_concl gl) with + | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) -> + Auto.h_auto None [] (Some []) + | _ -> + incr h_num; + tclCOMPLETE( + tclFIRST + [ tclTHEN + (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) + e_assumption + ; Eauto.eauto_with_bases + (true,5) + [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] + [Hints.Hint_db.empty TransparentState.empty false ] - ) - ) - ) - g) - in + ] + )) in + let lemma = build_proof env (Evd.from_env env) start_tac end_tac in Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None in let info = Lemmas.Info.make ~hook:(DeclareDef.Hook.make hook) @@ -1409,18 +1375,18 @@ let com_terminate thm_name using_lemmas nb_args ctx hook = - let start_proof env ctx (tac_start:tactic) (tac_end:tactic) = + let start_proof env ctx tac_start tac_end = let info = Lemmas.Info.make ~hook ~scope:(DeclareDef.Global ImportDefaultBehavior) ~kind:Decls.(IsProof Lemma) () in let lemma = Lemmas.start_lemma ~name:thm_name ~poly:false (*FIXME*) ~info ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) in - let lemma = fst @@ Lemmas.by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "starting_tac") tac_start)) lemma in + let lemma = fst @@ Lemmas.by (New.observe_tac (fun _ _ -> str "starting_tac") tac_start) lemma in fst @@ Lemmas.by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref input_type relation rec_arg_num ))) lemma in - let lemma = start_proof Global.(env ()) ctx tclIDTAC tclIDTAC in + let lemma = start_proof Global.(env ()) ctx Tacticals.New.tclIDTAC Tacticals.New.tclIDTAC in try let sigma, new_goal_type = build_new_goal_type lemma in let sigma = Evd.from_ctx (Evd.evar_universe_context sigma) in @@ -1469,7 +1435,7 @@ let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref equation_lemm {nb_arg=nb_arg; f_terminate = EConstr.of_constr (constr_of_monomorphic_global terminate_ref); f_constr = EConstr.of_constr f_constr; - concl_tac = tclIDTAC; + concl_tac = Tacticals.New.tclIDTAC; func=functional_ref; info=(instantiate_lambda Evd.empty (EConstr.of_constr (def_of_const (constr_of_monomorphic_global functional_ref))) diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index e6aa452def..3225411c85 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -1,10 +1,10 @@ open Constr -val tclUSER_if_not_mes : - Tacmach.tactic -> - bool -> - Names.Id.t list option -> - Tacmach.tactic +val tclUSER_if_not_mes + : unit Proofview.tactic + -> bool + -> Names.Id.t list option + -> unit Proofview.tactic val recursive_definition : interactive_proof:bool diff --git a/plugins/funind/recdef_plugin.mlpack b/plugins/funind/recdef_plugin.mlpack index 755fa4f879..2adcfddd0a 100644 --- a/plugins/funind/recdef_plugin.mlpack +++ b/plugins/funind/recdef_plugin.mlpack @@ -6,4 +6,5 @@ Functional_principles_proofs Functional_principles_types Invfun Indfun +Gen_principle G_indfun diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index 2654729652..e6e6e29d4f 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -332,7 +332,7 @@ END let local_test_lpar_id_colon = let err () = raise Stream.Failure in Pcoq.Entry.of_parser "lpar_id_colon" - (fun strm -> + (fun _ strm -> match Util.stream_nth 0 strm with | Tok.KEYWORD "(" -> (match Util.stream_nth 1 strm with diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 5c84b35f1b..cab8ed0a55 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -64,7 +64,7 @@ let classic_proof_mode = Pvernac.register_proof_mode "Classic" tactic_mode (* Hack to parse "[ id" without dropping [ *) let test_bracket_ident = Pcoq.Entry.of_parser "test_bracket_ident" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | KEYWORD "[" -> (match stream_nth 1 strm with diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 945a2dd613..9b52b710c1 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -24,7 +24,6 @@ open Tactypes open Tactics open Inv open Locus -open Decl_kinds open Pcoq @@ -40,7 +39,7 @@ let err () = raise Stream.Failure (* admissible notation "(x t)" *) let test_lpar_id_coloneq = Pcoq.Entry.of_parser "lpar_id_coloneq" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | KEYWORD "(" -> (match stream_nth 1 strm with @@ -54,7 +53,7 @@ let test_lpar_id_coloneq = (* Hack to recognize "(x)" *) let test_lpar_id_rpar = Pcoq.Entry.of_parser "lpar_id_coloneq" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | KEYWORD "(" -> (match stream_nth 1 strm with @@ -68,7 +67,7 @@ let test_lpar_id_rpar = (* idem for (x:=t) and (1:=t) *) let test_lpar_idnum_coloneq = Pcoq.Entry.of_parser "test_lpar_idnum_coloneq" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | KEYWORD "(" -> (match stream_nth 1 strm with @@ -85,7 +84,7 @@ open Extraargs (* idem for (x1..xn:t) [n^2 complexity but exceptional use] *) let check_for_coloneq = Pcoq.Entry.of_parser "lpar_id_colon" - (fun strm -> + (fun _ strm -> let rec skip_to_rpar p n = match List.last (Stream.npeek n strm) with | KEYWORD "(" -> skip_to_rpar (p+1) (n+1) @@ -109,7 +108,7 @@ let check_for_coloneq = let lookup_at_as_comma = Pcoq.Entry.of_parser "lookup_at_as_comma" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | KEYWORD (","|"at"|"as") -> () | _ -> err ()) @@ -450,9 +449,9 @@ GRAMMAR EXTEND Gram | -> { true } ] ] ; simple_binder: - [ [ na=name -> { ([na],Default Explicit, CAst.make ~loc @@ + [ [ na=name -> { ([na],Default Glob_term.Explicit, CAst.make ~loc @@ CHole (Some (Evar_kinds.BinderType na.CAst.v), IntroAnonymous, None)) } - | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> { (nal,Default Explicit,c) } + | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> { (nal,Default Glob_term.Explicit,c) } ] ] ; fixdecl: diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 0e38ce575b..6df068883c 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -20,7 +20,6 @@ open Stdarg open Notation_gram open Tactypes open Locus -open Decl_kinds open Genredexpr open Ppconstr open Pputils @@ -1097,7 +1096,7 @@ let pr_goal_selector ~toplevel s = let rec strip_ty acc n ty = if Int.equal n 0 then (List.rev acc, (ty,None)) else match DAst.get ty with - Glob_term.GProd(na,Explicit,a,b) -> + Glob_term.GProd(na,Glob_term.Explicit,a,b) -> strip_ty (([CAst.make na],(a,None))::acc) (n-1) b | _ -> user_err Pp.(str "Cannot translate fix tactic: not enough products") in strip_ty [] n ty diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 726752a2bf..1493092f2f 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -546,7 +546,7 @@ let rewrite_core_unif_flags = { Unification.check_applied_meta_types = true; Unification.use_pattern_unification = true; Unification.use_meta_bound_pattern_unification = true; - Unification.frozen_evars = Evar.Set.empty; + Unification.allowed_evars = Unification.AllowAll; Unification.restrict_conv_on_strict_subterms = false; Unification.modulo_betaiota = false; Unification.modulo_eta = true; diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 33e9f871fd..473612fda7 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -181,7 +181,6 @@ let option_assert_get o msg = (** Constructors for rawconstr *) open Glob_term -open Decl_kinds let mkRHole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index aa1316f15e..4c6b7cdcb6 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -128,10 +128,9 @@ let newssrcongrtac arg ist gl = x, re_sig si sigma in let arr, gl = pf_mkSsrConst "ssr_congr_arrow" gl in let ssr_congr lr = EConstr.mkApp (arr, lr) in + let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in (* here the two cases: simple equality or arrow *) - let equality, _, eq_args, gl' = - let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in - pf_saturate gl (EConstr.of_constr eq) 3 in + let equality, _, eq_args, gl' = pf_saturate gl (EConstr.of_constr eq) 3 in tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) (fun ty -> congrtac (arg, Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) ty) ist) (fun () -> @@ -336,17 +335,21 @@ let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_ let sigma, p = (* The resulting goal *) Evarutil.new_evar env sigma (beta (EConstr.Vars.subst1 new_rdx pred)) in let pred = EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdx_ty pred in - let elim, gl = - let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in + let sigma, elim = let sort = elimination_sort_of_goal gl in - let elim, gl = pf_fresh_global (Indrec.lookup_eliminator env ind sort) gl in - if dir = R2L then elim, gl else (* taken from Coq's rewrite *) - let elim, _ = destConst elim in - let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical elim)) in - let l' = Label.of_id (Nameops.add_suffix (Label.to_id l) "_r") in - let c1' = Global.constant_of_delta_kn (Constant.canonical (Constant.make2 mp l')) in - mkConst c1', gl in - let elim = EConstr.of_constr elim in + match Equality.eq_elimination_ref (dir = L2R) sort with + | Some r -> Evd.fresh_global env sigma r + | None -> + let ((kn, i) as ind, _), unfolded_c_ty = Tacred.reduce_to_quantified_ind env sigma c_ty in + let sort = elimination_sort_of_goal gl in + let sigma, elim = Evd.fresh_global env sigma (Indrec.lookup_eliminator env ind sort) in + if dir = R2L then sigma, elim else + let elim, _ = EConstr.destConst sigma elim in + let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical elim)) in + let l' = Label.of_id (Nameops.add_suffix (Label.to_id l) "_r") in + let c1' = Global.constant_of_delta_kn (Constant.canonical (Constant.make2 mp l')) in + sigma, EConstr.of_constr (mkConst c1') + in let proof = EConstr.mkApp (elim, [| rdx_ty; new_rdx; pred; p; rdx; c |]) in (* We check the proof is well typed *) let sigma, proof_ty = @@ -491,7 +494,8 @@ let rwprocess_rule dir rule gl = | _ -> let sigma, pi2 = Evd.fresh_global env sigma coq_prod.Coqlib.proj2 in EConstr.mkApp (pi2, ra), sigma in - if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.(lib_ref "core.True.type"))) then + let sigma,trty = Evd.fresh_global env sigma Coqlib.(lib_ref "core.True.type") in + if EConstr.eq_constr sigma a.(0) trty then let s, sigma = sr sigma 2 in loop (converse_dir d) sigma s a.(1) rs 0 else diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 962730d8dc..a1f707ffa8 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -32,7 +32,6 @@ open Ppconstr open Namegen open Tactypes -open Decl_kinds open Constrexpr open Constrexpr_ops @@ -235,7 +234,7 @@ let pr_ssrsimpl _ _ _ = pr_simpl let wit_ssrsimplrep = add_genarg "ssrsimplrep" (fun env sigma -> pr_simpl) -let test_ssrslashnum b1 b2 strm = +let test_ssrslashnum b1 b2 _ strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "/" -> (match Util.stream_nth 1 strm with @@ -276,8 +275,8 @@ let test_ssrslashnum11 = test_ssrslashnum true true let test_ssrslashnum01 = test_ssrslashnum false true let test_ssrslashnum00 = test_ssrslashnum false false -let negate_parser f x = - let rc = try Some (f x) with Stream.Failure -> None in +let negate_parser f tok x = + let rc = try Some (f tok x) with Stream.Failure -> None in match rc with | None -> () | Some _ -> raise Stream.Failure @@ -474,7 +473,7 @@ END (* Old kinds of terms *) -let input_ssrtermkind strm = match Util.stream_nth 0 strm with +let input_ssrtermkind _ strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "(" -> xInParens | Tok.KEYWORD "@" -> xWithAt | _ -> xNoFlag @@ -483,7 +482,7 @@ let ssrtermkind = Pcoq.Entry.of_parser "ssrtermkind" input_ssrtermkind (* New kinds of terms *) -let input_term_annotation strm = +let input_term_annotation _ strm = match Stream.npeek 2 strm with | Tok.KEYWORD "(" :: Tok.KEYWORD "(" :: _ -> `DoubleParens | Tok.KEYWORD "(" :: _ -> `Parens @@ -747,7 +746,7 @@ let pushIPatNoop = function | pats :: orpat -> (IPatNoop :: pats) :: orpat | [] -> [] -let test_ident_no_do strm = +let test_ident_no_do _ strm = match Util.stream_nth 0 strm with | Tok.IDENT s when s <> "do" -> () | _ -> raise Stream.Failure @@ -825,7 +824,7 @@ END { -let reject_ssrhid strm = +let reject_ssrhid _ strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "[" -> (match Util.stream_nth 1 strm with @@ -835,13 +834,13 @@ let reject_ssrhid strm = let test_nohidden = Pcoq.Entry.of_parser "test_ssrhid" reject_ssrhid -let rec reject_binder crossed_paren k s = +let rec reject_binder crossed_paren k tok s = match try Some (Util.stream_nth k s) with Stream.Failure -> None with - | Some (Tok.KEYWORD "(") when not crossed_paren -> reject_binder true (k+1) s - | Some (Tok.IDENT _) when crossed_paren -> reject_binder true (k+1) s + | Some (Tok.KEYWORD "(") when not crossed_paren -> reject_binder true (k+1) tok s + | Some (Tok.IDENT _) when crossed_paren -> reject_binder true (k+1) tok s | Some (Tok.KEYWORD ":" | Tok.KEYWORD ":=") when crossed_paren -> raise Stream.Failure | Some (Tok.KEYWORD ")") when crossed_paren -> raise Stream.Failure @@ -1006,7 +1005,7 @@ END { -let accept_ssrfwdid strm = +let accept_ssrfwdid _ strm = match stream_nth 0 strm with | Tok.IDENT id -> accept_before_syms_or_any_id [":"; ":="; "("] strm | _ -> raise Stream.Failure @@ -1337,20 +1336,20 @@ ARGUMENT EXTEND ssrbinder TYPED AS (ssrfwdfmt * constr) PRINTED BY { pr_ssrbinde | [ ssrbvar(bv) ] -> { let { CAst.loc=xloc } as x = bvar_lname bv in (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) } + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Glob_term.Explicit,mkCHole xloc)],mkCHole (Some loc)) } | [ "(" ssrbvar(bv) ")" ] -> { let { CAst.loc=xloc } as x = bvar_lname bv in (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) } + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Glob_term.Explicit,mkCHole xloc)],mkCHole (Some loc)) } | [ "(" ssrbvar(bv) ":" lconstr(t) ")" ] -> { let x = bvar_lname bv in (FwdPose, [BFdecl 1]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum([x], Default Explicit, t)], mkCHole (Some loc)) } + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x], Default Glob_term.Explicit, t)], mkCHole (Some loc)) } | [ "(" ssrbvar(bv) ne_ssrbvar_list(bvs) ":" lconstr(t) ")" ] -> { let xs = List.map bvar_lname (bv :: bvs) in let n = List.length xs in (FwdPose, [BFdecl n]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum (xs, Default Explicit, t)], mkCHole (Some loc)) } + CAst.make ~loc @@ CLambdaN ([CLocalAssum (xs, Default Glob_term.Explicit, t)], mkCHole (Some loc)) } | [ "(" ssrbvar(id) ":" lconstr(t) ":=" lconstr(v) ")" ] -> { (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, Some t, mkCHole (Some loc)) } | [ "(" ssrbvar(id) ":=" lconstr(v) ")" ] -> @@ -1362,7 +1361,7 @@ GRAMMAR EXTEND Gram ssrbinder: [ [ ["of" -> { () } | "&" -> { () } ]; c = operconstr LEVEL "99" -> { (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum ([CAst.make ~loc Anonymous],Default Explicit,c)],mkCHole (Some loc)) } ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum ([CAst.make ~loc Anonymous],Default Glob_term.Explicit,c)],mkCHole (Some loc)) } ] ]; END @@ -1391,7 +1390,7 @@ let push_binders c2 bs = let rec fix_binders = let open CAst in function | (_, { v = CLambdaN ([CLocalAssum(xs, _, t)], _) } ) :: bs -> - CLocalAssum (xs, Default Explicit, t) :: fix_binders bs + CLocalAssum (xs, Default Glob_term.Explicit, t) :: fix_binders bs | (_, { v = CLetIn (x, v, oty, _) } ) :: bs -> CLocalDef (x, v, oty) :: fix_binders bs | _ -> [] @@ -1521,7 +1520,7 @@ let intro_id_to_binder = List.map (function | IPatId id -> let { CAst.loc=xloc } as x = bvar_lname (mkCVar id) in (FwdPose, [BFvar]), - CAst.make @@ CLambdaN ([CLocalAssum([x], Default Explicit, mkCHole xloc)], + CAst.make @@ CLambdaN ([CLocalAssum([x], Default Glob_term.Explicit, mkCHole xloc)], mkCHole None) | _ -> anomaly "non-id accepted as binder") @@ -1590,7 +1589,7 @@ END let sq_brace_tacnames = ["first"; "solve"; "do"; "rewrite"; "have"; "suffices"; "wlog"] (* "by" is a keyword *) -let accept_ssrseqvar strm = +let accept_ssrseqvar _ strm = match stream_nth 0 strm with | Tok.IDENT id when not (List.mem id sq_brace_tacnames) -> accept_before_syms_or_ids ["["] ["first";"last"] strm @@ -1684,7 +1683,7 @@ let ssr_id_of_string loc s = ^ "Scripts with explicit references to anonymous variables are fragile.")) end; Id.of_string s -let ssr_null_entry = Pcoq.Entry.of_parser "ssr_null" (fun _ -> ()) +let ssr_null_entry = Pcoq.Entry.of_parser "ssr_null" (fun _ _ -> ()) } @@ -1987,7 +1986,7 @@ END { -let accept_ssreqid strm = +let accept_ssreqid _ strm = match Util.stream_nth 0 strm with | Tok.IDENT _ -> accept_before_syms [":"] strm | Tok.KEYWORD ":" -> () @@ -2406,7 +2405,7 @@ let lbrace = Char.chr 123 (** Workaround to a limitation of coqpp *) let test_ssr_rw_syntax = - let test strm = + let test _ strm = if not !ssr_rw_syntax then raise Stream.Failure else if is_ssr_loaded () then () else match Util.stream_nth 0 strm with @@ -2617,7 +2616,7 @@ END { -let accept_idcomma strm = +let accept_idcomma _ strm = match stream_nth 0 strm with | Tok.IDENT _ | Tok.KEYWORD "_" -> accept_before_syms [","] strm | _ -> raise Stream.Failure diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 0adabb0673..f3f1d713e9 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -27,7 +27,6 @@ open Notation_ops open Notation_term open Glob_term open Stdarg -open Decl_kinds open Pp open Ppconstr open Printer diff --git a/plugins/ssrmatching/g_ssrmatching.mlg b/plugins/ssrmatching/g_ssrmatching.mlg index d920ea9a46..42b800b596 100644 --- a/plugins/ssrmatching/g_ssrmatching.mlg +++ b/plugins/ssrmatching/g_ssrmatching.mlg @@ -66,7 +66,7 @@ END { -let input_ssrtermkind strm = match Util.stream_nth 0 strm with +let input_ssrtermkind _ strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "(" -> '(' | Tok.KEYWORD "@" -> '@' | _ -> ' ' diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 17db25660f..4d7a04f5ee 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -36,7 +36,6 @@ open Ppconstr open Printer open Globnames open Namegen -open Decl_kinds open Evar_kinds open Constrexpr open Constrexpr_ops diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index a148a3bc73..9808c61255 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -112,7 +112,7 @@ let vernac_numeral_notation local ty f g scope opts = let cty = mkRefC ty in let app x y = mkAppC (x,[y]) in let arrow x y = - mkProdC ([CAst.make Anonymous],Default Decl_kinds.Explicit, 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 diff --git a/plugins/syntax/string_notation.ml b/plugins/syntax/string_notation.ml index 8c0f9a3339..c92acb0f55 100644 --- a/plugins/syntax/string_notation.ml +++ b/plugins/syntax/string_notation.ml @@ -61,7 +61,7 @@ let vernac_string_notation local ty f g scope = let of_ty = Smartlocate.global_with_alias g in let cty = cref ty in let arrow x y = - mkProdC ([CAst.make Anonymous],Default Decl_kinds.Explicit, x, y) + mkProdC ([CAst.make Anonymous],Default Glob_term.Explicit, x, y) in let constructors = get_constructors tyc in (* Check the type of f *) diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 534c0ca20b..a86d237164 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -47,7 +47,7 @@ let discharge_rename_args = function | _, (ReqGlobal (c, names), _ as req) when not (isVarRef c && Lib.is_in_section c) -> (try let vars = Lib.variable_section_segment_of_reference c in - let var_names = List.map (fst %> NamedDecl.get_id %> Name.mk_name) vars in + let var_names = List.map (NamedDecl.get_id %> Name.mk_name) vars in let names' = var_names @ names in Some (ReqGlobal (c, names), (c, names')) with Not_found -> Some req) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 2061b41292..e8c83c7de9 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -25,7 +25,6 @@ open Namegen open Libnames open Globnames open Mod_subst -open Decl_kinds open Context.Named.Declaration open Ltac_pretype diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index cc9f520583..9eb014aa62 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -57,10 +57,10 @@ val detype_rel_context : 'a delay -> ?lax:bool -> constr option -> Id.Set.t -> ( val share_pattern_names : (Id.Set.t -> names_context -> 'c -> Pattern.constr_pattern -> 'a) -> int -> - (Name.t * Decl_kinds.binding_kind * 'b option * 'a) list -> + (Name.t * binding_kind * 'b option * 'a) list -> Id.Set.t -> names_context -> 'c -> Pattern.constr_pattern -> Pattern.constr_pattern -> - (Name.t * Decl_kinds.binding_kind * 'b option * 'a) list * 'a * 'a + (Name.t * binding_kind * 'b option * 'a) list * 'a * 'a val detype_closed_glob : ?lax:bool -> bool -> Id.Set.t -> env -> evar_map -> closed_glob_constr -> glob_constr diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 6bde3dfd81..93f5923474 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -67,9 +67,9 @@ let glob_sort_eq u1 u2 = match u1, u2 with | (UNamed _ | UAnonymous _), _ -> false let binding_kind_eq bk1 bk2 = match bk1, bk2 with - | Decl_kinds.Explicit, Decl_kinds.Explicit -> true - | Decl_kinds.Implicit, Decl_kinds.Implicit -> true - | (Decl_kinds.Explicit | Decl_kinds.Implicit), _ -> false + | Explicit, Explicit -> true + | Implicit, Implicit -> true + | (Explicit | Implicit), _ -> false let case_style_eq s1 s2 = let open Constr in match s1, s2 with | LetStyle, LetStyle -> true diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 467b72e520..37aa31d094 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -48,6 +48,9 @@ val mkGApp : ?loc:Loc.t -> 'a glob_constr_g -> 'a glob_constr_g -> 'a glob_const val map_glob_constr : (glob_constr -> glob_constr) -> glob_constr -> glob_constr +(** Equality on [binding_kind] *) +val binding_kind_eq : binding_kind -> binding_kind -> bool + (** Ensure traversal from left to right *) val map_glob_constr_left_to_right : (glob_constr -> glob_constr) -> glob_constr -> glob_constr diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index 7c859a5332..10e9d60fd5 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -17,7 +17,6 @@ arguments and pattern-matching compilation are not. *) open Names -open Decl_kinds type existential_name = Id.t @@ -66,6 +65,8 @@ and 'a cases_pattern_g = ('a cases_pattern_r, 'a) DAst.t type cases_pattern = [ `any ] cases_pattern_g +type binding_kind = Explicit | Implicit + (** Representation of an internalized (or in other words globalized) term. *) type 'a glob_constr_r = | GRef of GlobRef.t * glob_level list option diff --git a/library/keys.ml b/pretyping/keys.ml index 9964992433..f8eecd80d4 100644 --- a/library/keys.ml +++ b/pretyping/keys.ml @@ -49,7 +49,7 @@ module KeyOrdered = struct | _, 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 @@ -69,7 +69,7 @@ let add_kv k v m = try Keymap.modify k (fun k' vs -> Keyset.add v vs) m with Not_found -> Keymap.add k (Keyset.singleton v) m -let add_keys k v = +let add_keys k v = keys := add_kv k v (add_kv v k !keys) let equiv_keys k k' = @@ -85,7 +85,7 @@ let load_keys _ (_,(ref,ref')) = let cache_keys o = load_keys 1 o -let subst_key subst k = +let subst_key subst k = match k with | KGlob gr -> KGlob (subst_global_reference subst gr) | _ -> k @@ -98,7 +98,7 @@ let discharge_key = function | x -> Some x let discharge_keys (_,(k,k')) = - match discharge_key k, discharge_key k' with + match discharge_key k, discharge_key k' with | Some x, Some y -> Some (x, y) | _ -> None @@ -124,7 +124,7 @@ let constr_key kind c = | App (f, _) -> aux f | Proj (p, _) -> KGlob (GlobRef.ConstRef (Projection.constant p)) | Cast (p, _, _) -> aux p - | Lambda _ -> KLam + | Lambda _ -> KLam | Prod _ -> KProd | Case _ -> KCase | Fix _ -> KFix @@ -132,7 +132,7 @@ let constr_key kind c = | Rel _ -> KRel | Meta _ -> raise Not_found | Evar _ -> raise Not_found - | Sort _ -> KSort + | Sort _ -> KSort | LetIn _ -> KLet | Int _ -> KInt in Some (aux c) @@ -152,10 +152,10 @@ let pr_key pr_global = function | KRel -> str"Rel" | KInt -> str"Int" -let pr_keyset pr_global v = +let pr_keyset pr_global v = prlist_with_sep spc (pr_key pr_global) (Keyset.elements v) -let pr_mapping pr_global k v = +let pr_mapping pr_global k v = pr_key pr_global k ++ str" <-> " ++ pr_keyset pr_global v let pr_keys pr_global = diff --git a/library/keys.mli b/pretyping/keys.mli index a7adf7791b..a7adf7791b 100644 --- a/library/keys.mli +++ b/pretyping/keys.mli diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 99e3c5025e..ccc3b6e83c 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -18,7 +18,6 @@ open Context open Glob_term open Pp open Mod_subst -open Decl_kinds open Pattern open Environ diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index c28c3ab730..4fed526cfc 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -1193,7 +1193,7 @@ let path_convertible env sigma p q = let mkGRef ref = DAst.make @@ Glob_term.GRef(ref,None) in let mkGVar id = DAst.make @@ Glob_term.GVar(id) in let mkGApp(rt,rtl) = DAst.make @@ Glob_term.GApp(rt,rtl) in - let mkGLambda(n,t,b) = DAst.make @@ Glob_term.GLambda(n,Decl_kinds.Explicit,t,b) in + let mkGLambda(n,t,b) = DAst.make @@ Glob_term.GLambda(n,Explicit,t,b) in let mkGHole () = DAst.make @@ Glob_term.GHole(Evar_kinds.BinderType Anonymous,Namegen.IntroAnonymous,None) in let path_to_gterm p = match p with diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index 34a6cecc95..0ca39f0404 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -35,4 +35,5 @@ Indrec GlobEnv Cases Pretyping +Keys Unification diff --git a/pretyping/unification.ml b/pretyping/unification.ml index a9eb43e573..4d34139ec0 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -254,6 +254,10 @@ let unify_r2l x = x let sort_eqns = unify_r2l *) +type allowed_evars = +| AllowAll +| AllowFun of (Evar.t -> bool) + type core_unify_flags = { modulo_conv_on_closed_terms : TransparentState.t option; (* What this flag controls was activated with all constants transparent, *) @@ -287,8 +291,8 @@ type core_unify_flags = { (* This allowed for instance to unify "forall x:?A, ?B x" with "A' -> B'" *) (* when ?B is a Meta. *) - frozen_evars : Evar.Set.t; - (* Evars of this set are considered axioms and never instantiated *) + allowed_evars : allowed_evars; + (* Evars that are allowed to be instantiated *) (* Useful e.g. for autorewrite *) restrict_conv_on_strict_subterms : bool; @@ -339,7 +343,7 @@ let default_core_unify_flags () = check_applied_meta_types = true; use_pattern_unification = true; use_meta_bound_pattern_unification = true; - frozen_evars = Evar.Set.empty; + allowed_evars = AllowAll; restrict_conv_on_strict_subterms = false; modulo_betaiota = true; modulo_eta = true; @@ -417,6 +421,10 @@ let default_no_delta_unify_flags ts = resolve_evars = false } +let allow_new_evars sigma = + let undefined = Evd.undefined_map sigma in + AllowFun (fun evk -> not (Evar.Map.mem evk undefined)) + (* Default flags for looking for subterms in elimination tactics *) (* Not used in practice at the current date, to the exception of *) (* allow_K) because only closed terms are involved in *) @@ -424,9 +432,7 @@ let default_no_delta_unify_flags ts = (* call w_unify for induction/destruct/case/elim (13/6/2011) *) let elim_core_flags sigma = { (default_core_unify_flags ()) with modulo_betaiota = false; - frozen_evars = - fold_undefined (fun evk _ evars -> Evar.Set.add evk evars) - sigma Evar.Set.empty; + allowed_evars = allow_new_evars sigma; } let elim_flags_evars sigma = @@ -600,8 +606,12 @@ let do_reduce ts (env, nb) sigma c = Stack.zip sigma (whd_betaiota_deltazeta_for_iota_state ts env sigma (c, Stack.empty)) +let is_evar_allowed flags evk = match flags.allowed_evars with +| AllowAll -> true +| AllowFun f -> f evk + let isAllowedEvar sigma flags c = match EConstr.kind sigma c with - | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars) + | Evar (evk,_) -> is_evar_allowed flags evk | _ -> false @@ -749,7 +759,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e evarsubst) else error_cannot_unify_local curenv sigma (m,n,cM) | Evar (evk,_ as ev), Evar (evk',_) - when not (Evar.Set.mem evk flags.frozen_evars) + when is_evar_allowed flags evk && Evar.equal evk evk' -> begin match constr_cmp cv_pb env sigma flags cM cN with | Some sigma -> @@ -758,14 +768,14 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e sigma,metasubst,((curenv,ev,cN)::evarsubst) end | Evar (evk,_ as ev), _ - when not (Evar.Set.mem evk flags.frozen_evars) + 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) else error_cannot_unify_local curenv sigma (m,n,cN) | _, Evar (evk,_ as ev) - when not (Evar.Set.mem evk flags.frozen_evars) + 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 @@ -1554,7 +1564,7 @@ let default_matching_core_flags sigma = check_applied_meta_types = true; use_pattern_unification = false; use_meta_bound_pattern_unification = false; - frozen_evars = Evar.Map.domain (Evd.undefined_map sigma); + allowed_evars = allow_new_evars sigma; restrict_conv_on_strict_subterms = false; modulo_betaiota = false; modulo_eta = false; diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 0ee71246d8..d7ddbcb721 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -13,6 +13,10 @@ open EConstr open Environ open Evd +type allowed_evars = +| AllowAll +| AllowFun of (Evar.t -> bool) + type core_unify_flags = { modulo_conv_on_closed_terms : TransparentState.t option; use_metas_eagerly_in_conv_on_closed_terms : bool; @@ -22,7 +26,7 @@ type core_unify_flags = { check_applied_meta_types : bool; use_pattern_unification : bool; use_meta_bound_pattern_unification : bool; - frozen_evars : Evar.Set.t; + allowed_evars : allowed_evars; restrict_conv_on_strict_subterms : bool; modulo_betaiota : bool; modulo_eta : bool; diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index aea4f23205..5ed96dd5e3 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -21,7 +21,6 @@ open Glob_term open Constrexpr open Constrexpr_ops open Notation_gram -open Decl_kinds open Namegen (*i*) diff --git a/printing/printer.ml b/printing/printer.ml index ec1b9b8e49..e3225fadd5 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -853,7 +853,8 @@ let pr_goal_emacs ~proof gid sid = type axiom = | Constant of Constant.t (* An axiom or a constant. *) | Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *) - | Guarded of Constant.t (* a constant whose (co)fixpoints have been assumed to be guarded *) + | Guarded of GlobRef.t (* a constant whose (co)fixpoints have been assumed to be guarded *) + | TypeInType of GlobRef.t (* a constant which relies on type in type *) type context_object = | Variable of Id.t (* A section variable or a Let definition *) @@ -873,7 +874,7 @@ struct | Positive m1 , Positive m2 -> MutInd.CanOrd.compare m1 m2 | Guarded k1 , Guarded k2 -> - Constant.CanOrd.compare k1 k2 + GlobRef.Ordered.compare k1 k2 | _ , Constant _ -> 1 | _ , Positive _ -> 1 | _ -> -1 @@ -903,14 +904,20 @@ let pr_assumptionset env sigma s = let safe_pr_constant env kn = try pr_constant env kn with Not_found -> - (* FIXME? *) - let mp,lab = Constant.repr2 kn in - str (ModPath.to_string mp) ++ str "." ++ Label.print lab + Names.Constant.print kn + in + let safe_pr_global env gr = + try pr_global_env (Termops.vars_of_env env) gr + with Not_found -> + let open GlobRef in match gr with + | VarRef id -> Id.print id + | ConstRef con -> Constant.print con + | IndRef (mind,_) -> MutInd.print mind + | ConstructRef _ -> assert false in let safe_pr_inductive env kn = try pr_inductive env (kn,0) with Not_found -> - (* FIXME? *) MutInd.print kn in let safe_pr_ltype env sigma typ = @@ -927,9 +934,11 @@ let pr_assumptionset env sigma s = | Constant kn -> safe_pr_constant env kn ++ safe_pr_ltype env sigma typ | Positive m -> - hov 2 (safe_pr_inductive env m ++ spc () ++ strbrk"is positive.") - | Guarded kn -> - hov 2 (safe_pr_constant env kn ++ spc () ++ strbrk"is positive.") + hov 2 (safe_pr_inductive env m ++ spc () ++ strbrk"is assumed to be positive.") + | Guarded gr -> + hov 2 (safe_pr_global env gr ++ spc () ++ strbrk"is assumed to be guarded.") + | TypeInType gr -> + hov 2 (safe_pr_global env gr ++ spc () ++ strbrk"relies on an unsafe hierarchy.") in let fold t typ accu = let (v, a, o, tr) = accu in @@ -1003,3 +1012,8 @@ let print_and_diff oldp newp = pr_open_subgoals ~proof in Feedback.msg_notice output;; + +let pr_typing_flags flags = + str "check_guarded: " ++ bool flags.check_guarded ++ fnl () + ++ str "check_positive: " ++ bool flags.check_positive ++ fnl () + ++ str "check_universes: " ++ bool flags.check_universes diff --git a/printing/printer.mli b/printing/printer.mli index a72f319636..788f303aee 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -191,7 +191,8 @@ val print_and_diff : Proof.t option -> Proof.t option -> unit type axiom = | Constant of Constant.t (* An axiom or a constant. *) | Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *) - | Guarded of Constant.t (* a constant whose (co)fixpoints have been assumed to be guarded *) + | Guarded of GlobRef.t (* a constant whose (co)fixpoints have been assumed to be guarded *) + | TypeInType of GlobRef.t (* a constant which relies on type in type *) type context_object = | Variable of Id.t (* A section variable or a Let definition *) @@ -207,3 +208,5 @@ val pr_assumptionset : env -> evar_map -> types ContextObjectMap.t -> Pp.t 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 diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 1904d9b112..8e7d1df29a 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -108,7 +108,7 @@ let fail_quick_core_unif_flags = { check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; (* ? *) - frozen_evars = Evar.Set.empty; + allowed_evars = AllowAll; restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = false; modulo_eta = true; diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 129444c3b3..a487799b74 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -77,17 +77,18 @@ include Util (* ****************** - foo - bar - baz *********************************** *) let static_bullet ({ entry_point; prev_node } as view) = + let open Vernacexpr in assert (not (Vernacprop.has_Fail entry_point.ast)); - match Vernacprop.under_control entry_point.ast with - | Vernacexpr.VernacBullet b -> + match entry_point.ast.CAst.v.expr with + | VernacBullet b -> let base = entry_point.indentation in let last_tac = prev_node entry_point in crawl view ~init:last_tac (fun prev node -> if node.indentation < base then `Stop else if node.indentation > base then `Cont node else if Vernacprop.has_Fail node.ast then `Stop - else match Vernacprop.under_control node.ast with - | Vernacexpr.VernacBullet b' when b = b' -> + else match node.ast.CAst.v.expr with + | VernacBullet b' when b = b' -> `Found { block_stop = entry_point.id; block_start = prev.id; dynamic_switch = node.id; carry_on_data = of_bullet_val b } | _ -> `Stop) entry_point @@ -99,7 +100,7 @@ let dynamic_bullet doc { dynamic_switch = id; carry_on_data = b } = `ValidBlock { base_state = id; goals_to_admit = focused; - recovery_command = Some (CAst.make @@ Vernacexpr.VernacExpr([], Vernacexpr.VernacBullet (to_bullet_val b))) + recovery_command = Some (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacBullet (to_bullet_val b)}) } | `Not -> `Leaks @@ -109,16 +110,17 @@ let () = register_proof_block_delimiter (* ******************** { block } ***************************************** *) let static_curly_brace ({ entry_point; prev_node } as view) = - assert(Vernacprop.under_control entry_point.ast = Vernacexpr.VernacEndSubproof); + let open Vernacexpr in + assert(entry_point.ast.CAst.v.expr = VernacEndSubproof); crawl view (fun (nesting,prev) node -> if Vernacprop.has_Fail node.ast then `Cont (nesting,node) - else match Vernacprop.under_control node.ast with - | Vernacexpr.VernacSubproof _ when nesting = 0 -> + else match node.ast.CAst.v.expr with + | VernacSubproof _ when nesting = 0 -> `Found { block_stop = entry_point.id; block_start = prev.id; dynamic_switch = node.id; carry_on_data = unit_val } - | Vernacexpr.VernacSubproof _ -> + | VernacSubproof _ -> `Cont (nesting - 1,node) - | Vernacexpr.VernacEndSubproof -> + | VernacEndSubproof -> `Cont (nesting + 1,node) | _ -> `Cont (nesting,node)) (-1, entry_point) @@ -128,7 +130,7 @@ let dynamic_curly_brace doc { dynamic_switch = id } = `ValidBlock { base_state = id; goals_to_admit = focused; - recovery_command = Some (CAst.make @@ Vernacexpr.VernacExpr ([], Vernacexpr.VernacEndSubproof)) + recovery_command = Some (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacEndSubproof }) } | `Not -> `Leaks diff --git a/stm/stm.ml b/stm/stm.ml index 69dbebbc57..7f0632bd7c 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -571,7 +571,7 @@ end = struct (* {{{ *) vcs := rewrite_merge !vcs id ~ours ~theirs:Noop ~at branch let reachable id = reachable !vcs id let mk_branch_name { expr = x } = Branch.make - (match Vernacprop.under_control x with + (match x.CAst.v.Vernacexpr.expr with | VernacDefinition (_,({CAst.v=Name i},_),_) -> Id.to_string i | VernacStartTheoremProof (_,[({CAst.v=i},_),_]) -> Id.to_string i | VernacInstance (({CAst.v=Name i},_),_,_,_,_) -> Id.to_string i @@ -1054,9 +1054,9 @@ end = struct (* {{{ *) end (* }}} *) (* Wrapper for the proof-closing special path for Qed *) -let stm_qed_delay_proof ?route ~proof ~info ~id ~st ~loc pending : Vernacstate.t = +let stm_qed_delay_proof ?route ~proof ~info ~id ~st ~loc ~control pending : Vernacstate.t = set_id_for_feedback ?route dummy_doc id; - Vernacentries.interp_qed_delayed_proof ~proof ~info ~st ?loc:loc pending + Vernacentries.interp_qed_delayed_proof ~proof ~info ~st ~control (CAst.make ?loc pending) (* Wrapper for Vernacentries.interp to set the feedback id *) (* It is currently called 19 times, this number should be certainly @@ -1078,7 +1078,7 @@ let stm_vernac_interp ?route id st { verbose; expr } : Vernacstate.t = | _ -> false in (* XXX unsupported attributes *) - let cmd = Vernacprop.under_control expr in + let cmd = expr.CAst.v.expr in if is_filtered_command cmd then (stm_pperr_endline Pp.(fun () -> str "ignoring " ++ Ppvernac.pr_vernac expr); st) else begin @@ -1141,7 +1141,7 @@ end = struct (* {{{ *) | { step = `Fork ((_,_,_,l),_) } -> l, false,0 | { step = `Cmd { cids = l; ctac } } -> l, ctac,0 | { step = `Alias (_,{ expr }) } when not (Vernacprop.has_Fail expr) -> - begin match Vernacprop.under_control expr with + begin match expr.CAst.v.expr with | VernacUndo n -> [], false, n | _ -> [],false,0 end @@ -1171,7 +1171,7 @@ end = struct (* {{{ *) if not (VCS.is_interactive ()) && !cur_opt.async_proofs_cache <> Some Force then undo_costly_in_batch_mode v; try - match Vernacprop.under_control v with + match v.CAst.v.expr with | VernacResetInitial -> Stateid.initial | VernacResetName {CAst.v=name} -> @@ -1532,7 +1532,7 @@ end = struct (* {{{ *) let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_qed_delay_proof ~st ~id:stop - ~proof:pobject ~info:(Lemmas.Info.make ()) ~loc (Proved (opaque,None))) in + ~proof:pobject ~info:(Lemmas.Info.make ()) ~loc ~control:[] (Proved (opaque,None))) in ignore(Future.join checked_proof); end; (* STATE: Restore the state XXX: handle exn *) @@ -1683,7 +1683,7 @@ end = struct (* {{{ *) *) (* STATE We use the state resulting from reaching start. *) let st = Vernacstate.freeze_interp_state ~marshallable:false in - ignore(stm_qed_delay_proof ~id:stop ~st ~proof ~info ~loc (Proved (opaque,None))); + ignore(stm_qed_delay_proof ~id:stop ~st ~proof ~info ~loc ~control:[] (Proved (opaque,None))); `OK proof end with e -> @@ -1977,13 +1977,14 @@ end = struct (* {{{ *) let vernac_interp ~solve ~abstract ~cancel_switch nworkers priority safe_id id { indentation; verbose; expr = e; strlen } : unit = - let e, time, batch, fail = - let rec find ~time ~batch ~fail v = CAst.with_loc_val (fun ?loc -> function - | VernacTime (batch,e) -> find ~time:true ~batch ~fail e - | VernacRedirect (_,e) -> find ~time ~batch ~fail e - | VernacFail e -> find ~time ~batch ~fail:true e - | e -> CAst.make ?loc e, time, batch, fail) v in - find ~time:false ~batch:false ~fail:false e in + let cl, time, batch, fail = + let rec find ~time ~batch ~fail cl = match cl with + | ControlTime batch :: cl -> find ~time:true ~batch ~fail cl + | ControlRedirect _ :: cl -> find ~time ~batch ~fail cl + | ControlFail :: cl -> find ~time ~batch ~fail:true cl + | cl -> cl, time, batch, fail in + find ~time:false ~batch:false ~fail:false e.CAst.v.control in + let e = CAst.map (fun cmd -> { cmd with control = cl }) e in let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_fail ~st fail (fun () -> (if time then System.with_time ~batch ~header:(Pp.mt ()) else (fun x -> x)) (fun () -> @@ -2151,14 +2152,14 @@ let collect_proof keep cur hd brkind id = | VernacEndProof (Proved (Proof_global.Transparent,_)) -> true | _ -> false in let is_defined = function - | _, { expr = e } -> is_defined_expr (Vernacprop.under_control e) + | _, { expr = e } -> is_defined_expr e.CAst.v.expr && (not (Vernacprop.has_Fail e)) in let proof_using_ast = function | VernacProof(_,Some _) -> true | _ -> false in let proof_using_ast = function - | Some (_, v) when proof_using_ast (Vernacprop.under_control v.expr) + | Some (_, v) when proof_using_ast v.expr.CAst.v.expr && (not (Vernacprop.has_Fail v.expr)) -> Some v | _ -> None in let has_proof_using x = proof_using_ast x <> None in @@ -2167,14 +2168,14 @@ let collect_proof keep cur hd brkind id = | _ -> assert false in let proof_no_using = function - | Some (_, v) -> proof_no_using (Vernacprop.under_control v.expr), v + | Some (_, v) -> proof_no_using v.expr.CAst.v.expr, v | _ -> assert false in let has_proof_no_using = function | VernacProof(_,None) -> true | _ -> false in let has_proof_no_using = function - | Some (_, v) -> has_proof_no_using (Vernacprop.under_control v.expr) + | Some (_, v) -> has_proof_no_using v.expr.CAst.v.expr && (not (Vernacprop.has_Fail v.expr)) | _ -> false in let too_complex_to_delegate = function @@ -2191,7 +2192,7 @@ let collect_proof keep cur hd brkind id = let view = VCS.visit id in match view.step with | (`Sideff (ReplayCommand x,_) | `Cmd { cast = x }) - when too_complex_to_delegate (Vernacprop.under_control x.expr) -> + when too_complex_to_delegate x.expr.CAst.v.expr -> `Sync(no_name,`Print) | `Cmd { cast = x } -> collect (Some (id,x)) (id::accn) view.next | `Sideff (ReplayCommand x,_) -> collect (Some (id,x)) (id::accn) view.next @@ -2212,7 +2213,7 @@ let collect_proof keep cur hd brkind id = (try let name, hint = name ids, get_hint_ctx loc in let t, v = proof_no_using last in - v.expr <- CAst.map (fun _ -> VernacExpr([], VernacProof(t, Some hint))) v.expr; + v.expr <- CAst.map (fun _ -> { control = []; attrs = []; expr = VernacProof(t, Some hint)}) v.expr; `ASync (parent last,accn,name,delegate name) with Not_found -> let name = name ids in @@ -2235,7 +2236,7 @@ let collect_proof keep cur hd brkind id = | _ -> false in match cur, (VCS.visit id).step, brkind with - | (parent, x), `Fork _, _ when is_vernac_exact (Vernacprop.under_control x.expr) + | (parent, x), `Fork _, _ when is_vernac_exact x.expr.CAst.v.expr && (not (Vernacprop.has_Fail x.expr)) -> `Sync (no_name,`Immediate) | _, _, { VCS.kind = `Edit _ } -> check_policy (collect (Some cur) [] id) @@ -2350,8 +2351,8 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = term.` could also fail in this case, however that'd be a bug I do believe as proof injection shouldn't happen here. *) let extract_pe (x : aast) = - match Vernacprop.under_control x.expr with - | VernacEndProof pe -> pe + match x.expr.CAst.v.expr with + | VernacEndProof pe -> x.expr.CAst.v.control, pe | _ -> CErrors.anomaly Pp.(str "Non-qed command classified incorrectly") in (* ugly functions to process nested lemmas, i.e. hard to reproduce @@ -2486,7 +2487,8 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = if not delegate then ignore(Future.compute fp); reach view.next; let st = Vernacstate.freeze_interp_state ~marshallable:false in - ignore(stm_qed_delay_proof ~id ~st ~proof ~info ~loc (extract_pe x)); + let control, pe = extract_pe x in + ignore(stm_qed_delay_proof ~id ~st ~proof ~info ~loc ~control pe); feedback ~id:id Incomplete | { VCS.kind = `Master }, _ -> assert false end; @@ -2526,7 +2528,8 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = let _st = match proof with | None -> stm_vernac_interp id st x | Some (proof, info) -> - stm_qed_delay_proof ~id ~st ~proof ~info ~loc (extract_pe x) + let control, pe = extract_pe x in + stm_qed_delay_proof ~id ~st ~proof ~info ~loc ~control pe in let wall_clock3 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc:x.expr.CAst.loc "proof_check_time" @@ -2873,7 +2876,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) let queue = if VCS.is_vio_doc () && VCS.((get_branch head).kind = `Master) && - may_pierce_opaque (Vernacprop.under_control x.expr) + may_pierce_opaque x.expr.CAst.v.expr then `SkipQueue else `MainQueue in VCS.commit id (mkTransCmd x [] false queue); @@ -2939,7 +2942,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) VCS.commit id (mkTransCmd x l true `MainQueue); (* We can't replay a Definition since universes may be differently * inferred. This holds in Coq >= 8.5 *) - let action = match Vernacprop.under_control x.expr with + let action = match x.expr.CAst.v.expr with | VernacDefinition(_, _, DefineBody _) -> CherryPickEnv | _ -> ReplayCommand x in VCS.propagate_sideff ~action diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 5af576dad2..8d600c2859 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -202,18 +202,17 @@ let classify_vernac e = try Vernacextend.get_vernac_classifier s l with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in - let rec static_control_classifier v = v |> CAst.with_val (function - | VernacExpr (atts, e) -> - static_classifier ~atts e - | VernacTimeout (_,e) -> static_control_classifier e - | VernacTime (_,e) | VernacRedirect (_, e) -> - static_control_classifier e - | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) - (* XXX why is Fail not always Query? *) - (match static_control_classifier e with + let static_control_classifier ({ CAst.v ; _ } as cmd) = + (* Fail Qed or Fail Lemma must not join/fork the DAG *) + (* XXX why is Fail not always Query? *) + if Vernacprop.has_Fail cmd then + (match static_classifier ~atts:v.attrs v.expr with | VtQuery | VtProofStep _ | VtSideff _ | VtMeta as x -> x | VtQed _ -> VtProofStep { parallel = `No; proof_block_detection = None } - | VtStartProof _ | VtProofMode _ -> VtQuery)) + | VtStartProof _ | VtProofMode _ -> VtQuery) + else + static_classifier ~atts:v.attrs v.expr + in static_control_classifier e diff --git a/tactics/auto.ml b/tactics/auto.ml index 499e7a63d7..67f49f0074 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -49,7 +49,7 @@ let auto_core_unif_flags_of st1 st2 = { check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; - frozen_evars = Evar.Set.empty; + allowed_evars = AllowAll; restrict_conv_on_strict_subterms = false; (* Compat *) modulo_betaiota = false; modulo_eta = true; diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 05f40d0570..cf5c64c3ae 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -151,7 +151,7 @@ let pr_ev evs ev = open Auto open Unification -let auto_core_unif_flags st freeze = { +let auto_core_unif_flags st allowed_evars = { modulo_conv_on_closed_terms = Some st; use_metas_eagerly_in_conv_on_closed_terms = true; use_evars_eagerly_in_conv_on_closed_terms = false; @@ -160,14 +160,14 @@ let auto_core_unif_flags st freeze = { check_applied_meta_types = false; use_pattern_unification = true; use_meta_bound_pattern_unification = true; - frozen_evars = freeze; + allowed_evars; restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = true; modulo_eta = false; } -let auto_unif_flags freeze st = - let fl = auto_core_unif_flags st freeze in +let auto_unif_flags ?(allowed_evars = AllowAll) st = + let fl = auto_core_unif_flags st allowed_evars in { core_unify_flags = fl; merge_unify_flags = fl; subterm_unify_flags = fl; @@ -357,23 +357,25 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm let open Proofview.Notations in let prods, concl = EConstr.decompose_prod_assum sigma concl in let nprods = List.length prods in - let freeze = + let allowed_evars = try match hdc with | Some (hd,_) when only_classes -> let cl = Typeclasses.class_info env sigma hd in if cl.cl_strict then - Evarutil.undefined_evars_of_term sigma concl - else Evar.Set.empty - | _ -> Evar.Set.empty - with e when CErrors.noncritical e -> Evar.Set.empty + let undefined = lazy (Evarutil.undefined_evars_of_term sigma concl) in + let allowed evk = not (Evar.Set.mem evk (Lazy.force undefined)) in + AllowFun allowed + else AllowAll + | _ -> AllowAll + with e when CErrors.noncritical e -> AllowAll in let hint_of_db = hintmap_of sigma hdc secvars concl in let hintl = List.map_append (fun db -> let tacs = hint_of_db db in - let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in + let flags = auto_unif_flags ~allowed_evars (Hint_db.transparent_state db) in List.map (fun x -> (flags, x)) tacs) (local_db::db_list) in @@ -1198,7 +1200,7 @@ let autoapply c i = let hintdb = try Hints.searchtable_map i with Not_found -> CErrors.user_err (Pp.str ("Unknown hint database " ^ i ^ ".")) in - let flags = auto_unif_flags Evar.Set.empty + let flags = auto_unif_flags (Hints.Hint_db.transparent_state hintdb) in let cty = Tacmach.New.pf_unsafe_type_of gl c in let ce = mk_clenv_from gl (c,cty) in diff --git a/tactics/declare.ml b/tactics/declare.ml index b8ba62a5e5..c280760e84 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -71,8 +71,7 @@ let load_constant i ((sp,kn), obj) = let cooking_info segment = let modlist = replacement_context () in - let { abstr_ctx = hyps; abstr_subst = subst; abstr_uctx = uctx } = segment in - let named_ctx = List.map fst hyps in + let { abstr_ctx = named_ctx; abstr_subst = subst; abstr_uctx = uctx } = segment in let abstract = (named_ctx, subst, uctx) in { Opaqueproof.modlist; abstract } @@ -244,11 +243,16 @@ let get_roles export eff = in List.map map export +let feedback_axiom () = Feedback.(feedback AddedAxiom) +let is_unsafe_typing_flags () = + let flags = Environ.typing_flags (Global.env()) in + not (flags.check_universes && flags.check_guarded && flags.check_positive) + let define_constant ~side_effect ~name cd = let open Proof_global in (* Logically define the constant and its subproofs, no libobject tampering *) let in_section = Lib.sections_are_opened () in - let export, decl = match cd with + let export, decl, unsafe = match cd with | DefinitionEntry de -> (* We deal with side effects *) if not de.proof_entry_opaque then @@ -258,19 +262,20 @@ let define_constant ~side_effect ~name cd = let export = get_roles export eff in let de = { de with proof_entry_body = Future.from_val (body, ()) } in let cd = Entries.DefinitionEntry (cast_proof_entry de) in - export, ConstantEntry (PureEntry, cd) + export, ConstantEntry (PureEntry, cd), false else let map (body, eff) = body, eff.Evd.seff_private in let body = Future.chain de.proof_entry_body map in let de = { de with proof_entry_body = body } in let de = cast_opaque_proof_entry de in - [], ConstantEntry (EffectEntry, Entries.OpaqueEntry de) + [], ConstantEntry (EffectEntry, Entries.OpaqueEntry de), false | ParameterEntry e -> - [], ConstantEntry (PureEntry, Entries.ParameterEntry e) + [], ConstantEntry (PureEntry, Entries.ParameterEntry e), not (Lib.is_modtype_strict()) | PrimitiveEntry e -> - [], ConstantEntry (PureEntry, Entries.PrimitiveEntry e) + [], ConstantEntry (PureEntry, Entries.PrimitiveEntry e), false in let kn, eff = Global.add_constant ~side_effect ~in_section name decl in + if unsafe || is_unsafe_typing_flags() then feedback_axiom(); kn, eff, export let declare_constant ?(local = ImportDefaultBehavior) ~name ~kind cd = @@ -295,7 +300,7 @@ let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind (** Declaration of section variables and local definitions *) type variable_declaration = | SectionLocalDef of Evd.side_effects Proof_global.proof_entry - | SectionLocalAssum of { typ:Constr.types; univs:Univ.ContextSet.t; poly:bool; impl:bool } + | SectionLocalAssum of { typ:Constr.types; univs:Univ.ContextSet.t; poly:bool; impl:Glob_term.binding_kind } (* This object is only for things which iterate over objects to find variables (only Prettyp.print_context AFAICT) *) @@ -308,12 +313,11 @@ let declare_variable ~name ~kind d = if Decls.variable_exists name then raise (AlreadyDeclared (None, name)); - let impl,opaque,poly,univs = match d with (* Fails if not well-typed *) + let impl,opaque,poly = match d with (* Fails if not well-typed *) | SectionLocalAssum {typ;univs;poly;impl} -> let () = declare_universe_context ~poly univs in let () = Global.push_named_assum (name,typ) in - let impl = if impl then Decl_kinds.Implicit else Decl_kinds.Explicit in - impl, true, poly, univs + impl, true, poly | SectionLocalDef (de) -> (* The body should already have been forced upstream because it is a section-local definition, but it's not enforced by typing *) @@ -337,14 +341,14 @@ let declare_variable ~name ~kind d = secdef_type = de.proof_entry_type; } in let () = Global.push_named_def (name, se) in - Decl_kinds.Explicit, de.proof_entry_opaque, - poly, univs + Glob_term.Explicit, de.proof_entry_opaque, + poly in Nametab.push (Nametab.Until 1) (Libnames.make_path DirPath.empty name) (GlobRef.VarRef name); - add_section_variable ~name ~kind:impl ~poly univs; + add_section_variable ~name ~poly; Decls.(add_variable_data name {opaque;kind}); add_anonymous_leaf (inVariable ()); - Impargs.declare_var_implicits name; + Impargs.declare_var_implicits ~impl name; Notation.declare_ref_arguments_scope Evd.empty (GlobRef.VarRef name) (** Declaration of inductive blocks *) @@ -490,6 +494,7 @@ let declare_mind mie = | ind::_ -> ind.mind_entry_typename | [] -> CErrors.anomaly (Pp.str "cannot declare an empty list of inductives.") in let (sp,kn as oname) = add_leaf id (inInductive mie) in + if is_unsafe_typing_flags() then feedback_axiom(); let mind = Global.mind_of_delta_kn kn in let isprim = declare_projections mie.mind_entry_universes mind in Impargs.declare_mib_implicits mind; diff --git a/tactics/declare.mli b/tactics/declare.mli index 89b41076f7..4ae9f6c7ae 100644 --- a/tactics/declare.mli +++ b/tactics/declare.mli @@ -23,7 +23,7 @@ open Entries type variable_declaration = | SectionLocalDef of Evd.side_effects Proof_global.proof_entry - | SectionLocalAssum of { typ:types; univs:Univ.ContextSet.t; poly:bool; impl:bool } + | SectionLocalAssum of { typ:types; univs:Univ.ContextSet.t; poly:bool; impl:Glob_term.binding_kind } type 'a constant_entry = | DefinitionEntry of 'a Proof_global.proof_entry diff --git a/tactics/eauto.ml b/tactics/eauto.ml index cc3e78f3b8..d4e4322bef 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -408,7 +408,7 @@ let e_search_auto debug (in_depth,p) lems db_list gl = (* let e_search_auto = CProfile.profile5 e_search_auto_key e_search_auto *) let eauto_with_bases ?(debug=Off) np lems db_list = - Proofview.V82.of_tactic (Hints.wrap_hint_warning (Proofview.V82.tactic (tclTRY (e_search_auto debug np lems db_list)))) + Hints.wrap_hint_warning (Proofview.V82.tactic (tclTRY (e_search_auto debug np lems db_list))) let eauto ?(debug=Off) np lems dbnames = let db_list = make_db_list dbnames in diff --git a/tactics/eauto.mli b/tactics/eauto.mli index ec99baef45..f9347b7b0f 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -26,7 +26,7 @@ val gen_eauto : ?debug:debug -> bool * int -> delayed_open_constr list -> val eauto_with_bases : ?debug:debug -> bool * int -> - delayed_open_constr list -> hint_db list -> Proofview.V82.tac + delayed_open_constr list -> hint_db list -> unit Proofview.tactic val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic diff --git a/tactics/equality.ml b/tactics/equality.ml index 7c90c59f61..220b9bc475 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -38,7 +38,6 @@ open Coqlib open Declarations open Indrec open Clenv -open Evd open Ind_tables open Eqschemes open Locus @@ -107,7 +106,7 @@ let rewrite_core_unif_flags = { check_applied_meta_types = true; use_pattern_unification = true; use_meta_bound_pattern_unification = true; - frozen_evars = Evar.Set.empty; + allowed_evars = AllowAll; restrict_conv_on_strict_subterms = false; modulo_betaiota = false; modulo_eta = true; @@ -126,16 +125,17 @@ let freeze_initial_evars sigma flags clause = (* We take evars of the type: this may include old evars! For excluding *) (* all old evars, including the ones occurring in the rewriting lemma, *) (* we would have to take the clenv_value *) - let newevars = Evarutil.undefined_evars_of_term sigma (clenv_type clause) in - let evars = - fold_undefined (fun evk _ evars -> - if Evar.Set.mem evk newevars then evars - else Evar.Set.add evk evars) - sigma Evar.Set.empty in + let newevars = lazy (Evarutil.undefined_evars_of_term sigma (clenv_type clause)) in + let initial = Evd.undefined_map sigma in + let allowed evk = + if Evar.Map.mem evk initial then false + else Evar.Set.mem evk (Lazy.force newevars) + in + let allowed_evars = AllowFun allowed in {flags with - core_unify_flags = {flags.core_unify_flags with frozen_evars = evars}; - merge_unify_flags = {flags.merge_unify_flags with frozen_evars = evars}; - subterm_unify_flags = {flags.subterm_unify_flags with frozen_evars = evars}} + core_unify_flags = {flags.core_unify_flags with allowed_evars}; + merge_unify_flags = {flags.merge_unify_flags with allowed_evars}; + subterm_unify_flags = {flags.subterm_unify_flags with allowed_evars}} let make_flags frzevars sigma flags clause = if frzevars then freeze_initial_evars sigma flags clause else flags @@ -188,8 +188,7 @@ let rewrite_conv_closed_core_unif_flags = { use_meta_bound_pattern_unification = true; - frozen_evars = Evar.Set.empty; - (* This is set dynamically *) + allowed_evars = AllowAll; restrict_conv_on_strict_subterms = false; modulo_betaiota = false; @@ -223,8 +222,7 @@ let rewrite_keyed_core_unif_flags = { use_meta_bound_pattern_unification = true; - frozen_evars = Evar.Set.empty; - (* This is set dynamically *) + allowed_evars = AllowAll; restrict_conv_on_strict_subterms = false; modulo_betaiota = true; @@ -334,6 +332,21 @@ let jmeq_same_dom env sigma = function | _, [dom1; _; dom2;_] -> is_conv env sigma dom1 dom2 | _ -> false +let eq_elimination_ref l2r sort = + let name = + if l2r then + match sort with + | InProp -> "core.eq.ind_r" + | InSProp -> "core.eq.sind_r" + | InSet | InType -> "core.eq.rect_r" + else + match sort with + | InProp -> "core.eq.ind" + | InSProp -> "core.eq.sind" + | InSet | InType -> "core.eq.rect" + in + if Coqlib.has_ref name then Some (Coqlib.lib_ref name) else None + (* find_elim determines which elimination principle is necessary to eliminate lbeq on sort_of_gl. *) @@ -345,35 +358,35 @@ let find_elim hdcncl lft2rgt dep cls ot = in let inccl = Option.is_empty cls in let env = Proofview.Goal.env gl in - (* if (is_global Coqlib.glob_eq hdcncl || *) - (* (is_global Coqlib.glob_jmeq hdcncl && *) - (* jmeq_same_dom env sigma ot)) && not dep *) - if (is_global_exists "core.eq.type" hdcncl || - (is_global_exists "core.JMeq.type" hdcncl - && jmeq_same_dom env sigma ot)) && not dep + let is_eq = is_global_exists "core.eq.type" hdcncl in + let is_jmeq = is_global_exists "core.JMeq.type" hdcncl && jmeq_same_dom env sigma ot in + if (is_eq || is_jmeq) && not dep then + let sort = elimination_sort_of_clause cls gl in let c = match EConstr.kind sigma hdcncl with | Ind (ind_sp,u) -> - let pr1 = - lookup_eliminator env ind_sp (elimination_sort_of_clause cls gl) - in begin match lft2rgt, cls with | Some true, None | Some false, Some _ -> - let c1 = destConstRef pr1 in - let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical c1)) in - let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in - let c1' = Global.constant_of_delta_kn (KerName.make mp l') in - begin + begin match if is_eq then eq_elimination_ref true sort else None with + | Some r -> destConstRef r + | None -> + let c1 = destConstRef (lookup_eliminator env ind_sp sort) in + let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical c1)) in + let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in + let c1' = Global.constant_of_delta_kn (KerName.make mp l') in try - let _ = Global.lookup_constant c1' in - c1' + let _ = Global.lookup_constant c1' in c1' with Not_found -> user_err ~hdr:"Equality.find_elim" (str "Cannot find rewrite principle " ++ Label.print l' ++ str ".") end - | _ -> destConstRef pr1 + | _ -> + begin match if is_eq then eq_elimination_ref false sort else None with + | Some r -> destConstRef r + | None -> destConstRef (lookup_eliminator env ind_sp sort) + end end | _ -> (* cannot occur since we checked that we are in presence of diff --git a/tactics/equality.mli b/tactics/equality.mli index f8166bba2d..8225195ca7 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -29,6 +29,8 @@ type conditions = | FirstSolved (* Use the first match whose side-conditions are solved *) | AllMatches (* Rewrite all matches whose side-conditions are solved *) +val eq_elimination_ref : orientation -> Sorts.family -> GlobRef.t option + val general_rewrite_bindings : orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> evars_flag -> unit Proofview.tactic diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index a3a88df21e..61e0e41eb9 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -258,7 +258,6 @@ type equation_kind = exception NoEquationFound open Glob_term -open Decl_kinds open Evar_kinds let mkPattern c = snd (Patternops.pattern_of_glob_constr c) diff --git a/test-suite/bugs/closed/bug_10088.v b/test-suite/bugs/closed/bug_10088.v new file mode 100644 index 0000000000..3e17bfc12a --- /dev/null +++ b/test-suite/bugs/closed/bug_10088.v @@ -0,0 +1,6 @@ +Require Import ssreflect. +From Ltac2 Require Import Ltac2. + +Inductive nat_list := + Nil +| Cons of nat & nat_list. diff --git a/test-suite/output/Emacs_and_diffs.out b/test-suite/output/Emacs_and_diffs.out new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/test-suite/output/Emacs_and_diffs.out diff --git a/test-suite/output/Emacs_and_diffs.v b/test-suite/output/Emacs_and_diffs.v new file mode 100644 index 0000000000..c35fd1a11b --- /dev/null +++ b/test-suite/output/Emacs_and_diffs.v @@ -0,0 +1,3 @@ +(* coq-prog-args: ("-emacs") *) +Set Diffs "on". +(* verify this does not produce an error message *) diff --git a/test-suite/success/RewriteRegisteredElim.v b/test-suite/success/RewriteRegisteredElim.v new file mode 100644 index 0000000000..39b103747c --- /dev/null +++ b/test-suite/success/RewriteRegisteredElim.v @@ -0,0 +1,35 @@ + +Set Universe Polymorphism. + +Cumulative Inductive EQ {A} (x : A) : A -> Type + := EQ_refl : EQ x x. + +Register EQ as core.eq.type. + +Lemma renamed_EQ_rect {A} (x:A) (P : A -> Type) + (c : P x) (y : A) (e : EQ x y) : P y. +Proof. destruct e. assumption. Qed. + +Register renamed_EQ_rect as core.eq.rect. +Register renamed_EQ_rect as core.eq.ind. + +Lemma renamed_EQ_rect_r {A} (x:A) (P : A -> Type) + (c : P x) (y : A) (e : EQ y x) : P y. +Proof. destruct e. assumption. Qed. + +Register renamed_EQ_rect_r as core.eq.rect_r. +Register renamed_EQ_rect_r as core.eq.ind_r. + +Lemma EQ_sym1 {A} {x y : A} (e : EQ x y) : EQ y x. +Proof. rewrite e. reflexivity. Qed. + +Lemma EQ_sym2 {A} {x y : A} (e : EQ x y) : EQ y x. +Proof. rewrite <- e. reflexivity. Qed. + +Require Import ssreflect. + +Lemma ssr_EQ_sym1 {A} {x y : A} (e : EQ x y) : EQ y x. +Proof. rewrite e. reflexivity. Qed. + +Lemma ssr_EQ_sym2 {A} {x y : A} (e : EQ x y) : EQ y x. +Proof. rewrite -e. reflexivity. Qed. diff --git a/test-suite/success/typing_flags.v b/test-suite/success/typing_flags.v new file mode 100644 index 0000000000..bd20d9c804 --- /dev/null +++ b/test-suite/success/typing_flags.v @@ -0,0 +1,43 @@ + +Print Typing Flags. +Unset Guard Checking. +Fixpoint f' (n : nat) : nat := f' n. + +Fixpoint f (n : nat) : nat. +Proof. + exact (f n). +Defined. + +Fixpoint bla (A:Type) (n:nat) := match n with 0 =>0 | S n => n end. + +Print Typing Flags. + +Set Guard Checking. + +Print Assumptions f. + +Unset Universe Checking. + +Definition T := Type. +Fixpoint g (n : nat) : T := T. + +Print Typing Flags. +Set Universe Checking. + +Fail Definition g2 (n : nat) : T := T. + +Fail Definition e := fix e (n : nat) : nat := e n. + +Unset Positivity Checking. + +Inductive Cor := +| Over : Cor +| Next : ((Cor -> list nat) -> list nat) -> Cor. + +Set Positivity Checking. +Print Assumptions Cor. + +Inductive Box := +| box : forall n, f n = n -> g 2 -> Box. + +Print Assumptions Box. diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index 1920d493de..adb416e3ce 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -193,9 +193,7 @@ let pp_vo_dep dir fmt vo = pp_rule fmt all_targets deps action let pp_mlg_dep _dir fmt ml = - let target = Filename.(remove_extension ml) ^ ".ml" in - let mlg_rule = "(run coqpp %{pp-file})" in - pp_rule fmt [target] [ml] mlg_rule + fprintf fmt "@[(coq.pp (modules %s))@]@\n" (Filename.remove_extension ml) let pp_dep dir fmt oo = match oo with | VO vo -> pp_vo_dep dir fmt vo diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index eb0331d95e..67d70416c8 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -184,7 +184,7 @@ let add_load_vernacular opts verb s = (** Options for proof general *) let set_emacs opts = Printer.enable_goal_tags_printing := true; - { opts with config = { opts.config with color = `OFF; print_emacs = true }} + { opts with config = { opts.config with color = `EMACS; print_emacs = true }} let set_logic f oval = { oval with config = { oval.config with logic = f oval.config.logic }} diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 2673995a86..78640334e2 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -242,10 +242,10 @@ let set_prompt prompt = (* Read the input stream until a dot is encountered *) let parse_to_dot = - let rec dot st = match Stream.next st with + let rec dot tok st = match Stream.next st with | Tok.KEYWORD ("."|"...") -> () | Tok.EOI -> () - | _ -> dot st + | _ -> dot tok st in Pcoq.Entry.of_parser "Coqtoplevel.dot" dot @@ -340,8 +340,8 @@ let print_anyway_opts = [ let print_anyway c = let open Vernacexpr in - match c with - | VernacExpr (_, VernacSetOption (_, opt, _)) -> List.mem opt print_anyway_opts + match c.expr with + | VernacSetOption (_, opt, _) -> List.mem opt print_anyway_opts | _ -> false (* We try to behave better when goal printing raises an exception diff --git a/toplevel/dune b/toplevel/dune index f51e50aaa3..2d64ae303c 100644 --- a/toplevel/dune +++ b/toplevel/dune @@ -7,7 +7,4 @@ ; Coqlevel provides the `Num` library to plugins, we could also use ; -linkall in the plugins file, to be discussed. -(rule - (targets g_toplevel.ml) - (deps (:mlg-file g_toplevel.mlg)) - (action (run coqpp %{mlg-file}))) +(coq.pp (modules g_toplevel)) diff --git a/toplevel/g_toplevel.mlg b/toplevel/g_toplevel.mlg index 1a1537113e..e180d9e750 100644 --- a/toplevel/g_toplevel.mlg +++ b/toplevel/g_toplevel.mlg @@ -36,7 +36,7 @@ let err () = raise Stream.Failure let test_show_goal = Pcoq.Entry.of_parser "test_show_goal" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | IDENT "Show" -> (match stream_nth 1 strm with diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 7a59a4dd12..e9d8263b85 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -20,14 +20,10 @@ open Vernacprop Use the module Coqtoplevel, which catches these exceptions (the exceptions are explained only at the toplevel). *) -let checknav_simple ({ CAst.loc; _ } as cmd) = - if is_navigation_vernac cmd && not (is_reset cmd) then +let checknav { CAst.loc; v = { expr } } = + if is_navigation_vernac expr && not (is_reset expr) then CErrors.user_err ?loc (str "Navigation commands forbidden in files.") -let checknav_deep ({ CAst.loc; _ } as cmd) = - if is_deep_navigation_vernac cmd then - CErrors.user_err ?loc (str "Navigation commands forbidden in nested commands.") - (* Echo from a buffer based on position. XXX: Should move to utility file. *) let vernac_echo ?loc in_chan = let open Loc in @@ -60,7 +56,7 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = due to the way it prints. *) let com = if state.time then begin - CAst.make ?loc @@ VernacTime(state.time,com) + CAst.map (fun cmd -> { cmd with control = ControlTime state.time :: cmd.control }) com end else com in let doc, nsid, ntip = Stm.add ~doc:state.doc ~ontop:state.sid (not !Flags.quiet) com in @@ -108,7 +104,7 @@ let load_vernac_core ~echo ~check ~interactive ~state file = (* Printing of AST for -compile-verbose *) Option.iter (vernac_echo ?loc:ast.CAst.loc) in_echo; - checknav_simple ast; + checknav ast; let state = Flags.silently (interp_vernac ~check ~interactive ~state) ast in @@ -122,7 +118,6 @@ let load_vernac_core ~echo ~check ~interactive ~state file = iraise (e, info) let process_expr ~state loc_ast = - checknav_deep loc_ast; interp_vernac ~interactive:true ~check:true ~state loc_ast (******************************************************************************) diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 23b5f4daef..adc1606016 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -23,31 +23,31 @@ open Ltac_plugin let err () = raise Stream.Failure -type lookahead = int -> Tok.t Stream.t -> int option +type lookahead = Gramlib.Plexing.location_function -> int -> Tok.t Stream.t -> int option let entry_of_lookahead s (lk : lookahead) = - let run strm = match lk 0 strm with None -> err () | Some _ -> () in + let run tok strm = match lk tok 0 strm with None -> err () | Some _ -> () in Pcoq.Entry.of_parser s run -let (>>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with +let (>>) (lk1 : lookahead) lk2 tok n strm = match lk1 tok n strm with | None -> None -| Some n -> lk2 n strm +| Some n -> lk2 tok n strm -let (<+>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with -| None -> lk2 n strm +let (<+>) (lk1 : lookahead) lk2 tok n strm = match lk1 tok n strm with +| None -> lk2 tok n strm | Some n -> Some n -let lk_empty n strm = Some n +let lk_empty tok n strm = Some n -let lk_kw kw n strm = match stream_nth n strm with +let lk_kw kw tok n strm = match stream_nth n strm with | KEYWORD kw' | IDENT kw' -> if String.equal kw kw' then Some (n + 1) else None | _ -> None -let lk_ident n strm = match stream_nth n strm with +let lk_ident tok n strm = match stream_nth n strm with | IDENT _ -> Some (n + 1) | _ -> None -let lk_int n strm = match stream_nth n strm with +let lk_int tok n strm = match stream_nth n strm with | NUMERAL { NumTok.int = _; frac = ""; exp = "" } -> Some (n + 1) | _ -> None @@ -80,9 +80,13 @@ let test_lpar_id_rpar = lk_kw "(" >> lk_ident >> lk_kw ")" end +let check_no_space tok m strm = + let n = Stream.count strm in + if G_prim.contiguous tok n (n+m-1) then Some m else None + let test_ampersand_ident = entry_of_lookahead "test_ampersand_ident" begin - lk_kw "&" >> lk_ident + lk_kw "&" >> lk_ident >> check_no_space end let test_dollar_ident = diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index ab341e4ab8..a72e43de01 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -313,9 +313,15 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = if cb.const_typing_flags.check_guarded then accu else let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in - ContextObjectMap.add (Axiom (Guarded kn, l)) Constr.mkProp accu + ContextObjectMap.add (Axiom (Guarded obj, l)) Constr.mkProp accu in - if not (Declareops.constant_has_body cb) || not cb.const_typing_flags.check_universes then + let accu = + if cb.const_typing_flags.check_universes then accu + else + let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in + ContextObjectMap.add (Axiom (TypeInType obj, l)) Constr.mkProp accu + in + if not (Declareops.constant_has_body cb) then let t = type_of_constant cb in let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in ContextObjectMap.add (Axiom (Constant kn,l)) t accu @@ -329,10 +335,24 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = accu | IndRef (m,_) | ConstructRef ((m,_),_) -> let mind = lookup_mind m in - if mind.mind_typing_flags.check_guarded then - accu - else - let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in - ContextObjectMap.add (Axiom (Positive m, l)) Constr.mkProp accu - in - GlobRef.Map_env.fold fold graph ContextObjectMap.empty + let accu = + if mind.mind_typing_flags.check_positive then accu + else + let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in + ContextObjectMap.add (Axiom (Positive m, l)) Constr.mkProp accu + in + let accu = + if mind.mind_typing_flags.check_guarded then accu + else + let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in + ContextObjectMap.add (Axiom (Guarded obj, l)) Constr.mkProp accu + in + let accu = + if mind.mind_typing_flags.check_universes then accu + else + let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in + ContextObjectMap.add (Axiom (TypeInType obj, l)) Constr.mkProp accu + in + accu + + in GlobRef.Map_env.fold fold graph ContextObjectMap.empty diff --git a/vernac/classes.ml b/vernac/classes.ml index efe452d5f1..d5f5656e1d 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -28,9 +28,7 @@ module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration (*i*) -open Decl_kinds - -let set_typeclass_transparency c local b = +let set_typeclass_transparency c local b = Hints.add_hints ~local [typeclasses_db] (Hints.HintsTransparencyEntry (Hints.HintsReferences [c], b)) @@ -179,7 +177,7 @@ let discharge_class (_,cl) = let open CVars in let repl = Lib.replacement_context () in let rel_of_variable_context ctx = List.fold_right - ( fun (decl,_) (ctx', subst) -> + ( fun decl (ctx', subst) -> let decl' = decl |> NamedDecl.map_constr (substn_vars 1 subst) |> NamedDecl.to_rel_decl in (decl' :: ctx', NamedDecl.get_id decl :: subst) ) ctx ([], []) in @@ -527,7 +525,7 @@ let do_instance_program env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri let interp_instance_context ~program_mode env ctx ~generalize pl tclass = let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in let tclass = - if generalize then CAst.make @@ CGeneralization (Implicit, Some AbsPi, tclass) + if generalize then CAst.make @@ CGeneralization (Glob_term.Implicit, Some AbsPi, tclass) else tclass in let sigma, (impls, ((env', ctx), imps)) = interp_context_evars ~program_mode env sigma ctx in diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index d59d471d5f..e3f90ab98c 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -59,7 +59,7 @@ match scope with let sigma = Evd.from_env env in let () = Classes.declare_instance env sigma None true r in let () = if is_coe then Class.try_add_new_coercion r ~local:true ~poly:false in - (r,Univ.Instance.empty,true) + (r,Univ.Instance.empty) | Global local -> let do_instance = should_axiom_into_instance kind in @@ -84,7 +84,7 @@ match scope with | Polymorphic_entry (_, univs) -> Univ.UContext.instance univs | Monomorphic_entry _ -> Univ.Instance.empty in - (gr,inst,Lib.is_modtype_strict ()) + (gr,inst) let interp_assumption ~program_mode sigma env impls c = let sigma, (ty, impls) = interp_type_evars_impls ~program_mode env sigma ~impls c in @@ -98,14 +98,13 @@ let next_uctx = | Monomorphic_entry _ -> empty_uctx let declare_assumptions idl is_coe ~scope ~poly ~kind typ uctx pl imps nl = - let refs, status, _ = - List.fold_left (fun (refs,status,uctx) id -> - let ref',u',status' = - declare_assumption is_coe ~scope ~poly ~kind typ uctx pl imps false nl id in - (ref',u')::refs, status' && status, next_uctx uctx) - ([],true,uctx) idl + let refs, _ = + List.fold_left (fun (refs,uctx) id -> + let ref = declare_assumption is_coe ~scope ~poly ~kind typ uctx pl imps Glob_term.Explicit nl id in + ref::refs, next_uctx uctx) + ([],uctx) idl in - List.rev refs, status + List.rev refs let maybe_error_many_udecls = function @@ -178,15 +177,17 @@ let do_assumptions ~program_mode ~poly ~scope ~kind nl l = let sigma = Evd.restrict_universe_context sigma uvars in let uctx = Evd.check_univ_decl ~poly sigma udecl in let ubinders = Evd.universe_binders sigma in - pi2 (List.fold_left (fun (subst,status,uctx) ((is_coe,idl),typ,imps) -> + let _, _ = List.fold_left (fun (subst,uctx) ((is_coe,idl),typ,imps) -> let typ = replace_vars subst typ in - let refs, status' = declare_assumptions idl is_coe ~poly ~scope ~kind typ uctx ubinders imps nl in + let refs = declare_assumptions idl is_coe ~poly ~scope ~kind typ uctx ubinders imps nl in let subst' = List.map2 (fun {CAst.v=id} (c,u) -> (id, Constr.mkRef (c,u))) idl refs in - subst'@subst, status' && status, next_uctx uctx) - ([], true, uctx) l) + subst'@subst, next_uctx uctx) + ([], uctx) l + in + () let do_primitive id prim typopt = if Lib.sections_are_opened () then @@ -270,41 +271,43 @@ let context ~poly l = Monomorphic_entry Univ.ContextSet.empty end in - let fn status (name, b, t) = + let fn (name, b, t) = let b, t = Option.map (EConstr.to_constr sigma) b, EConstr.to_constr sigma t in if Lib.is_modtype () && not (Lib.sections_are_opened ()) then (* Declare the universe context once *) let kind = Decls.(IsAssumption Logical) in let decl = match b with - | None -> - Declare.ParameterEntry (None,(t,univs),None) - | Some b -> - let entry = Declare.definition_entry ~univs ~types:t b in - Declare.DefinitionEntry entry + | None -> + Declare.ParameterEntry (None,(t,univs),None) + | Some b -> + let entry = Declare.definition_entry ~univs ~types:t b in + Declare.DefinitionEntry entry in let cst = Declare.declare_constant ~name ~kind decl in let env = Global.env () in Classes.declare_instance env sigma (Some Hints.empty_hint_info) true (GlobRef.ConstRef cst); - status + () else let test x = match x.CAst.v with - | Some (Name id',_) -> Id.equal name id' - | _ -> false + | Some (Name id',_) -> Id.equal name id' + | _ -> false in - let impl = List.exists test impls in + let impl = if List.exists test impls then Glob_term.Implicit else Glob_term.Explicit in let scope = if Lib.sections_are_opened () then DeclareDef.Discharge else DeclareDef.Global ImportDefaultBehavior in - let nstatus = match b with + match b with | None -> - pi3 (declare_assumption false ~scope ~poly ~kind:Decls.Context t univs UnivNames.empty_binders [] impl - Declaremods.NoInline (CAst.make name)) + let _, _ = + declare_assumption false ~scope ~poly ~kind:Decls.Context t + univs UnivNames.empty_binders [] impl + Declaremods.NoInline (CAst.make name) + in + () | Some b -> let entry = Declare.definition_entry ~univs ~types:t b in let _gr = DeclareDef.declare_definition ~name ~scope:DeclareDef.Discharge ~kind:Decls.Definition UnivNames.empty_binders entry [] in - Lib.sections_are_opened () || Lib.is_modtype_strict () - in - status && nstatus + () in - List.fold_left fn true (List.rev ctx) + List.iter fn (List.rev ctx) diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index 028ed39656..2715bd8305 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -21,7 +21,7 @@ val do_assumptions -> kind:Decls.assumption_object_kind -> Declaremods.inline -> (ident_decl list * constr_expr) with_coercion list - -> bool + -> unit (** returns [false] if the assumption is neither local to a section, nor in a module type and meant to be instantiated. *) @@ -34,10 +34,10 @@ val declare_assumption -> Entries.universes_entry -> UnivNames.universe_binders -> Impargs.manual_implicits - -> bool (** implicit *) + -> Glob_term.binding_kind -> Declaremods.inline -> variable CAst.t - -> GlobRef.t * Univ.Instance.t * bool + -> GlobRef.t * Univ.Instance.t (** Context command *) @@ -46,6 +46,6 @@ val declare_assumption val context : poly:bool -> local_binder_expr list - -> bool + -> unit val do_primitive : lident -> CPrimitives.op_or_type -> constr_expr option -> unit diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 74c9bc2886..b6843eab33 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -323,11 +323,6 @@ let adjust_rec_order ~structonly binders rec_order = in Option.map (extract_decreasing_argument ~structonly) rec_order -let check_safe () = - let open Declarations in - let flags = Environ.typing_flags (Global.env ()) in - flags.check_universes && flags.check_guarded - let do_fixpoint_common (fixl : Vernacexpr.fixpoint_expr list) = let fixl = List.map (fun fix -> Vernacexpr.{ fix @@ -339,13 +334,11 @@ let do_fixpoint_common (fixl : Vernacexpr.fixpoint_expr list) = let do_fixpoint_interactive ~scope ~poly l : Lemmas.t = let fixl, ntns, fix, possible_indexes = do_fixpoint_common l in let lemma = declare_fixpoint_interactive_generic ~indexes:possible_indexes ~scope ~poly fix ntns in - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); lemma let do_fixpoint ~scope ~poly l = let fixl, ntns, fix, possible_indexes = do_fixpoint_common l in - declare_fixpoint_generic ~indexes:possible_indexes ~scope ~poly fix ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + declare_fixpoint_generic ~indexes:possible_indexes ~scope ~poly 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 @@ -355,10 +348,8 @@ let do_cofixpoint_common (fixl : Vernacexpr.cofixpoint_expr list) = let do_cofixpoint_interactive ~scope ~poly l = let cofix, ntns = do_cofixpoint_common l in let lemma = declare_fixpoint_interactive_generic ~scope ~poly cofix ntns in - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); lemma let do_cofixpoint ~scope ~poly l = let cofix, ntns = do_cofixpoint_common l in - declare_fixpoint_generic ~scope ~poly cofix ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + declare_fixpoint_generic ~scope ~poly cofix ntns diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 664010c917..adbe196699 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -567,9 +567,7 @@ let do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind ~uni (* Declare the possible notations of inductive types *) List.iter (Metasyntax.add_notation_interpretation (Global.env ())) ntns; (* Declare the coercions *) - List.iter (fun qid -> Class.try_add_new_coercion (Nametab.locate qid) ~local:false ~poly) coes; - (* If positivity is assumed declares itself as unsafe. *) - if Environ.deactivated_guard (Global.env ()) then Feedback.feedback Feedback.AddedAxiom else () + List.iter (fun qid -> Class.try_add_new_coercion (Nametab.locate qid) ~local:false ~poly) coes (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index c6e68effd7..3497e6369f 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -292,7 +292,7 @@ let do_program_recursive ~scope ~poly fixkind fixl = let ntns = List.map_append (fun { Vernacexpr.notations } -> notations ) fixl in Obligations.add_mutual_definitions defs ~poly ~scope ~kind ~univdecl:pl ctx ntns fixkind -let do_program_fixpoint ~scope ~poly l = +let do_fixpoint ~scope ~poly l = let g = List.map (fun { Vernacexpr.rec_order } -> rec_order) l in match g, l with | [Some { CAst.v = CWfRec (n,r) }], @@ -322,19 +322,9 @@ let do_program_fixpoint ~scope ~poly l = do_program_recursive ~scope ~poly fixkind l | _, _ -> - user_err ~hdr:"do_program_fixpoint" + user_err ~hdr:"do_fixpoint" (str "Well-founded fixpoints not allowed in mutually recursive blocks") -let check_safe () = - let open Declarations in - let flags = Environ.typing_flags (Global.env ()) in - flags.check_universes && flags.check_guarded - -let do_fixpoint ~scope ~poly l = - do_program_fixpoint ~scope ~poly l; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () - let do_cofixpoint ~scope ~poly fixl = let fixl = List.map (fun fix -> { fix with Vernacexpr.rec_order = None }) fixl in - do_program_recursive ~scope ~poly DeclareObl.IsCoFixpoint fixl; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + do_program_recursive ~scope ~poly DeclareObl.IsCoFixpoint fixl diff --git a/vernac/dune b/vernac/dune index 45b567d631..ba361b1377 100644 --- a/vernac/dune +++ b/vernac/dune @@ -5,12 +5,4 @@ (wrapped false) (libraries tactics parsing)) -(rule - (targets g_proofs.ml) - (deps (:mlg-file g_proofs.mlg)) - (action (run coqpp %{mlg-file}))) - -(rule - (targets g_vernac.ml) - (deps (:mlg-file g_vernac.mlg)) - (action (run coqpp %{mlg-file}))) +(coq.pp (modules g_proofs g_vernac)) diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index ad5d98669d..8a94a010a0 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -72,16 +72,29 @@ let parse_compat_version = let open Flags in function CErrors.user_err ~hdr:"get_compat_version" Pp.(str "Unknown compatibility version \"" ++ str s ++ str "\".") +(* For now we just keep the top-level location of the whole + vernacular, that is to say, including attributes and control flags; + this is not very convenient for advanced clients tho, so in the + future it'd be cool to actually locate the attributes and control + flags individually too. *) +let add_control_flag ~loc ~flag { CAst.v = cmd } = + CAst.make ~loc { cmd with control = flag :: cmd.control } + } GRAMMAR EXTEND Gram GLOBAL: vernac_control quoted_attributes gallina_ext noedit_mode subprf; vernac_control: FIRST - [ [ IDENT "Time"; c = vernac_control -> { CAst.make ~loc @@ VernacTime (false,c) } - | IDENT "Redirect"; s = ne_string; c = vernac_control -> { CAst.make ~loc @@ VernacRedirect (s, c) } - | IDENT "Timeout"; n = natural; v = vernac_control -> { CAst.make ~loc @@ VernacTimeout(n,v) } - | IDENT "Fail"; v = vernac_control -> { CAst.make ~loc @@ VernacFail v } - | v = decorated_vernac -> { let (f, v) = v in CAst.make ~loc @@ VernacExpr(f, v) } ] + [ [ IDENT "Time"; c = vernac_control -> + { add_control_flag ~loc ~flag:(ControlTime false) c } + | IDENT "Redirect"; s = ne_string; c = vernac_control -> + { add_control_flag ~loc ~flag:(ControlRedirect s) c } + | IDENT "Timeout"; n = natural; c = vernac_control -> + { add_control_flag ~loc ~flag:(ControlTimeout n) c } + | IDENT "Fail"; c = vernac_control -> + { add_control_flag ~loc ~flag:ControlFail c } + | v = decorated_vernac -> + { let (attrs, expr) = v in CAst.make ~loc { control = []; attrs; expr = expr } } ] ] ; decorated_vernac: @@ -519,7 +532,7 @@ END let only_starredidentrefs = Pcoq.Entry.of_parser "test_only_starredidentrefs" - (fun strm -> + (fun _ strm -> let rec aux n = match Util.stream_nth n strm with | KEYWORD "." -> () @@ -1035,6 +1048,7 @@ GRAMMAR EXTEND Gram | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr -> { PrintCoercionPaths (s,t) } | IDENT "Canonical"; IDENT "Projections" -> { PrintCanonicalConversions } + | IDENT "Typing"; IDENT "Flags" -> { PrintTypingFlags } | IDENT "Tables" -> { PrintTables } | IDENT "Options" -> { PrintTables (* A Synonymous to Tables *) } | IDENT "Hint" -> { PrintHintGoal } diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 23a8bf20a3..cf87646905 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -553,7 +553,7 @@ let declare_default_schemes kn = let mib = Global.lookup_mind kn in let n = Array.length mib.mind_packets in if !elim_flag && (mib.mind_finite <> Declarations.BiFinite || !bifinite_elim_flag) - && mib.mind_typing_flags.check_guarded then + && mib.mind_typing_flags.check_positive then declare_induction_schemes kn; if !case_flag then map_inductive_block declare_one_case_analysis_scheme kn n; if is_eq_flag() then try_declare_beq_scheme kn; diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 6a754a0cde..7809425a10 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -258,7 +258,7 @@ let save_remaining_recthms env sigma ~poly ~scope ~udecl uctx body opaq i { Rect let open DeclareDef in (match scope with | Discharge -> - let impl = false in (* copy values from Vernacentries *) + let impl = Glob_term.Explicit in let univs = match univs with | Polymorphic_entry (_, univs) -> (* What is going on here? *) @@ -336,8 +336,7 @@ let finish_admitted env sigma ~name ~poly ~scope pe ctx hook ~udecl impargs othe let () = Declare.assumption_message name in Declare.declare_univ_binders (GlobRef.ConstRef kn) (UState.universe_binders ctx); (* This takes care of the implicits and hook for the current constant*) - process_recthms ?fix_exn:None ?hook env sigma ctx ~udecl ~poly ~scope:(Global local) (GlobRef.ConstRef kn) impargs other_thms; - Feedback.feedback Feedback.AddedAxiom + process_recthms ?fix_exn:None ?hook env sigma ctx ~udecl ~poly ~scope:(Global local) (GlobRef.ConstRef kn) impargs other_thms let save_lemma_admitted ~(lemma : t) : unit = (* Used for printing in recthms *) diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 0eb0b1b6f6..f91983d31c 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -514,6 +514,8 @@ let string_of_theorem_kind = let open Decls in function ++ pr_class_rawexpr t | PrintCanonicalConversions -> keyword "Print Canonical Structures" + | PrintTypingFlags -> + keyword "Print Typing Flags" | PrintTables -> keyword "Print Tables" | PrintHintGoal -> @@ -1266,6 +1268,16 @@ let string_of_definition_object_kind = let open Decls in function | VernacEndSubproof -> return (str "}") +let pr_control_flag (p : control_flag) = + let w = match p with + | ControlTime _ -> keyword "Time" + | ControlRedirect s -> keyword "Redirect" ++ spc() ++ qs s + | ControlTimeout n -> keyword "Timeout " ++ int n + | ControlFail -> keyword "Fail" in + w ++ spc () + +let pr_vernac_control flags = Pp.prlist pr_control_flag flags + let rec pr_vernac_flag (k, v) = let k = keyword k in let open Attributes in @@ -1281,19 +1293,11 @@ let pr_vernac_attributes = | [] -> mt () | flags -> str "#[" ++ pr_vernac_flags flags ++ str "]" ++ cut () - let rec pr_vernac_control v = - let return = tag_vernac v in - match v.v with - | VernacExpr (f, v') -> pr_vernac_attributes f ++ pr_vernac_expr v' ++ sep_end v' - | VernacTime (_,v) -> - return (keyword "Time" ++ spc() ++ pr_vernac_control v) - | VernacRedirect (s, v) -> - return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_control v) - | VernacTimeout(n,v) -> - return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac_control v) - | VernacFail v-> - return (keyword "Fail" ++ spc() ++ pr_vernac_control v) - - let pr_vernac v = - try pr_vernac_control v - with e -> CErrors.print e +let pr_vernac ({v = {control; attrs; expr}} as v) = + try + tag_vernac v + (pr_vernac_control control ++ + pr_vernac_attributes attrs ++ + pr_vernac_expr expr ++ + sep_end expr) + with e -> CErrors.print e diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index da28e260b3..826e88cabf 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -67,7 +67,7 @@ module Vernac_ = let command_entry = Pcoq.Entry.of_parser "command_entry" - (fun strm -> Pcoq.Entry.parse_token_stream (select_tactic_entry !command_entry_ref) strm) + (fun _ strm -> Pcoq.Entry.parse_token_stream (select_tactic_entry !command_entry_ref) strm) end diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 9af8d8b67c..4ae9d6d54f 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -604,8 +604,7 @@ let vernac_assumption ~atts discharge kind l nl = match scope with | DeclareDef.Global _ -> Dumpglob.dump_definition lid false "ax" | DeclareDef.Discharge -> Dumpglob.dump_definition lid true "var") idl) l; - let status = ComAssumption.do_assumptions ~poly:atts.polymorphic ~program_mode:atts.program ~scope ~kind nl l in - if not status then Feedback.feedback Feedback.AddedAxiom + ComAssumption.do_assumptions ~poly:atts.polymorphic ~program_mode:atts.program ~scope ~kind nl l let is_polymorphic_inductive_cumulativity = declare_bool_option_and_ref ~depr:false ~value:false @@ -1074,9 +1073,6 @@ let vernac_declare_instance ~atts id bl inst pri = let global = not (make_section_locality locality) in Classes.declare_new_instance ~program_mode:program ~global ~poly id bl inst pri -let vernac_context ~poly l = - if not (ComAssumption.context ~poly l) then Feedback.feedback Feedback.AddedAxiom - let vernac_existing_instance ~section_local insts = let glob = not section_local in List.iter (fun (id, info) -> Classes.existing_instance glob id (Some info)) insts @@ -1728,6 +1724,30 @@ let () = optread = Nativenorm.get_profiling_enabled; optwrite = Nativenorm.set_profiling_enabled } +let _ = + declare_bool_option + { optdepr = false; + optname = "guard checking"; + optkey = ["Guard"; "Checking"]; + optread = (fun () -> (Global.typing_flags ()).Declarations.check_guarded); + optwrite = (fun b -> Global.set_check_guarded b) } + +let _ = + declare_bool_option + { optdepr = false; + optname = "positivity/productivity checking"; + optkey = ["Positivity"; "Checking"]; + optread = (fun () -> (Global.typing_flags ()).Declarations.check_positive); + optwrite = (fun b -> Global.set_check_positive b) } + +let _ = + declare_bool_option + { optdepr = false; + optname = "universes checking"; + optkey = ["Universe"; "Checking"]; + optread = (fun () -> (Global.typing_flags ()).Declarations.check_universes); + optwrite = (fun b -> Global.set_check_universes b) } + let vernac_set_strategy ~local l = let local = Option.default false local in let glob_ref r = @@ -1932,6 +1952,7 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = let vernac_print ~pstate ~atts = let sigma, env = get_current_or_global_context ~pstate in function + | PrintTypingFlags -> pr_typing_flags (Environ.typing_flags (Global.env ())) | PrintTables -> print_tables () | PrintFullContext-> print_full_context_typ env sigma | PrintSectionContext qid -> print_sec_context_typ env sigma qid @@ -2253,7 +2274,33 @@ let locate_if_not_already ?loc (e, info) = | None -> (e, Option.cata (Loc.add_loc info) info loc) | Some l -> (e, info) -exception End_of_input +let mk_time_header = + (* Drop the time header to print the command, we should indeed use a + different mechanism to `-time` commands than the current hack of + adding a time control to the AST. *) + let pr_time_header vernac = + let vernac = match vernac with + | { v = { control = ControlTime _ :: control; attrs; expr }; loc } -> + CAst.make ?loc { control; attrs; expr } + | _ -> vernac + in + Topfmt.pr_cmd_header vernac + in + fun vernac -> Lazy.from_fun (fun () -> pr_time_header vernac) + +let interp_control_flag ~time_header (f : control_flag) ~st + (fn : st:Vernacstate.t -> Vernacstate.LemmaStack.t option) = + match f with + | ControlFail -> + with_fail ~st (fun () -> fn ~st); + st.Vernacstate.lemmas + | ControlTimeout timeout -> + vernac_timeout ~timeout (fun () -> fn ~st) () + | ControlTime batch -> + let header = if batch then Lazy.force time_header else Pp.mt () in + System.with_time ~batch ~header (fun () -> fn ~st) () + | ControlRedirect s -> + Topfmt.with_output_to_file s (fun () -> fn ~st) () (* EJGA: We may remove this, only used twice below *) let vernac_require_open_lemma ~stack f = @@ -2439,7 +2486,7 @@ let rec translate_vernac ~atts v = let open Vernacextend in match v with | VernacDeclareInstance (id, bl, inst, info) -> VtDefault(fun () -> vernac_declare_instance ~atts id bl inst info) | VernacContext sup -> - VtDefault(fun () -> vernac_context ~poly:(only_polymorphism atts) sup) + VtDefault(fun () -> ComAssumption.context ~poly:(only_polymorphism atts) sup) | VernacExistingInstance insts -> VtDefault(fun () -> with_section_locality ~atts vernac_existing_instance insts) | VernacExistingClass id -> @@ -2614,7 +2661,7 @@ let rec translate_vernac ~atts v = let open Vernacextend in match v with * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) -and interp_expr ?proof ~atts ~st c = +and interp_expr ~atts ~st c = let stack = st.Vernacstate.lemmas in vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); match c with @@ -2644,6 +2691,8 @@ and interp_expr ?proof ~atts ~st c = without a considerable amount of refactoring. *) and vernac_load ~verbosely fname = + let exception End_of_input in + (* Note that no proof should be open here, so the state here is just token for now *) let st = Vernacstate.freeze_interp_state ~marshallable:false in let fname = @@ -2664,7 +2713,7 @@ and vernac_load ~verbosely fname = try let proof_mode = Option.map (fun _ -> get_default_proof_mode ()) stack in let stack = - v_mod (interp_control ?proof:None ~st:{ st with Vernacstate.lemmas = stack }) + v_mod (interp_control ~st:{ st with Vernacstate.lemmas = stack }) (parse_sentence proof_mode input) in load_loop ~stack with @@ -2677,23 +2726,36 @@ and vernac_load ~verbosely fname = CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); () -and interp_control ?proof ~st v = match v with - | { v=VernacExpr (atts, cmd) } -> - let before_univs = Global.universes () in - let pstack = interp_expr ?proof ~atts ~st cmd in - if before_univs == Global.universes () then pstack - else Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:Proof_global.update_global_env) pstack - | { v=VernacFail v } -> - with_fail ~st (fun () -> interp_control ?proof ~st v); - st.Vernacstate.lemmas - | { v=VernacTimeout (timeout,v) } -> - vernac_timeout ~timeout (interp_control ?proof ~st) v - | { v=VernacRedirect (s, v) } -> - Topfmt.with_output_to_file s (interp_control ?proof ~st) v - | { v=VernacTime (batch, cmd) }-> - let header = if batch then Topfmt.pr_cmd_header cmd else Pp.mt () in - System.with_time ~batch ~header (interp_control ?proof ~st) cmd - +and interp_control ~st ({ v = cmd } as vernac) = + let time_header = mk_time_header vernac in + List.fold_right (fun flag fn -> interp_control_flag ~time_header flag fn) + cmd.control + (fun ~st -> + let before_univs = Global.universes () in + let pstack = interp_expr ~atts:cmd.attrs ~st cmd.expr in + if before_univs == Global.universes () then pstack + else Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:Proof_global.update_global_env) pstack) + ~st + +(* Interpreting a possibly delayed proof *) +let interp_qed_delayed ~proof ~info ~st pe : Vernacstate.LemmaStack.t option = + let stack = st.Vernacstate.lemmas in + let stack = Option.cata (fun stack -> snd @@ Vernacstate.LemmaStack.pop stack) None stack in + let () = match pe with + | Admitted -> + save_lemma_admitted_delayed ~proof ~info + | Proved (_,idopt) -> + save_lemma_proved_delayed ~proof ~info ~idopt in + stack + +let interp_qed_delayed_control ~proof ~info ~st ~control { loc; v=pe } = + let time_header = mk_time_header (CAst.make ?loc { control; attrs = []; expr = VernacEndProof pe }) in + List.fold_right (fun flag fn -> interp_control_flag ~time_header flag fn) + control + (fun ~st -> interp_qed_delayed ~proof ~info ~st pe) + ~st + +(* General interp with management of state *) let () = declare_int_option { optdepr = false; @@ -2703,11 +2765,11 @@ let () = optwrite = ((:=) default_timeout) } (* Be careful with the cache here in case of an exception. *) -let interp ?(verbosely=true) ~st cmd = +let interp_gen ~verbosely ~st ~interp_fn cmd = Vernacstate.unfreeze_interp_state st; try vernac_timeout (fun st -> let v_mod = if verbosely then Flags.verbosely else Flags.silently in - let ontop = v_mod (interp_control ~st) cmd in + let ontop = v_mod (interp_fn ~st) cmd in Vernacstate.Proof_global.set ontop [@ocaml.warning "-3"]; Vernacstate.freeze_interp_state ~marshallable:false ) st @@ -2717,18 +2779,10 @@ let interp ?(verbosely=true) ~st cmd = Vernacstate.invalidate_cache (); iraise exn -let interp_qed_delayed_proof ~proof ~info ~st ?loc pe : Vernacstate.t = - let stack = st.Vernacstate.lemmas in - let stack = Option.cata (fun stack -> snd @@ Vernacstate.LemmaStack.pop stack) None stack in - try - let () = match pe with - | Admitted -> - save_lemma_admitted_delayed ~proof ~info - | Proved (_,idopt) -> - save_lemma_proved_delayed ~proof ~info ~idopt in - { st with Vernacstate.lemmas = stack } - with exn -> - let exn = CErrors.push exn in - let exn = locate_if_not_already ?loc exn in - Vernacstate.invalidate_cache (); - iraise exn +(* Regular interp *) +let interp ?(verbosely=true) ~st cmd = + interp_gen ~verbosely ~st ~interp_fn:interp_control cmd + +let interp_qed_delayed_proof ~proof ~info ~st ~control pe : Vernacstate.t = + interp_gen ~verbosely:false ~st + ~interp_fn:(interp_qed_delayed_control ~proof ~info ~control) pe diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index e618cdcefe..e65f9d3cfe 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -17,8 +17,8 @@ val interp_qed_delayed_proof : proof:Proof_global.proof_object -> info:Lemmas.Info.t -> st:Vernacstate.t - -> ?loc:Loc.t - -> Vernacexpr.proof_end + -> control:Vernacexpr.control_flag list + -> Vernacexpr.proof_end CAst.t -> Vernacstate.t (** [with_fail ~st f] runs [f ()] and expects it to fail, otherwise it fails. *) diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 0968632c2d..b712d7e264 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -24,6 +24,7 @@ type goal_reference = | GoalId of Id.t type printable = + | PrintTypingFlags | PrintTables | PrintFullContext | PrintSectionContext of qualid @@ -169,7 +170,7 @@ type inductive_expr = type one_inductive_expr = lident * local_binder_expr list * constr_expr option * constructor_expr list -type typeclass_constraint = name_decl * Decl_kinds.binding_kind * constr_expr +type typeclass_constraint = name_decl * Glob_term.binding_kind * constr_expr and typeclass_context = typeclass_constraint list type proof_expr = @@ -414,12 +415,17 @@ type nonrec vernac_expr = (* For extension *) | VernacExtend of extend_name * Genarg.raw_generic_argument list -type vernac_control_r = - | VernacExpr of Attributes.vernac_flags * vernac_expr +type control_flag = + | ControlTime of bool (* boolean is true when the `-time` batch-mode command line flag was set. the flag is used to print differently in `-time` vs `Time foo` *) - | VernacTime of bool * vernac_control - | VernacRedirect of string * vernac_control - | VernacTimeout of int * vernac_control - | VernacFail of vernac_control + | ControlRedirect of string + | ControlTimeout of int + | ControlFail + +type vernac_control_r = + { control : control_flag list + ; attrs : Attributes.vernac_flags + ; expr : vernac_expr + } and vernac_control = vernac_control_r CAst.t diff --git a/vernac/vernacprop.ml b/vernac/vernacprop.ml index 747998c6cc..903a28e953 100644 --- a/vernac/vernacprop.ml +++ b/vernac/vernacprop.ml @@ -13,47 +13,26 @@ open Vernacexpr -let rec under_control v = v |> CAst.with_val (function - | VernacExpr (_, c) -> c - | VernacRedirect (_,c) - | VernacTime (_,c) - | VernacFail c - | VernacTimeout (_,c) -> under_control c - ) - -let rec has_Fail v = v |> CAst.with_val (function - | VernacExpr _ -> false - | VernacRedirect (_,c) - | VernacTime (_,c) - | VernacTimeout (_,c) -> has_Fail c - | VernacFail _ -> true) +(* Does this vernacular involve Fail? *) +let has_Fail { CAst.v } = List.mem ControlFail v.control (* Navigation commands are allowed in a coqtop session but not in a .v file *) -let is_navigation_vernac_expr = function +let is_navigation_vernac = function | VernacResetInitial | VernacResetName _ | VernacBack _ -> true | _ -> false -let is_navigation_vernac c = - is_navigation_vernac_expr (under_control c) - -let rec is_deep_navigation_vernac v = v |> CAst.with_val (function - | VernacTime (_,c) -> is_deep_navigation_vernac c - | VernacRedirect (_, c) - | VernacTimeout (_, c) | VernacFail c -> is_navigation_vernac c - | VernacExpr _ -> false) - (* NB: Reset is now allowed again as asked by A. Chlipala *) -let is_reset = CAst.with_val (function - | VernacExpr ( _, VernacResetInitial) - | VernacExpr (_, VernacResetName _) -> true - | _ -> false) +let is_reset = function + | VernacResetInitial + | VernacResetName _ -> true + | _ -> false -let is_debug cmd = match under_control cmd with +let is_debug = function | VernacSetOption (_, ["Ltac";"Debug"], _) -> true | _ -> false -let is_undo cmd = match under_control cmd with +let is_undo = function | VernacUndo _ | VernacUndoTo _ -> true | _ -> false diff --git a/vernac/vernacprop.mli b/vernac/vernacprop.mli index 8875b86d94..320878e401 100644 --- a/vernac/vernacprop.mli +++ b/vernac/vernacprop.mli @@ -13,16 +13,9 @@ open Vernacexpr -(* Return the vernacular command below control (Time, Timeout, Redirect, Fail). - Beware that Fail can change many properties of the underlying command, since - a success of Fail means the command was backtracked over. *) -val under_control : vernac_control -> vernac_expr - val has_Fail : vernac_control -> bool - -val is_navigation_vernac : vernac_control -> bool -val is_deep_navigation_vernac : vernac_control -> bool -val is_reset : vernac_control -> bool -val is_debug : vernac_control -> bool -val is_undo : vernac_control -> bool +val is_navigation_vernac : vernac_expr -> bool +val is_reset : vernac_expr -> bool +val is_debug : vernac_expr -> bool +val is_undo : vernac_expr -> bool |