diff options
228 files changed, 2576 insertions, 2112 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 06a733be45..2a325f2d71 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -173,6 +173,8 @@ azure-pipelines.yml @coq/ci-maintainers /plugins/rtauto/ @PierreCorbineau # Secondary maintainer @herbelin +/user-contrib/Ltac2 @ppedrot + ########## Pretyper ########## /pretyping/ @mattam82 diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 1be10f91d0..a8ddb09a5d 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -10,7 +10,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-04-20-V1" + CACHEKEY: "bionic_coq-V2019-06-11-V1" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -295,16 +295,12 @@ windows32: - /^pr-.*$/ lint: - image: docker:git stage: test - script: - - apk add bash - - dev/lint-repository.sh + script: dev/lint-repository.sh dependencies: [] - before_script: [] variables: - # we need an unknown amount of history for per-commit linting - GIT_DEPTH: "" + GIT_DEPTH: "" # we need an unknown amount of history for per-commit linting + OPAM_SWITCH: base pkg:opam: stage: test diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index f0e17909c1..0d11d092ba 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -105,6 +105,12 @@ files end with newlines) is checked by the `lint` job on GitLab CI (using git hook which fixes these errors at commit time. `configure` automatically sets you up to use it, unless you already have a hook at `.git/hooks/pre-commit`. +Each commit in your pull request should compile (this makes bisecting +easier). The `lint` job checks compilation of the OCaml files, please +try to keep the rest of Coq in a functioning state as well. + +You may run the linter yourself with `dev/lint-repository.sh`. + Here are a few tags Coq developers may add to your PR and what they mean. In general feedback and requests for you as the pull request author will be in the comments and tags are only used to organize pull requests. @@ -155,6 +155,7 @@ of the Coq Proof assistant during the indicated time: Yann Régis-Gianas (INRIA-PPS then IRIF, 2009-now) Clément Renard (INRIA, 2001-2004) Talia Ringer (University of Washington, 2019) + Andreas Lynge (Aarhus University, 2019) Claudio Sacerdoti Coen (INRIA, 2004-2005) Amokrane Saïbi (INRIA, 1993-1998) Vincent Semeria (2018) diff --git a/Makefile.build b/Makefile.build index 147668187f..c76c14f2de 100644 --- a/Makefile.build +++ b/Makefile.build @@ -365,7 +365,7 @@ $(COQPP): $(COQPPCMO) coqpp/coqpp_main.ml ########################################################################### # Specific rules for Uint63 ########################################################################### -kernel/uint63.ml: kernel/write_uint63.ml kernel/uint63_x86.ml kernel/uint63_amd64.ml +kernel/uint63.ml: kernel/write_uint63.ml kernel/uint63_i386_31.ml kernel/uint63_amd64_63.ml $(SHOW)'WRITE $@' $(HIDE)(cd kernel && ocaml unix.cma $(shell basename $<)) diff --git a/checker/check.ml b/checker/check.ml index c5bc59e72a..903258daef 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -51,7 +51,7 @@ let pr_path sp = type compilation_unit_name = DirPath.t type seg_univ = Univ.ContextSet.t * bool -type seg_proofs = Constr.constr option array +type seg_proofs = (Opaqueproof.cooking_info list * int * Constr.constr option) array type library_t = { library_name : compilation_unit_name; @@ -98,9 +98,19 @@ let access_opaque_table dp i = with Not_found -> assert false in assert (i < Array.length t); - t.(i) + let (info, n, c) = t.(i) in + match c with + | None -> None + | Some c -> Some (Cooking.cook_constr info n c) -let () = Mod_checking.set_indirect_accessor access_opaque_table +let access_discharge = Cooking.cook_constr + +let indirect_accessor = { + Opaqueproof.access_proof = access_opaque_table; + Opaqueproof.access_discharge = access_discharge; +} + +let () = Mod_checking.set_indirect_accessor indirect_accessor let check_one_lib admit senv (dir,m) = let md = m.library_compiled in @@ -327,7 +337,6 @@ let intern_from_file ~intern_mode (dir, f) = let (sd:summary_disk), _, digest = marshal_in_segment f ch in let (md:library_disk), _, digest = marshal_in_segment f ch in let (opaque_csts:seg_univ option), _, udg = marshal_in_segment f ch in - let (discharging:'a option), _, _ = marshal_in_segment f ch in let (tasks:'a option), _, _ = marshal_in_segment f ch in let (table:seg_proofs option), pos, checksum = marshal_or_skip ~intern_mode f ch in @@ -340,7 +349,7 @@ let intern_from_file ~intern_mode (dir, f) = if dir <> sd.md_name then user_err ~hdr:"intern_from_file" (name_clash_message dir sd.md_name f); - if tasks <> None || discharging <> None then + if tasks <> None then user_err ~hdr:"intern_from_file" (str "The file "++str f++str " contains unfinished tasks"); if opaque_csts <> None then begin diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index ccce0bd9a7..0684623a81 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -8,13 +8,13 @@ open Environ (** {6 Checking constants } *) -let get_proof = ref (fun _ _ -> assert false) -let set_indirect_accessor f = get_proof := f - -let indirect_accessor = { - Opaqueproof.access_proof = (fun dp n -> !get_proof dp n); +let indirect_accessor = ref { + Opaqueproof.access_proof = (fun _ _ -> assert false); + Opaqueproof.access_discharge = (fun _ _ _ -> assert false); } +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 *) @@ -40,7 +40,7 @@ let check_constant_declaration env kn cb = let body = match cb.const_body with | Undef _ | Primitive _ -> None | Def c -> Some (Mod_subst.force_constr c) - | OpaqueDef o -> Some (Opaqueproof.force_proof indirect_accessor otab o) + | OpaqueDef o -> Some (Opaqueproof.force_proof !indirect_accessor otab o) in let () = match body with diff --git a/checker/mod_checking.mli b/checker/mod_checking.mli index dbc81c8507..7aa1f837a0 100644 --- a/checker/mod_checking.mli +++ b/checker/mod_checking.mli @@ -8,6 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val set_indirect_accessor : (Names.DirPath.t -> int -> Constr.t option) -> unit +val set_indirect_accessor : Opaqueproof.indirect_accessor -> unit val check_module : Environ.env -> Names.ModPath.t -> Declarations.module_body -> unit diff --git a/checker/values.ml b/checker/values.ml index 031f05dd6b..4a4c8d803c 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -131,7 +131,7 @@ let v_proj = v_tuple "projection" [|v_proj_repr; v_bool|] let rec v_constr = Sum ("constr",0,[| [|Int|]; (* Rel *) - [|Fail "Var"|]; (* Var *) + [|v_id|]; (* Var *) [|Fail "Meta"|]; (* Meta *) [|Fail "Evar"|]; (* Evar *) [|v_sort|]; (* Sort *) @@ -383,6 +383,22 @@ let v_libsum = let v_lib = Tuple ("library",[|v_compiled_lib;v_libraryobjs|]) -let v_opaques = Array (Opt v_constr) +let v_ndecl = v_sum "named_declaration" 0 + [| [|v_binder_annot v_id; v_constr|]; (* LocalAssum *) + [|v_binder_annot v_id; v_constr; v_constr|] |] (* LocalDef *) + +let v_nctxt = List v_ndecl + +let v_work_list = + let v_abstr = v_pair v_instance (Array v_id) in + Tuple ("work_list", [|v_hmap v_cst v_abstr; v_hmap v_cst v_abstr|]) + +let v_abstract = + Tuple ("abstract", [| v_nctxt; v_instance; v_abs_context |]) + +let v_cooking_info = + Tuple ("cooking_info", [|v_work_list; v_abstract|]) + +let v_opaques = Array (Tuple ("opaque", [| List v_cooking_info; Int; Opt v_constr |])) let v_univopaques = Opt (Tuple ("univopaques",[|v_context_set;v_bool|])) diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 95fceb773a..fa39b41565 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -215,7 +215,7 @@ ######################################################################## # simple-io ######################################################################## -: "${simple_io_CI_REF:=dev}" +: "${simple_io_CI_REF:=master}" : "${simple_io_CI_GITURL:=https://github.com/Lysxia/coq-simple-io}" : "${simple_io_CI_ARCHIVEURL:=${simple_io_CI_GITURL}/archive}" diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh index bba17314f7..e8c8d22678 100755 --- a/dev/ci/ci-fiat-crypto.sh +++ b/dev/ci/ci-fiat-crypto.sh @@ -11,7 +11,7 @@ git_download fiat_crypto # c.f. https://github.com/coq/coq/pull/8313#issuecomment-416650241 fiat_crypto_CI_TARGETS1="c-files printlite lite" -fiat_crypto_CI_TARGETS2="print-nobigmem nobigmem" +fiat_crypto_CI_TARGETS2="coq" ( cd "${CI_BUILD_DIR}/fiat_crypto" && git submodule update --init --recursive && \ ulimit -s 32768 && \ diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 8eebb3af64..818454dbbc 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-04-20-V1" +# CACHEKEY: "bionic_coq-V2019-06-11-V1" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -38,7 +38,7 @@ ENV COMPILER="4.05.0" # `num` does not have a version number as the right version to install varies # with the compiler version. ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.2 ounit.2.0.8 odoc.1.4.0" \ - CI_OPAM="menhir.20181113 elpi.1.2.0 ocamlgraph.1.8.8" + CI_OPAM="menhir.20181113 elpi.1.3.1 ocamlgraph.1.8.8" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV COQIDE_OPAM="cairo2.0.6 lablgtk3-sourceview3.3.0.beta5" diff --git a/dev/ci/user-overlays/07819-mattam-ho-matching-occ-sel.sh b/dev/ci/user-overlays/07819-mattam-ho-matching-occ-sel.sh deleted file mode 100644 index 2b4c1489ad..0000000000 --- a/dev/ci/user-overlays/07819-mattam-ho-matching-occ-sel.sh +++ /dev/null @@ -1,13 +0,0 @@ -_OVERLAY_BRANCH=ho-matching-occ-sel - -if [ "$CI_PULL_REQUEST" = "7819" ] || [ "$CI_BRANCH" = "$_OVERLAY_BRANCH" ]; then - - unicoq_CI_REF="PR7819-overlay" - - mtac2_CI_REF="PR7819-overlay" - mtac2_CI_GITURL=https://github.com/mattam82/Mtac2 - - equations_CI_GITURL=https://github.com/mattam82/Coq-Equations - equations_CI_REF="PR7819-overlay" - -fi diff --git a/dev/ci/user-overlays/08726-herbelin-master+more-stable-meaning-to-Discharge-flag.sh b/dev/ci/user-overlays/08726-herbelin-master+more-stable-meaning-to-Discharge-flag.sh new file mode 100644 index 0000000000..242b177d71 --- /dev/null +++ b/dev/ci/user-overlays/08726-herbelin-master+more-stable-meaning-to-Discharge-flag.sh @@ -0,0 +1,23 @@ +if [ "$CI_PULL_REQUEST" = "8726" ] || [ "$CI_BRANCH" = "master+more-stable-meaning-to-Discharge-flag" ]; then + + fiat_parsers_CI_BRANCH=master+change-for-coq-pr8726 + fiat_parsers_CI_REF=master+change-for-coq-pr8726 + fiat_parsers_CI_GITURL=https://github.com/herbelin/fiat + + elpi_CI_BRANCH=coq-master+fix-global-pr8726 + elpi_CI_REF=coq-master+fix-global-pr8726 + elpi_CI_GITURL=https://github.com/herbelin/coq-elpi + + equations_CI_BRANCH=master+fix-global-pr8726 + equations_CI_REF=master+fix-global-pr8726 + equations_CI_GITURL=https://github.com/herbelin/Coq-Equations + + mtac2_CI_BRANCH=master+fix-global-pr8726 + mtac2_CI_REF=master+fix-global-pr8726 + mtac2_CI_GITURL=https://github.com/herbelin/Mtac2 + + paramcoq_CI_BRANCH=master+fix-global-pr8726 + paramcoq_CI_REF=master+fix-global-pr8726 + paramcoq_CI_GITURL=https://github.com/herbelin/paramcoq + +fi diff --git a/dev/ci/user-overlays/08764-validsdp-master-parsing-decimal.sh b/dev/ci/user-overlays/08764-validsdp-master-parsing-decimal.sh deleted file mode 100644 index 67f6f8610a..0000000000 --- a/dev/ci/user-overlays/08764-validsdp-master-parsing-decimal.sh +++ /dev/null @@ -1,18 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8764" ] || [ "$CI_BRANCH" = "master-parsing-decimal" ]; then - - ltac2_CI_REF=master-parsing-decimal - ltac2_CI_GITURL=https://github.com/proux01/ltac2 - - quickchick_CI_REF=master-parsing-decimal - quickchick_CI_GITURL=https://github.com/proux01/QuickChick - - Corn_CI_REF=master-parsing-decimal - Corn_CI_GITURL=https://github.com/proux01/corn - - HoTT_CI_REF=master-parsing-decimal - HoTT_CI_GITURL=https://github.com/proux01/HoTT - - stdlib2_CI_REF=master-parsing-decimal - stdlib2_CI_GITURL=https://github.com/proux01/stdlib2 - -fi diff --git a/dev/ci/user-overlays/08817-sprop.sh b/dev/ci/user-overlays/08817-sprop.sh deleted file mode 100644 index 81e18226ed..0000000000 --- a/dev/ci/user-overlays/08817-sprop.sh +++ /dev/null @@ -1,34 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8817" ] || [ "$CI_BRANCH" = "sprop" ]; then - aac_tactics_CI_REF=sprop - aac_tactics_CI_GITURL=https://github.com/SkySkimmer/aac-tactics - - coq_dpdgraph_CI_REF=sprop - coq_dpdgraph_CI_GITURL=https://github.com/SkySkimmer/coq-dpdgraph - - coqhammer_CI_REF=sprop - coqhammer_CI_GITURL=https://github.com/SkySkimmer/coqhammer - - elpi_CI_REF=sprop - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - - equations_CI_REF=sprop - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - ltac2_CI_REF=sprop - ltac2_CI_GITURL=https://github.com/SkySkimmer/ltac2 - - unicoq_CI_REF=sprop - unicoq_CI_GITURL=https://github.com/SkySkimmer/unicoq - - mtac2_CI_REF=sprop - mtac2_CI_GITURL=https://github.com/SkySkimmer/mtac2 - - paramcoq_CI_REF=sprop - paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq - - quickchick_CI_REF=sprop - quickchick_CI_GITURL=https://github.com/SkySkimmer/QuickChick - - relation_algebra_CI_REF=sprop - relation_algebra_CI_GITURL=https://github.com/SkySkimmer/relation-algebra -fi diff --git a/dev/ci/user-overlays/08829-proj-syntax-check.sh b/dev/ci/user-overlays/08829-proj-syntax-check.sh deleted file mode 100644 index c04621114f..0000000000 --- a/dev/ci/user-overlays/08829-proj-syntax-check.sh +++ /dev/null @@ -1,5 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8829" ] || [ "$CI_BRANCH" = "proj-syntax-check" ]; then - lambdaRust_CI_REF=proj-syntax-check - lambdaRust_CI_GITURL=https://github.com/SkySkimmer/lambda-rust - lambdaRust_CI_ARCHIVEURL=$lambdaRust_CI_GITURL/archive -fi diff --git a/dev/ci/user-overlays/08893-herbelin-master+moving-evars-of-term-on-econstr.sh b/dev/ci/user-overlays/08893-herbelin-master+moving-evars-of-term-on-econstr.sh deleted file mode 100644 index dc39ea5ef0..0000000000 --- a/dev/ci/user-overlays/08893-herbelin-master+moving-evars-of-term-on-econstr.sh +++ /dev/null @@ -1,7 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8893" ] || [ "$CI_BRANCH" = "master+moving-evars-of-term-on-econstr" ]; then - - equations_CI_BRANCH=master+fix-evars_of_term-pr8893 - equations_CI_REF=master+fix-evars_of_term-pr8893 - equations_CI_GITURL=https://github.com/herbelin/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/08984-vbgl-rm-hardwired-hint-db.sh b/dev/ci/user-overlays/08984-vbgl-rm-hardwired-hint-db.sh deleted file mode 100644 index 12be1b676a..0000000000 --- a/dev/ci/user-overlays/08984-vbgl-rm-hardwired-hint-db.sh +++ /dev/null @@ -1,12 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "8984" ] || [ "$CI_BRANCH" = "rm-hardwired-hint-db" ]; then - - HoTT_CI_REF=rm-hardwired-hint-db - HoTT_CI_GITURL=https://github.com/vbgl/HoTT - - ltac2_CI_REF=rm-hardwired-hint-db - ltac2_CI_GITURL=https://github.com/vbgl/ltac2 - - UniMath_CI_REF=rm-hardwired-hint-db - UniMath_CI_GITURL=https://github.com/vbgl/UniMath - -fi diff --git a/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh b/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh deleted file mode 100644 index c09d1b8929..0000000000 --- a/dev/ci/user-overlays/09129-ejgallego-proof+no_global_partial.sh +++ /dev/null @@ -1,30 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9129" ] || [ "$CI_BRANCH" = "proof+no_global_partial" ]; then - - aac_tactics_CI_REF=proof+no_global_partial - aac_tactics_CI_GITURL=https://github.com/ejgallego/aac-tactics - - # coqhammer_CI_REF=proof+no_global_partial - # coqhammer_CI_GITURL=https://github.com/ejgallego/coqhammer - - elpi_CI_REF=proof+no_global_partial - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - - equations_CI_REF=proof+no_global_partial - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - ltac2_CI_REF=proof+no_global_partial - ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 - - # unicoq_CI_REF=proof+no_global_partial - # unicoq_CI_GITURL=https://github.com/ejgallego/unicoq - - mtac2_CI_REF=proof+no_global_partial - mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 - - paramcoq_CI_REF=proof+no_global_partial - paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq - - quickchick_CI_REF=proof+no_global_partial - quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick - -fi diff --git a/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh b/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh deleted file mode 100644 index 1e1d36d54a..0000000000 --- a/dev/ci/user-overlays/09165-ejgallego-recarg-cleanup.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9165" ] || [ "$CI_BRANCH" = "recarg-cleanup" ]; then - - elpi_CI_REF=recarg-cleanup - elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi - - quickchick_CI_REF=recarg-cleanup - quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick - -fi diff --git a/dev/ci/user-overlays/09173-ejgallego-proofview+proof_info.sh b/dev/ci/user-overlays/09173-ejgallego-proofview+proof_info.sh deleted file mode 100644 index 23eb24c304..0000000000 --- a/dev/ci/user-overlays/09173-ejgallego-proofview+proof_info.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9173" ] || [ "$CI_BRANCH" = "proofview+proof_info" ]; then - - ltac2_CI_REF=proofview+proof_info - ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 - - fiat_parsers_CI_REF=proofview+proof_info - fiat_parsers_CI_GITURL=https://github.com/ejgallego/fiat - -fi diff --git a/dev/ci/user-overlays/09389-SkySkimmer-set-implicits.sh b/dev/ci/user-overlays/09389-SkySkimmer-set-implicits.sh deleted file mode 100644 index 1110157069..0000000000 --- a/dev/ci/user-overlays/09389-SkySkimmer-set-implicits.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9389" ] || [ "$CI_BRANCH" = "set-implicits" ]; then - - equations_CI_REF=set-implicits - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - mtac2_CI_REF=set-implicits - mtac2_CI_GITURL=https://github.com/SkySkimmer/Mtac2 - -fi diff --git a/dev/ci/user-overlays/09439-sep-variance.sh b/dev/ci/user-overlays/09439-sep-variance.sh deleted file mode 100644 index cca85a2f68..0000000000 --- a/dev/ci/user-overlays/09439-sep-variance.sh +++ /dev/null @@ -1,14 +0,0 @@ - -if [ "$CI_PULL_REQUEST" = "9439" ] || [ "$CI_BRANCH" = "sep-variance" ]; then - elpi_CI_REF=sep-variance - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - - equations_CI_REF=sep-variance - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - - mtac2_CI_REF=sep-variance - mtac2_CI_GITURL=https://github.com/SkySkimmer/mtac2 - - paramcoq_CI_REF=sep-variance - paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq -fi diff --git a/dev/ci/user-overlays/09476-ppedrot-context-constructor.sh b/dev/ci/user-overlays/09476-ppedrot-context-constructor.sh deleted file mode 100644 index 1af8b5430d..0000000000 --- a/dev/ci/user-overlays/09476-ppedrot-context-constructor.sh +++ /dev/null @@ -1,9 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9476" ] || [ "$CI_BRANCH" = "context-constructor" ]; then - - quickchick_CI_REF=context-constructor - quickchick_CI_GITURL=https://github.com/ppedrot/QuickChick - - equations_CI_REF=context-constructor - equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/09566-ejgallego-proof_global+move_termination_routine_out.sh b/dev/ci/user-overlays/09566-ejgallego-proof_global+move_termination_routine_out.sh new file mode 100644 index 0000000000..e4cf74aa51 --- /dev/null +++ b/dev/ci/user-overlays/09566-ejgallego-proof_global+move_termination_routine_out.sh @@ -0,0 +1,12 @@ +if [ "$CI_PULL_REQUEST" = "9566" ] || [ "$CI_BRANCH" = "proof_global+move_termination_routine_out" ]; then + + aac_tactics_CI_REF=proof_global+move_termination_routine_out + aac_tactics_CI_GITURL=https://github.com/ejgallego/aac-tactics + + equations_CI_REF=proof_global+move_termination_routine_out + equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + paramcoq_CI_REF=proof_global+move_termination_routine_out + paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq + +fi diff --git a/dev/ci/user-overlays/09567-ejgallego-hooks_unify.sh b/dev/ci/user-overlays/09567-ejgallego-hooks_unify.sh deleted file mode 100644 index 27ce9aca16..0000000000 --- a/dev/ci/user-overlays/09567-ejgallego-hooks_unify.sh +++ /dev/null @@ -1,12 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9567" ] || [ "$CI_BRANCH" = "hooks_unify" ]; then - - equations_CI_REF=hooks_unify - equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - mtac2_CI_REF=hooks_unify - mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 - - paramcoq_CI_REF=hooks_unify - paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq - -fi diff --git a/dev/ci/user-overlays/09602-gares-more-delta-in-termination-checking.sh b/dev/ci/user-overlays/09602-gares-more-delta-in-termination-checking.sh deleted file mode 100644 index 18a295cdbb..0000000000 --- a/dev/ci/user-overlays/09602-gares-more-delta-in-termination-checking.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9602" ] || [ "$CI_BRANCH" = "more-delta-in-termination-checking" ]; then - - equations_CI_REF=more-delta-in-termination-checking - equations_CI_GITURL=https://github.com/gares/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/09678-printed-by-env.sh b/dev/ci/user-overlays/09678-printed-by-env.sh deleted file mode 100644 index ccb3498764..0000000000 --- a/dev/ci/user-overlays/09678-printed-by-env.sh +++ /dev/null @@ -1,14 +0,0 @@ - -if [ "$CI_PULL_REQUEST" = "9678" ] || [ "$CI_BRANCH" = "printed-by-env" ]; then - elpi_CI_REF=printed-by-env - elpi_CI_GITURL=https://github.com/maximedenes/coq-elpi - - equations_CI_REF=printed-by-env - equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations - - ltac2_CI_REF=printed-by-env - ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 - - quickchick_CI_REF=printed-by-env - quickchick_CI_GITURL=https://github.com/maximedenes/QuickChick -fi diff --git a/dev/ci/user-overlays/09733-gares-quotations.sh b/dev/ci/user-overlays/09733-gares-quotations.sh deleted file mode 100644 index b17454fc4c..0000000000 --- a/dev/ci/user-overlays/09733-gares-quotations.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9733" ] || [ "$CI_BRANCH" = "quotations" ]; then - - ltac2_CI_REF=quotations - ltac2_CI_GITURL=https://github.com/gares/ltac2 - -fi diff --git a/dev/ci/user-overlays/09815-token-type.sh b/dev/ci/user-overlays/09815-token-type.sh deleted file mode 100644 index 4b49011de3..0000000000 --- a/dev/ci/user-overlays/09815-token-type.sh +++ /dev/null @@ -1,4 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9815" ] || [ "$CI_BRANCH" = "token-type" ]; then - ltac2_CI_REF=token-type - ltac2_CI_GITURL=https://github.com/proux01/ltac2 -fi diff --git a/dev/ci/user-overlays/09870-vbgl-recordops.sh b/dev/ci/user-overlays/09870-vbgl-recordops.sh deleted file mode 100644 index bb14a8c204..0000000000 --- a/dev/ci/user-overlays/09870-vbgl-recordops.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9870" ] || [ "$CI_BRANCH" = "doc-canonical" ]; then - - elpi_CI_REF=pr-9870 - elpi_CI_GITURL=https://github.com/vbgl/coq-elpi - -fi diff --git a/dev/ci/user-overlays/09895-ejgallego-require+upper.sh b/dev/ci/user-overlays/09895-ejgallego-require+upper.sh deleted file mode 100644 index 9a42c829ce..0000000000 --- a/dev/ci/user-overlays/09895-ejgallego-require+upper.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9895" ] || [ "$CI_BRANCH" = "require+upper" ]; then - - quickchick_CI_REF=require+upper - quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick - -fi diff --git a/dev/ci/user-overlays/09909-maximedenes-pretyping-rm-global.sh b/dev/ci/user-overlays/09909-maximedenes-pretyping-rm-global.sh deleted file mode 100644 index 01d3068591..0000000000 --- a/dev/ci/user-overlays/09909-maximedenes-pretyping-rm-global.sh +++ /dev/null @@ -1,21 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9909" ] || [ "$CI_BRANCH" = "pretyping-rm-global" ]; then - - elpi_CI_REF=pretyping-rm-global - elpi_CI_GITURL=https://github.com/maximedenes/coq-elpi - - coqhammer_CI_REF=pretyping-rm-global - coqhammer_CI_GITURL=https://github.com/maximedenes/coqhammer - - equations_CI_REF=pretyping-rm-global - equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations - - ltac2_CI_REF=pretyping-rm-global - ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 - - paramcoq_CI_REF=pretyping-rm-global - paramcoq_CI_GITURL=https://github.com/maximedenes/paramcoq - - mtac2_CI_REF=pretyping-rm-global - mtac2_CI_GITURL=https://github.com/maximedenes/Mtac2 - -fi diff --git a/dev/ci/user-overlays/09973-gares-elpi-2.1.sh b/dev/ci/user-overlays/09973-gares-elpi-2.1.sh deleted file mode 100644 index 9a6e25d893..0000000000 --- a/dev/ci/user-overlays/09973-gares-elpi-2.1.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "9973" ] || [ "$CI_BRANCH" = "elpi-1.2" ]; then - - elpi_CI_REF=overlay-elpi1.2-coq-master - elpi_CI_GITURL=https://github.com/LPCIC/coq-elpi - -fi diff --git a/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh b/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh deleted file mode 100644 index 9f9cc19e83..0000000000 --- a/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10052" ] || [ "$CI_BRANCH" = "cleanup-logic-convert-hyp" ]; then - - relation_algebra_CI_REF=cleanup-logic-convert-hyp - relation_algebra_CI_GITURL=https://github.com/ppedrot/relation-algebra - -fi diff --git a/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh b/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh deleted file mode 100644 index 0e1449f36c..0000000000 --- a/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10069" ] || [ "$CI_BRANCH" = "whd-for-evar-conv-no-stack" ]; then - - unicoq_CI_REF=whd-for-evar-conv-no-stack - unicoq_CI_GITURL=https://github.com/ppedrot/unicoq - -fi diff --git a/dev/ci/user-overlays/10076-vbgl-canonical-disable-hint.sh b/dev/ci/user-overlays/10076-vbgl-canonical-disable-hint.sh deleted file mode 100644 index 2015935dd9..0000000000 --- a/dev/ci/user-overlays/10076-vbgl-canonical-disable-hint.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10076" ] || [ "$CI_BRANCH" = "canonical-disable-hint" ]; then - - elpi_CI_REF=canonical-disable-hint - elpi_CI_GITURL=https://github.com/vbgl/coq-elpi - -fi diff --git a/dev/ci/user-overlays/10125-SkySkimmer-run_tactic_gen.sh b/dev/ci/user-overlays/10125-SkySkimmer-run_tactic_gen.sh deleted file mode 100644 index 4032b1c6b5..0000000000 --- a/dev/ci/user-overlays/10125-SkySkimmer-run_tactic_gen.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10125" ] || [ "$CI_BRANCH" = "run_tactic_gen" ]; then - - paramcoq_CI_REF=run_tactic_gen - paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq - -fi diff --git a/dev/ci/user-overlays/10133-SkySkimmer-kelim.sh b/dev/ci/user-overlays/10133-SkySkimmer-kelim.sh deleted file mode 100644 index 3658e96a3a..0000000000 --- a/dev/ci/user-overlays/10133-SkySkimmer-kelim.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10133" ] || [ "$CI_BRANCH" = "kelim" ]; then - - equations_CI_REF=kelim - equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations - -fi diff --git a/dev/ci/user-overlays/10135-maximedenes-detype-anonymous.sh b/dev/ci/user-overlays/10135-maximedenes-detype-anonymous.sh deleted file mode 100644 index bc8aa33565..0000000000 --- a/dev/ci/user-overlays/10135-maximedenes-detype-anonymous.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10135" ] || [ "$CI_BRANCH" = "detype-anonymous" ]; then - - unicoq_CI_REF=detype-anonymous - unicoq_CI_GITURL=https://github.com/maximedenes/unicoq - -fi diff --git a/dev/ci/user-overlays/10157-SkySkimmer-def-not-visible-generic-warning.sh b/dev/ci/user-overlays/10157-SkySkimmer-def-not-visible-generic-warning.sh deleted file mode 100644 index fcbeb32a58..0000000000 --- a/dev/ci/user-overlays/10157-SkySkimmer-def-not-visible-generic-warning.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10188" ] || [ "$CI_BRANCH" = "def-not-visible-remove-warning" ]; then - - elpi_CI_REF=def-not-visible-generic-warning - elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi - -fi diff --git a/dev/ci/user-overlays/10177-SkySkimmer-generalize.sh b/dev/ci/user-overlays/10177-SkySkimmer-generalize.sh deleted file mode 100644 index a89f6aca1b..0000000000 --- a/dev/ci/user-overlays/10177-SkySkimmer-generalize.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10177" ] || [ "$CI_BRANCH" = "generalize" ]; then - - quickchick_CI_REF=generalize - quickchick_CI_GITURL=https://github.com/SkySkimmer/QuickChick - -fi diff --git a/dev/ci/user-overlays/10201-ppedrot-opaque-future-cleanup.sh b/dev/ci/user-overlays/10201-ppedrot-opaque-future-cleanup.sh deleted file mode 100644 index e3bbb84bcb..0000000000 --- a/dev/ci/user-overlays/10201-ppedrot-opaque-future-cleanup.sh +++ /dev/null @@ -1,15 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10201" ] || [ "$CI_BRANCH" = "opaque-future-cleanup" ]; then - - coq_dpdgraph_CI_REF=opaque-future-cleanup - coq_dpdgraph_CI_GITURL=https://github.com/ppedrot/coq-dpdgraph - - coqhammer_CI_REF=opaque-future-cleanup - coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer - - elpi_CI_REF=opaque-future-cleanup - elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi - - paramcoq_CI_REF=opaque-future-cleanup - paramcoq_CI_GITURL=https://github.com/ppedrot/paramcoq - -fi diff --git a/dev/ci/user-overlays/10215-gares-less-ontop.sh b/dev/ci/user-overlays/10215-gares-less-ontop.sh deleted file mode 100644 index bceb5ad0e8..0000000000 --- a/dev/ci/user-overlays/10215-gares-less-ontop.sh +++ /dev/null @@ -1,15 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10215" ] || [ "$CI_BRANCH" = "custom-typing" ]; then - - equations_CI_REF=pass-less-ontop - equations_CI_GITURL=https://github.com/gares/Coq-Equations - - mtac2_CI_REF=pass-less-ontop - mtac2_CI_GITURL=https://github.com/SkySkimmer/Mtac2 - - paramcoq_CI_REF=pass-less-ontop - paramcoq_CI_GITURL=https://github.com/gares/paramcoq - - quickchick_CI_REF=pass-less-ontop - quickchick_CI_GITURL=https://github.com/gares/QuickChick - -fi diff --git a/dev/ci/user-overlays/10334-ppedrot-rm-kernel-sideeff-role.sh b/dev/ci/user-overlays/10334-ppedrot-rm-kernel-sideeff-role.sh new file mode 100644 index 0000000000..2c3f490c03 --- /dev/null +++ b/dev/ci/user-overlays/10334-ppedrot-rm-kernel-sideeff-role.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10334" ] || [ "$CI_BRANCH" = "rm-kernel-sideeff-role" ]; then + + equations_CI_REF=rm-kernel-sideeff-role + equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/10358-gares-elpi13.sh b/dev/ci/user-overlays/10358-gares-elpi13.sh new file mode 100644 index 0000000000..d2ba9b5ddf --- /dev/null +++ b/dev/ci/user-overlays/10358-gares-elpi13.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10358" ] || [ "$CI_BRANCH" = "elpi-13-coq" ]; then + + elpi_CI_REF="elpi-13-coq" + elpi_CI_GITURL=https://github.com/LPCIC/coq-elpi + +fi diff --git a/dev/ci/user-overlays/README.md b/dev/ci/user-overlays/README.md index 7fb73e447d..4c2f264a74 100644 --- a/dev/ci/user-overlays/README.md +++ b/dev/ci/user-overlays/README.md @@ -21,14 +21,14 @@ The name of your overlay file should start with a five-digit pull request number, followed by a dash, anything (for instance your GitHub nickname and the branch name), then a `.sh` extension (`[0-9]{5}-[a-zA-Z0-9-_]+.sh`). -Example: `00669-maximedenes-ssr-merge.sh` containing +Example: `10185-SkySkimmer-instance-no-bang.sh` containing ``` -#!/bin/sh +if [ "$CI_PULL_REQUEST" = "10185" ] || [ "$CI_BRANCH" = "instance-no-bang" ]; then + + quickchick_CI_REF=instance-no-bang + quickchick_CI_GITURL=https://github.com/SkySkimmer/QuickChick -if [ "$CI_PULL_REQUEST" = "669" ] || [ "$CI_BRANCH" = "ssr-merge" ]; then - mathcomp_CI_REF=ssr-merge - mathcomp_CI_GITURL=https://github.com/maximedenes/math-comp fi ``` diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 339ac2d9b7..51d90df89f 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -5,6 +5,21 @@ - Functions and types deprecated in 8.10 have been removed in Coq 8.11. +- Type Decl_kinds.locality has been restructured, see commit + message. Main change to do generally is to change the flag "Global" + to "Global ImportDefaultBehavior". + +Proof state: + + Proofs that are attached to a top-level constant (such as lemmas) + are represented by `Lemmas.t`, as they do contain additional + information related to the constant declaration. + + Plugins that require access to the information about currently + opened lemmas can add one of the `![proof]` attributes to their + `mlg` entry, which will refine the type accordingly. See + documentation in `vernacentries` for more information. + ## Changes between Coq 8.9 and Coq 8.10 ### ML4 Pre Processing @@ -59,6 +74,19 @@ Coqlib: command then enables to locate the registered constant through its name. The name resolution is dynamic. +Proof state: + +- Handling of proof state has been fully functionalized, thus it is + not possible to call global functions such as `get_current_context ()`. + + The main type for functions that need to handle proof state is + `Proof_global.t`. + + Unfortunately, this change was not possible to do in a + backwards-compatible way, but in most case the api changes are + straightforward, with functions taking and returning an extra + argument. + Macros: - The RAW_TYPED AS and GLOB_TYPED AS stanzas of the ARGUMENT EXTEND macro are diff --git a/dev/lint-commits.sh b/dev/lint-commits.sh index 96c92e3162..539bb5f1f9 100755 --- a/dev/lint-commits.sh +++ b/dev/lint-commits.sh @@ -19,21 +19,40 @@ fi BASE_COMMIT="$1" HEAD_COMMIT="$2" -bad=() +bad_ws=() +bad_compile=() while IFS= read -r commit; do echo Checking "$commit" # git diff --check # uses .gitattributes to know what to check if ! git diff --check "${commit}^" "$commit"; - then - bad+=("$commit") + then bad_ws+=("$commit") + fi + + if ! make -f Makefile.dune check + then bad_compile+=("$commit") fi done < <(git rev-list "$HEAD_COMMIT" --not "$BASE_COMMIT" --) -if [ "${#bad[@]}" != 0 ] +# report errors + +CODE=0 + +if [ "${#bad_ws[@]}" != 0 ] then >&2 echo "Whitespace errors!" - >&2 echo "In commits ${bad[*]}" + >&2 echo "In commits ${bad_ws[*]}" >&2 echo "If you use emacs, you can prevent this kind of error from reoccurring by installing ws-butler and enabling ws-butler-convert-leading-tabs-or-spaces." - exit 1 + >&2 echo + CODE=1 fi + +if [ "${#bad_compile[@]}" != 0 ] +then + >&2 echo "Compilation errors!" + >&2 echo "In commits ${bad_compile[*]}" + >&2 echo + CODE=1 +fi + +exit $CODE diff --git a/dev/tools/coqdev.el b/dev/tools/coqdev.el index b89ae67a82..5f9f326750 100644 --- a/dev/tools/coqdev.el +++ b/dev/tools/coqdev.el @@ -78,11 +78,7 @@ Specifically `camldebug-command-name' and `ocamldebug-command-name'." Note that this function is executed before _Coqproject is read if it exists." (let ((dir (coqdev-default-directory))) (when dir - (unless coq-prog-args - (setq coq-prog-args - `("-coqlib" ,dir - "-topfile" ,buffer-file-name))) - (setq-local coq-prog-name (concat dir "bin/coqtop"))))) + (setq-local coq-prog-name (concat dir "_build/default/dev/shim/coqtop-prelude"))))) (add-hook 'hack-local-variables-hook #'coqdev-setup-proofgeneral) (defvar coqdev-ocamldebug-command "dune exec dev/dune-dbg" diff --git a/dev/tools/update-compat.py b/dev/tools/update-compat.py index ff9b32fe78..0338cd42c7 100755 --- a/dev/tools/update-compat.py +++ b/dev/tools/update-compat.py @@ -73,8 +73,6 @@ FLAGS_ML_PATH = os.path.join(ROOT_PATH, 'lib', 'flags.ml') COQARGS_ML_PATH = os.path.join(ROOT_PATH, 'toplevel', 'coqargs.ml') G_VERNAC_PATH = os.path.join(ROOT_PATH, 'vernac', 'g_vernac.mlg') DOC_INDEX_PATH = os.path.join(ROOT_PATH, 'doc', 'stdlib', 'index-list.html.template') -BUG_4798_PATH = os.path.join(ROOT_PATH, 'test-suite', 'bugs', 'closed', 'bug_4798.v') -BUG_9166_PATH = os.path.join(ROOT_PATH, 'test-suite', 'bugs', 'closed', 'bug_9166.v') TEST_SUITE_RUN_PATH = os.path.join(ROOT_PATH, 'test-suite', 'tools', 'update-compat', 'run.sh') TEST_SUITE_PATHS = tuple(os.path.join(ROOT_PATH, 'test-suite', 'success', i) for i in ('CompatOldOldFlag.v', 'CompatOldFlag.v', 'CompatPreviousFlag.v', 'CompatCurrentFlag.v')) @@ -401,34 +399,6 @@ dev/tools/update-compat.py --assert-unchanged %s || exit $? ''' % ' '.join([('--master' if args['master'] else ''), ('--release' if args['release'] else '')]).strip() update_if_changed(contents, new_contents, TEST_SUITE_RUN_PATH, pass_through_shebang=True, **args) -def update_bug_4789(new_versions, **args): - # we always update this compat notation to oldest - # currently-supported compat version, which should never be the - # current version - with open(BUG_4798_PATH, 'r') as f: contents = f.read() - new_contents = BUG_HEADER + r"""Check match 2 with 0 => 0 | S n => n end. -Notation "|" := 1 (compat "%s"). -Check match 2 with 0 => 0 | S n => n end. (* fails *) -""" % new_versions[0] - update_if_changed(contents, new_contents, BUG_4798_PATH, **args) - -def update_bug_9166(new_versions, **args): - # we always update this compat notation to oldest - # currently-supported compat version, which should never be the - # current version - with open(BUG_9166_PATH, 'r') as f: contents = f.read() - new_contents = BUG_HEADER + r"""Set Warnings "+deprecated". - -Notation bar := option (compat "%s"). - -Definition foo (x: nat) : nat := - match x with - | 0 => 0 - | S bar => bar - end. -""" % new_versions[0] - update_if_changed(contents, new_contents, BUG_9166_PATH, **args) - def update_compat_notations_in(old_versions, new_versions, contents): for v in old_versions: if v not in new_versions: @@ -508,7 +478,5 @@ if __name__ == '__main__': update_test_suite(new_versions, **args) update_test_suite_run(**args) update_doc_index(new_versions, **args) - update_bug_4789(new_versions, **args) - update_bug_9166(new_versions, **args) update_compat_notations(known_versions, new_versions, **args) display_git_grep(known_versions, new_versions) diff --git a/doc/changelog/03-notations/10180-deprecate-notations.rst b/doc/changelog/03-notations/10180-deprecate-notations.rst new file mode 100644 index 0000000000..01f2e893ed --- /dev/null +++ b/doc/changelog/03-notations/10180-deprecate-notations.rst @@ -0,0 +1,6 @@ +- The :cmd:`Notation` and :cmd:`Infix` commands now support the `deprecated` + attribute. The former `compat` annotation for notations is + deprecated, and its semantics changed. It is now made equivalent to using + a `deprecated` attribute, and is no longer connected with the `-compat` + command-line flag. + (`#10180 <https://github.com/coq/coq/pull/10180>`_, by Maxime Dénès). diff --git a/doc/changelog/04-tactics/10205-discriminate-HoTT.rst b/doc/changelog/04-tactics/10205-discriminate-HoTT.rst new file mode 100644 index 0000000000..bb2d2a092e --- /dev/null +++ b/doc/changelog/04-tactics/10205-discriminate-HoTT.rst @@ -0,0 +1,6 @@ +- Make the :tacn:`discriminate` tactic work together with + :flag:`Universe Polymorphism` and equality in :g:`Type`. This, + in particular, makes :tacn:`discriminate` compatible with the HoTT + library https://github.com/HoTT/HoTT. + (`#10205 <https://github.com/coq/coq/pull/10205>`_, + by Andreas Lynge, review by Pierre-Marie Pédrot and Matthieu Sozeau) diff --git a/doc/changelog/04-tactics/10318-select-only-error.rst b/doc/changelog/04-tactics/10318-select-only-error.rst new file mode 100644 index 0000000000..03ed15d948 --- /dev/null +++ b/doc/changelog/04-tactics/10318-select-only-error.rst @@ -0,0 +1,4 @@ +- The goal selector tactical ``only`` now checks that the goal range + it is given is valid instead of ignoring goals out of the focus + range. (`#10318 <https://github.com/coq/coq/pull/10318>`_, by Gaëtan + Gilbert). diff --git a/doc/changelog/05-tactic-language/10002-ltac2.rst b/doc/changelog/05-tactic-language/10002-ltac2.rst new file mode 100644 index 0000000000..6d62f11eff --- /dev/null +++ b/doc/changelog/05-tactic-language/10002-ltac2.rst @@ -0,0 +1,9 @@ +- Ltac2, a new version of the tactic language Ltac, that doesn't + preserve backward compatibility, has been integrated in the main Coq + distribution. It is still experimental, but we already recommend + users of advanced Ltac to start using it and report bugs or request + enhancements. See its documentation in the :ref:`dedicated chapter + <ltac2>` (`#10002 <https://github.com/coq/coq/pull/10002>`_, plugin + authored by Pierre-Marie Pédrot, with contributions by various + users, integration by Maxime Dénès, help on integrating / improving + the documentation by Théo Zimmermann and Jim Fehrle). diff --git a/doc/changelog/05-tactic-language/10289-ltac2+delimited-constr-in-notations.rst b/doc/changelog/05-tactic-language/10289-ltac2+delimited-constr-in-notations.rst new file mode 100644 index 0000000000..bd1c0c42e8 --- /dev/null +++ b/doc/changelog/05-tactic-language/10289-ltac2+delimited-constr-in-notations.rst @@ -0,0 +1,5 @@ +- Ltac2 tactic notations with “constr” arguments can specify the + interpretation scope for these arguments; + see :ref:`ltac2_notations` for details + (`#10289 <https://github.com/coq/coq/pull/10289>`_, + by Vincent Laporte). diff --git a/doc/changelog/06-ssreflect/10302-case-HoTT.rst b/doc/changelog/06-ssreflect/10302-case-HoTT.rst new file mode 100644 index 0000000000..686b3c3cca --- /dev/null +++ b/doc/changelog/06-ssreflect/10302-case-HoTT.rst @@ -0,0 +1,7 @@ +- Make the ``case E: t`` tactic work together with + :flag:`Universe Polymorphism` and equality in :g:`Type`. + This makes tacn:`case` compatible with the HoTT + library https://github.com/HoTT/HoTT. + (`#10302 <https://github.com/coq/coq/pull/10302>`_, + fixes `#10301 <https://github.com/coq/coq/issues/10301>`_, + by Andreas Lynge, review by Enrico Tassi) diff --git a/doc/changelog/06-ssreflect/10305-unfold-HoTT.rst b/doc/changelog/06-ssreflect/10305-unfold-HoTT.rst new file mode 100644 index 0000000000..b82de1a879 --- /dev/null +++ b/doc/changelog/06-ssreflect/10305-unfold-HoTT.rst @@ -0,0 +1,7 @@ +- Make the ``rewrite /t`` tactic work together with + :flag:`Universe Polymorphism`. + This makes tacn:`rewrite` compatible with the HoTT + library https://github.com/HoTT/HoTT. + (`#10305 <https://github.com/coq/coq/pull/10305>`_, + fixes `#9336 <https://github.com/coq/coq/issues/9336>`_, + by Andreas Lynge, review by Enrico Tassi) diff --git a/doc/changelog/08-tools/10245-require-command-line.rst b/doc/changelog/08-tools/10245-require-command-line.rst new file mode 100644 index 0000000000..54417077f5 --- /dev/null +++ b/doc/changelog/08-tools/10245-require-command-line.rst @@ -0,0 +1,6 @@ +- Add command line options `-require-import`, `-require-export`, + `-require-import-from` and `-require-export-from`, as well as their + shorthand, `-ri`, `-re`, `-refrom` and -`rifrom`. Deprecate + confusing command line option `-require` + (`#10245 <https://github.com/coq/coq/pull/10245>`_ + by Hugo Herbelin, review by Emilio Gallego). diff --git a/doc/plugin_tutorial/README.md b/doc/plugin_tutorial/README.md index f82edb2352..6d142a9af8 100644 --- a/doc/plugin_tutorial/README.md +++ b/doc/plugin_tutorial/README.md @@ -1,34 +1,20 @@ How to write plugins in Coq =========================== - # Working environment : merlin, tuareg (open question) + # Working environment + + In addition to installing OCaml and Coq, it can help to install several tools for development. - ## OCaml & related tools + ## Merlin These instructions use [OPAM](http://opam.ocaml.org/doc/Install.html) ```shell -opam init --root=$PWD/CIW2018 --compiler=4.06.0 -j2 -eval `opam config env --root=$PWD/CIW2018` -opam install camlp5 ocamlfind num # Coq's dependencies -opam install lablgtk # Coqide's dependencies (optional) opam install merlin # prints instructions for vim and emacs ``` - ## Coq - -```shell -git clone git@github.com:coq/coq.git -cd coq -./configure -profile devel -make -j2 -cd .. -export PATH=$PWD/coq/bin:$PATH -``` - ## This tutorial ```shell -git clone git@github.com:ybertot/plugin_tutorials.git cd plugin_tutorials/tuto0 make .merlin # run before opening .ml files in your editor make # build @@ -40,6 +26,8 @@ make # build package a ml4 file in a plugin, organize a `Makefile`, `_CoqProject` - Example of syntax to add a new toplevel command - Example of function call to print a simple message + - Example of function call to print a simple warning + - Example of function call to raise a simple error to the user - Example of syntax to add a simple tactic (that does nothing and prints a message) - To use it: @@ -54,19 +42,23 @@ make # build Require Import Tuto0.Loader. HelloWorld. ``` - # tuto1 : Ocaml to Coq communication + You can also modify and run `theories/Demo.v`. + + # tuto1 : OCaml to Coq communication Explore the memory of Coq, modify it - - Commands that take arguments: strings, symbols, expressions of the calculus of constructions + - Commands that take arguments: strings, integers, symbols, expressions of the calculus of constructions + - Examples of using environments correctly + - Examples of using state (the evar_map) correctly - Commands that interact with type-checking in Coq + - A command that checks convertibility between two terms - A command that adds a new definition or theorem - - A command that uses a name and exploits the existing definitions - or theorems + - A command that uses a name and exploits the existing definitions or theorems - A command that exploits an existing ongoing proof - A command that defines a new tactic Compilation and loading must be performed as for `tuto0`. - # tuto2 : Ocaml to Coq communication + # tuto2 : OCaml to Coq communication A more step by step introduction to writing commands - Explanation of the syntax of entries - Adding a new type to and parsing to the available choices diff --git a/doc/plugin_tutorial/tuto0/src/g_tuto0.mlg b/doc/plugin_tutorial/tuto0/src/g_tuto0.mlg index 5c633fe862..97689adfed 100644 --- a/doc/plugin_tutorial/tuto0/src/g_tuto0.mlg +++ b/doc/plugin_tutorial/tuto0/src/g_tuto0.mlg @@ -5,14 +5,70 @@ DECLARE PLUGIN "tuto0_plugin" open Pp open Ltac_plugin +let tuto_warn = CWarnings.create ~name:"name" ~category:"category" + (fun _ -> strbrk Tuto0_main.message) + } +(*** Printing messages ***) + +(* + * This defines a command that prints HelloWorld. + * Note that Feedback.msg_notice can be used to print messages. + *) VERNAC COMMAND EXTEND HelloWorld CLASSIFIED AS QUERY | [ "HelloWorld" ] -> { Feedback.msg_notice (strbrk Tuto0_main.message) } END +(* + * This is a tactic version of the same thing. + *) TACTIC EXTEND hello_world_tactic | [ "hello_world" ] -> { let _ = Feedback.msg_notice (str Tuto0_main.message) in Tacticals.New.tclIDTAC } END + +(*** Printing warnings ***) + +(* + * This defines a command that prints HelloWorld as a warning. + * tuto_warn is defined at the top-level, before the command runs, + * which is standard. + *) +VERNAC COMMAND EXTEND HelloWarning CLASSIFIED AS QUERY +| [ "HelloWarning" ] -> + { + tuto_warn () + } +END + +(* + * This is a tactic version of the same thing. + *) +TACTIC EXTEND hello_warning_tactic +| [ "hello_warning" ] -> + { + let _ = tuto_warn () in + Tacticals.New.tclIDTAC + } +END + +(*** Printing errors ***) + +(* + * This defines a command that prints HelloWorld inside of an error. + * Note that CErrors.user_err can be used to raise errors to the user. + *) +VERNAC COMMAND EXTEND HelloError CLASSIFIED AS QUERY +| [ "HelloError" ] -> { CErrors.user_err (str Tuto0_main.message) } +END + +(* + * This is a tactic version of the same thing. + *) +TACTIC EXTEND hello_error_tactic +| [ "hello_error" ] -> + { let _ = CErrors.user_err (str Tuto0_main.message) in + Tacticals.New.tclIDTAC } +END diff --git a/doc/plugin_tutorial/tuto0/theories/Demo.v b/doc/plugin_tutorial/tuto0/theories/Demo.v index bdc61986af..54d5239421 100644 --- a/doc/plugin_tutorial/tuto0/theories/Demo.v +++ b/doc/plugin_tutorial/tuto0/theories/Demo.v @@ -1,8 +1,28 @@ From Tuto0 Require Import Loader. +(*** Printing messages ***) + HelloWorld. Lemma test : True. Proof. hello_world. Abort. + +(*** Printing warnings ***) + +HelloWarning. + +Lemma test : True. +Proof. +hello_warning. +Abort. + +(*** Signaling errors ***) + +Fail HelloError. + +Lemma test : True. +Proof. +Fail hello_error. +Abort. diff --git a/doc/plugin_tutorial/tuto1/_CoqProject b/doc/plugin_tutorial/tuto1/_CoqProject index 585d1360be..60f9f0a0c7 100644 --- a/doc/plugin_tutorial/tuto1/_CoqProject +++ b/doc/plugin_tutorial/tuto1/_CoqProject @@ -2,7 +2,10 @@ -I src theories/Loader.v +theories/Demo.v +src/inspector.mli +src/inspector.ml src/simple_check.mli src/simple_check.ml src/simple_declare.mli diff --git a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg index 300d62285a..73d94c2a51 100644 --- a/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg +++ b/doc/plugin_tutorial/tuto1/src/g_tuto1.mlg @@ -8,7 +8,6 @@ DECLARE PLUGIN "tuto1_plugin" theories/Loader.v *) open Ltac_plugin -open Attributes open Pp (* This module defines the types of arguments to be used in the EXTEND directives below, for example the string one. *) @@ -16,139 +15,279 @@ open Stdarg } -VERNAC COMMAND EXTEND HelloWorld CLASSIFIED AS QUERY -| [ "Hello" string(s) ] -> - { Feedback.msg_notice (strbrk "Hello " ++ str s) } -END +(*** Printing inputs ***) -(* reference is allowed as a syntactic entry, but so are all the entries - found the signature of module Prim in file coq/parsing/pcoq.mli *) +(* + * This command prints an input from the user. + * + * A list with allowable inputs can be found in interp/stdarg.mli, + * plugin/ltac/extraargs.mli, and plugin/ssr/ssrparser.mli + * (remove the wit_ prefix), but not all of these are allowable + * (unit and bool, for example, are not usable from within here). + * + * We include only some examples that are standard and useful for commands. + * Some of the omitted examples are useful for tactics. + * + * Inspector is our own file that defines a simple messaging function. + * The printing functions (pr_qualid and so on) are in printing. + * + * Some of these cases would be ambiguous if we used "What's" for each of + * these. For example, all of these are terms. We purposely disambiguate. + *) +VERNAC COMMAND EXTEND WhatIsThis CLASSIFIED AS QUERY +| [ "What's" constr(e) ] -> + { + let env = Global.env () in (* we'll explain later *) + let sigma = Evd.from_env env in (* we'll explain later *) + Inspector.print_input e (Ppconstr.pr_constr_expr env sigma) "term" + } +| [ "What" "kind" "of" "term" "is" string(s) ] -> + { Inspector.print_input s strbrk "string" } +| [ "What" "kind" "of" "term" "is" int(i) ] -> + { Inspector.print_input i Pp.int "int" } +| [ "What" "kind" "of" "term" "is" ident(id) ] -> + { Inspector.print_input id Ppconstr.pr_id "identifier" } +| [ "What" "kind" "of" "identifier" "is" reference(r) ] -> + { Inspector.print_input r Ppconstr.pr_qualid "reference" } +END -VERNAC COMMAND EXTEND HelloAgain CLASSIFIED AS QUERY -| [ "HelloAgain" reference(r)] -> -(* The function Ppconstr.pr_qualid was found by searching all mli files - for a function of type qualid -> Pp.t *) - { Feedback.msg_notice - (strbrk "Hello again " ++ Ppconstr.pr_qualid r)} +(* + * This command demonstrates basic combinators built into the DSL here. + * You can generalize this for constr_list, constr_opt, int_list, and so on. + *) +VERNAC COMMAND EXTEND WhatAreThese CLASSIFIED AS QUERY +| [ "What" "is" int_list(l) "a" "list" "of" ] -> + { + let print l = str "[" ++ Pp.prlist_with_sep (fun () -> str ";") Pp.int l ++ str "]" in + Inspector.print_input l print "int list" + } +| [ "Is" ne_int_list(l) "nonempty" ] -> + { + let print l = str "[" ++ Pp.prlist_with_sep (fun () -> str ";") Pp.int l ++ str "]" in + Inspector.print_input l print "nonempty int list" + } +| [ "And" "is" int_opt(o) "provided" ] -> + { + let print o = strbrk (if Option.has_some o then "Yes" else "No") in + Feedback.msg_notice (print o) + } END -(* According to parsing/pcoq.mli, e has type constr_expr *) -(* this type is defined in pretyping/constrexpr.ml *) -(* Question for the developers: why is the file constrexpr.ml and not - constrexpr.mli --> Easier for packing the software in components. *) -VERNAC COMMAND EXTEND TakingConstr CLASSIFIED AS QUERY -| [ "Cmd1" constr(e) ] -> - { let _ = e in Feedback.msg_notice (strbrk "Cmd1 parsed something") } + +(*** Interning terms ***) + +(* + * The next step is to make something of parsed expression. + * Interesting information in interp/constrintern.mli. + * + * When you read in constr(e), e will have type Constrexpr.constr_expr, + * which is defined in pretyping/constrexpr.ml. Your plugin + * will want a different representation. + * + * The important function is Constrintern.interp_constr_evars, + * which converts between a constr_expr and an + * (EConstr.constr, evar_map) pair. This essentially contains + * an internal representation of the term along with some state. + * For more on the state, read /dev/doc/econstr.md. + * + * NOTE ON INTERNING: Always prefer Constrintern.interp_constr_evars + * over Constrintern.interp_constr. The latter is an internal function + * not meant for external use. + * + * To get your initial environment, call Global.env (). + * To get state from that environment, call Evd.from_env on that environment. + * It is important to NEVER use the empty environment or Evd.empty; + * if you do, you will get confusing errors. + * + * NOTE ON STATE: It is important to use the evar_map that is returned to you. + * Otherwise, you may get cryptic errors later in your plugin. + * For example, you may get universe inconsistency errors. + * In general, if a function returns an evar_map to you, that's the one + * you want to thread through the rest of your command. + * + * NOTE ON STYLE: In general, it's better practice to move large + * chunks of OCaml code like this one into an .ml file. We include + * this here because it's really important to understand how to + * thread state in a plugin, and it's easier to see that if it's in the + * top-level file itself. + *) +VERNAC COMMAND EXTEND Intern CLASSIFIED AS QUERY +| [ "Intern" constr(e) ] -> + { + let env = Global.env () in (* use this; never use empty *) + let sigma = Evd.from_env env in (* use this; never use empty *) + let debug sigma = Termops.pr_evar_map ~with_univs:true None env sigma in + Feedback.msg_notice (strbrk "State before intern: " ++ debug sigma); + let (sigma, t) = Constrintern.interp_constr_evars env sigma e in + Feedback.msg_notice (strbrk "State after intern: " ++ debug sigma); + let print t = Printer.pr_econstr_env env sigma t in + Feedback.msg_notice (strbrk "Interned: " ++ print t) + } END -(* The next step is to make something of parsed expression. - Interesting information in interp/constrintern.mli *) - -(* There are several phases of transforming a parsed expression into - the final internal data-type (constr). There exists a collection of - functions that combine all the phases *) - -VERNAC COMMAND EXTEND TakingConstr2 CLASSIFIED AS QUERY -| [ "Cmd2" constr(e) ] -> - { let _ = Constrintern.interp_constr - (Global.env()) - (* Make sure you don't use Evd.empty here, as this does not - check consistency with existing universe constraints. *) - (Evd.from_env (Global.env())) e in - Feedback.msg_notice (strbrk "Cmd2 parsed something legitimate") } +(*** Defining terms ***) + +(* + * To define a term, we start similarly to our intern functionality, + * then we call another function. We define this function in + * the Simple_declare module. + * + * The line #[ poly = Attributes.polymorphic ] says that this command accepts + * polymorphic attributes. + * @SkySkimmer: Here, poly is what the result is bound to in the + * rule's code. Multiple attributes may be used separated by ;, and we have + * punning so foo is equivalent to foo = foo. + * + * The declare_definition function returns the reference + * that was defined. This reference will be present in the new environment. + * If you want to refer to it later in your plugin, you must use an + * updated environment and the constructed reference. + * + * Note since we are now defining a term, we must classify this + * as a side-effect (CLASSIFIED AS SIDEFF). + *) +VERNAC COMMAND EXTEND MyDefine CLASSIFIED AS SIDEFF +| #[ poly = Attributes.polymorphic ] [ "MyDefine" ident(i) ":=" constr(e) ] -> + { + let env = Global.env () in + let sigma = Evd.from_env env in + let (sigma, t) = Constrintern.interp_constr_evars env sigma e in + let r = Simple_declare.declare_definition ~poly i sigma t in + let print r = strbrk "Defined " ++ Printer.pr_global r ++ strbrk "." in + Feedback.msg_notice (print r) + } END -(* This is to show what happens when typing in an empty environment - with an empty evd. - Question for the developers: why does "Cmd3 (fun x : nat => x)." - raise an anomaly, not the same error as "Cmd3 (fun x : a => x)." *) - -VERNAC COMMAND EXTEND TakingConstr3 CLASSIFIED AS QUERY -| [ "Cmd3" constr(e) ] -> - { let _ = Constrintern.interp_constr Environ.empty_env - Evd.empty e in - Feedback.msg_notice - (strbrk "Cmd3 accepted something in the empty context")} +(*** Printing terms ***) + +(* + * This command takes a name and return its value. It does less + * than Print, because it fails on constructors, axioms, and inductive types. + * It signals an error to the user for unsupported terms. + * + * Simple_print contains simple_body_access, which shows how to look up + * a global reference. + *) +VERNAC COMMAND EXTEND ExamplePrint CLASSIFIED AS QUERY +| [ "MyPrint" reference(r) ] -> + { + let env = Global.env () in + let sigma = Evd.from_env env in + try + let t = Simple_print.simple_body_access (Nametab.global r) in + Feedback.msg_notice (Printer.pr_econstr_env env sigma t) + with Failure s -> + CErrors.user_err (str s) + } END -(* When adding a definition, we have to be careful that just - the operation of constructing a well-typed term may already change - the environment, at the level of universe constraints (which - are recorded in the evd component). The function - Constrintern.interp_constr ignores this side-effect, so it should - not be used here. *) - -(* Looking at the interface file interp/constrintern.ml4, I lost - some time because I did not see that the "constr" type appearing - there was "EConstr.constr" and not "Constr.constr". *) - -VERNAC COMMAND EXTEND Define1 CLASSIFIED AS SIDEFF -| #[ poly = polymorphic ] [ "Cmd4" ident(i) constr(e) ] -> - { let v = Constrintern.interp_constr (Global.env()) - (Evd.from_env (Global.env())) e in - Simple_declare.packed_declare_definition ~poly i v } +(* + * This command shows that after you define a new term, + * you can also look it up. But there's a catch! You need to actually + * refresh your environment. Otherwise, the defined term + * will not be in the environment. + * + * Using the global reference as opposed to the ID is generally + * a good idea, otherwise you might end up running into unforeseen + * problems inside of modules and sections and so on. + * + * Inside of simple_body_access, note that it uses Global.env (), + * which refreshes the environment before looking up the term. + *) +VERNAC COMMAND EXTEND DefineLookup CLASSIFIED AS SIDEFF +| #[ poly = Attributes.polymorphic ] [ "DefineLookup" ident(i) ":=" constr(e) ] -> + { + let env = Global.env () in + let sigma = Evd.from_env env in + let (sigma, t) = Constrintern.interp_constr_evars env sigma e in + let r = Simple_declare.declare_definition ~poly i sigma t in + let print r = strbrk "Defined " ++ Printer.pr_global r ++ strbrk "." in + Feedback.msg_notice (print r); + let env = Global.env () in + let sigma = Evd.from_env env in + let t = Simple_print.simple_body_access r in + let print t = strbrk "Found " ++ Printer.pr_econstr_env env sigma t in + Feedback.msg_notice (print t) + } END +(*** Checking terms ***) + +(* + * These are two commands for simple type-checking of terms. + * The bodies and explanations of the differences are in simple_check.ml. + *) + VERNAC COMMAND EXTEND Check1 CLASSIFIED AS QUERY -| [ "Cmd5" constr(e) ] -> - { let v = Constrintern.interp_constr (Global.env()) - (Evd.from_env (Global.env())) e in - let (_, ctx) = v in - let sigma = Evd.from_ctx ctx in - Feedback.msg_notice - (Printer.pr_econstr_env (Global.env()) sigma - (Simple_check.simple_check1 v)) } +| [ "Check1" constr(e) ] -> + { + let env = Global.env () in + let sigma = Evd.from_env env in + let (sigma, t) = Constrintern.interp_constr_evars env sigma e in + let (sigma, typ) = Simple_check.simple_check1 env sigma t in + Feedback.msg_notice (Printer.pr_econstr_env env sigma typ) + } END VERNAC COMMAND EXTEND Check2 CLASSIFIED AS QUERY -| [ "Cmd6" constr(e) ] -> - { let v = Constrintern.interp_constr (Global.env()) - (Evd.from_env (Global.env())) e in - let sigma, ty = Simple_check.simple_check2 v in - Feedback.msg_notice - (Printer.pr_econstr_env (Global.env()) sigma ty) } +| [ "Check2" constr(e) ] -> + { + let env = Global.env () in + let sigma = Evd.from_env env in + let (sigma, t) = Constrintern.interp_constr_evars env sigma e in + let typ = Simple_check.simple_check2 env sigma t in + Feedback.msg_notice (Printer.pr_econstr_env env sigma typ) + } END -VERNAC COMMAND EXTEND Check1 CLASSIFIED AS QUERY -| [ "Cmd7" constr(e) ] -> - { let v = Constrintern.interp_constr (Global.env()) - (Evd.from_env (Global.env())) e in - let (a, ctx) = v in - let sigma = Evd.from_ctx ctx in - Feedback.msg_notice - (Printer.pr_econstr_env (Global.env()) sigma - (Simple_check.simple_check3 v)) } -END +(*** Convertibility ***) -(* This command takes a name and return its value. It does less - than Print, because it fails on constructors, axioms, and inductive types. - This should be improved, because the error message is an anomaly. - Anomalies should never appear even when using a command outside of its - intended use. *) -VERNAC COMMAND EXTEND ExamplePrint CLASSIFIED AS QUERY -| [ "Cmd8" reference(r) ] -> - { let env = Global.env() in - let sigma = Evd.from_env env in - Feedback.msg_notice - (Printer.pr_econstr_env env sigma - (EConstr.of_constr - (Simple_print.simple_body_access (Nametab.global r)))) } +(* + * This command checks if there is a possible assignment of + * constraints in the state under which the two terms are + * convertible. + *) +VERNAC COMMAND EXTEND Convertible CLASSIFIED AS QUERY +| [ "Convertible" constr(e1) constr(e2) ] -> + { + let env = Global.env () in + let sigma = Evd.from_env env in + let (sigma, t1) = Constrintern.interp_constr_evars env sigma e1 in + let (sigma, t2) = Constrintern.interp_constr_evars env sigma e2 in + match Reductionops.infer_conv env sigma t1 t2 with + | Some _ -> + Feedback.msg_notice (strbrk "Yes :)") + | None -> + Feedback.msg_notice (strbrk "No :(") + } END +(*** Introducing terms ***) + +(* + * We can call the tactics defined in Tactics within our tactics. + * Here we call intros. + *) TACTIC EXTEND my_intro | [ "my_intro" ident(i) ] -> { Tactics.introduction i } END -(* if one write this: - VERNAC COMMAND EXTEND exploreproof CLASSIFIED AS QUERY - it gives an error message that is basically impossible to understand. *) +(*** Exploring proof state ***) +(* + * This command demonstrates exploring the proof state from within + * a command. + * + * Note that Pfedit.get_current_context gets us the environment + * and state within a proof, as opposed to the global environment + * and state. This is important within tactics. + *) VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY -| ![ proof_query ] [ "Cmd9" ] -> +| ![ proof_query ] [ "ExploreProof" ] -> { fun ~pstate -> let sigma, env = Pfedit.get_current_context pstate in - let pprf = Proof.partial_proof Proof_global.(give_me_the_proof pstate) in + let pprf = Proof.partial_proof (Proof_global.get_proof pstate) in Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) } diff --git a/doc/plugin_tutorial/tuto1/src/inspector.ml b/doc/plugin_tutorial/tuto1/src/inspector.ml new file mode 100644 index 0000000000..d37cbdb74c --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/inspector.ml @@ -0,0 +1,8 @@ +open Pp + +(* + * Inspect an input and print a feedback message explaining what it is + *) +let print_input (a : 'a) (printer : 'a -> Pp.t) (type_str : string) : unit = + let msg = printer a ++ strbrk (Printf.sprintf " is a %s." type_str) in + Feedback.msg_notice msg diff --git a/doc/plugin_tutorial/tuto1/src/inspector.mli b/doc/plugin_tutorial/tuto1/src/inspector.mli new file mode 100644 index 0000000000..52b970bbe0 --- /dev/null +++ b/doc/plugin_tutorial/tuto1/src/inspector.mli @@ -0,0 +1,4 @@ +(* + * Inspect an input and print a feedback message explaining what it is + *) +val print_input : 'a -> ('a -> Pp.t) -> string -> unit diff --git a/doc/plugin_tutorial/tuto1/src/simple_check.ml b/doc/plugin_tutorial/tuto1/src/simple_check.ml index c2f09c64e0..684864a056 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_check.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_check.ml @@ -1,32 +1,14 @@ -let simple_check1 value_with_constraints = - begin - let evalue, st = value_with_constraints in - let sigma = Evd.from_ctx st in -(* This is reverse engineered from vernacentries.ml *) -(* The point of renaming is to make sure the bound names printed by Check - can be re-used in `apply with` tactics that use bound names to - refer to arguments. *) - let j = Environ.on_judgment EConstr.of_constr - (Arguments_renaming.rename_typing (Global.env()) - (EConstr.to_constr sigma evalue)) in - let {Environ.uj_type=x}=j in x - end - -let simple_check2 value_with_constraints = - let evalue, st = value_with_constraints in - let sigma = Evd.from_ctx st in -(* This version should be preferred if bound variable names are not so - important, you want to really verify that the input is well-typed, +let simple_check1 env sigma evalue = +(* This version should be preferred if you want to really + verify that the input is well-typed, and if you want to obtain the type. *) (* Note that the output value is a pair containing a new evar_map: typing will fill out blanks in the term by add evar bindings. *) - Typing.type_of (Global.env()) sigma evalue + Typing.type_of env sigma evalue -let simple_check3 value_with_constraints = - let evalue, st = value_with_constraints in - let sigma = Evd.from_ctx st in -(* This version should be preferred if bound variable names are not so - important and you already expect the input to have been type-checked - before. Set ~lax to false if you want an anomaly to be raised in - case of a type error. Otherwise a ReTypeError exception is raised. *) - Retyping.get_type_of ~lax:true (Global.env()) sigma evalue +let simple_check2 env sigma evalue = +(* This version should be preferred if you already expect the input to + have been type-checked before. Set ~lax to false if you want an anomaly + to be raised in case of a type error. Otherwise a ReTypeError exception + is raised. *) + Retyping.get_type_of ~lax:true env sigma evalue diff --git a/doc/plugin_tutorial/tuto1/src/simple_check.mli b/doc/plugin_tutorial/tuto1/src/simple_check.mli index bcf1bf56cf..4b28ac74fe 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_check.mli +++ b/doc/plugin_tutorial/tuto1/src/simple_check.mli @@ -1,8 +1,5 @@ val simple_check1 : - EConstr.constr Evd.in_evar_universe_context -> EConstr.constr + Environ.env -> Evd.evar_map -> EConstr.constr -> Evd.evar_map * EConstr.constr val simple_check2 : - EConstr.constr Evd.in_evar_universe_context -> Evd.evar_map * EConstr.constr - -val simple_check3 : - EConstr.constr Evd.in_evar_universe_context -> EConstr.constr + Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index e9b91d5a7e..eb8161c2bb 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -6,11 +6,9 @@ let edeclare ?hook ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = let hook_data = Option.map (fun hook -> hook, uctx, []) hook in DeclareDef.declare_definition ident k ce ubinders imps ?hook_data -let packed_declare_definition ~poly ident value_with_constraints = - let body, ctx = value_with_constraints in - let sigma = Evd.from_ctx ctx in - let k = (Decl_kinds.Global, poly, Decl_kinds.Definition) in +let declare_definition ~poly ident sigma body = + let k = Decl_kinds.(Global ImportDefaultBehavior, poly, Definition) in let udecl = UState.default_univ_decl in - ignore (edeclare ident k ~opaque:false sigma udecl body None []) + edeclare ident k ~opaque:false sigma udecl body None [] (* But this definition cannot be undone by Reset ident *) diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.mli b/doc/plugin_tutorial/tuto1/src/simple_declare.mli index fd74e81526..c55b36742f 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.mli +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.mli @@ -1,5 +1,4 @@ open Names -open EConstr -val packed_declare_definition : - poly:bool -> Id.t -> constr Evd.in_evar_universe_context -> unit +val declare_definition : + poly:bool -> Id.t -> Evd.evar_map -> EConstr.t -> Names.GlobRef.t diff --git a/doc/plugin_tutorial/tuto1/src/simple_print.ml b/doc/plugin_tutorial/tuto1/src/simple_print.ml index 22a0163fbb..48b5f2214c 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_print.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_print.ml @@ -12,6 +12,6 @@ let simple_body_access gref = | Globnames.ConstRef cst -> let cb = Environ.lookup_constant cst (Global.env()) in match Global.body_of_constant_body Library.indirect_accessor cb with - | Some(e, _) -> e + | Some(e, _) -> EConstr.of_constr e | None -> failwith "This term has no value" diff --git a/doc/plugin_tutorial/tuto1/src/simple_print.mli b/doc/plugin_tutorial/tuto1/src/simple_print.mli index 254b56ff79..943e26acb6 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_print.mli +++ b/doc/plugin_tutorial/tuto1/src/simple_print.mli @@ -1 +1 @@ -val simple_body_access : Names.GlobRef.t -> Constr.constr +val simple_body_access : Names.GlobRef.t -> EConstr.constr diff --git a/doc/plugin_tutorial/tuto1/src/tuto1_plugin.mlpack b/doc/plugin_tutorial/tuto1/src/tuto1_plugin.mlpack index a797a509e0..9309f78cd0 100644 --- a/doc/plugin_tutorial/tuto1/src/tuto1_plugin.mlpack +++ b/doc/plugin_tutorial/tuto1/src/tuto1_plugin.mlpack @@ -1,3 +1,4 @@ +Inspector Simple_check Simple_declare Simple_print diff --git a/doc/plugin_tutorial/tuto1/theories/Demo.v b/doc/plugin_tutorial/tuto1/theories/Demo.v new file mode 100644 index 0000000000..5723e2f82e --- /dev/null +++ b/doc/plugin_tutorial/tuto1/theories/Demo.v @@ -0,0 +1,95 @@ +From Tuto1 Require Import Loader. + +(*** Printing user inputs ***) + +Definition definition := 5. +What's definition. +What kind of term is definition. +What kind of identifier is definition. + +What is 1 2 3 a list of. +What is a list of. (* no arguments = empty list *) + +Is 1 2 3 nonempty. +(* Is nonempty *) (* does not parse *) + +And is 1 provided. +And is provided. + +(*** Interning terms ***) + +Intern 3. +Intern definition. +Intern (fun (x : Prop) => x). +Intern (fun (x : Type) => x). +Intern (forall (T : Type), T). +Intern (fun (T : Type) (t : T) => t). +Intern _. +Intern (Type : Type). + +(*** Defining terms ***) + +MyDefine n := 1. +Print n. + +MyDefine f := (fun (x : Type) => x). +Print f. + +(*** Printing terms ***) + +MyPrint f. +MyPrint n. +Fail MyPrint nat. + +DefineLookup n' := 1. +DefineLookup f' := (fun (x : Type) => x). + +(*** Checking terms ***) + +Check1 3. +Check1 definition. +Check1 (fun (x : Prop) => x). +Check1 (fun (x : Type) => x). +Check1 (forall (T : Type), T). +Check1 (fun (T : Type) (t : T) => t). +Check1 _. +Check1 (Type : Type). + +Check2 3. +Check2 definition. +Check2 (fun (x : Prop) => x). +Check2 (fun (x : Type) => x). +Check2 (forall (T : Type), T). +Check2 (fun (T : Type) (t : T) => t). +Check2 _. +Check2 (Type : Type). + +(*** Convertibility ***) + +Convertible 1 1. +Convertible (fun (x : Type) => x) (fun (x : Type) => x). +Convertible Type Type. +Convertible 1 ((fun (x : nat) => x) 1). + +Convertible 1 2. +Convertible (fun (x : Type) => x) (fun (x : Prop) => x). +Convertible Type Prop. +Convertible 1 ((fun (x : nat) => x) 2). + +(*** Introducing variables ***) + +Theorem foo: + forall (T : Set) (t : T), T. +Proof. + my_intro T. my_intro t. apply t. +Qed. + +(*** Exploring proof state ***) + +Fail ExploreProof. (* not in a proof *) + +Theorem bar: + forall (T : Set) (t : T), T. +Proof. + ExploreProof. my_intro T. ExploreProof. my_intro t. ExploreProof. apply t. +Qed. diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index ebaa6fde66..38f6714f46 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -1508,7 +1508,10 @@ the following attributes names are recognized: Takes as value the optional attributes ``since`` and ``note``; both have a string value. - This attribute can trigger the following warnings: + This attribute is supported by the following commands: :cmd:`Ltac`, + :cmd:`Tactic Notation`, :cmd:`Notation`, :cmd:`Infix`. + + It can trigger the following warnings: .. warn:: Tactic @qualid is deprecated since @string. @string. :undocumented: @@ -1516,6 +1519,11 @@ the following attributes names are recognized: .. warn:: Tactic Notation @qualid is deprecated since @string. @string. :undocumented: + .. warn:: Notation @string__1 is deprecated since @string__2. @string__3. + + :n:`@string__1` is the actual notation, :n:`@string__2` is the version number, + :n:`@string__3` is the note. + .. example:: .. coqtop:: all reset warn diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index bdda35fcc0..48d5f4075e 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -124,11 +124,11 @@ and ``coqtop``, unless stated otherwise: :ref:`names-of-libraries` and the command Declare ML Module Section :ref:`compiled-files`. -:-Q *directory* dirpath: Add physical path *directory* to the list of +:-Q *directory* *dirpath*: Add physical path *directory* to the list of directories where |Coq| looks for a file and bind it to the logical directory *dirpath*. The subdirectory structure of *directory* is recursively available from |Coq| using absolute names (extending the - dirpath prefix) (see Section :ref:`qualified-names`).Note that only those + :n:`@dirpath` prefix) (see Section :ref:`qualified-names`). Note that only those subdirectories and files which obey the lexical conventions of what is an :n:`@ident` are taken into account. Conversely, the underlying file systems or operating systems may be more restrictive @@ -138,13 +138,13 @@ and ``coqtop``, unless stated otherwise: disallow two files differing only in the case in the same directory. .. seealso:: Section :ref:`names-of-libraries`. -:-R *directory* dirpath: Do as -Q *directory* dirpath but make the +:-R *directory* *dirpath*: Do as ``-Q`` *directory* *dirpath* but make the subdirectory structure of *directory* recursively visible so that the recursive contents of physical *directory* is available from |Coq| using short or partially qualified names. .. seealso:: Section :ref:`names-of-libraries`. -:-top dirpath: Set the toplevel module name to dirpath instead of Top. +:-top *dirpath*: Set the toplevel module name to :n:`@dirpath` instead of ``Top``. Not valid for `coqc` as the toplevel module name is inferred from the name of the output file. :-exclude-dir *directory*: Exclude any subdirectory named *directory* @@ -164,10 +164,17 @@ and ``coqtop``, unless stated otherwise: :-lv *file*, -load-vernac-source-verbose *file*: Load and execute the |Coq| script from *file.v*. Write its contents to the standard output as it is executed. -:-load-vernac-object dirpath: Load |Coq| compiled library dirpath. This - is equivalent to runningRequire dirpath. -:-require dirpath: Load |Coq| compiled library dirpath and import it. - This is equivalent to running Require Import dirpath. +:-load-vernac-object *qualid*: Load |Coq| compiled library :n:`@qualid`. This + is equivalent to running :cmd:`Require` :n:`qualid`. +:-ri *qualid*, -require-import *qualid*: Load |Coq| compiled library :n:`@qualid` and import it. + This is equivalent to running :cmd:`Require Import` :n:`@qualid`. +:-re *qualid*, -require-export *qualid*: Load |Coq| compiled library :n:`@qualid` and transitively import it. + This is equivalent to running :cmd:`Require Export` :n:`@qualid`. +:-rifrom *dirpath* *qualid*, -require-import-from *dirpath* *qualid*: Load |Coq| compiled library :n:`@qualid` and import it. + This is equivalent to running :n:`From` :n:`@dirpath` :cmd:`Require Import` :n:`@qualid`. +:-refrom *dirpath* *qualid*, -require-export-from *dirpath* *qualid*: Load |Coq| compiled library :n:`@qualid` and transitively import it. + This is equivalent to running :n:`From` :n:`@dirpath` :cmd:`Require Export` :n:`@qualid`. +:-require *qualid*: Deprecated; use ``-ri`` *qualid*. :-batch: Exit just after argument parsing. Available for ``coqtop`` only. :-compile *file.v*: Deprecated; use ``coqc`` instead. Compile file *file.v* into *file.vo*. This option implies -batch (exit just after argument parsing). It is available only @@ -193,7 +200,7 @@ and ``coqtop``, unless stated otherwise: :-emacs, -ide-slave: Start a special toplevel to communicate with a specific IDE. :-impredicative-set: Change the logical theory of |Coq| by declaring the - sort Set impredicative. + sort :g:`Set` impredicative. .. warning:: diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 5f2e911ff9..36eeff6192 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -655,6 +655,8 @@ this features has the same semantics as in Ltac1. In particular, a ``reverse`` flag can be specified to match hypotheses from the more recently introduced to the least recently introduced one. +.. _ltac2_notations: + Notations --------- @@ -679,6 +681,11 @@ The following scopes are built-in. + parses :n:`c = @term` and produces :n:`constr:(c)` + This scope can be parameterized by a list of delimiting keys of interpretation + scopes (as described in :ref:`LocalInterpretationRulesForNotations`), + describing how to interpret the parsed term. For instance, :n:`constr(A, B)` + parses :n:`c = @term` and produces :n:`constr:(c%A%B)`. + - :n:`ident`: + parses :n:`id = @ident` and produces :n:`ident:(id)` diff --git a/engine/evd.ml b/engine/evd.ml index 15b4c31851..34de2f41bb 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -430,6 +430,14 @@ type evar_flags = restricted_evars : Evar.t Evar.Map.t; typeclass_evars : Evar.Set.t } +type side_effect_role = +| Schema of inductive * string + +type side_effects = { + seff_private : Safe_typing.private_constants; + seff_roles : side_effect_role Cmap.t; +} + type evar_map = { (* Existential variables *) defn_evars : evar_info EvMap.t; @@ -444,7 +452,7 @@ type evar_map = { metas : clbinding Metamap.t; evar_flags : evar_flags; (** Interactive proofs *) - effects : Safe_typing.private_constants; + effects : side_effects; future_goals : Evar.t list; (** list of newly created evars, to be eventually turned into goals if not solved.*) principal_future_goal : Evar.t option; (** if [Some e], [e] must be @@ -672,6 +680,11 @@ let empty_evar_flags = restricted_evars = Evar.Map.empty; typeclass_evars = Evar.Set.empty } +let empty_side_effects = { + seff_private = Safe_typing.empty_private_constants; + seff_roles = Cmap.empty; +} + let empty = { defn_evars = EvMap.empty; undf_evars = EvMap.empty; @@ -680,7 +693,7 @@ let empty = { last_mods = Evar.Set.empty; evar_flags = empty_evar_flags; metas = Metamap.empty; - effects = Safe_typing.empty_private_constants; + effects = empty_side_effects; evar_names = EvNames.empty; (* id<->key for undefined evars *) future_goals = []; principal_future_goal = None; @@ -1011,12 +1024,17 @@ exception UniversesDiffer = UState.UniversesDiffer (**********************************************************) (* Side effects *) +let concat_side_effects eff eff' = { + seff_private = Safe_typing.concat_private eff.seff_private eff'.seff_private; + seff_roles = Cmap.fold Cmap.add eff.seff_roles eff'.seff_roles; +} + let emit_side_effects eff evd = - { evd with effects = Safe_typing.concat_private eff evd.effects; - universes = UState.emit_side_effects eff evd.universes } + let effects = concat_side_effects eff evd.effects in + { evd with effects; universes = UState.emit_side_effects eff.seff_private evd.universes } let drop_side_effects evd = - { evd with effects = Safe_typing.empty_private_constants; } + { evd with effects = empty_side_effects; } let eval_side_effects evd = evd.effects diff --git a/engine/evd.mli b/engine/evd.mli index 587a1de044..5478431e14 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -307,10 +307,22 @@ val dependent_evar_ident : Evar.t -> evar_map -> Id.t (** {5 Side-effects} *) -val emit_side_effects : Safe_typing.private_constants -> evar_map -> evar_map +type side_effect_role = +| Schema of inductive * string + +type side_effects = { + seff_private : Safe_typing.private_constants; + seff_roles : side_effect_role Cmap.t; +} + +val empty_side_effects : side_effects + +val concat_side_effects : side_effects -> side_effects -> side_effects + +val emit_side_effects : side_effects -> evar_map -> evar_map (** Push a side-effect into the evar map. *) -val eval_side_effects : evar_map -> Safe_typing.private_constants +val eval_side_effects : evar_map -> side_effects (** Return the effects contained in the evar map. *) val drop_side_effects : evar_map -> evar_map diff --git a/engine/proofview.ml b/engine/proofview.ml index c00c90e5e9..d4f6fe3aef 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -373,32 +373,24 @@ let tclTRYFOCUS i j t = tclFOCUS ~nosuchgoal:(tclUNIT ()) i j t let tclFOCUSLIST ?(nosuchgoal=tclZERO (NoSuchGoals 0)) l t = let open Proof in Comb.get >>= fun comb -> - let n = CList.length comb in - (* First, remove empty intervals, and bound the intervals to the number - of goals. *) - let sanitize (i, j) = - if i > j then None - else if i > n then None - else if j < 1 then None - else Some ((max i 1), (min j n)) - in - let l = CList.map_filter sanitize l in + let n = CList.length comb in + let ok (i, j) = 1 <= i && i <= j && j <= n in + if not (CList.for_all ok l) then nosuchgoal + else match l with - | [] -> nosuchgoal - | (mi, _) :: _ -> - (* Get the left-most goal to focus. This goal won't move, and we - will then place all the other goals to focus to the right. *) - let mi = CList.fold_left (fun m (i, _) -> min m i) mi l in - (* [CList.goto] returns a zipper, so that - [(rev left) @ sub_right = comb]. *) - let left, sub_right = CList.goto (mi-1) comb in - let p x _ = CList.exists (fun (i, j) -> i <= x + mi && x + mi <= j) l in - let sub, right = CList.partitioni p sub_right in - let mj = mi - 1 + CList.length sub in - Comb.set (CList.rev_append left (sub @ right)) >> - tclFOCUS mi mj t - - + | [] -> nosuchgoal + | (mi, _) :: _ -> + (* Get the left-most goal to focus. This goal won't move, and we + will then place all the other goals to focus to the right. *) + let mi = CList.fold_left (fun m (i, _) -> min m i) mi l in + (* [CList.goto] returns a zipper, so that + [(rev left) @ sub_right = comb]. *) + let left, sub_right = CList.goto (mi-1) comb in + let p x _ = CList.exists (fun (i, j) -> i <= x + mi && x + mi <= j) l in + let sub, right = CList.partitioni p sub_right in + let mj = mi - 1 + CList.length sub in + Comb.set (CList.rev_append left (sub @ right)) >> + tclFOCUS mi mj t (** Like {!tclFOCUS} but selects a single goal by name. *) let tclFOCUSID ?(nosuchgoal=tclZERO (NoSuchGoals 1)) id t = diff --git a/engine/proofview.mli b/engine/proofview.mli index 60697c1611..22e67357cd 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -381,7 +381,7 @@ val tclENV : Environ.env tactic (** {7 Put-like primitives} *) (** [tclEFFECTS eff] add the effects [eff] to the current state. *) -val tclEFFECTS : Safe_typing.private_constants -> unit tactic +val tclEFFECTS : Evd.side_effects -> unit tactic (** [mark_as_unsafe] declares the current tactic is unsafe. *) val mark_as_unsafe : unit tactic diff --git a/engine/uState.mli b/engine/uState.mli index 3df7f9e8e9..a34d4db8a6 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -100,7 +100,7 @@ val restrict_universe_context : ContextSet.t -> LSet.t -> ContextSet.t universes are preserved. *) val restrict : t -> Univ.LSet.t -> t -val demote_seff_univs : Safe_typing.private_constants Entries.definition_entry -> t -> t +val demote_seff_univs : 'a Entries.definition_entry -> t -> t type rigid = | UnivRigid diff --git a/ide/idetop.ml b/ide/idetop.ml index 90bd2f314d..a3b8854e8f 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -339,8 +339,7 @@ let import_search_constraint = function | Interface.Include_Blacklist -> Search.Include_Blacklist let search flags = - let pstate = Vernacstate.Proof_global.get () in - let pstate = Option.map Proof_global.get_current_pstate pstate in + let pstate = Vernacstate.Proof_global.get_pstate () in List.map export_coq_object (Search.interface_search ?pstate ( List.map (fun (c, b) -> (import_search_constraint c, b)) flags) ) diff --git a/ide/session.ml b/ide/session.ml index 90412f53f0..d0c3969ab2 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -447,7 +447,7 @@ let build_layout (sn:session) = let script_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:script_frame#add () in let state_paned = GPack.paned `VERTICAL - ~packing:(eval_paned#pack2 ~shrink:false) () in + ~packing:(eval_paned#pack2 ~shrink:true) () in (* Proof buffer. *) @@ -455,19 +455,21 @@ let build_layout (sn:session) = let proof_detachable = Wg_Detachable.detachable ~title () in let () = proof_detachable#button#misc#hide () in let () = proof_detachable#frame#set_shadow_type `IN in - let () = state_paned#add1 proof_detachable#coerce in - let callback _ = proof_detachable#show in + let () = state_paned#pack1 ~shrink:true proof_detachable#coerce in + let proof_scroll = GBin.scrolled_window + ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:proof_detachable#pack () in + let callback _ = proof_detachable#show; + proof_scroll#coerce#misc#set_size_request ~width:0 ~height:0 () + in let () = proof_detachable#connect#attached ~callback in let callback _ = - sn.proof#coerce#misc#set_size_request ~width:500 ~height:400 () + proof_scroll#coerce#misc#set_size_request ~width:500 ~height:400 () in let () = proof_detachable#connect#detached ~callback in - let proof_scroll = GBin.scrolled_window - ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:proof_detachable#pack () in (* Message buffer. *) - let message_frame = GPack.notebook ~packing:state_paned#add () in + let message_frame = GPack.notebook ~packing:(state_paned#pack2 ~shrink:true) () in let add_msg_page pos name text (w : GObj.widget) = let detachable = Wg_Detachable.detachable ~title:(text^" ("^name^")") () in @@ -503,18 +505,14 @@ let build_layout (sn:session) = let _ = eval_paned#misc#connect#size_allocate ~callback: - (let old_paned_width = ref 2 in - let old_paned_height = ref 2 in + (let b = ref true in fun {Gtk.width=paned_width;Gtk.height=paned_height} -> - if !old_paned_width <> paned_width || - !old_paned_height <> paned_height - then begin + if !b then begin eval_paned#set_position - (eval_paned#position * paned_width / !old_paned_width); + (paned_width / 2); state_paned#set_position - (state_paned#position * paned_height / !old_paned_height); - old_paned_width := paned_width; - old_paned_height := paned_height; + (paned_height / 2); + b := false end) in session_box#pack sn.finder#coerce; diff --git a/interp/constrextern.ml b/interp/constrextern.ml index fe50bd4b08..701c07dc8d 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -757,11 +757,10 @@ let extended_glob_local_binder_of_decl ?loc u = DAst.make ?loc (extended_glob_lo (* mapping glob_constr to constr_expr *) let extern_glob_sort = function - | GSProp -> GSProp - | GProp -> GProp - | GSet -> GSet - | GType _ as s when !print_universes -> s - | GType _ -> GType [] + (* In case we print a glob_constr w/o having passed through detyping *) + | UNamed [(GSProp,0) | (GProp,0) | (GSet,0)] as u -> u + | UNamed _ when not !print_universes -> UAnonymous {rigid=true} + | UNamed _ | UAnonymous _ as u -> u let extern_universes = function | Some _ as l when !print_universes -> l @@ -1312,10 +1311,10 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) - | PSort Sorts.InSProp -> GSort GSProp - | PSort Sorts.InProp -> GSort GProp - | PSort Sorts.InSet -> GSort GSet - | PSort Sorts.InType -> GSort (GType []) + | PSort Sorts.InSProp -> GSort (UNamed [GSProp,0]) + | PSort Sorts.InProp -> GSort (UNamed [GProp,0]) + | PSort Sorts.InSet -> GSort (UNamed [GSet,0]) + | PSort Sorts.InType -> GSort (UAnonymous {rigid=true}) | PInt i -> GInt i let extern_constr_pattern env sigma pat = diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 1dd68f2abf..1a81dc41a1 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -998,18 +998,10 @@ let intern_reference qid = in Smartlocate.global_of_extended_global r -let sort_info_of_level_info (info: level_info) : (Libnames.qualid * int) option = - match info with - | UAnonymous -> None - | UUnknown -> None - | UNamed id -> Some (id, 0) - let glob_sort_of_level (level: glob_level) : glob_sort = match level with - | GSProp -> GSProp - | GProp -> GProp - | GSet -> GSet - | GType info -> GType [sort_info_of_level_info info] + | UAnonymous {rigid} -> UAnonymous {rigid} + | UNamed id -> UNamed [id,0] (* Is it a global reference or a syntactic definition? *) let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = @@ -1045,7 +1037,7 @@ let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = DAst.make ?loc @@ GApp (DAst.make ?loc:loc' @@ GRef (ref, us), arg) | _ -> err () end - | Some [s], GSort (GType []) -> DAst.make ?loc @@ GSort (glob_sort_of_level s) + | Some [s], GSort (UAnonymous {rigid=true}) -> DAst.make ?loc @@ GSort (glob_sort_of_level s) | Some [_old_level], GSort _new_sort -> (* TODO: add old_level and new_sort to the error message *) user_err ?loc (str "Cannot change universe level of notation " ++ pr_qualid qid) diff --git a/interp/declare.ml b/interp/declare.ml index cc6f29f756..17de06ed57 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -39,10 +39,10 @@ type constant_obj = { cst_decl : Cooking.recipe option; (** Non-empty only when rebuilding a constant after a section *) cst_kind : logical_kind; - cst_locl : bool; + cst_locl : import_status; } -type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind +type constant_declaration = Evd.side_effects constant_entry * logical_kind (* At load-time, the segment starting from the module name to the discharge *) (* section (if Remark or Fact) is needed to access a construction *) @@ -63,8 +63,9 @@ let cooking_info segment = (* Opening means making the name without its module qualification available *) let open_constant i ((sp,kn), obj) = (* Never open a local definition *) - if obj.cst_locl then () - else + match obj.cst_locl with + | ImportNeedQualified -> () + | ImportDefaultBehavior -> let con = Global.constant_of_delta_kn kn in Nametab.push (Nametab.Exactly i) sp (ConstRef con) @@ -137,14 +138,14 @@ let register_constant kn kind local = update_tables kn let register_side_effect (c, role) = - let () = register_constant c (IsProof Theorem) false in + let () = register_constant c (IsProof Theorem) ImportDefaultBehavior in match role with - | Subproof -> () - | Schema (ind, kind) -> !declare_scheme kind [|ind,c|] + | None -> () + | Some (Evd.Schema (ind, kind)) -> !declare_scheme kind [|ind,c|] let default_univ_entry = Monomorphic_entry Univ.ContextSet.empty let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types - ?(univs=default_univ_entry) ?(eff=Safe_typing.empty_private_constants) body = + ?(univs=default_univ_entry) ?(eff=Evd.empty_side_effects) body = { const_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), eff); const_entry_secctx = None; const_entry_type = types; @@ -153,7 +154,14 @@ let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types const_entry_feedback = None; const_entry_inline_code = inline} -let define_constant ?role ?(export_seff=false) id cd = +let get_roles export eff = + let map c = + let role = try Some (Cmap.find c eff.Evd.seff_roles) with Not_found -> None in + (c, role) + in + List.map map export + +let define_constant ~side_effect ?(export_seff=false) id cd = (* Logically define the constant and its subproofs, no libobject tampering *) let is_poly de = match de.const_entry_universes with | Monomorphic_entry _ -> false @@ -167,30 +175,43 @@ let define_constant ?role ?(export_seff=false) id cd = not de.const_entry_opaque || is_poly de -> (* This globally defines the side-effects in the environment. *) - let body, export = Global.export_private_constants ~in_section (Future.force de.const_entry_body) in + let body, eff = Future.force de.const_entry_body in + let body, export = Global.export_private_constants ~in_section (body, eff.Evd.seff_private) in + let export = get_roles export eff in let de = { de with const_entry_body = Future.from_val (body, ()) } in export, ConstantEntry (PureEntry, DefinitionEntry de) - | _ -> [], ConstantEntry (EffectEntry, cd) + | DefinitionEntry de -> + let map (body, eff) = body, eff.Evd.seff_private in + let body = Future.chain de.const_entry_body map in + let de = { de with const_entry_body = body } in + [], ConstantEntry (EffectEntry, DefinitionEntry de) + | ParameterEntry _ | PrimitiveEntry _ as cd -> + [], ConstantEntry (PureEntry, cd) in - let kn, eff = Global.add_constant ?role ~in_section id decl in + let kn, eff = Global.add_constant ~side_effect ~in_section id decl in kn, eff, export -let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = +let declare_constant ?(internal = UserIndividualRequest) ?(local = ImportDefaultBehavior) id ?(export_seff=false) (cd, kind) = let () = check_exists id in - let kn, _eff, export = define_constant ~export_seff id cd in + let kn, (), export = define_constant ~side_effect:PureEntry ~export_seff id cd in (* Register the libobjects attached to the constants and its subproofs *) let () = List.iter register_side_effect export in let () = register_constant kn kind local in kn -let declare_private_constant ~role ?(internal=UserIndividualRequest) ?(local = false) id (cd, kind) = - let kn, eff, export = define_constant ~role id cd in +let declare_private_constant ?role ?(internal=UserIndividualRequest) ?(local = ImportDefaultBehavior) id (cd, kind) = + let kn, eff, export = define_constant ~side_effect:EffectEntry id cd in let () = assert (List.is_empty export) in let () = register_constant kn kind local in + let seff_roles = match role with + | None -> Cmap.empty + | Some r -> Cmap.singleton kn r + in + let eff = { Evd.seff_private = eff; Evd.seff_roles; } in kn, eff let declare_definition ?(internal=UserIndividualRequest) - ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) + ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = ImportDefaultBehavior) id ?types (body,univs) = let cb = definition_entry ?types ~univs ~opaque body @@ -200,7 +221,7 @@ let declare_definition ?(internal=UserIndividualRequest) (** Declaration of section variables and local definitions *) type section_variable_entry = - | SectionLocalDef of Safe_typing.private_constants definition_entry + | SectionLocalDef of Evd.side_effects definition_entry | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) type variable_declaration = DirPath.t * section_variable_entry * logical_kind @@ -221,7 +242,9 @@ let cache_variable ((sp,_),o) = | SectionLocalDef (de) -> (* The body should already have been forced upstream because it is a section-local definition, but it's not enforced by typing *) - let ((body, uctx), eff) = Global.export_private_constants ~in_section:true (Future.force de.const_entry_body) in + let (body, eff) = Future.force de.const_entry_body in + let ((body, uctx), export) = Global.export_private_constants ~in_section:true (body, eff.Evd.seff_private) in + let eff = get_roles export eff in let () = List.iter register_side_effect eff in let poly, univs = match de.const_entry_universes with | Monomorphic_entry uctx -> false, uctx diff --git a/interp/declare.mli b/interp/declare.mli index 795d9a767d..e2485d7cf0 100644 --- a/interp/declare.mli +++ b/interp/declare.mli @@ -23,7 +23,7 @@ open Decl_kinds (** Declaration of local constructions (Variable/Hypothesis/Local) *) type section_variable_entry = - | SectionLocalDef of Safe_typing.private_constants definition_entry + | SectionLocalDef of Evd.side_effects definition_entry | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) type variable_declaration = DirPath.t * section_variable_entry * logical_kind @@ -33,7 +33,7 @@ val declare_variable : variable -> variable_declaration -> Libobject.object_name (** Declaration of global constructions i.e. Definition/Theorem/Axiom/Parameter/... *) -type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind +type constant_declaration = Evd.side_effects constant_entry * logical_kind type internal_flag = | UserAutomaticRequest @@ -44,7 +44,7 @@ type internal_flag = val definition_entry : ?fix_exn:Future.fix_exn -> ?opaque:bool -> ?inline:bool -> ?types:types -> ?univs:Entries.universes_entry -> - ?eff:Safe_typing.private_constants -> constr -> Safe_typing.private_constants definition_entry + ?eff:Evd.side_effects -> constr -> Evd.side_effects definition_entry (** [declare_constant id cd] declares a global declaration (constant/parameter) with name [id] in the current section; it returns @@ -53,14 +53,14 @@ val definition_entry : ?fix_exn:Future.fix_exn -> internal specify if the constant has been created by the kernel or by the user, and in the former case, if its errors should be silent *) val declare_constant : - ?internal:internal_flag -> ?local:bool -> Id.t -> ?export_seff:bool -> constant_declaration -> Constant.t + ?internal:internal_flag -> ?local:import_status -> Id.t -> ?export_seff:bool -> constant_declaration -> Constant.t val declare_private_constant : - role:side_effect_role -> ?internal:internal_flag -> ?local:bool -> Id.t -> constant_declaration -> Constant.t * Safe_typing.private_constants + ?role:Evd.side_effect_role -> ?internal:internal_flag -> ?local:import_status -> Id.t -> constant_declaration -> Constant.t * Evd.side_effects val declare_definition : ?internal:internal_flag -> ?opaque:bool -> ?kind:definition_object_kind -> - ?local:bool -> Id.t -> ?types:constr -> + ?local:import_status -> Id.t -> ?types:constr -> constr Entries.in_universes_entry -> Constant.t (** Since transparent constants' side effects are globally declared, we @@ -90,5 +90,4 @@ val declare_univ_binders : GlobRef.t -> UnivNames.universe_binders -> unit val declare_universe_context : polymorphic -> Univ.ContextSet.t -> unit val do_universe : polymorphic -> lident list -> unit -val do_constraint : polymorphic -> (Glob_term.glob_level * Univ.constraint_type * Glob_term.glob_level) list -> - unit +val do_constraint : polymorphic -> Glob_term.glob_constraint list -> unit diff --git a/interp/deprecation.ml b/interp/deprecation.ml new file mode 100644 index 0000000000..b6f0dceb89 --- /dev/null +++ b/interp/deprecation.ml @@ -0,0 +1,21 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type t = { since : string option ; note : string option } + +let make ?since ?note () = { since ; note } + +let create_warning ~object_name ~warning_name name_printer = + let open Pp in + CWarnings.create ~name:warning_name ~category:"deprecated" + (fun (qid,depr) -> str object_name ++ spc () ++ name_printer qid ++ + strbrk " is deprecated" ++ + pr_opt (fun since -> str "since " ++ str since) depr.since ++ + str "." ++ pr_opt (fun note -> str note) depr.note) diff --git a/interp/deprecation.mli b/interp/deprecation.mli new file mode 100644 index 0000000000..aab87c11a2 --- /dev/null +++ b/interp/deprecation.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +type t = { since : string option ; note : string option } + +val make : ?since:string -> ?note:string -> unit -> t + +val create_warning : object_name:string -> warning_name:string -> + ('b -> Pp.t) -> ?loc:Loc.t -> 'b * t -> unit diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index a537b4848c..274f9b851a 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -91,7 +91,8 @@ let type_of_logical_kind = function (match a with | Definitional -> "defax" | Logical -> "prfax" - | Conjectural -> "prfax") + | Conjectural -> "prfax" + | Context -> "prfax") | IsProof th -> (match th with | Theorem diff --git a/interp/interp.mllib b/interp/interp.mllib index b65a171ef9..52978a2ab6 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -1,3 +1,4 @@ +Deprecation NumTok Constrexpr Tactypes diff --git a/interp/notation.ml b/interp/notation.ml index a7bac96d31..cc06d5abfc 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -72,6 +72,7 @@ type notation_location = (DirPath.t * DirPath.t) * string type notation_data = { not_interp : interpretation; not_location : notation_location; + not_deprecation : Deprecation.t option; } type scope = { @@ -1095,7 +1096,7 @@ let warn_notation_overridden = str "Notation" ++ spc () ++ pr_notation ntn ++ spc () ++ strbrk "was already used" ++ which_scope ++ str ".") -let declare_notation_interpretation ntn scopt pat df ~onlyprint = +let declare_notation_interpretation ntn scopt pat df ~onlyprint deprecation = let scope = match scopt with Some s -> s | None -> default_scope in let sc = find_scope scope in if not onlyprint then begin @@ -1109,6 +1110,7 @@ let declare_notation_interpretation ntn scopt pat df ~onlyprint = let notdata = { not_interp = pat; not_location = df; + not_deprecation = deprecation; } in let sc = { sc with notations = NotationMap.add ntn notdata sc.notations } in scope_map := String.Map.add scope sc !scope_map @@ -1125,10 +1127,10 @@ let declare_uninterpretation rule (metas,c as pat) = let rec find_interpretation ntn find = function | [] -> raise Not_found | Scope scope :: scopes -> - (try let (pat,df) = find scope in pat,(df,Some scope) + (try let n = find scope in (n,Some scope) with Not_found -> find_interpretation ntn find scopes) | SingleNotation ntn'::scopes when notation_eq ntn' ntn -> - (try let (pat,df) = find default_scope in pat,(df,None) + (try let n = find default_scope in (n,None) with Not_found -> (* e.g. because single notation only for constr, not cases_pattern *) find_interpretation ntn find scopes) @@ -1136,8 +1138,7 @@ let rec find_interpretation ntn find = function find_interpretation ntn find scopes let find_notation ntn sc = - let n = NotationMap.find ntn (find_scope sc).notations in - (n.not_interp, n.not_location) + NotationMap.find ntn (find_scope sc).notations let notation_of_prim_token = function | Numeral (SPlus,n) -> InConstrEntrySomeLevel, NumTok.to_string n @@ -1147,7 +1148,9 @@ let notation_of_prim_token = function let find_prim_token check_allowed ?loc p sc = (* Try for a user-defined numerical notation *) try - let (_,c),df = find_notation (notation_of_prim_token p) sc in + let n = find_notation (notation_of_prim_token p) sc in + let (_,c) = n.not_interp in + let df = n.not_location in let pat = Notation_ops.glob_constr_of_notation_constr ?loc c in check_allowed pat; pat, df @@ -1167,7 +1170,9 @@ let find_prim_token check_allowed ?loc p sc = let interp_prim_token_gen ?loc g p local_scopes = let scopes = make_current_scopes local_scopes in let p_as_ntn = try notation_of_prim_token p with Not_found -> InConstrEntrySomeLevel,"" in - try find_interpretation p_as_ntn (find_prim_token ?loc g p) scopes + try + let (pat,loc), sc = find_interpretation p_as_ntn (find_prim_token ?loc g p) scopes in + pat, (loc,sc) with Not_found -> user_err ?loc ~hdr:"interp_prim_token" ((match p with @@ -1192,11 +1197,18 @@ let rec check_allowed_ref_in_pat looked_for = DAst.(with_val (function let interp_prim_token_cases_pattern_expr ?loc looked_for p = interp_prim_token_gen ?loc (check_allowed_ref_in_pat looked_for) p +let warn_deprecated_notation = + Deprecation.create_warning ~object_name:"Notation" ~warning_name:"deprecated-notation" + pr_notation + let interp_notation ?loc ntn local_scopes = let scopes = make_current_scopes local_scopes in - try find_interpretation ntn (find_notation ntn) scopes + try + let (n,sc) = find_interpretation ntn (find_notation ntn) scopes in + Option.iter (fun d -> warn_deprecated_notation (ntn,d)) n.not_deprecation; + n.not_interp, (n.not_location, sc) with Not_found -> - user_err ?loc + user_err ?loc (str "Unknown interpretation for notation " ++ pr_notation ntn ++ str ".") let uninterp_notations c = diff --git a/interp/notation.mli b/interp/notation.mli index a67948a778..b32561d908 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -217,7 +217,8 @@ type interp_rule = | SynDefRule of KerName.t val declare_notation_interpretation : notation -> scope_name option -> - interpretation -> notation_location -> onlyprint:bool -> unit + interpretation -> notation_location -> onlyprint:bool -> + Deprecation.t option -> unit val declare_uninterpretation : interp_rule -> interpretation -> unit diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 7f084fffdd..08619d912e 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -1190,7 +1190,11 @@ let rec match_ inner u alp metas sigma a1 a2 = Array.fold_left2 (match_in u alp metas) sigma bl1 bl2 | GCast(t1, c1), NCast(t2, c2) -> match_cast (match_in u alp metas) (match_in u alp metas sigma t1 t2) c1 c2 - | GSort (GType _), NSort (GType _) when not u -> sigma + + (* Next pair of lines useful only if not coming from detyping *) + | GSort (UNamed [(GProp|GSet),0]), NSort (UAnonymous _) -> raise No_match + | GSort _, NSort (UAnonymous _) when not u -> sigma + | GSort s1, NSort s2 when glob_sort_eq s1 s2 -> sigma | GInt i1, NInt i2 when Uint63.equal i1 i2 -> sigma | GPatVar _, NHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index a7e1de736c..8df04187f1 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -19,20 +19,24 @@ open Notation_term (* Syntactic definitions. *) -type version = Flags.compat_version option +type syndef = + { syndef_pattern : interpretation; + syndef_onlyparsing : bool; + syndef_deprecation : Deprecation.t option; + } let syntax_table = - Summary.ref (KNmap.empty : (interpretation*version) KNmap.t) - ~name:"SYNTAXCONSTANT" + Summary.ref (KNmap.empty : syndef KNmap.t) + ~name:"SYNDEFS" -let add_syntax_constant kn c onlyparse = - syntax_table := KNmap.add kn (c,onlyparse) !syntax_table +let add_syntax_constant kn syndef = + syntax_table := KNmap.add kn syndef !syntax_table -let load_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = +let load_syntax_constant i ((sp,kn),(_local,syndef)) = if Nametab.exists_cci sp then user_err ~hdr:"cache_syntax_constant" (Id.print (basename sp) ++ str " already exists"); - add_syntax_constant kn pat onlyparse; + add_syntax_constant kn syndef; Nametab.push_syndef (Nametab.Until i) sp kn let is_alias_of_already_visible_name sp = function @@ -42,30 +46,29 @@ let is_alias_of_already_visible_name sp = function | _ -> false -let open_syntax_constant i ((sp,kn),(_,pat,onlyparse)) = +let open_syntax_constant i ((sp,kn),(_local,syndef)) = + let pat = syndef.syndef_pattern in if not (Int.equal i 1 && is_alias_of_already_visible_name sp pat) then begin Nametab.push_syndef (Nametab.Exactly i) sp kn; - match onlyparse with - | None -> + if not syndef.syndef_onlyparsing then (* Redeclare it to be used as (short) name in case an other (distfix) notation was declared in between *) Notation.declare_uninterpretation (Notation.SynDefRule kn) pat - | _ -> () end let cache_syntax_constant d = load_syntax_constant 1 d; open_syntax_constant 1 d -let subst_syntax_constant (subst,(local,pat,onlyparse)) = - (local,Notation_ops.subst_interpretation subst pat,onlyparse) +let subst_syntax_constant (subst,(local,syndef)) = + let syndef_pattern = Notation_ops.subst_interpretation subst syndef.syndef_pattern in + (local, { syndef with syndef_pattern }) -let classify_syntax_constant (local,_,_ as o) = +let classify_syntax_constant (local,_ as o) = if local then Dispose else Substitute o -let in_syntax_constant - : bool * interpretation * Flags.compat_version option -> obj = - declare_object {(default_object "SYNTAXCONSTANT") with +let in_syntax_constant : (bool * syndef) -> obj = + declare_object {(default_object "SYNDEF") with cache_function = cache_syntax_constant; load_function = load_syntax_constant; open_function = open_syntax_constant; @@ -79,36 +82,31 @@ type syndef_interpretation = (Id.t * subscopes) list * notation_constr let in_pat (ids,ac) = (List.map (fun (id,sc) -> (id,((Constrexpr.InConstrEntrySomeLevel,sc),NtnTypeConstr))) ids,ac) let out_pat (ids,ac) = (List.map (fun (id,((_,sc),typ)) -> (id,sc)) ids,ac) -let declare_syntactic_definition local id onlyparse pat = - let _ = add_leaf id (in_syntax_constant (local,in_pat pat,onlyparse)) in () - -let pr_syndef kn = pr_qualid (Nametab.shortest_qualid_of_syndef Id.Set.empty kn) - -let pr_compat_warning (kn, def, v) = - let pp_def = match def with - | [], NRef r -> spc () ++ str "is" ++ spc () ++ Nametab.pr_global_env Id.Set.empty r - | _ -> strbrk " is a compatibility notation" +let declare_syntactic_definition ~local deprecation id ~onlyparsing pat = + let syndef = + { syndef_pattern = in_pat pat; + syndef_onlyparsing = onlyparsing; + syndef_deprecation = deprecation; + } in - pr_syndef kn ++ pp_def + let _ = add_leaf id (in_syntax_constant (local,syndef)) in () -let warn_compatibility_notation = - CWarnings.(create ~name:"compatibility-notation" - ~category:"deprecated" ~default:Enabled pr_compat_warning) +let pr_syndef kn = pr_qualid (Nametab.shortest_qualid_of_syndef Id.Set.empty kn) -let verbose_compat ?loc kn def = function - | Some v when Flags.version_strictly_greater v -> - warn_compatibility_notation ?loc (kn, def, v) - | _ -> () +let warn_deprecated_syntactic_definition = + Deprecation.create_warning ~object_name:"Notation" ~warning_name:"deprecated-syntactic-definition" + pr_syndef let search_syntactic_definition ?loc kn = - let pat,v = KNmap.find kn !syntax_table in - let def = out_pat pat in - verbose_compat ?loc kn def v; + let syndef = KNmap.find kn !syntax_table in + let def = out_pat syndef.syndef_pattern in + Option.iter (fun d -> warn_deprecated_syntactic_definition (kn,d)) syndef.syndef_deprecation; def let search_filtered_syntactic_definition ?loc filter kn = - let pat,v = KNmap.find kn !syntax_table in - let def = out_pat pat in + let syndef = KNmap.find kn !syntax_table in + let def = out_pat syndef.syndef_pattern in let res = filter def in - (match res with Some _ -> verbose_compat ?loc kn def v | None -> ()); + if Option.has_some res then + Option.iter (fun d -> warn_deprecated_syntactic_definition (kn,d)) syndef.syndef_deprecation; res diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index 77873f8f67..e6e3b9cffa 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -15,8 +15,8 @@ open Notation_term type syndef_interpretation = (Id.t * subscopes) list * notation_constr -val declare_syntactic_definition : bool -> Id.t -> - Flags.compat_version option -> syndef_interpretation -> unit +val declare_syntactic_definition : local:bool -> Deprecation.t option -> Id.t -> + onlyparsing:bool -> syndef_interpretation -> unit val search_syntactic_definition : ?loc:Loc.t -> KerName.t -> syndef_interpretation diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 620efbafd6..1336e3e8bf 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -202,17 +202,21 @@ let lift_univs cb subst auctx0 = let subst, auctx = discharge_abstract_universe_context subst auctx0 auctx in subst, (Polymorphic auctx) -let cook_constr { Opaqueproof.modlist ; abstract } c = +let cook_constr { Opaqueproof.modlist ; abstract } (univs, c) = let cache = RefTable.create 13 in let abstract, usubst, abs_ctx = abstract in - (* For now the STM only handles deferred computation of monomorphic - constants. The API will need to be adapted when it's not the case - anymore. *) - let () = assert (AUContext.is_empty abs_ctx) in + let ainst = Instance.of_array (Array.init univs Level.var) in + let usubst = Instance.append usubst ainst in let expmod = expmod_constr_subst cache modlist usubst in let hyps = Context.Named.map expmod abstract in let hyps = abstract_context hyps in - abstract_constant_body (expmod c) hyps + let c = abstract_constant_body (expmod c) hyps in + univs + AUContext.size abs_ctx, c + +let cook_constr infos univs c = + let fold info (univs, c) = cook_constr info (univs, c) in + let (_, c) = List.fold_right fold infos (univs, c) in + c let cook_constant { from = cb; info } = let { Opaqueproof.modlist; abstract } = info in @@ -227,7 +231,7 @@ let cook_constant { from = cb; info } = | Undef _ as x -> x | Def cs -> Def (Mod_subst.from_val (map (Mod_subst.force_constr cs))) | OpaqueDef o -> - OpaqueDef (Opaqueproof.discharge_direct_opaque ~cook_constr:map info o) + OpaqueDef (Opaqueproof.discharge_direct_opaque info o) | Primitive _ -> CErrors.anomaly (Pp.str "Primitives cannot be cooked") in let const_hyps = diff --git a/kernel/cooking.mli b/kernel/cooking.mli index abae3880d7..934b7c6b50 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -28,7 +28,7 @@ type 'opaque result = { } val cook_constant : recipe -> Opaqueproof.opaque result -val cook_constr : Opaqueproof.cooking_info -> constr -> constr +val cook_constr : Opaqueproof.cooking_info list -> int -> constr -> constr val cook_inductive : Opaqueproof.cooking_info -> mutual_inductive_body -> Entries.mutual_inductive_entry diff --git a/kernel/dune b/kernel/dune index 5b23a705ae..4038bf5638 100644 --- a/kernel/dune +++ b/kernel/dune @@ -3,7 +3,7 @@ (synopsis "The Coq Kernel") (public_name coq.kernel) (wrapped false) - (modules (:standard \ genOpcodeFiles uint63_x86 uint63_amd64 write_uint63)) + (modules (:standard \ genOpcodeFiles uint63_i386_31 uint63_amd64_63 write_uint63)) (libraries lib byterun dynlink)) (executable @@ -14,15 +14,10 @@ (targets copcodes.ml) (action (with-stdout-to %{targets} (run ./genOpcodeFiles.exe copml)))) -(executable - (name write_uint63) - (modules write_uint63) - (libraries unix)) - (rule (targets uint63.ml) - (deps (:gen ./write_uint63.exe) uint63_x86.ml uint63_amd64.ml) - (action (run %{gen}))) + (deps (:gen-file uint63_%{ocaml-config:architecture}_%{ocaml-config:int_size}.ml)) + (action (copy# %{gen-file} %{targets}))) (documentation (package coq)) diff --git a/kernel/entries.ml b/kernel/entries.ml index adb3f6bd29..45b11e97ba 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -107,8 +107,3 @@ type module_entry = | MType of module_params_entry * module_struct_entry | MExpr of module_params_entry * module_struct_entry * module_struct_entry option - -(** Not used by the kernel. *) -type side_effect_role = - | Subproof - | Schema of inductive * string diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 1971c67c61..e18b726111 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -16,19 +16,22 @@ open Mod_subst type work_list = (Instance.t * Id.t array) Cmap.t * (Instance.t * Id.t array) Mindmap.t +type cooking_info = { + modlist : work_list; + abstract : Constr.named_context * Univ.Instance.t * Univ.AUContext.t } + type indirect_accessor = { access_proof : DirPath.t -> int -> constr option; + access_discharge : cooking_info list -> int -> constr -> constr; } -type cooking_info = { - modlist : work_list; - abstract : Constr.named_context * Univ.Instance.t * Univ.AUContext.t } type proofterm = (constr * Univ.ContextSet.t) Future.computation +type universes = int type opaque = | Indirect of substitution list * DirPath.t * int (* subst, lib, index *) - | Direct of cooking_info list * proofterm + | Direct of universes * cooking_info list * proofterm type opaquetab = { - opaque_val : (cooking_info list * proofterm) Int.Map.t; + opaque_val : (int * cooking_info list * proofterm) Int.Map.t; (** Actual proof terms *) opaque_len : int; (** Size of the above map *) @@ -43,14 +46,14 @@ let empty_opaquetab = { let not_here () = CErrors.user_err Pp.(str "Cannot access opaque delayed proof") -let create cu = Direct ([],cu) +let create ~univs cu = Direct (univs, [],cu) let turn_indirect dp o tab = match o with | Indirect (_,_,i) -> if not (Int.Map.mem i tab.opaque_val) then CErrors.anomaly (Pp.str "Indirect in a different table.") else CErrors.anomaly (Pp.str "Already an indirect opaque.") - | Direct (d,cu) -> + | Direct (nunivs, d, cu) -> (* Invariant: direct opaques only exist inside sections, we turn them indirect as soon as we are at toplevel. At this moment, we perform hashconsing of their contents, potentially as a future. *) @@ -61,7 +64,7 @@ let turn_indirect dp o tab = match o with in let cu = Future.chain cu hcons in let id = tab.opaque_len in - let opaque_val = Int.Map.add id (d,cu) tab.opaque_val in + let opaque_val = Int.Map.add id (nunivs, d,cu) tab.opaque_val in let opaque_dir = if DirPath.equal dp tab.opaque_dir then tab.opaque_dir else if DirPath.equal tab.opaque_dir DirPath.initial then dp @@ -74,10 +77,10 @@ let subst_opaque sub = function | Indirect (s,dp,i) -> Indirect (sub::s,dp,i) | Direct _ -> CErrors.anomaly (Pp.str "Substituting a Direct opaque.") -let discharge_direct_opaque ~cook_constr ci = function +let discharge_direct_opaque ci = function | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") - | Direct (d,cu) -> - Direct (ci::d,Future.chain cu (fun (c, u) -> cook_constr c, u)) + | Direct (n, d, cu) -> + Direct (n, ci :: d, cu) let join except cu = match except with | None -> ignore (Future.join cu) @@ -86,54 +89,61 @@ let join except cu = match except with else ignore (Future.join cu) let join_opaque ?except { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> join except cu + | Direct (_,_,cu) -> join except cu | Indirect (_,dp,i) -> if DirPath.equal dp odp then - let fp = snd (Int.Map.find i prfs) in + let (_, _, fp) = Int.Map.find i prfs in join except fp let force_proof access { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> - fst(Future.force cu) + | Direct (n, d, cu) -> + let (c, _) = Future.force cu in + access.access_discharge d n c | Indirect (l,dp,i) -> - let pt = + let c = if DirPath.equal dp odp - then Future.chain (snd (Int.Map.find i prfs)) fst + then + let (n, d, cu) = Int.Map.find i prfs in + let (c, _) = Future.force cu in + access.access_discharge d n c else match access.access_proof dp i with | None -> not_here () - | Some v -> Future.from_val v + | Some v -> v in - let c = Future.force pt in force_constr (List.fold_right subst_substituted l (from_val c)) let force_constraints _access { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> snd(Future.force cu) + | Direct (_,_,cu) -> + snd(Future.force cu) | Indirect (_,dp,i) -> if DirPath.equal dp odp - then snd (Future.force (snd (Int.Map.find i prfs))) + then + let (_, _, cu) = Int.Map.find i prfs in + snd (Future.force cu) else Univ.ContextSet.empty let get_direct_constraints = function | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") -| Direct (_, cu) -> Future.chain cu snd +| Direct (_, _, cu) -> Future.chain cu snd module FMap = Future.UUIDMap let dump ?(except = Future.UUIDSet.empty) { opaque_val = otab; opaque_len = n; _ } = - let opaque_table = Array.make n None in - let disch_table = Array.make n [] in + let opaque_table = Array.make n ([], 0, None) in let f2t_map = ref FMap.empty in - let iter n (d, cu) = + let iter n (univs, d, cu) = let uid = Future.uuid cu in let () = f2t_map := FMap.add (Future.uuid cu) n !f2t_map in - if Future.is_val cu then - let (c, _) = Future.force cu in - opaque_table.(n) <- Some c - else if Future.UUIDSet.mem uid except then - disch_table.(n) <- d - else - CErrors.anomaly - Pp.(str"Proof object "++int n++str" is not checked nor to be checked") + let c = + if Future.is_val cu then + let (c, _) = Future.force cu in + Some c + else if Future.UUIDSet.mem uid except then None + else + CErrors.anomaly + Pp.(str"Proof object "++int n++str" is not checked nor to be checked") + in + opaque_table.(n) <- (d, univs, c) in let () = Int.Map.iter iter otab in - opaque_table, disch_table, !f2t_map + opaque_table, !f2t_map diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 46b0500507..6e275649cd 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -28,15 +28,23 @@ type opaque val empty_opaquetab : opaquetab (** From a [proofterm] to some [opaque]. *) -val create : proofterm -> opaque +val create : univs:int -> proofterm -> opaque (** Turn a direct [opaque] into an indirect one. It is your responsibility to hashcons the inner term beforehand. The integer is an hint of the maximum id used so far *) val turn_indirect : DirPath.t -> opaque -> opaquetab -> opaque * opaquetab +type work_list = (Univ.Instance.t * Id.t array) Cmap.t * + (Univ.Instance.t * Id.t array) Mindmap.t + +type cooking_info = { + modlist : work_list; + abstract : Constr.named_context * Univ.Instance.t * Univ.AUContext.t } + type indirect_accessor = { access_proof : DirPath.t -> int -> constr option; + access_discharge : cooking_info list -> int -> constr -> constr; } (** When stored indirectly, opaque terms are indexed by their library dirpath and an integer index. The two functions above activate @@ -51,23 +59,11 @@ val get_direct_constraints : opaque -> Univ.ContextSet.t Future.computation val subst_opaque : substitution -> opaque -> opaque -type work_list = (Univ.Instance.t * Id.t array) Cmap.t * - (Univ.Instance.t * Id.t array) Mindmap.t - -type cooking_info = { - modlist : work_list; - abstract : Constr.named_context * Univ.Instance.t * Univ.AUContext.t } - -(* The type has two caveats: - 1) cook_constr is defined after - 2) we have to store the input in the [opaque] in order to be able to - discharge it when turning a .vi into a .vo *) val discharge_direct_opaque : - cook_constr:(constr -> constr) -> cooking_info -> opaque -> opaque + cooking_info -> opaque -> opaque val join_opaque : ?except:Future.UUIDSet.t -> opaquetab -> opaque -> unit val dump : ?except:Future.UUIDSet.t -> opaquetab -> - Constr.t option array * - cooking_info list array * + (cooking_info list * int * Constr.t option) array * int Future.UUIDMap.t diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 9f7466902d..0b0f14eee7 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -231,8 +231,7 @@ let check_engagement env expected_impredicative_set = type side_effect = { from_env : Declarations.structure_body CEphemeron.key; seff_constant : Constant.t; - seff_body : (Constr.t * Univ.ContextSet.t) Declarations.constant_body; - seff_role : Entries.side_effect_role; + seff_body : Constr.t Declarations.constant_body; } module SideEffects : @@ -299,11 +298,6 @@ let concat_private = SideEffects.concat let universes_of_private eff = let fold acc eff = - let acc = match eff.seff_body.const_body with - | Def _ -> acc - | OpaqueDef (_, ctx) -> ctx :: acc - | Primitive _ | Undef _ -> assert false - in match eff.seff_body.const_universes with | Monomorphic ctx -> ctx :: acc | Polymorphic _ -> acc @@ -541,8 +535,7 @@ type 'a effect_entry = type global_declaration = | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration -type exported_private_constant = - Constant.t * Entries.side_effect_role +type exported_private_constant = Constant.t let add_constant_aux ~in_section senv (kn, cb) = let l = Constant.label kn in @@ -601,7 +594,7 @@ let inline_side_effects env body side_eff = let fold (subst, var, ctx, args) (c, cb) = let (b, opaque) = match cb.const_body with | Def b -> (Mod_subst.force_constr b, false) - | OpaqueDef (b, _) -> (b, true) + | OpaqueDef b -> (b, true) | _ -> assert false in match cb.const_universes with @@ -689,13 +682,13 @@ let constant_entry_of_side_effect eff = | Polymorphic auctx -> Polymorphic_entry (Univ.AUContext.names auctx, Univ.AUContext.repr auctx) in - let pt = + let p = match cb.const_body with - | OpaqueDef (b, c) -> b, c - | Def b -> Mod_subst.force_constr b, Univ.ContextSet.empty + | OpaqueDef b -> b + | Def b -> Mod_subst.force_constr b | _ -> assert false in DefinitionEntry { - const_entry_body = Future.from_val (pt, ()); + const_entry_body = Future.from_val ((p, Univ.ContextSet.empty), ()); const_entry_secctx = None; const_entry_feedback = None; const_entry_type = Some cb.const_type; @@ -704,7 +697,7 @@ let constant_entry_of_side_effect eff = const_entry_inline_code = cb.const_inline_code } let export_eff eff = - (eff.seff_constant, eff.seff_body, eff.seff_role) + (eff.seff_constant, eff.seff_body) let export_side_effects mb env (b_ctx, eff) = let not_exists e = @@ -721,11 +714,6 @@ let export_side_effects mb env (b_ctx, eff) = match cb.const_universes with | Polymorphic _ -> env | Monomorphic ctx -> - let ctx = match eff.seff_body.const_body with - | Def _ -> ctx - | OpaqueDef (_, ctx') -> Univ.ContextSet.union ctx' ctx - | Undef _ | Primitive _ -> assert false - in Environ.push_context_set ~strict:true ctx env in let rec translate_seff sl seff acc env = @@ -737,7 +725,12 @@ let export_side_effects mb env (b_ctx, eff) = let kn = eff.seff_constant in let ce = constant_entry_of_side_effect eff in let cb = Term_typing.translate_constant Term_typing.Pure env kn ce in - let cb = map_constant Future.force cb in + let map cu = + let (c, u) = Future.force cu in + let () = assert (Univ.ContextSet.is_empty u) in + c + in + let cb = map_constant map cb in let eff = { eff with seff_body = cb } in (push_seff env eff, export_eff eff) in @@ -749,11 +742,15 @@ let export_side_effects mb env (b_ctx, eff) = in translate_seff trusted seff [] env +let n_univs cb = match cb.const_universes with +| Monomorphic _ -> 0 +| Polymorphic auctx -> Univ.AUContext.size auctx + let export_private_constants ~in_section ce senv = let exported, ce = export_side_effects senv.revstruct senv.env ce in - let map (kn, cb, _) = (kn, map_constant (fun p -> Opaqueproof.create (Future.from_val p)) cb) in + let map (kn, cb) = (kn, map_constant (fun p -> Opaqueproof.create ~univs:(n_univs cb) (Future.from_val (p, Univ.ContextSet.empty))) cb) in let bodies = List.map map exported in - let exported = List.map (fun (kn, _, r) -> (kn, r)) exported in + let exported = List.map (fun (kn, _) -> kn) exported in let senv = List.fold_left (add_constant_aux ~in_section) senv bodies in (ce, exported), senv @@ -763,7 +760,7 @@ let add_recipe ~in_section l r senv = let senv = add_constant_aux ~in_section senv (kn, cb) in kn, senv -let add_constant ?role ~in_section l decl senv = +let add_constant (type a) ~(side_effect : a effect_entry) ~in_section l decl senv : (Constant.t * a) * safe_environment = let kn = Constant.make2 senv.modpath l in let cb = match decl with @@ -778,7 +775,7 @@ let add_constant ?role ~in_section l decl senv = Term_typing.translate_constant Term_typing.Pure senv.env kn ce in let senv = - let cb = map_constant Opaqueproof.create cb in + let cb = map_constant (fun c -> Opaqueproof.create ~univs:(n_univs cb) c) cb in add_constant_aux ~in_section senv (kn, cb) in let senv = match decl with @@ -787,16 +784,28 @@ let add_constant ?role ~in_section l decl senv = add_retroknowledge (Retroknowledge.Register_type(t,kn)) senv | _ -> senv in - let eff = match role with - | None -> empty_private_constants - | Some role -> - let cb = map_constant Future.force cb in + let eff : a = match side_effect with + | PureEntry -> () + | EffectEntry -> + let body, univs = match cb.const_body with + | (Primitive _ | Undef _) -> assert false + | Def c -> (Def c, cb.const_universes) + | OpaqueDef o -> + let (b, ctx) = Future.force o in + match cb.const_universes with + | Monomorphic ctx' -> + OpaqueDef b, Monomorphic (Univ.ContextSet.union ctx ctx') + | Polymorphic auctx -> + (* Upper layers enforce that there are no internal constraints *) + let () = assert (Univ.ContextSet.is_empty ctx) in + OpaqueDef b, Polymorphic auctx + in + let cb = { cb with const_body = body; const_universes = univs } in let from_env = CEphemeron.create senv.revstruct in let eff = { from_env = from_env; seff_constant = kn; seff_body = cb; - seff_role = role; } in SideEffects.add eff empty_private_constants in diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 770caf5406..3e902303c3 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -87,18 +87,16 @@ type 'a effect_entry = type global_declaration = | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration -type exported_private_constant = - Constant.t * Entries.side_effect_role +type exported_private_constant = Constant.t val export_private_constants : in_section:bool -> private_constants Entries.proof_output -> (Constr.constr Univ.in_universe_context_set * exported_private_constant list) safe_transformer -(** returns the main constant plus a list of auxiliary constants (empty - unless one requires the side effects to be exported) *) +(** returns the main constant plus a certificate of its validity *) val add_constant : - ?role:Entries.side_effect_role -> in_section:bool -> Label.t -> global_declaration -> - (Constant.t * private_constants) safe_transformer + side_effect:'a effect_entry -> in_section:bool -> Label.t -> global_declaration -> + (Constant.t * 'a) safe_transformer val add_recipe : in_section:bool -> Label.t -> Cooking.recipe -> Constant.t safe_transformer diff --git a/kernel/uint63_amd64.ml b/kernel/uint63_amd64_63.ml index 2d4d685775..2d4d685775 100644 --- a/kernel/uint63_amd64.ml +++ b/kernel/uint63_amd64_63.ml diff --git a/kernel/uint63_x86.ml b/kernel/uint63_i386_31.ml index fa45c90241..fa45c90241 100644 --- a/kernel/uint63_x86.ml +++ b/kernel/uint63_i386_31.ml diff --git a/kernel/write_uint63.ml b/kernel/write_uint63.ml index beb59ce205..42bb5dfbb1 100644 --- a/kernel/write_uint63.ml +++ b/kernel/write_uint63.ml @@ -31,8 +31,8 @@ let ml_file_copy input output = let write_uint63 () = ml_file_copy - (if max_int = 1073741823 (* 32-bits *) then "uint63_x86.ml" - else (* 64 bits *) "uint63_amd64.ml") + (if max_int = 1073741823 (* 32-bits *) then "uint63_i386_31.ml" + else (* 64 bits *) "uint63_amd64_63.ml") "uint63.ml" let () = write_uint63 () diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml index 8d5c2fb687..39042e1ab7 100644 --- a/library/decl_kinds.ml +++ b/library/decl_kinds.ml @@ -12,7 +12,9 @@ type discharge = DoDischarge | NoDischarge -type locality = Discharge | Local | Global +type import_status = ImportDefaultBehavior | ImportNeedQualified + +type locality = Discharge | Global of import_status type binding_kind = Explicit | Implicit @@ -46,7 +48,7 @@ type definition_object_kind = | Method | Let -type assumption_object_kind = Definitional | Logical | Conjectural +type assumption_object_kind = Definitional | Logical | Conjectural | Context (* [assumption_kind] diff --git a/library/global.ml b/library/global.ml index d5ffae7716..3f30a63808 100644 --- a/library/global.ml +++ b/library/global.ml @@ -94,7 +94,7 @@ let make_sprop_cumulative () = globalize0 Safe_typing.make_sprop_cumulative let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) let sprop_allowed () = Environ.sprop_allowed (env()) let export_private_constants ~in_section cd = globalize (Safe_typing.export_private_constants ~in_section cd) -let add_constant ?role ~in_section id d = globalize (Safe_typing.add_constant ?role ~in_section (i2l id) d) +let add_constant ~side_effect ~in_section id d = globalize (Safe_typing.add_constant ~side_effect ~in_section (i2l id) d) let add_recipe ~in_section id d = globalize (Safe_typing.add_recipe ~in_section (i2l id) d) let add_mind id mie = globalize (Safe_typing.add_mind (i2l id) mie) let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl) diff --git a/library/global.mli b/library/global.mli index eaa76c3117..c36cec3511 100644 --- a/library/global.mli +++ b/library/global.mli @@ -46,7 +46,7 @@ val export_private_constants : in_section:bool -> Constr.constr Univ.in_universe_context_set * Safe_typing.exported_private_constant list val add_constant : - ?role:Entries.side_effect_role -> in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t * Safe_typing.private_constants + side_effect:'a Safe_typing.effect_entry -> in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t * 'a val add_recipe : in_section:bool -> Id.t -> Cooking.recipe -> Constant.t val add_mind : Id.t -> Entries.mutual_inductive_entry -> MutInd.t diff --git a/library/library.ml b/library/library.ml index e3b8511af1..1ac75d2fdc 100644 --- a/library/library.ml +++ b/library/library.ml @@ -276,11 +276,11 @@ let in_import_library : DirPath.t list * bool -> obj = (** Delayed / available tables of opaque terms *) type 'a table_status = - | ToFetch of 'a option array delayed - | Fetched of 'a option array + | ToFetch of 'a array delayed + | Fetched of 'a array let opaque_tables = - ref (LibraryMap.empty : (Constr.constr table_status) LibraryMap.t) + ref (LibraryMap.empty : ((Opaqueproof.cooking_info list * int * Constr.constr option) table_status) LibraryMap.t) let add_opaque_table dp st = opaque_tables := LibraryMap.add dp st !opaque_tables @@ -306,10 +306,14 @@ let access_table what tables dp i = let access_opaque_table dp i = let what = "opaque proofs" in - access_table what opaque_tables dp i + let (info, n, c) = access_table what opaque_tables dp i in + match c with + | None -> None + | Some c -> Some (Cooking.cook_constr info n c) let indirect_accessor = { Opaqueproof.access_proof = access_opaque_table; + Opaqueproof.access_discharge = Cooking.cook_constr; } (************************************************************************) @@ -319,8 +323,7 @@ type seg_sum = summary_disk type seg_lib = library_disk type seg_univ = (* true = vivo, false = vi *) Univ.ContextSet.t * bool -type seg_discharge = Opaqueproof.cooking_info list array -type seg_proofs = Constr.constr option array +type seg_proofs = (Opaqueproof.cooking_info list * int * Constr.t option) array let mk_library sd md digests univs = { @@ -344,7 +347,6 @@ let intern_from_file f = let ((lmd : seg_lib delayed), digest_lmd) = in_delayed f ch in let (univs : seg_univ option), _, digest_u = System.marshal_in_segment f ch in let _ = System.skip_in_segment f ch in - let _ = System.skip_in_segment f ch in let ((del_opaque : seg_proofs delayed),_) = in_delayed f ch in close_in ch; register_library_filename lsd.md_name f; @@ -527,15 +529,13 @@ let load_library_todo f = let (s0 : seg_sum), _, _ = System.marshal_in_segment f ch in let (s1 : seg_lib), _, _ = System.marshal_in_segment f ch in let (s2 : seg_univ option), _, _ = System.marshal_in_segment f ch in - let (s3 : seg_discharge option), _, _ = System.marshal_in_segment f ch in let tasks, _, _ = System.marshal_in_segment f ch in - let (s5 : seg_proofs), _, _ = System.marshal_in_segment f ch in + let (s4 : seg_proofs), _, _ = System.marshal_in_segment f ch in close_in ch; if tasks = None then user_err ~hdr:"restart" (str"not a .vio file"); if s2 = None then user_err ~hdr:"restart" (str"not a .vio file"); - if s3 = None then user_err ~hdr:"restart" (str"not a .vio file"); if snd (Option.get s2) then user_err ~hdr:"restart" (str"not a .vio file"); - s0, s1, Option.get s2, Option.get s3, Option.get tasks, s5 + s0, s1, Option.get s2, Option.get tasks, s4 (************************************************************************) (*s [save_library dir] ends library [dir] and save it to the disk. *) @@ -578,10 +578,10 @@ let save_library_to ?todo ~output_native_objects dir f otab = List.fold_left (fun e (r,_) -> Future.UUIDSet.add r.Stateid.uuid e) Future.UUIDSet.empty l in let cenv, seg, ast = Declaremods.end_library ~output_native_objects ~except dir in - let opaque_table, disch_table, f2t_map = Opaqueproof.dump ~except otab in - let tasks, utab, dtab = + let opaque_table, f2t_map = Opaqueproof.dump ~except otab in + let tasks, utab = match todo with - | None -> None, None, None + | None -> None, None | Some (tasks, rcbackup) -> let tasks = List.map Stateid.(fun (r,b) -> @@ -589,8 +589,8 @@ let save_library_to ?todo ~output_native_objects dir f otab = with Not_found -> assert b; { r with uuid = -1 }, b) tasks in Some (tasks,rcbackup), - Some (Univ.ContextSet.empty,false), - Some disch_table in + Some (Univ.ContextSet.empty,false) + in let sd = { md_name = dir; md_deps = Array.of_list (current_deps ()); @@ -610,7 +610,6 @@ let save_library_to ?todo ~output_native_objects dir f otab = System.marshal_out_segment f' ch (sd : seg_sum); System.marshal_out_segment f' ch (md : seg_lib); System.marshal_out_segment f' ch (utab : seg_univ option); - System.marshal_out_segment f' ch (dtab : seg_discharge option); System.marshal_out_segment f' ch (tasks : 'tasks option); System.marshal_out_segment f' ch (opaque_table : seg_proofs); close_out ch; @@ -630,7 +629,6 @@ let save_library_raw f sum lib univs proofs = System.marshal_out_segment f ch (sum : seg_sum); System.marshal_out_segment f ch (lib : seg_lib); System.marshal_out_segment f ch (Some univs : seg_univ option); - System.marshal_out_segment f ch (None : seg_discharge option); System.marshal_out_segment f ch (None : 'tasks option); System.marshal_out_segment f ch (proofs : seg_proofs); close_out ch diff --git a/library/library.mli b/library/library.mli index 142206e2c5..727eca10cf 100644 --- a/library/library.mli +++ b/library/library.mli @@ -35,8 +35,7 @@ type seg_sum type seg_lib type seg_univ = (* all_cst, finished? *) Univ.ContextSet.t * bool -type seg_discharge = Opaqueproof.cooking_info list array -type seg_proofs = Constr.constr option array +type seg_proofs = (Opaqueproof.cooking_info list * int * Constr.t option) array (** Open a module (or a library); if the boolean is true then it's also an export otherwise just a simple import *) @@ -51,7 +50,7 @@ val save_library_to : val load_library_todo : CUnix.physical_path - -> seg_sum * seg_lib * seg_univ * seg_discharge * 'tasks * seg_proofs + -> seg_sum * seg_lib * seg_univ * 'tasks * seg_proofs val save_library_raw : string -> seg_sum -> seg_lib -> seg_univ -> seg_proofs -> unit diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index bd88570224..79cfe33b12 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -133,7 +133,8 @@ let aliasvar = function { CAst.v = CPatAlias (_, na) } -> Some na | _ -> None } GRAMMAR EXTEND Gram - GLOBAL: binder_constr lconstr constr operconstr universe_level sort sort_family + GLOBAL: binder_constr lconstr constr operconstr + universe_level universe_name sort sort_family global constr_pattern lconstr_pattern Constr.ident closed_binder open_binders binder binders binders_fixannot record_declaration typeclass_constraint pattern appl_arg; @@ -153,11 +154,12 @@ GRAMMAR EXTEND Gram [ [ c = lconstr -> { c } ] ] ; sort: - [ [ "Set" -> { GSet } - | "Prop" -> { GProp } - | "SProp" -> { GSProp } - | "Type" -> { GType [] } - | "Type"; "@{"; u = universe; "}" -> { GType u } + [ [ "Set" -> { UNamed [GSet,0] } + | "Prop" -> { UNamed [GProp,0] } + | "SProp" -> { UNamed [GSProp,0] } + | "Type" -> { UAnonymous {rigid=true} } + | "Type"; "@{"; "_"; "}" -> { UAnonymous {rigid=false} } + | "Type"; "@{"; u = universe; "}" -> { UNamed u } ] ] ; sort_family: @@ -167,11 +169,17 @@ GRAMMAR EXTEND Gram | "Type" -> { Sorts.InType } ] ] ; + universe_increment: + [ [ "+"; n = natural -> { n } + | -> { 0 } ] ] + ; + universe_name: + [ [ id = global -> { GType id } + | "Set" -> { GSet } + | "Prop" -> { GProp } ] ] + ; universe_expr: - [ [ id = global; "+"; n = natural -> { Some (id,n) } - | id = global -> { Some (id,0) } - | "_" -> { None } - ] ] + [ [ id = universe_name; n = universe_increment -> { (id,n) } ] ] ; universe: [ [ IDENT "max"; "("; ids = LIST1 universe_expr SEP ","; ")" -> { ids } @@ -328,12 +336,12 @@ GRAMMAR EXTEND Gram | -> { None } ] ] ; universe_level: - [ [ "Set" -> { GSet } + [ [ "Set" -> { UNamed GSet } (* no parsing SProp as a level *) - | "Prop" -> { GProp } - | "Type" -> { GType UUnknown } - | "_" -> { GType UAnonymous } - | id = global -> { GType (UNamed id) } + | "Prop" -> { UNamed GProp } + | "Type" -> { UAnonymous {rigid=true} } + | "_" -> { UAnonymous {rigid=false} } + | id = global -> { UNamed (GType id) } ] ] ; fix_constr: diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index b474c8e9a9..b375c526ad 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -427,6 +427,7 @@ module Constr = let binder_constr = gec_constr "binder_constr" let ident = make_gen_entry uconstr "ident" let global = make_gen_entry uconstr "global" + let universe_name = make_gen_entry uconstr "universe_name" let universe_level = make_gen_entry uconstr "universe_level" let sort = make_gen_entry uconstr "sort" let sort_family = make_gen_entry uconstr "sort_family" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 5f982346ab..196835f184 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -182,6 +182,7 @@ module Constr : val operconstr : constr_expr Entry.t val ident : Id.t Entry.t val global : qualid Entry.t + val universe_name : Glob_term.glob_sort_name Entry.t val universe_level : Glob_term.glob_level Entry.t val sort : Glob_term.glob_sort Entry.t val sort_family : Sorts.family Entry.t diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 9c1882dc9a..aad3967f6d 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -12,8 +12,8 @@ open Constr open Context open Context.Named.Declaration -let map_const_entry_body (f:constr->constr) (x:Safe_typing.private_constants Entries.const_entry_body) - : Safe_typing.private_constants Entries.const_entry_body = +let map_const_entry_body (f:constr->constr) (x: Evd.side_effects Entries.const_entry_body) + : Evd.side_effects Entries.const_entry_body = Future.chain x begin fun ((b,ctx),fx) -> (f b , ctx) , fx end @@ -22,11 +22,11 @@ let map_const_entry_body (f:constr->constr) (x:Safe_typing.private_constants Ent (which can contain references to [f]) in the context extended by [f:=?x]. When the proof ends, [f] is defined as the value of [?x] and [lemma] as the proof. *) -let start_deriving f suchthat lemma = +let start_deriving f suchthat name : Lemmas.t = let env = Global.env () in let sigma = Evd.from_env env in - let kind = Decl_kinds.(Global,false,DefinitionBody Definition) in + let kind = Decl_kinds.(Global ImportDefaultBehavior,false,DefinitionBody Definition) in (* create a sort variable for the type of [f] *) (* spiwack: I don't know what the rigidity flag does, picked the one @@ -48,7 +48,6 @@ let start_deriving f suchthat lemma = (* The terminator handles the registering of constants when the proof is closed. *) let terminator com = - let open Proof_global in (* Extracts the relevant information from the proof. [Admitted] and [Save] result in user errors. [opaque] is [true] if the proof was concluded by [Qed], and [false] if [Defined]. [f_def] @@ -56,10 +55,10 @@ let start_deriving f suchthat lemma = [suchthat], respectively. *) let (opaque,f_def,lemma_def) = match com with - | Admitted _ -> CErrors.user_err Pp.(str "Admitted isn't supported in Derive.") - | Proved (_,Some _,_) -> + | Lemmas.Admitted _ -> CErrors.user_err Pp.(str "Admitted isn't supported in Derive.") + | Lemmas.Proved (_,Some _,_) -> CErrors.user_err Pp.(str "Cannot save a proof of Derive with an explicit name.") - | Proved (opaque, None, obj) -> + | Lemmas.Proved (opaque, None, obj) -> match Proof_global.(obj.entries) with | [_;f_def;lemma_def] -> opaque <> Proof_global.Transparent , f_def , lemma_def @@ -97,12 +96,11 @@ let start_deriving f suchthat lemma = Entries.DefinitionEntry lemma_def , Decl_kinds.(IsProof Proposition) in - ignore (Declare.declare_constant lemma lemma_def) - in + ignore (Declare.declare_constant name lemma_def) + in - let terminator = Proof_global.make_terminator terminator in - let pstate = Proof_global.start_dependent_proof lemma kind goals terminator in - Proof_global.modify_proof begin fun p -> - let p,_,() = Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p in - p - end pstate + let terminator ?hook _ = Lemmas.Internal.make_terminator terminator in + let lemma = Lemmas.start_dependent_lemma name kind goals ~terminator in + Lemmas.pf_map (Proof_global.map_proof begin fun p -> + Util.pi1 @@ Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p + end) lemma diff --git a/plugins/derive/derive.mli b/plugins/derive/derive.mli index 6bb923118e..ffbc726e22 100644 --- a/plugins/derive/derive.mli +++ b/plugins/derive/derive.mli @@ -12,4 +12,8 @@ (which can contain references to [f]) in the context extended by [f:=?x]. When the proof ends, [f] is defined as the value of [?x] and [lemma] as the proof. *) -val start_deriving : Names.Id.t -> Constrexpr.constr_expr -> Names.Id.t -> Proof_global.t +val start_deriving + : Names.Id.t + -> Constrexpr.constr_expr + -> Names.Id.t + -> Lemmas.t diff --git a/plugins/derive/g_derive.mlg b/plugins/derive/g_derive.mlg index 526989fdf3..6c9cd66f96 100644 --- a/plugins/derive/g_derive.mlg +++ b/plugins/derive/g_derive.mlg @@ -24,5 +24,5 @@ let classify_derive_command _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpac VERNAC COMMAND EXTEND Derive CLASSIFIED BY { classify_derive_command } STATE open_proof | [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> - { Derive.(start_deriving f suchthat lemma) } + { Derive.start_deriving f suchthat lemma } END diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index c5439ffaf6..4cd34100bc 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -752,13 +752,13 @@ let extract_and_compile l = (* Show the extraction of the current ongoing proof *) let show_extraction ~pstate = init ~inner:true false false; - let prf = Proof_global.give_me_the_proof pstate in + let prf = Proof_global.get_proof pstate in let sigma, env = Pfedit.get_current_context pstate in let trms = Proof.partial_proof prf in let extr_term t = let ast, ty = extract_constr env sigma t in let mp = Lib.current_mp () in - let l = Label.of_id (Proof_global.get_current_proof_name pstate) in + let l = Label.of_id (Proof_global.get_proof_name pstate) in let fake_ref = ConstRef (Constant.make2 mp l) in let decl = Dterm (fake_ref, ast, ty) in print_one_decl [] mp decl diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index e38ea992ab..b8e1286b9e 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -990,21 +990,19 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) - let pstate = Lemmas.start_proof + let lemma = Lemmas.start_lemma (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious i*) (mk_equation_id f_id) - (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem)) + Decl_kinds.(Global ImportDefaultBehavior, false, Proof Theorem) evd lemma_type in - let pstate,_ = Pfedit.by (Proofview.V82.tactic prove_replacement) pstate in - let ontop = Proof_global.push ~ontop:None pstate in - ignore(Lemmas.save_proof_proved ?proof:None ~ontop ~opaque:Proof_global.Transparent ~idopt:None); + let lemma,_ = Lemmas.by (Proofview.V82.tactic prove_replacement) lemma in + let () = Lemmas.save_lemma_proved ?proof:None ~lemma ~opaque:Proof_global.Transparent ~idopt:None in evd - let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = let equation_lemma = try @@ -1725,11 +1723,3 @@ let prove_principle_for_gen ] gl - - - - - - - - diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 7b26cb0c74..5363dc9a02 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -308,16 +308,16 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in evd := sigma; let hook = Lemmas.mk_hook (hook new_principle_type) in - let pstate = - Lemmas.start_proof + let lemma = + Lemmas.start_lemma new_princ_name - (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) + Decl_kinds.(Global ImportDefaultBehavior,false,Proof Theorem) !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 pstate,_ = Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) pstate 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 *) @@ -325,7 +325,7 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin (* end; *) let open Proof_global in - let { id; entries; persistence } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pstate in + let { id; entries; persistence } = Lemmas.pf_fold (close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x)) lemma in match entries with | [entry] -> (id,(entry,persistence)), hook @@ -471,7 +471,7 @@ let get_funs_constant mp = exception No_graph_found exception Found_type of int -let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_constants definition_entry list = +let make_scheme evd (fas : (pconstant*Sorts.family) list) : Evd.side_effects definition_entry list = let env = Global.env () in let funs = List.map fst fas in let first_fun = List.hd funs in @@ -597,7 +597,7 @@ let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_ in {const with const_entry_body = - (Future.from_val (Safe_typing.mk_pure_proof princ_body)); + (Future.from_val ((princ_body, Univ.ContextSet.empty), Evd.empty_side_effects)); const_entry_type = Some scheme_type } ) diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index 97f9acdb3a..759c522820 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -34,7 +34,7 @@ val generate_functional_principle : exception No_graph_found val make_scheme : Evd.evar_map ref -> - (pconstant*Sorts.family) list -> Safe_typing.private_constants Entries.definition_entry list + (pconstant*Sorts.family) list -> Evd.side_effects Entries.definition_entry list val build_scheme : (Id.t*Libnames.qualid*Sorts.family) list -> unit val build_case_scheme : (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 4c67d65816..201d953692 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1299,10 +1299,10 @@ let rec rebuild_return_type rt = | Constrexpr.CProdN(n,t') -> CAst.make ?loc @@ Constrexpr.CProdN(n,rebuild_return_type t') | Constrexpr.CLetIn(na,v,t,t') -> - CAst.make ?loc @@ Constrexpr.CLetIn(na,v,t,rebuild_return_type 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)], - CAst.make @@ Constrexpr.CSort(GType [])) + CAst.make @@ Constrexpr.CSort(UAnonymous {rigid=true})) let do_build_inductive evd (funconstants: pconstant list) (funsargs: (Name.t * glob_constr * glob_constr option) list list) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 241da053b7..d710f4490d 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -417,7 +417,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp ComDefinition.do_definition ~program_mode:false fname - (Decl_kinds.Global,false,Decl_kinds.Definition) pl + Decl_kinds.(Global ImportDefaultBehavior,false,Definition) pl bl None body (Some ret_type); let evd,rev_pconstants = List.fold_left @@ -434,7 +434,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp in None, evd,List.rev rev_pconstants | _ -> - ComFixpoint.do_fixpoint Global false fixpoint_exprl; + ComFixpoint.do_fixpoint (Global ImportDefaultBehavior) false fixpoint_exprl; let evd,rev_pconstants = List.fold_left (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> @@ -634,9 +634,9 @@ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacex let do_generate_principle_aux pconstants on_error register_built interactive_proof - (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) : Proof_global.t option = + (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) : Lemmas.t option = List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; - let pstate, _is_struct = + let lemma, _is_struct = match fixpoint_exprl with | [((_,Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)},_,_,_),_) as fixpoint_expr] -> let (((({CAst.v=name},pl),_,args,types,body)),_) as fixpoint_expr = @@ -702,7 +702,7 @@ let do_generate_principle_aux pconstants on_error register_built interactive_pro (* 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 pstate,evd,pconstants = + let lemma,evd,pconstants = if register_built then register_struct is_rec fixpoint_exprl else None, Evd.from_env (Global.env ()), pconstants @@ -720,9 +720,9 @@ let do_generate_principle_aux pconstants on_error register_built interactive_pro (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); if register_built then begin derive_inversion fix_names; end; - pstate, true + lemma, true in - pstate + lemma let rec add_args id new_args = CAst.map (function | CRef (qid,_) as b -> @@ -911,18 +911,18 @@ let make_graph (f_ref : GlobRef.t) = (* *************** statically typed entrypoints ************************* *) -let do_generate_principle_interactive fixl : Proof_global.t = +let do_generate_principle_interactive fixl : Lemmas.t = match do_generate_principle_aux [] warning_error true true fixl with - | Some pstate -> pstate + | Some lemma -> lemma | None -> - CErrors.anomaly - (Pp.str"indfun: leaving no open proof in interactive mode") + 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 _pstate -> - CErrors.anomaly - (Pp.str"indfun: leaving a goal open in non-interactive mode") + | 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 1ba245a45d..3bc52272ac 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -10,7 +10,7 @@ val do_generate_principle : val do_generate_principle_interactive : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> - Proof_global.t + Lemmas.t val functional_induction : bool -> diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 48cf040919..6d9690096f 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -124,26 +124,20 @@ open Declare let definition_message = Declare.definition_message -let get_locality = function -| Discharge -> true -| Local -> true -| Global -> false - let save id const ?hook uctx (locality,_,kind) = let fix_exn = Future.fix_exn_of const.const_entry_body in - let l,r = match locality with - | Discharge when Lib.sections_are_opened () -> + let r = match locality with + | Discharge -> let k = Kindops.logical_kind_of_goal_kind kind in let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in - (Local, VarRef id) - | Discharge | Local | Global -> - let local = get_locality locality in + VarRef id + | Global local -> let k = Kindops.logical_kind_of_goal_kind kind in let kn = declare_constant id ~local (DefinitionEntry const, k) in - (locality, ConstRef kn) + ConstRef kn in - Lemmas.call_hook ?hook ~fix_exn uctx [] l r; + Lemmas.call_hook ?hook ~fix_exn uctx [] locality r; definition_message id let with_full_print f a = diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 9670cf1fa7..4078c34331 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -44,7 +44,7 @@ val jmeq_refl : unit -> EConstr.constr val save : Id.t - -> Safe_typing.private_constants Entries.definition_entry + -> Evd.side_effects Entries.definition_entry -> ?hook:Lemmas.declaration_hook -> UState.t -> Decl_kinds.goal_kind diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 03568fc6c7..857b7df96f 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -803,15 +803,15 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list i*) let lem_id = mk_correct_id f_id in let (typ,_) = lemmas_types_infos.(i) in - let pstate = Lemmas.start_proof + let lemma = Lemmas.start_lemma lem_id - (Decl_kinds.Global,false,((Decl_kinds.Proof Decl_kinds.Theorem))) + Decl_kinds.(Global ImportDefaultBehavior,false,Proof Theorem) !evd typ in - let pstate = fst @@ Pfedit.by + let lemma = fst @@ Lemmas.by (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") - (proving_tac i))) pstate in - let () = Lemmas.save_pstate_proved ~pstate ~opaque:Proof_global.Transparent ~idopt:None in + (proving_tac i))) lemma in + let () = Lemmas.save_lemma_proved ?proof:None ~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 @@ -865,13 +865,13 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list Ensures by: obvious i*) let lem_id = mk_complete_id f_id in - let pstate = Lemmas.start_proof lem_id - (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) sigma + let lemma = Lemmas.start_lemma lem_id + Decl_kinds.(Global ImportDefaultBehavior,false,Proof Theorem) sigma (fst lemmas_types_infos.(i)) in - let pstate = fst (Pfedit.by + let lemma = fst (Lemmas.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") - (proving_tac i))) pstate) in - let () = Lemmas.save_pstate_proved ~pstate ~opaque:Proof_global.Transparent ~idopt:None in + (proving_tac i))) lemma) in + let () = Lemmas.save_lemma_proved ?proof:None ~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 diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index e2321d233c..17d962f30f 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -34,7 +34,6 @@ open Declare open Decl_kinds open Tacred open Goal -open Pfedit open Glob_term open Pretyping open Termops @@ -72,7 +71,8 @@ let declare_fun f_id kind ?univs value = let ce = definition_entry ?univs value (*FIXME *) in ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; -let defined pstate = Lemmas.save_pstate_proved ~pstate ~opaque:Proof_global.Transparent ~idopt:None +let defined lemma = + Lemmas.save_lemma_proved ?proof:None ~lemma ~opaque:Proof_global.Transparent ~idopt:None let def_of_const t = match (Constr.kind t) with @@ -1221,7 +1221,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a end let get_current_subgoals_types pstate = - let p = Proof_global.give_me_the_proof pstate in + let p = Proof_global.get_proof pstate in let Proof.{ goals=sgs; sigma; _ } = Proof.data p in sigma, List.map (Goal.V82.abstract_type sigma) sgs @@ -1281,8 +1281,8 @@ let clear_goals sigma = List.map clear_goal -let build_new_goal_type pstate = - let sigma, sub_gls_types = get_current_subgoals_types pstate in +let build_new_goal_type lemma = + let sigma, sub_gls_types = Lemmas.pf_fold get_current_subgoals_types lemma in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) let sub_gls_types = clear_goals sigma sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) @@ -1297,9 +1297,9 @@ let is_opaque_constant c = | Declarations.Def _ -> Proof_global.Transparent | Declarations.Primitive _ -> Proof_global.Opaque -let open_new_goal pstate build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) - let current_proof_name = Proof_global.get_current_proof_name pstate in + let current_proof_name = Lemmas.pf_fold Proof_global.get_proof_name lemma in let name = match goal_name with | Some s -> s | None -> @@ -1323,7 +1323,7 @@ let open_new_goal pstate 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 pstate = build_proof env (Evd.from_env env) + 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 "") @@ -1367,17 +1367,17 @@ let open_new_goal pstate build_proof sigma using_lemmas ref_ goal_name (gls_type ) g) in - Lemmas.save_pstate_proved ~pstate ~opaque:opacity ~idopt:None + Lemmas.save_lemma_proved ?proof:None ~lemma ~opaque:opacity ~idopt:None in - let pstate = Lemmas.start_proof + let lemma = Lemmas.start_lemma na - (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma) + Decl_kinds.(Global ImportDefaultBehavior, false (* FIXME *), Proof Lemma) sigma gls_type ~hook:(Lemmas.mk_hook hook) in - let pstate = if Indfun_common.is_strict_tcc () + let lemma = if Indfun_common.is_strict_tcc () then - fst @@ by (Proofview.V82.tactic (tclIDTAC)) pstate + fst @@ Lemmas.by (Proofview.V82.tactic (tclIDTAC)) lemma else - fst @@ by (Proofview.V82.tactic begin + fst @@ Lemmas.by (Proofview.V82.tactic begin fun g -> tclTHEN (decompose_and_tac) @@ -1393,9 +1393,9 @@ let open_new_goal pstate build_proof sigma using_lemmas ref_ goal_name (gls_type ) using_lemmas) ) tclIDTAC) - g end) pstate + g end) lemma in - if Proof_global.get_open_goals pstate = 0 then (defined pstate; None) else Some pstate + if Lemmas.(pf_fold Proof_global.get_open_goals) lemma = 0 then (defined lemma; None) else Some lemma let com_terminate interactive_proof @@ -1410,26 +1410,26 @@ let com_terminate nb_args ctx hook = let start_proof env ctx (tac_start:tactic) (tac_end:tactic) = - let pstate = Lemmas.start_proof thm_name - (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) + let lemma = Lemmas.start_lemma thm_name + (Global ImportDefaultBehavior, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) ~hook in - let pstate = fst @@ by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "starting_tac") tac_start)) pstate in - fst @@ 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 ))) pstate + let lemma = fst @@ Lemmas.by (Proofview.V82.tactic (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 pstate = start_proof Global.(env ()) ctx tclIDTAC tclIDTAC in + let lemma = start_proof Global.(env ()) ctx tclIDTAC tclIDTAC in try - let sigma, new_goal_type = build_new_goal_type pstate in + let sigma, new_goal_type = build_new_goal_type lemma in let sigma = Evd.from_ctx (Evd.evar_universe_context sigma) in - open_new_goal pstate start_proof sigma + open_new_goal ~lemma start_proof sigma using_lemmas tcc_lemma_ref (Some tcc_lemma_name) (new_goal_type) with EmptySubgoals -> (* a non recursive function declared with measure ! *) tcc_lemma_ref := Not_needed; - if interactive_proof then Some pstate - else (defined pstate; None) + if interactive_proof then Some lemma + else (defined lemma; None) let start_equation (f:GlobRef.t) (term_f:GlobRef.t) (cont_tactic:Id.t list -> tactic) g = @@ -1457,9 +1457,9 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation let evd = Evd.from_ctx uctx in let f_constr = constr_of_monomorphic_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in - let pstate = Lemmas.start_proof eq_name (Global, false, Proof Lemma) ~sign evd + let lemma = Lemmas.start_lemma eq_name (Global ImportDefaultBehavior, false, Proof Lemma) ~sign evd (EConstr.of_constr equation_lemma_type) in - let pstate = fst @@ by + let lemma = fst @@ Lemmas.by (Proofview.V82.tactic (start_equation f_ref terminate_ref (fun x -> prove_eq (fun _ -> tclIDTAC) @@ -1486,14 +1486,14 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation ih = Id.of_string "______"; } ) - )) pstate in - let _ = Flags.silently (fun () -> Lemmas.save_pstate_proved ~pstate ~opaque:opacity ~idopt:None) () in + )) lemma in + let _ = Flags.silently (fun () -> Lemmas.save_lemma_proved ?proof:None ~lemma ~opaque:opacity ~idopt:None) () in () (* Pp.msgnl (fun _ _ -> str "eqn finished"); *) let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type_of_f r rec_arg_num eq - generate_induction_principle using_lemmas : Proof_global.t option = + generate_induction_principle using_lemmas : Lemmas.t option = let open Term in let open Constr in let open CVars in @@ -1550,8 +1550,9 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type let stop = (* XXX: What is the correct way to get sign at hook time *) let sign = Environ.named_context_val Global.(env ()) in - try com_eqn sign uctx (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); - false + try + com_eqn sign uctx (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); + false with e when CErrors.noncritical e -> begin if do_observe () @@ -1582,15 +1583,15 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type in (* XXX STATE Why do we need this... why is the toplevel protection not enough *) funind_purify (fun () -> - let pstate = com_terminate - interactive_proof - tcc_lemma_name - tcc_lemma_constr - is_mes functional_ref - (EConstr.of_constr rec_arg_type) - relation rec_arg_num - term_id - using_lemmas - (List.length res_vars) - evd (Lemmas.mk_hook hook) - in pstate) () + com_terminate + interactive_proof + tcc_lemma_name + tcc_lemma_constr + is_mes functional_ref + (EConstr.of_constr rec_arg_type) + relation rec_arg_num + term_id + using_lemmas + (List.length res_vars) + evd (Lemmas.mk_hook hook)) + () diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index b92ac3a0ec..e6aa452def 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -1,23 +1,21 @@ open Constr -val tclUSER_if_not_mes : +val tclUSER_if_not_mes : Tacmach.tactic -> - bool -> - Names.Id.t list option -> + bool -> + Names.Id.t list option -> Tacmach.tactic -val recursive_definition : - interactive_proof:bool -> - is_mes:bool -> - Names.Id.t -> - Constrintern.internalization_env -> - Constrexpr.constr_expr -> - Constrexpr.constr_expr -> - int -> - Constrexpr.constr_expr -> - (pconstant -> - Indfun_common.tcc_lemma_value ref -> - pconstant -> - pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) -> - Constrexpr.constr_expr list -> - Proof_global.t option +val recursive_definition + : interactive_proof:bool + -> is_mes:bool + -> Names.Id.t + -> Constrintern.internalization_env + -> Constrexpr.constr_expr + -> Constrexpr.constr_expr + -> int + -> Constrexpr.constr_expr + -> (pconstant -> Indfun_common.tcc_lemma_value ref -> pconstant -> + pconstant -> int -> EConstr.types -> int -> EConstr.constr -> unit) + -> Constrexpr.constr_expr list + -> Lemmas.t option diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 0ded60d9c7..7691ca225e 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -934,7 +934,7 @@ END VERNAC COMMAND EXTEND GrabEvars STATE proof | [ "Grab" "Existential" "Variables" ] => { classify_as_proofstep } - -> { fun ~pstate -> Proof_global.modify_proof (fun p -> Proof.V82.grab_evars p) pstate } + -> { fun ~pstate -> Proof_global.map_proof (fun p -> Proof.V82.grab_evars p) pstate } END (* Shelves all the goals under focus. *) @@ -966,7 +966,7 @@ END VERNAC COMMAND EXTEND Unshelve STATE proof | [ "Unshelve" ] => { classify_as_proofstep } - -> { fun ~pstate -> Proof_global.modify_proof (fun p -> Proof.unshelve p) pstate } + -> { fun ~pstate -> Proof_global.map_proof (fun p -> Proof.unshelve p) pstate } END (* Gives up on the goals under focus: the goals are considered solved, diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 960e5b76f8..d10d10a664 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -376,7 +376,7 @@ let () = declare_int_option { let vernac_solve ~pstate n info tcom b = let open Goal_select in - let pstate, status = Proof_global.with_proof (fun etac p -> + let pstate, status = Proof_global.map_fold_proof_endline (fun etac p -> let with_end_tac = if b then Some etac else None in let global = match n with SelectAll | SelectList _ -> true | _ -> false in let info = Option.append info !print_info_trace in diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 7b286e69dc..2da6584aba 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -946,9 +946,9 @@ let fold_match ?(force=false) env sigma c = if dep then case_dep_scheme_kind_from_prop else case_scheme_kind_from_prop else ( - if dep - then case_dep_scheme_kind_from_type_in_prop - else case_scheme_kind_from_type) + if dep + then case_dep_scheme_kind_from_type_in_prop + else case_scheme_kind_from_type) else ((* sortc <> InProp by typing *) if dep then case_dep_scheme_kind_from_type @@ -1962,7 +1962,6 @@ let add_setoid atts binders a aeq t n = (qualid_of_ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); (qualid_of_ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])] - let make_tactic name = let open Tacexpr in let tacqid = Libnames.qualid_of_string name in @@ -1988,14 +1987,14 @@ let add_morphism_as_parameter atts m n : unit = (PropGlobal.proper_class env evd) Hints.empty_hint_info atts.global (ConstRef cst)); declare_projection n instance_id (ConstRef cst) -let add_morphism_interactive atts m n : Proof_global.t = +let add_morphism_interactive atts m n : Lemmas.t = warn_add_morphism_deprecated ?loc:m.CAst.loc (); init_setoid (); let instance_id = add_suffix n "_Proper" in let env = Global.env () in let evd = Evd.from_env env in let uctx, instance = build_morphism_signature env evd m in - let kind = Decl_kinds.Global, atts.polymorphic, + let kind = Decl_kinds.Global Decl_kinds.ImportDefaultBehavior, atts.polymorphic, Decl_kinds.DefinitionBody Decl_kinds.Instance in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in @@ -2010,8 +2009,8 @@ let add_morphism_interactive atts m n : Proof_global.t = let hook = Lemmas.mk_hook hook in Flags.silently (fun () -> - let pstate = Lemmas.start_proof ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) in - fst Pfedit.(by (Tacinterp.interp tac) pstate)) () + let lemma = Lemmas.start_lemma ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) in + fst (Lemmas.by (Tacinterp.interp tac) lemma)) () let add_morphism atts binders m s n = init_setoid (); @@ -2023,12 +2022,12 @@ let add_morphism atts binders m s n = [cHole; s; m]) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in - let _id, pstate = Classes.new_instance_interactive + let _id, lemma = Classes.new_instance_interactive ~global:atts.global atts.polymorphic instance_name binders instance_t ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info in - pstate (* no instance body -> always open proof *) + lemma (* no instance body -> always open proof *) (** Bind to "rewrite" too *) diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 3ef33c6dc9..a5c3782b30 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -101,16 +101,16 @@ val add_setoid -> Id.t -> unit -val add_morphism_interactive : rewrite_attributes -> constr_expr -> Id.t -> Proof_global.t +val add_morphism_interactive : rewrite_attributes -> constr_expr -> Id.t -> Lemmas.t val add_morphism_as_parameter : rewrite_attributes -> constr_expr -> Id.t -> unit val add_morphism - : rewrite_attributes + : rewrite_attributes -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t - -> Proof_global.t + -> Lemmas.t val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index 309db539d0..2cc6f9a279 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -12,11 +12,10 @@ open Vernacexpr open Tacexpr -open Attributes (** {5 Tactic Definitions} *) -val register_ltac : locality_flag -> ?deprecation:deprecation -> +val register_ltac : locality_flag -> ?deprecation:Deprecation.t -> Tacexpr.tacdef_body list -> unit (** Adds new Ltac definitions to the environment. *) @@ -36,7 +35,7 @@ type argument = Genarg.ArgT.any Extend.user_symbol leaves. *) val add_tactic_notation : - locality_flag -> int -> ?deprecation:deprecation -> raw_argument + locality_flag -> int -> ?deprecation:Deprecation.t -> raw_argument grammar_tactic_prod_item_expr list -> raw_tactic_expr -> unit (** [add_tactic_notation local level prods expr] adds a tactic notation in the environment at level [level] with locality [local] made of the grammar @@ -49,7 +48,7 @@ val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type - to finding an argument by name (as in {!Genarg}) if there is none matching. *) -val add_ml_tactic_notation : ml_tactic_name -> level:int -> ?deprecation:deprecation -> +val add_ml_tactic_notation : ml_tactic_name -> level:int -> ?deprecation:Deprecation.t -> argument grammar_tactic_prod_item_expr list list -> unit (** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND ML-side macro. *) @@ -80,7 +79,7 @@ type _ ty_sig = type ty_ml = TyML : 'r ty_sig * 'r -> ty_ml val tactic_extend : string -> string -> level:Int.t -> - ?deprecation:deprecation -> ty_ml list -> unit + ?deprecation:Deprecation.t -> ty_ml list -> unit (** {5 ARGUMENT EXTEND} *) diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml index d5f22b2c72..3347f594d2 100644 --- a/plugins/ltac/tacenv.ml +++ b/plugins/ltac/tacenv.ml @@ -55,7 +55,7 @@ type alias = KerName.t type alias_tactic = { alias_args: Id.t list; alias_body: glob_tactic_expr; - alias_deprecation: Attributes.deprecation option; + alias_deprecation: Deprecation.t option; } let alias_map = Summary.ref ~name:"tactic-alias" @@ -121,7 +121,7 @@ type ltac_entry = { tac_for_ml : bool; tac_body : glob_tactic_expr; tac_redef : ModPath.t list; - tac_deprecation : Attributes.deprecation option + tac_deprecation : Deprecation.t option } let mactab = @@ -178,7 +178,7 @@ let subst_md (subst, (local, id, b, t, deprecation)) = let classify_md (local, _, _, _, _ as o) = Substitute o let inMD : bool * ltac_constant option * bool * glob_tactic_expr * - Attributes.deprecation option -> obj = + Deprecation.t option -> obj = declare_object {(default_object "TAC-DEFINITION") with cache_function = cache_md; load_function = load_md; diff --git a/plugins/ltac/tacenv.mli b/plugins/ltac/tacenv.mli index 5b98daf383..2fc45760d1 100644 --- a/plugins/ltac/tacenv.mli +++ b/plugins/ltac/tacenv.mli @@ -12,7 +12,6 @@ open Names open Libnames open Tacexpr open Geninterp -open Attributes (** This module centralizes the various ways of registering tactics. *) @@ -33,7 +32,7 @@ type alias = KerName.t type alias_tactic = { alias_args: Id.t list; alias_body: glob_tactic_expr; - alias_deprecation: deprecation option; + alias_deprecation: Deprecation.t option; } (** Contents of a tactic notation *) @@ -48,7 +47,7 @@ val check_alias : alias -> bool (** {5 Coq tactic definitions} *) -val register_ltac : bool -> bool -> ?deprecation:deprecation -> Id.t -> +val register_ltac : bool -> bool -> ?deprecation:Deprecation.t -> Id.t -> glob_tactic_expr -> unit (** Register a new Ltac with the given name and body. @@ -57,7 +56,7 @@ val register_ltac : bool -> bool -> ?deprecation:deprecation -> Id.t -> definition. It also puts the Ltac name in the nametab, so that it can be used unqualified. *) -val redefine_ltac : bool -> ?deprecation:deprecation -> KerName.t -> +val redefine_ltac : bool -> ?deprecation:Deprecation.t -> KerName.t -> glob_tactic_expr -> unit (** Replace a Ltac with the given name and body. If the boolean flag is set to true, then this is a local redefinition. *) @@ -68,7 +67,7 @@ val interp_ltac : KerName.t -> glob_tactic_expr val is_ltac_for_ml_tactic : KerName.t -> bool (** Whether the tactic is defined from ML-side *) -val tac_deprecation : KerName.t -> deprecation option +val tac_deprecation : KerName.t -> Deprecation.t option (** The tactic deprecation notice, if any *) type ltac_entry = { @@ -78,7 +77,7 @@ type ltac_entry = { (** The current body of the tactic *) tac_redef : ModPath.t list; (** List of modules redefining the tactic in reverse chronological order *) - tac_deprecation : deprecation option; + tac_deprecation : Deprecation.t option; (** Deprecation notice to be printed when the tactic is used *) } diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index c1f7fab123..7434f81946 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -119,18 +119,13 @@ let intern_constr_reference strict ist qid = (* Internalize an isolated reference in position of tactic *) let warn_deprecated_tactic = - CWarnings.create ~name:"deprecated-tactic" ~category:"deprecated" - (fun (qid,depr) -> str "Tactic " ++ pr_qualid qid ++ - strbrk " is deprecated" ++ - pr_opt (fun since -> str "since " ++ str since) depr.Attributes.since ++ - str "." ++ pr_opt (fun note -> str note) depr.Attributes.note) + Deprecation.create_warning ~object_name:"Tactic" ~warning_name:"deprecated-tactic" + pr_qualid let warn_deprecated_alias = - CWarnings.create ~name:"deprecated-tactic-notation" ~category:"deprecated" - (fun (kn,depr) -> str "Tactic Notation " ++ Pptactic.pr_alias_key kn ++ - strbrk " is deprecated since" ++ - pr_opt (fun since -> str "since " ++ str since) depr.Attributes.since ++ - str "." ++ pr_opt (fun note -> str note) depr.Attributes.note) + Deprecation.create_warning ~object_name:"Tactic Notation" + ~warning_name:"deprecated-tactic-notation" + Pptactic.pr_alias_key let intern_isolated_global_tactic_reference qid = let loc = qid.CAst.loc in diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 56f17703ff..6c7b4702b6 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -194,8 +194,8 @@ let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) let mkRVar id = DAst.make @@ GRef (VarRef id,None) let mkRltacVar id = DAst.make @@ GVar (id) let mkRCast rc rt = DAst.make @@ GCast (rc, CastConv rt) -let mkRType = DAst.make @@ GSort (GType []) -let mkRProp = DAst.make @@ GSort (GProp) +let mkRType = DAst.make @@ GSort (UAnonymous {rigid=true}) +let mkRProp = DAst.make @@ GSort (UNamed [GProp,0]) let mkRArrow rt1 rt2 = DAst.make @@ GProd (Anonymous, Explicit, rt1, rt2) let mkRConstruct c = DAst.make @@ GRef (ConstructRef c,None) let mkRInd mind = DAst.make @@ GRef (IndRef mind,None) @@ -871,8 +871,8 @@ open Constrexpr open Util (** Constructors for constr_expr *) -let mkCProp loc = CAst.make ?loc @@ CSort GProp -let mkCType loc = CAst.make ?loc @@ CSort (GType []) +let mkCProp loc = CAst.make ?loc @@ CSort (UNamed [GProp,0]) +let mkCType loc = CAst.make ?loc @@ CSort (UAnonymous {rigid=true}) let mkCVar ?loc id = CAst.make ?loc @@ CRef (qualid_of_ident ?loc id, None) let rec mkCHoles ?loc n = if n <= 0 then [] else (CAst.make ?loc @@ CHole (None, Namegen.IntroAnonymous, None)) :: mkCHoles ?loc (n - 1) @@ -1119,6 +1119,7 @@ let cleartac clr = check_hyps_uniq [] clr; Tactics.clear (hyps_ids clr) (* XXX the k of the redex should percolate out *) let pf_interp_gen_aux gl to_ind ((oclr, occ), t) = let pat = interp_cpattern gl t None in (* UGLY API *) + let gl = pf_merge_uc_of (fst pat) gl in let cl, env, sigma = Tacmach.pf_concl gl, pf_env gl, project gl in let (c, ucst), cl = try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr cl) pat occ 1 @@ -1253,6 +1254,7 @@ let abs_wgen keep_let f gen (gl,args,c) = | _, Some ((x, "@"), Some p) -> let x = hoi_id x in let cp = interp_cpattern gl p None in + let gl = pf_merge_uc_of (fst cp) gl in let (t, ucst), c = try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr c) cp None 1 with NoMatch -> redex_of_pattern env cp, (EConstr.Unsafe.to_constr c) in @@ -1265,6 +1267,7 @@ let abs_wgen keep_let f gen (gl,args,c) = | _, Some ((x, _), Some p) -> let x = hoi_id x in let cp = interp_cpattern gl p None in + let gl = pf_merge_uc_of (fst cp) gl in let (t, ucst), c = try fill_occ_pattern ~raise_NoMatch:true env sigma (EConstr.Unsafe.to_constr c) cp None 1 with NoMatch -> redex_of_pattern env cp, (EConstr.Unsafe.to_constr c) in diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index dbc9bb24c5..3a0868b7e4 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -383,15 +383,22 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let c = fire_subst gl (List.assoc (n_elim_args - k - 1) elim_args) in let gl, t = pfe_type_of gl c in let gl, eq = get_eq_type gl in - let gen_eq_tac, gl = + let gen_eq_tac, eq_ty, gl = let refl = EConstr.mkApp (eq, [|t; c; c|]) in let new_concl = EConstr.mkArrow refl Sorts.Relevant (EConstr.Vars.lift 1 (pf_concl orig_gl)) in let new_concl = fire_subst gl new_concl in let erefl, gl = mkRefl t c gl in let erefl = fire_subst gl erefl in - apply_type new_concl [erefl], gl in + let erefl_ty = Retyping.get_type_of (pf_env gl) (project gl) erefl in + let eq_ty = Retyping.get_type_of (pf_env gl) (project gl) erefl_ty in + let gen_eq_tac s = + let open Evd in + let sigma = merge_universe_context s.sigma (evar_universe_context (project gl)) in + apply_type new_concl [erefl] { s with sigma } + in + gen_eq_tac, eq_ty, gl in let rel = k + if c_is_head_p then 1 else 0 in - let src, gl = mkProt EConstr.mkProp EConstr.(mkApp (eq,[|t; c; mkRel rel|])) gl in + let src, gl = mkProt eq_ty EConstr.(mkApp (eq,[|t; c; mkRel rel|])) gl in let concl = EConstr.mkArrow src Sorts.Relevant (EConstr.Vars.lift 1 concl) in let clr = if deps <> [] then clr else [] in concl, gen_eq_tac, clr, gl diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 538d0c4e9a..91905d277c 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -336,14 +336,14 @@ 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 elim, gl = let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in 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 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 @@ -619,7 +619,11 @@ let rwargtac ?under ?map_redex ist ((dir, mult), (((oclr, occ), grx), (kind, gt) with _ when snd mult = May -> fail := true; (project gl, EConstr.mkProp) in let rwtac gl = let rx = Option.map (interp_rpattern gl) grx in + let gl = match rx with + | None -> gl + | Some (s,_) -> pf_merge_uc_of s gl in let t = interp gt gl in + let gl = pf_merge_uc_of (fst t) gl in (match kind with | RWred sim -> simplintac occ rx sim | RWdef -> if dir = R2L then foldtac occ rx t else unfoldintac occ rx t gt diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 82726eccf0..18a036cb8c 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -688,20 +688,21 @@ let hack_qualid_of_univ_level sigma l = let detype_universe sigma u = let fn (l, n) = - let qid = hack_qualid_of_univ_level sigma l in - Some (qid, n) - in + let s = + if Univ.Level.is_prop l then GProp else + if Univ.Level.is_set l then GSet else + GType (hack_qualid_of_univ_level sigma l) in + (s, n) in Univ.Universe.map fn u let detype_sort sigma = function - | SProp -> GSProp - | Prop -> GProp - | Set -> GSet + | SProp -> UNamed [GSProp,0] + | Prop -> UNamed [GProp,0] + | Set -> UNamed [GSet,0] | Type u -> - GType (if !print_universes - then detype_universe sigma u - else []) + then UNamed (detype_universe sigma u) + else UAnonymous {rigid=true}) type binder_kind = BProd | BLambda | BLetIn @@ -710,7 +711,7 @@ type binder_kind = BProd | BLambda | BLetIn let detype_level sigma l = let l = hack_qualid_of_univ_level sigma l in - GType (UNamed l) + UNamed (GType l) let detype_instance sigma l = let l = EInstance.kind sigma l in diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 85b9faac77..a3a3c7f811 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -45,20 +45,27 @@ let map_glob_decl_left_to_right f (na,k,obd,ty) = let comp2 = f ty in (na,k,comp1,comp2) +let glob_sort_name_eq g1 g2 = match g1, g2 with + | GSProp, GSProp + | GProp, GProp + | GSet, GSet -> true + | GType u1, GType u2 -> Libnames.qualid_eq u1 u2 + | (GSProp|GProp|GSet|GType _), _ -> false -let glob_sort_eq g1 g2 = let open Glob_term in match g1, g2 with -| GSProp, GSProp -| GProp, GProp -| GSet, GSet -> true -| GType l1, GType l2 -> - List.equal (Option.equal (fun (x,m) (y,n) -> Libnames.qualid_eq x y && Int.equal m n)) l1 l2 -| (GSProp|GProp|GSet|GType _), _ -> false +exception ComplexSort let glob_sort_family = let open Sorts in function -| GSProp -> InSProp -| GProp -> InProp -| GSet -> InSet -| GType _ -> InType + | UAnonymous {rigid=true} -> InType + | UNamed [GSProp,0] -> InProp + | UNamed [GProp,0] -> InProp + | UNamed [GSet,0] -> InSet + | _ -> raise ComplexSort + +let glob_sort_eq u1 u2 = match u1, u2 with + | UAnonymous {rigid=r1}, UAnonymous {rigid=r2} -> r1 = r2 + | UNamed l1, UNamed l2 -> + List.equal (fun (x,m) (y,n) -> glob_sort_name_eq x y && Int.equal m n) l1 l2 + | (UNamed _ | UAnonymous _), _ -> false let binding_kind_eq bk1 bk2 = match bk1, bk2 with | Decl_kinds.Explicit, Decl_kinds.Explicit -> true diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index df902a8fa7..3995ab6a5a 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -15,10 +15,13 @@ open Glob_term val glob_sort_eq : Glob_term.glob_sort -> Glob_term.glob_sort -> bool -val glob_sort_family : 'a glob_sort_gen -> Sorts.family - val cases_pattern_eq : 'a cases_pattern_g -> 'a cases_pattern_g -> bool +(** Expect a Prop/SProp/Set/Type universe; raise [ComplexSort] if + contains a max, an increment, or a flexible universe *) +exception ComplexSort +val glob_sort_family : glob_sort -> Sorts.family + val alias_of_pat : 'a cases_pattern_g -> Name.t val set_pat_alias : Id.t -> 'a cases_pattern_g -> 'a cases_pattern_g diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index 02cb294f6d..704cddd784 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -23,23 +23,23 @@ type existential_name = Id.t (** Sorts *) -type 'a glob_sort_gen = +type glob_sort_name = | GSProp (** representation of [SProp] literal *) - | GProp (** representation of [Prop] literal *) - | GSet (** representation of [Set] literal *) - | GType of 'a (** representation of [Type] literal *) + | GProp (** representation of [Prop] level *) + | GSet (** representation of [Set] level *) + | GType of Libnames.qualid (** representation of a [Type] level *) -type 'a universe_kind = - | UAnonymous - | UUnknown +type 'a glob_sort_expr = + | UAnonymous of { rigid : bool } (** not rigid = unifiable by minimization *) | UNamed of 'a -type level_info = Libnames.qualid universe_kind -type glob_level = level_info glob_sort_gen -type glob_constraint = glob_level * Univ.constraint_type * glob_level +(** levels, occurring in universe instances *) +type glob_level = glob_sort_name glob_sort_expr -type sort_info = (Libnames.qualid * int) option list -type glob_sort = sort_info glob_sort_gen +(** sort expressions *) +type glob_sort = (glob_sort_name * int) list glob_sort_expr + +type glob_constraint = glob_sort_name * Univ.constraint_type * glob_sort_name type glob_recarg = int option diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index c788efda48..2d27b27cab 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -410,7 +410,9 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function PLetIn (na, pat_of_raw metas vars c1, Option.map (pat_of_raw metas vars) t, pat_of_raw metas (na::vars) c2) - | GSort gs -> PSort (Glob_ops.glob_sort_family gs) + | GSort gs -> + (try PSort (Glob_ops.glob_sort_family gs) + with Glob_ops.ComplexSort -> user_err ?loc (str "Unexpected universe in pattern.")) | GHole _ -> PMeta None | GCast (c,_) -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index c7b657f96c..be8f7215fa 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -132,7 +132,7 @@ let is_strict_universe_declarations = (** Miscellaneous interpretation functions *) -let interp_known_universe_level evd qid = +let interp_known_universe_level_name evd qid = try let open Libnames in if qualid_is_ident qid then Evd.universe_of_name evd @@ qualid_basename qid @@ -142,7 +142,7 @@ let interp_known_universe_level evd qid = Univ.Level.make qid let interp_universe_level_name ~anon_rigidity evd qid = - try evd, interp_known_universe_level evd qid + try evd, interp_known_universe_level_name evd qid with Not_found -> if Libnames.qualid_is_ident qid then (* Undeclared *) let id = Libnames.qualid_basename qid in @@ -164,44 +164,31 @@ let interp_universe_level_name ~anon_rigidity evd qid = with UGraph.AlreadyDeclared -> evd in evd, level -let interp_universe ?loc evd = function - | [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in - evd, Univ.Universe.make l - | l -> - List.fold_left (fun (evd, u) l -> - let evd', u' = - match l with - | Some (l,n) -> - (* [univ_flexible_alg] can produce algebraic universes in terms *) - let anon_rigidity = univ_flexible in - let evd', l = interp_universe_level_name ~anon_rigidity evd l in - let u' = Univ.Universe.make l in - (match n with - | 0 -> evd', u' - | 1 -> evd', Univ.Universe.super u' - | _ -> - user_err ?loc ~hdr:"interp_universe" - (Pp.(str "Cannot interpret universe increment +" ++ int n))) - | None -> - let evd, l = new_univ_level_variable ?loc univ_flexible evd in - evd, Univ.Universe.make l +let interp_universe_name ?loc evd l = + (* [univ_flexible_alg] can produce algebraic universes in terms *) + let anon_rigidity = univ_flexible in + let evd', l = interp_universe_level_name ~anon_rigidity evd l in + evd', l + +let interp_sort_name ?loc sigma = function + | GSProp -> sigma, Univ.Level.sprop + | GProp -> sigma, Univ.Level.prop + | GSet -> sigma, Univ.Level.set + | GType l -> interp_universe_name ?loc sigma l + +let interp_sort_info ?loc evd l = + List.fold_left (fun (evd, u) (l,n) -> + let evd', u' = interp_sort_name ?loc evd l in + let u' = Univ.Universe.make u' in + let u' = match n with + | 0 -> u' + | 1 -> Univ.Universe.super u' + | n -> + user_err ?loc ~hdr:"interp_universe" + (Pp.(str "Cannot interpret universe increment +" ++ int n)) in (evd', Univ.sup u u')) (evd, Univ.Universe.type0m) l -let interp_known_level_info ?loc evd = function - | UUnknown | UAnonymous -> - user_err ?loc ~hdr:"interp_known_level_info" - (str "Anonymous universes not allowed here.") - | UNamed qid -> - try interp_known_universe_level evd qid - with Not_found -> - user_err ?loc ~hdr:"interp_known_level_info" (str "Undeclared universe " ++ Libnames.pr_qualid qid) - -let interp_level_info ?loc evd : level_info -> _ = function - | UUnknown -> new_univ_level_variable ?loc univ_rigid evd - | UAnonymous -> new_univ_level_variable ?loc univ_flexible evd - | UNamed s -> interp_universe_level_name ~anon_rigidity:univ_flexible evd s - type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr type inference_flags = { @@ -415,13 +402,14 @@ let interp_known_glob_level ?loc evd = function | GSProp -> Univ.Level.sprop | GProp -> Univ.Level.prop | GSet -> Univ.Level.set - | GType s -> interp_known_level_info ?loc evd s + | GType qid -> + try interp_known_universe_level_name evd qid + with Not_found -> + user_err ?loc ~hdr:"interp_known_level_info" (str "Undeclared universe " ++ Libnames.pr_qualid qid) let interp_glob_level ?loc evd : glob_level -> _ = function - | GSProp -> evd, Univ.Level.sprop - | GProp -> evd, Univ.Level.prop - | GSet -> evd, Univ.Level.set - | GType s -> interp_level_info ?loc evd s + | UAnonymous {rigid} -> new_univ_level_variable ?loc (if rigid then univ_rigid else univ_flexible) evd + | UNamed s -> interp_sort_name ?loc evd s let interp_instance ?loc evd l = let evd, l' = @@ -460,18 +448,26 @@ let pretype_ref ?loc sigma env ref us = let ty = unsafe_type_of !!env sigma c in sigma, make_judge c ty -let judge_of_Type ?loc evd s = - let evd, s = interp_universe ?loc evd s in +let interp_sort ?loc evd : glob_sort -> _ = function + | UAnonymous {rigid} -> + let evd, l = new_univ_level_variable ?loc (if rigid then univ_rigid else univ_flexible) evd in + evd, Univ.Universe.make l + | UNamed l -> interp_sort_info ?loc evd l + +let judge_of_sort ?loc evd s = let judge = { uj_val = mkType s; uj_type = mkType (Univ.super s) } in evd, judge -let pretype_sort ?loc sigma = function - | GSProp -> sigma, judge_of_sprop - | GProp -> sigma, judge_of_prop - | GSet -> sigma, judge_of_set - | GType s -> judge_of_Type ?loc sigma s +let pretype_sort ?loc sigma s = + match s with + | UNamed [GSProp,0] -> sigma, judge_of_sprop + | UNamed [GProp,0] -> sigma, judge_of_prop + | UNamed [GSet,0] -> sigma, judge_of_set + | _ -> + let sigma, s = interp_sort ?loc sigma s in + judge_of_sort ?loc sigma s let new_type_evar env sigma loc = new_type_evar env sigma ~src:(Loc.tag ?loc Evar_kinds.InternalHole) diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index c0a95e73c6..d38aafd0e9 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -31,7 +31,7 @@ val get_bidirectionality_hint : GlobRef.t -> int option val clear_bidirectionality_hint : GlobRef.t -> unit val interp_known_glob_level : ?loc:Loc.t -> Evd.evar_map -> - glob_level -> Univ.Level.t + glob_sort_name -> Univ.Level.t (** An auxiliary function for searching for fixpoint guard indexes *) diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 8d5213b988..27ed2189ed 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -157,10 +157,14 @@ let tag_var = tag Tag.variable let pr_sep_com sep f c = pr_with_comments ?loc:(constr_loc c) (sep() ++ f c) - let pr_univ_expr = function - | Some (x,n) -> - pr_qualid x ++ (match n with 0 -> mt () | _ -> str"+" ++ int n) - | None -> str"_" + let pr_glob_sort_name = function + | GSProp -> str "SProp" + | GProp -> str "Prop" + | GSet -> str "Set" + | GType qid -> pr_qualid qid + + let pr_univ_expr (u,n) = + pr_glob_sort_name u ++ (match n with 0 -> mt () | _ -> str"+" ++ int n) let pr_univ l = match l with @@ -170,19 +174,20 @@ let tag_var = tag Tag.variable let pr_univ_annot pr x = str "@{" ++ pr x ++ str "}" let pr_glob_sort = let open Glob_term in function - | GSProp -> tag_type (str "SProp") - | GProp -> tag_type (str "Prop") - | GSet -> tag_type (str "Set") - | GType [] -> tag_type (str "Type") - | GType u -> hov 0 (tag_type (str "Type") ++ pr_univ_annot pr_univ u) + | UNamed [GSProp,0] -> tag_type (str "SProp") + | UNamed [GProp,0] -> tag_type (str "Prop") + | UNamed [GSet,0] -> tag_type (str "Set") + | UAnonymous {rigid=true} -> tag_type (str "Type") + | UAnonymous {rigid=false} -> tag_type (str "Type") ++ pr_univ_annot (fun _ -> str "_") () + | UNamed u -> hov 0 (tag_type (str "Type") ++ pr_univ_annot pr_univ u) let pr_glob_level = let open Glob_term in function - | GSProp -> tag_type (str "SProp") - | GProp -> tag_type (str "Prop") - | GSet -> tag_type (str "Set") - | GType UUnknown -> tag_type (str "Type") - | GType UAnonymous -> tag_type (str "_") - | GType (UNamed u) -> tag_type (pr_qualid u) + | UNamed GSProp -> tag_type (str "SProp") + | UNamed GProp -> tag_type (str "Prop") + | UNamed GSet -> tag_type (str "Set") + | UAnonymous {rigid=true} -> tag_type (str "Type") + | UAnonymous {rigid=false} -> tag_type (str "_") + | UNamed (GType u) -> tag_type (pr_qualid u) let pr_qualid sp = let (sl, id) = repr_qualid sp in @@ -199,21 +204,8 @@ let tag_var = tag Tag.variable let pr_qualid = pr_qualid let pr_patvar = pr_id - let pr_glob_sort_instance = let open Glob_term in function - | GSProp -> - tag_type (str "SProp") - | GProp -> - tag_type (str "Prop") - | GSet -> - tag_type (str "Set") - | GType u -> - (match u with - | UNamed u -> pr_qualid u - | UAnonymous -> tag_type (str "Type") - | UUnknown -> tag_type (str "_")) - let pr_universe_instance l = - pr_opt_no_spc (pr_univ_annot (prlist_with_sep spc pr_glob_sort_instance)) l + pr_opt_no_spc (pr_univ_annot (prlist_with_sep spc pr_glob_level)) l let pr_reference qid = if qualid_is_ident qid then tag_var (pr_id @@ qualid_basename qid) diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 1332cd0168..219fe4336a 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -33,6 +33,7 @@ val pr_id : Id.t -> Pp.t val pr_qualid : qualid -> Pp.t val pr_patvar : Pattern.patvar -> Pp.t +val pr_glob_sort_name : Glob_term.glob_sort_name -> Pp.t val pr_glob_level : Glob_term.glob_level -> Pp.t val pr_glob_sort : Glob_term.glob_sort -> Pp.t val pr_guard_annot diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 66b47a64a7..0662354daf 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -42,11 +42,11 @@ let get_goal_context_gen pf i = (sigma, Refiner.pf_env { it=goal ; sigma=sigma; }) let get_goal_context pf i = - let p = Proof_global.give_me_the_proof pf in + let p = Proof_global.get_proof pf in get_goal_context_gen p i let get_current_goal_context pf = - let p = Proof_global.give_me_the_proof pf in + let p = Proof_global.get_proof pf in try get_goal_context_gen p 1 with | NoSuchGoal -> @@ -57,7 +57,7 @@ let get_current_goal_context pf = Evd.from_env env, env let get_current_context pf = - let p = Proof_global.give_me_the_proof pf in + let p = Proof_global.get_proof pf in try get_goal_context_gen p 1 with | NoSuchGoal -> @@ -108,7 +108,7 @@ let solve ?with_end_tac gi info_lvl tac pr = in (p,status) -let by tac = Proof_global.with_proof (fun _ -> solve (Goal_select.SelectNth 1) None tac) +let by tac = Proof_global.map_fold_proof (solve (Goal_select.SelectNth 1) None tac) (**********************************************************************) (* Shortcut to build a term using tactics *) @@ -117,15 +117,14 @@ open Decl_kinds let next = let n = ref 0 in fun () -> incr n; !n -let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theorem) typ tac = +let build_constant_by_tactic id ctx sign ?(goal_kind = Global ImportDefaultBehavior, false, Proof Theorem) typ tac = let evd = Evd.from_ctx ctx in - let terminator = Proof_global.make_terminator (fun _ -> ()) in let goals = [ (Global.env_of_context sign , typ) ] in - let pf = Proof_global.start_proof evd id goal_kind goals terminator in + let pf = Proof_global.start_proof evd id goal_kind goals in try let pf, status = by tac pf in let open Proof_global in - let { entries; universes } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pf in + let { entries; universes } = close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pf in match entries with | [entry] -> let univs = UState.demote_seff_univs entry universes in @@ -139,13 +138,13 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac = let id = Id.of_string ("temporary_proof"^string_of_int (next())) in let sign = val_of_named_context (named_context env) in - let gk = Global, poly, Proof Theorem in + let gk = Global ImportDefaultBehavior, poly, Proof Theorem in let ce, status, univs = build_constant_by_tactic id sigma sign ~goal_kind:gk typ tac in - let body = Future.force ce.const_entry_body in + let body, eff = Future.force ce.const_entry_body in let (cb, ctx) = - if side_eff then Safe_typing.inline_private_constants env body - else fst body + if side_eff then Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) + else body in let univs = UState.merge ~sideff:side_eff ~extend:true Evd.univ_rigid univs ctx in cb, status, univs @@ -196,5 +195,6 @@ let refine_by_tactic ~name ~poly env sigma ty tac = other goals that were already present during its invocation, so that those goals rely on effects that are not present anymore. Hopefully, this hack will work in most cases. *) + let neff = neff.Evd.seff_private in let (ans, _) = Safe_typing.inline_private_constants env ((ans, Univ.ContextSet.empty), neff) in ans, sigma diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 77d701b41f..63d5adfcd2 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -61,7 +61,7 @@ val use_unification_heuristics : unit -> bool val build_constant_by_tactic : Id.t -> UState.t -> named_context_val -> ?goal_kind:goal_kind -> EConstr.types -> unit Proofview.tactic -> - Safe_typing.private_constants Entries.definition_entry * bool * + Evd.side_effects Entries.definition_entry * bool * UState.t val build_by_tactic : ?side_eff:bool -> env -> UState.t -> ?poly:polymorphic -> diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index b642e8eea7..96d90e9252 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -29,74 +29,31 @@ type lemma_possible_guards = int list list type proof_object = { id : Names.Id.t; - entries : Safe_typing.private_constants Entries.definition_entry list; + entries : Evd.side_effects Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: UState.t; } type opacity_flag = Opaque | Transparent -type proof_ending = - | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * UState.t - | Proved of opacity_flag * - lident option * - proof_object - -type proof_terminator = proof_ending -> unit -type closed_proof = proof_object * proof_terminator - -type t = { - terminator : proof_terminator CEphemeron.key; - endline_tactic : Genarg.glob_generic_argument option; - section_vars : Constr.named_context option; - proof : Proof.t; - universe_decl: UState.universe_decl; - strength : Decl_kinds.goal_kind; -} - -(* The head of [t] is the actual current proof, the other ones are - to be resumed when the current proof is closed or aborted. *) -type stack = t * t list - -let pstate_map f (pf, pfl) = (f pf, List.map f pfl) - -let make_terminator f = f -let apply_terminator f = f - -let get_current_pstate (ps,_) = ps - -(* combinators for the current_proof lists *) -let push ~ontop a = - match ontop with - | None -> a , [] - | Some (l,ls) -> a, (l :: ls) - -let maybe_push ~ontop = function - | Some pstate -> Some (push ~ontop pstate) - | None -> ontop +type t = + { endline_tactic : Genarg.glob_generic_argument option + ; section_vars : Constr.named_context option + ; proof : Proof.t + ; universe_decl: UState.universe_decl + ; strength : Decl_kinds.goal_kind + } (*** Proof Global manipulation ***) -let get_all_proof_names (pf : stack) = - let (pn, pns) = pstate_map Proof.(function pf -> (data pf.proof).name) pf in - pn :: pns - -let give_me_the_proof ps = ps.proof -let get_current_proof_name ps = (Proof.data ps.proof).Proof.name -let get_current_persistence ps = ps.strength - -let with_current_pstate f (ps,psl) = - let ps, ret = f ps in - (ps, psl), ret +let get_proof ps = ps.proof +let get_proof_name ps = (Proof.data ps.proof).Proof.name +let get_persistence ps = ps.strength -let modify_current_pstate f (ps,psl) = - f ps, psl +let map_proof f p = { p with proof = f p.proof } +let map_fold_proof f p = let proof, res = f p.proof in { p with proof }, res -let modify_proof f ps = - let proof = f ps.proof in - {ps with proof} - -let with_proof f ps = +let map_fold_proof_endline f ps = let et = match ps.endline_tactic with | None -> Proofview.tclUNIT () @@ -111,37 +68,13 @@ let with_proof f ps = let ps = { ps with proof = newpr } in ps, ret -let with_current_proof f (ps,rest) = - let ps, ret = with_proof f ps in - (ps, rest), ret - -let simple_with_current_proof f pf = - let p, () = with_current_proof (fun t p -> f t p , ()) pf in p - -let simple_with_proof f ps = - let ps, () = with_proof (fun t ps -> f t ps, ()) ps in ps - -let compact_the_proof pf = simple_with_proof (fun _ -> Proof.compact) pf +let compact_the_proof pf = map_proof Proof.compact pf (* Sets the tactic to be used when a tactic line is closed with [...] *) let set_endline_tactic tac ps = { ps with endline_tactic = Some tac } -let pf_name_eq id ps = - let Proof.{ name } = Proof.data ps.proof in - Id.equal name id - -let discard {CAst.loc;v=id} (ps, psl) = - match List.filter (fun pf -> not (pf_name_eq id pf)) (ps :: psl) with - | [] -> None - | ps :: psl -> Some (ps, psl) - -let discard_current (_, psl) = - match psl with - | [] -> None - | ps :: psl -> Some (ps, psl) - -(** [start_proof sigma id pl str goals terminator] starts a proof of name +(** [start_proof sigma id pl str goals] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this is (spiwack: for potential printing, I believe is used only by @@ -149,21 +82,21 @@ let discard_current (_, psl) = end of the proof to close the proof. The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -let start_proof sigma name ?(pl=UState.default_univ_decl) kind goals terminator = - { terminator = CEphemeron.create terminator; - proof = Proof.start ~name ~poly:(pi2 kind) sigma goals; - endline_tactic = None; - section_vars = None; - universe_decl = pl; - strength = kind } - -let start_dependent_proof name ?(pl=UState.default_univ_decl) kind goals terminator = - { terminator = CEphemeron.create terminator; - proof = Proof.dependent_start ~name ~poly:(pi2 kind) goals; - endline_tactic = None; - section_vars = None; - universe_decl = pl; - strength = kind } +let start_proof sigma name ?(pl=UState.default_univ_decl) kind goals = + { proof = Proof.start ~name ~poly:(pi2 kind) sigma goals + ; endline_tactic = None + ; section_vars = None + ; universe_decl = pl + ; strength = kind + } + +let start_dependent_proof name ?(pl=UState.default_univ_decl) kind goals = + { proof = Proof.dependent_start ~name ~poly:(pi2 kind) goals + ; endline_tactic = None + ; section_vars = None + ; universe_decl = pl + ; strength = kind + } let get_used_variables pf = pf.section_vars let get_universe_decl pf = pf.universe_decl @@ -201,7 +134,7 @@ let get_open_goals ps = (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + List.length shelf -type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * UState.t +type closed_proof_output = (Constr.t * Evd.side_effects) list * UState.t let private_poly_univs = let b = ref true in @@ -217,7 +150,7 @@ let private_poly_univs = let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now (fpl : closed_proof_output Future.computation) ps = - let { section_vars; proof; terminator; universe_decl; strength } = ps in + let { section_vars; proof; universe_decl; strength } = ps in let Proof.{ name; poly; entry; initial_euctx } = Proof.data proof in let opaque = match opaque with Opaque -> true | Transparent -> false in let constrain_variables ctx = @@ -239,7 +172,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now let body = c in let allow_deferred = not poly && (keep_body_ucst_separate || - not (Safe_typing.empty_private_constants = eff)) + not (Safe_typing.empty_private_constants = eff.Evd.seff_private)) in let typ = if allow_deferred then t else nf t in let used_univs_body = Vars.universes_of_constr body in @@ -312,8 +245,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now in let entries = Future.map2 entry_fn fpl Proofview.(initial_goals entry) in { id = name; entries = entries; persistence = strength; - universes }, - fun pr_ending -> CEphemeron.get terminator pr_ending + universes } let return_proof ?(allow_partial=false) ps = let { proof } = ps in @@ -351,22 +283,9 @@ let close_proof ~opaque ~keep_body_ucst_separate fix_exn ps = close_proof ~opaque ~keep_body_ucst_separate ~now:true (Future.from_val ~fix_exn (return_proof ps)) ps -(** Gets the current terminator without checking that the proof has - been completed. Useful for the likes of [Admitted]. *) -let get_terminator ps = CEphemeron.get ps.terminator -let set_terminator hook ps = - { ps with terminator = CEphemeron.create hook } - -let copy_terminators ~src ~tgt = - let (ps, psl), (ts,tsl) = src, tgt in - assert(List.length psl = List.length tsl); - {ts with terminator = ps.terminator}, List.map2 (fun op p -> { p with terminator = op.terminator }) psl tsl - -let update_global_env pf = - let res, () = - with_proof (fun _ p -> - Proof.in_proof p (fun sigma -> - let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in - let (p,(status,info),()) = Proof.run_tactic (Global.env ()) tac p in - (p, ()))) pf - in res +let update_global_env = + map_proof (fun p -> + Proof.in_proof p (fun sigma -> + let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in + let p,(status,info),_ = Proof.run_tactic (Global.env ()) tac p in + p)) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index aff48b9636..f84ec27df7 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -13,18 +13,16 @@ environment. *) type t -type stack -val get_current_pstate : stack -> t - -val get_current_proof_name : t -> Names.Id.t -val get_current_persistence : t -> Decl_kinds.goal_kind -val get_all_proof_names : stack -> Names.Id.t list +(* Should be moved into a proper view *) +val get_proof : t -> Proof.t +val get_proof_name : t -> Names.Id.t +val get_persistence : t -> Decl_kinds.goal_kind +val get_used_variables : t -> Constr.named_context option -val discard : Names.lident -> stack -> stack option -val discard_current : stack -> stack option +(** Get the universe declaration associated to the current proof. *) +val get_universe_decl : t -> UState.universe_decl -val give_me_the_proof : t -> Proof.t val compact_the_proof : t -> t (** When a proof is closed, it is reified into a [proof_object], where @@ -37,30 +35,14 @@ type lemma_possible_guards = int list list type proof_object = { id : Names.Id.t; - entries : Safe_typing.private_constants Entries.definition_entry list; + entries : Evd.side_effects Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: UState.t; } type opacity_flag = Opaque | Transparent -type proof_ending = - | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * - UState.t - | Proved of opacity_flag * - Names.lident option * - proof_object -type proof_terminator -type closed_proof = proof_object * proof_terminator - -val make_terminator : (proof_ending -> unit) -> proof_terminator -val apply_terminator : proof_terminator -> proof_ending -> unit - -val push : ontop:stack option -> t -> stack - -val maybe_push : ontop:stack option -> t option -> stack option - -(** [start_proof ~ontop id str pl goals terminator] starts a proof of name +(** [start_proof id str pl goals] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this is; [terminator] is used at the end of the proof to close the proof @@ -68,16 +50,22 @@ val maybe_push : ontop:stack option -> t option -> stack option morphism). The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -val start_proof : - Evd.evar_map -> Names.Id.t -> ?pl:UState.universe_decl -> - Decl_kinds.goal_kind -> (Environ.env * EConstr.types) list -> - proof_terminator -> t +val start_proof + : Evd.evar_map + -> Names.Id.t + -> ?pl:UState.universe_decl + -> Decl_kinds.goal_kind + -> (Environ.env * EConstr.types) list + -> t (** Like [start_proof] except that there may be dependencies between initial goals. *) -val start_dependent_proof : - Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> - Proofview.telescope -> proof_terminator -> t +val start_dependent_proof + : Names.Id.t + -> ?pl:UState.universe_decl + -> Decl_kinds.goal_kind + -> Proofview.telescope + -> t (** Update the proofs global environment after a side-effecting command (e.g. a sublemma definition) has been run inside it. Assumes @@ -86,40 +74,25 @@ val update_global_env : t -> t (* Takes a function to add to the exceptions data relative to the state in which the proof was built *) -val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> - t -> closed_proof +val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> t -> proof_object (* Intermediate step necessary to delegate the future. * Both access the current proof state. The former is supposed to be * chained with a computation that completed the proof *) -type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * UState.t +type closed_proof_output = (Constr.t * Evd.side_effects) list * UState.t (* If allow_partial is set (default no) then an incomplete proof * is allowed (no error), and a warn is given if the proof is complete. *) val return_proof : ?allow_partial:bool -> t -> closed_proof_output val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> t -> - closed_proof_output Future.computation -> closed_proof + closed_proof_output Future.computation -> proof_object -(** Gets the current terminator without checking that the proof has - been completed. Useful for the likes of [Admitted]. *) -val get_terminator : t -> proof_terminator -val set_terminator : proof_terminator -> t -> t val get_open_goals : t -> int -(** Runs a tactic on the current proof. Raises [NoCurrentProof] is there is - no current proof. - The return boolean is set to [false] if an unsafe tactic has been used. *) -val with_current_proof : - (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> stack -> stack * 'a -val simple_with_current_proof : - (unit Proofview.tactic -> Proof.t -> Proof.t) -> stack -> stack - -val with_proof : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a -val modify_proof : (Proof.t -> Proof.t) -> t -> t - -val with_current_pstate : (t -> t * 'a) -> stack -> stack * 'a -val modify_current_pstate : (t -> t) -> stack -> stack +val map_proof : (Proof.t -> Proof.t) -> t -> t +val map_fold_proof : (Proof.t -> Proof.t * 'a) -> t -> t * 'a +val map_fold_proof_endline : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> t -> t * 'a (** Sets the tactic to be used when a tactic line is closed with [...] *) val set_endline_tactic : Genarg.glob_generic_argument -> t -> t @@ -129,10 +102,3 @@ val set_endline_tactic : Genarg.glob_generic_argument -> t -> t * ids to be cleared *) val set_used_variables : t -> Names.Id.t list -> (Constr.named_context * Names.lident list) * t - -val get_used_variables : t -> Constr.named_context option - -(** Get the universe declaration associated to the current proof. *) -val get_universe_decl : t -> UState.universe_decl - -val copy_terminators : src:stack -> tgt:stack -> stack diff --git a/proofs/refine.ml b/proofs/refine.ml index 4a9404aa96..d0e89183a8 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -60,7 +60,7 @@ let generic_refine ~typecheck f gl = let evs = Evd.save_future_goals sigma in (* Redo the effects in sigma in the monad's env *) let privates_csts = Evd.eval_side_effects sigma in - let env = Safe_typing.push_private_constants env privates_csts in + let env = Safe_typing.push_private_constants env privates_csts.Evd.seff_private in (* Check that the introduced evars are well-typed *) let fold accu ev = typecheck_evar ev env accu in let sigma = if typecheck then Evd.fold_future_goals fold sigma evs else sigma in @@ -116,9 +116,6 @@ let lift c = let make_refine_enter ~typecheck f gl = generic_refine ~typecheck (lift f) gl -let refine_one ~typecheck f = - Proofview.Goal.enter_one (make_refine_enter ~typecheck f) - let refine ~typecheck f = let f evd = let (evd,c) = f evd in (evd,((), c)) diff --git a/proofs/refine.mli b/proofs/refine.mli index b8948a92f3..93fd9d7a64 100644 --- a/proofs/refine.mli +++ b/proofs/refine.mli @@ -27,9 +27,6 @@ val refine : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> uni raised during the interpretation of [t] are caught and result in tactic failures. If [typecheck] is [true] [t] is type-checked beforehand. *) -val refine_one : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * ('a * EConstr.t)) -> 'a tactic -(** A variant of [refine] which assumes exactly one goal under focus *) - val generic_refine : typecheck:bool -> ('a * EConstr.t) tactic -> Proofview.Goal.t -> 'a tactic (** The general version of refine. *) diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 799f4a380b..557f428be9 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -129,9 +129,6 @@ let tclTHENSLASTn tac1 tac taci = tclTHENS3PARTS tac1 [||] tac taci let tclTHEN_i tac taci gls = finish_tac (thensi_tac taci (then_tac tac (start_tac gls))) -let tclTHENLASTn tac1 taci = tclTHENSLASTn tac1 tclIDTAC taci -let tclTHENFIRSTn tac1 taci = tclTHENSFIRSTn tac1 taci tclIDTAC - (* [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies [tac2] to every resulting subgoals *) let tclTHEN tac1 tac2 = tclTHENS3PARTS tac1 [||] tac2 [||] @@ -253,46 +250,9 @@ let rec tclFIRST = function | [] -> tclFAIL_s "No applicable tactic." | t::rest -> tclORELSE0 t (tclFIRST rest) -let ite_gen tcal tac_if continue tac_else gl= - let success=ref false in - let tac_if0 gl= - let result=tac_if gl in - success:=true;result in - let tac_else0 e gl= - if !success then - iraise e - else - try - tac_else gl - with - e' when CErrors.noncritical e' -> iraise e in - try - tcal tac_if0 continue gl - with (* Breakpoint *) - | e when CErrors.noncritical e -> - let e = CErrors.push e in catch_failerror e; tac_else0 e gl - -(* Try the first tactic and, if it succeeds, continue with - the second one, and if it fails, use the third one *) - -let tclIFTHENELSE=ite_gen tclTHEN - -(* Idem with tclTHENS and tclTHENSV *) - -let tclIFTHENSELSE=ite_gen tclTHENS - -let tclIFTHENSVELSE=ite_gen tclTHENSV - -let tclIFTHENTRYELSEMUST tac1 tac2 gl = - tclIFTHENELSE tac1 (tclTRY tac2) tac2 gl - (* Fails if a tactic did not solve the goal *) let tclCOMPLETE tac = tclTHEN tac (tclFAIL_s "Proof is not complete.") -(* Try the first that solves the current goal *) -let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl) - - (* Iteration tacticals *) let tclDO n t = @@ -311,22 +271,7 @@ let rec tclREPEAT t g = let tclAT_LEAST_ONCE t = (tclTHEN t (tclREPEAT t)) -(* Repeat on the first subgoal (no failure if no more subgoal) *) -let rec tclREPEAT_MAIN t g = - (tclORELSE (tclTHEN_i t (fun i -> if Int.equal i 1 then (tclREPEAT_MAIN t) else - tclIDTAC)) tclIDTAC) g - (* Change evars *) let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma} - -let tclEVARUNIVCONTEXT ctx gls = tclIDTAC {gls with sigma= Evd.set_universe_context gls.sigma ctx} - -(* Push universe context *) -let tclPUSHCONTEXT rigid ctx tac gl = - tclTHEN (tclEVARS (Evd.merge_context_set rigid (project gl) ctx)) tac gl - let tclPUSHEVARUNIVCONTEXT ctx gl = tclEVARS (Evd.merge_universe_context (project gl) ctx) gl - -let tclPUSHCONSTRAINTS cst gl = - tclEVARS (Evd.add_constraints (project gl) cst) gl diff --git a/proofs/refiner.mli b/proofs/refiner.mli index 52cbf7658b..0f34a79c49 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -32,12 +32,8 @@ val tclIDTAC_MESSAGE : Pp.t -> tactic (** [tclEVARS sigma] changes the current evar map *) val tclEVARS : evar_map -> tactic -val tclEVARUNIVCONTEXT : UState.t -> tactic - -val tclPUSHCONTEXT : Evd.rigid -> Univ.ContextSet.t -> tactic -> tactic val tclPUSHEVARUNIVCONTEXT : UState.t -> tactic -val tclPUSHCONSTRAINTS : Univ.Constraint.t -> tactic (** [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies [tac2] to every resulting subgoals *) @@ -86,16 +82,6 @@ val tclTHENSLASTn : tactic -> tactic -> tactic array -> tactic [tac2] for the remaining last subgoals (previously called tclTHENST) *) val tclTHENSFIRSTn : tactic -> tactic array -> tactic -> tactic -(** [tclTHENLASTn tac1 [t1 ; ... ; tn] gls] first applies [tac1] then, - applies [t1],...,[tn] on the last [n] resulting subgoals and leaves - unchanged the other subgoals *) -val tclTHENLASTn : tactic -> tactic array -> tactic - -(** [tclTHENFIRSTn tac1 [t1 ; ... ; tn] gls] first applies [tac1] then, - applies [t1],...,[tn] on the first [n] resulting subgoals and leaves - unchanged the other subgoals (previously called [tclTHENSI]) *) -val tclTHENFIRSTn : tactic -> tactic array -> tactic - (** A special exception for levels for the Fail tactic *) exception FailError of int * Pp.t Lazy.t @@ -106,9 +92,7 @@ val catch_failerror : Exninfo.iexn -> unit val tclORELSE0 : tactic -> tactic -> tactic val tclORELSE : tactic -> tactic -> tactic val tclREPEAT : tactic -> tactic -val tclREPEAT_MAIN : tactic -> tactic val tclFIRST : tactic list -> tactic -val tclSOLVE : tactic list -> tactic val tclTRY : tactic -> tactic val tclTHENTRY : tactic -> tactic -> tactic val tclCOMPLETE : tactic -> tactic @@ -118,16 +102,3 @@ val tclFAIL_lazy : int -> Pp.t Lazy.t -> tactic val tclDO : int -> tactic -> tactic val tclPROGRESS : tactic -> tactic val tclSHOWHYPS : tactic -> tactic - -(** [tclIFTHENELSE tac1 tac2 tac3 gls] first applies [tac1] to [gls] then, - if it succeeds, applies [tac2] to the resulting subgoals, - and if not applies [tac3] to the initial goal [gls] *) -val tclIFTHENELSE : tactic -> tactic -> tactic -> tactic -val tclIFTHENSELSE : tactic -> tactic list -> tactic ->tactic -val tclIFTHENSVELSE : tactic -> tactic array -> tactic ->tactic - -(** [tclIFTHENTRYELSEMUST tac1 tac2 gls] applies [tac1] then [tac2]. If [tac1] - has been successful, then [tac2] may fail. Otherwise, [tac2] must succeed. - Equivalent to [(tac1;try tac2)||tac2] *) - -val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 93031c2202..d7b4f729cb 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -81,12 +81,10 @@ let pf_type_of = pf_reduce type_of let pf_get_type_of = pf_reduce Retyping.get_type_of let pf_conv_x gl = pf_reduce test_conversion gl Reduction.CONV -let pf_conv_x_leq gl = pf_reduce test_conversion gl Reduction.CUMUL let pf_const_value = pf_reduce (fun env _ c -> EConstr.of_constr (constant_value_in env c)) let pf_reduce_to_quantified_ind = pf_reduce reduce_to_quantified_ind let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind - let pf_hnf_type_of gls = pf_get_type_of gls %> pf_whd_all gls (* Pretty-printers *) @@ -181,14 +179,7 @@ module New = struct let pf_hnf_type_of gl t = pf_whd_all gl (pf_get_type_of gl t) - let pf_whd_all gl t = pf_apply whd_all gl t let pf_compute gl t = pf_apply compute gl t let pf_nf_evar gl t = nf_evar (project gl) t - - let pf_undefined_evars gl = - let sigma = Proofview.Goal.sigma gl in - let ev = Proofview.Goal.goal gl in - let evi = Evd.find sigma ev in - Evarutil.filtered_undefined_evars_of_evar_info sigma evi end diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 23e1e6f566..195be04986 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -64,7 +64,6 @@ val pf_unfoldn : (occurrences * evaluable_global_reference) list val pf_const_value : Goal.goal sigma -> pconstant -> constr val pf_conv_x : Goal.goal sigma -> constr -> constr -> bool -val pf_conv_x_leq : Goal.goal sigma -> constr -> constr -> bool (** {6 Pretty-printing functions (debug only). } *) val pr_gls : Goal.goal sigma -> Pp.t @@ -109,11 +108,8 @@ module New : sig val pf_hnf_constr : Proofview.Goal.t -> constr -> types val pf_hnf_type_of : Proofview.Goal.t -> constr -> types - val pf_whd_all : Proofview.Goal.t -> constr -> constr val pf_compute : Proofview.Goal.t -> constr -> constr val pf_nf_evar : Proofview.Goal.t -> constr -> constr - (** Gathers the undefined evars of the given goal. *) - val pf_undefined_evars : Proofview.Goal.t -> Evar.Set.t end diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index dfa681395a..7ff6ed9dfb 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -48,15 +48,14 @@ let simple_goal sigma g gs = let is_focused_goal_simple ~doc id = match state_of_id ~doc id with | `Expired | `Error _ | `Valid None -> `Not - | `Valid (Some { Vernacstate.proof }) -> - Option.cata (fun proof -> - let proof = Proof_global.get_current_pstate proof in - let proof = Proof_global.give_me_the_proof proof in + | `Valid (Some { Vernacstate.lemmas }) -> + Option.cata (Lemmas.Stack.with_top_pstate ~f:(fun proof -> + let proof = Proof_global.get_proof proof in let Proof.{ goals=focused; stack=r1; shelf=r2; given_up=r3; sigma } = Proof.data proof in let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in if List.for_all (fun x -> simple_goal sigma x rest) focused then `Simple focused - else `Not) `Not proof + else `Not)) `Not lemmas type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ] diff --git a/stm/stm.ml b/stm/stm.ml index 0efea0b8e0..1e89d6937c 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -881,7 +881,7 @@ end = struct (* {{{ *) let invalidate_cur_state () = cur_id := Stateid.dummy type proof_part = - Proof_global.stack option * + Lemmas.Stack.t option * int * (* Evarutil.meta_counter_summary_tag *) int * (* Evd.evar_counter_summary_tag *) Obligations.program_info Names.Id.Map.t (* Obligations.program_tcc_summary_tag *) @@ -890,9 +890,9 @@ end = struct (* {{{ *) [ `Full of Vernacstate.t | `ProofOnly of Stateid.t * proof_part ] - let proof_part_of_frozen { Vernacstate.proof; system } = + let proof_part_of_frozen { Vernacstate.lemmas; system } = let st = States.summary_of_state system in - proof, + lemmas, Summary.project_from_summary st Util.(pi1 summary_pstate), Summary.project_from_summary st Util.(pi2 summary_pstate), Summary.project_from_summary st Util.(pi3 summary_pstate) @@ -956,17 +956,17 @@ end = struct (* {{{ *) try let prev = (VCS.visit id).next in if is_cached_and_valid prev - then { s with proof = + then { s with lemmas = PG_compat.copy_terminators - ~src:((get_cached prev).proof) ~tgt:s.proof } + ~src:((get_cached prev).lemmas) ~tgt:s.lemmas } else s with VCS.Expired -> s in VCS.set_state id (FullState s) | `ProofOnly(ontop,(pstate,c1,c2,c3)) -> if is_cached_and_valid ontop then let s = get_cached ontop in - let s = { s with proof = - PG_compat.copy_terminators ~src:s.proof ~tgt:pstate } in + let s = { s with lemmas = + PG_compat.copy_terminators ~src:s.lemmas ~tgt:pstate } in let s = { s with system = States.replace_summary s.system begin @@ -1168,9 +1168,7 @@ end = struct (* {{{ *) let get_proof ~doc id = match state_of_id ~doc id with - | `Valid (Some vstate) -> - Option.map (fun p -> Proof_global.(give_me_the_proof (get_current_pstate p))) - vstate.Vernacstate.proof + | `Valid (Some vstate) -> Option.map (Lemmas.Stack.with_top_pstate ~f:Proof_global.get_proof) vstate.Vernacstate.lemmas | _ -> None let undo_vernac_classifier v ~doc = @@ -1639,7 +1637,7 @@ and Slaves : sig val info_tasks : 'a tasks -> (string * float * int) list val finish_task : string -> - Library.seg_univ -> Library.seg_discharge -> Library.seg_proofs -> + Library.seg_univ -> Library.seg_proofs -> int tasks -> int -> Library.seg_univ val cancel_worker : WorkerPool.worker_id -> unit @@ -1675,14 +1673,17 @@ end = struct (* {{{ *) let _proof = PG_compat.return_proof ~allow_partial:true () in `OK_ADMITTED else begin - (* The original terminator, a hook, has not been saved in the .vio*) - PG_compat.set_terminator (Lemmas.standard_proof_terminator []); - let opaque = Proof_global.Opaque in - let proof = + + (* The original terminator, a hook, has not been saved in the .vio*) + let pterm, _invalid_terminator = PG_compat.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in + + let proof = pterm , Lemmas.standard_proof_terminator [] in + (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) + Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false start; (* STATE SPEC: * - start: First non-expired state! [This looks very fishy] @@ -1724,7 +1725,7 @@ end = struct (* {{{ *) str (Printexc.to_string e))); if drop then `ERROR_ADMITTED else `ERROR - let finish_task name (cst,_) d p l i = + let finish_task name (cst,_) p l i = let { Stateid.uuid = bucket }, drop = List.nth l i in let bucket_name = if bucket < 0 then (assert drop; ", no bucket") @@ -1734,7 +1735,6 @@ end = struct (* {{{ *) | `ERROR_ADMITTED -> cst, false | `OK_ADMITTED -> cst, false | `OK (po,_) -> - let discharge c = List.fold_right Cooking.cook_constr d.(bucket) c in let con = Nametab.locate_constant (Libnames.qualid_of_ident po.Proof_global.id) in @@ -1746,12 +1746,14 @@ end = struct (* {{{ *) the call to [check_task_aux] above. *) let uc = Opaqueproof.force_constraints Library.indirect_accessor (Global.opaque_tables ()) o in let uc = Univ.hcons_universe_context_set uc in + let (pr, ctx) = Option.get (Global.body_of_constant_body Library.indirect_accessor c) in (* We only manipulate monomorphic terms here. *) - let map (c, ctx) = assert (Univ.AUContext.is_empty ctx); c in - let pr = map (Option.get (Global.body_of_constant_body Library.indirect_accessor c)) in - let pr = discharge pr in + let () = assert (Univ.AUContext.is_empty ctx) in let pr = Constr.hcons pr in - p.(bucket) <- Some pr; + let (ci, univs, dummy) = p.(bucket) in + let () = assert (Option.is_empty dummy) in + let () = assert (Int.equal (Univ.AUContext.size ctx) univs) in + p.(bucket) <- ci, univs, Some pr; Univ.ContextSet.union cst uc, false let check_task name l i = @@ -1938,7 +1940,7 @@ end = struct (* {{{ *) "goals only")) else begin let (i, ast) = r_ast in - PG_compat.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); + PG_compat.map_proof (fun p -> Proof.focus focus_cond () i p); (* STATE SPEC: * - start : id * - return: id @@ -1994,7 +1996,7 @@ end = struct (* {{{ *) stm_fail ~st fail (fun () -> (if time then System.with_time ~batch ~header:(Pp.mt ()) else (fun x -> x)) (fun () -> TaskQueue.with_n_workers nworkers (fun queue -> - PG_compat.simple_with_current_proof (fun _ p -> + PG_compat.map_proof (fun p -> let Proof.{goals} = Proof.data p in let open TacTask in let res = CList.map_i (fun i g -> @@ -2309,8 +2311,8 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = Proofview.give_up else Proofview.tclUNIT () end in match (VCS.get_info base_state).state with - | FullState { Vernacstate.proof } -> - Option.iter PG_compat.unfreeze proof; + | FullState { Vernacstate.lemmas } -> + Option.iter PG_compat.unfreeze lemmas; PG_compat.with_current_proof (fun _ p -> feedback ~id:id Feedback.AddedAxiom; fst (Pfedit.solve Goal_select.SelectAll None tac p), ()); @@ -2747,11 +2749,11 @@ let check_task name (tasks,rcbackup) i = with e when CErrors.noncritical e -> VCS.restore vcs; false let info_tasks (tasks,_) = Slaves.info_tasks tasks -let finish_tasks name u d p (t,rcbackup as tasks) = +let finish_tasks name u p (t,rcbackup as tasks) = RemoteCounter.restore rcbackup; let finish_task u (_,_,i) = let vcs = VCS.backup () in - let u = State.purify (Slaves.finish_task name u d p t) i in + let u = State.purify (Slaves.finish_task name u p t) i in VCS.restore vcs; u in try diff --git a/stm/stm.mli b/stm/stm.mli index 5e1e9bf5ad..86e2566539 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -167,7 +167,7 @@ type tasks val check_task : string -> tasks -> int -> bool val info_tasks : tasks -> (string * float * int) list val finish_tasks : string -> - Library.seg_univ -> Library.seg_discharge -> Library.seg_proofs -> + Library.seg_univ -> Library.seg_proofs -> tasks -> Library.seg_univ * Library.seg_proofs (* Id of the tip of the current branch *) diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index 0f78e0acf6..cf0c8934b0 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -12,7 +12,7 @@ open Util let check_vio (ts,f_in) = Dumpglob.noglob (); - let _, _, _, _, tasks, _ = Library.load_library_todo f_in in + let _, _, _, tasks, _ = Library.load_library_todo f_in in Stm.set_compilation_hints f_in; List.fold_left (fun acc ids -> Stm.check_task f_in tasks ids && acc) true ts @@ -29,7 +29,7 @@ let schedule_vio_checking j fs = if j < 1 then CErrors.user_err Pp.(str "The number of workers must be bigger than 0"); let jobs = ref [] in List.iter (fun long_f_dot_vio -> - let _,_,_,_, tasks, _ = Library.load_library_todo long_f_dot_vio in + let _,_,_, tasks, _ = Library.load_library_todo long_f_dot_vio in Stm.set_compilation_hints long_f_dot_vio; let infos = Stm.info_tasks tasks in let eta = List.fold_left (fun a (_,t,_) -> a +. t) 0.0 infos in diff --git a/tactics/abstract.ml b/tactics/abstract.ml index a5b2f99457..967b0ef418 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -103,8 +103,8 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = question, how does abstract behave when discharge is local for example? *) let goal_kind, suffix = if opaque - then (Global,poly,Proof Theorem), "_subproof" - else (Global,poly,DefinitionBody Definition), "_subterm" in + then (Global ImportDefaultBehavior,poly,Proof Theorem), "_subproof" + else (Global ImportDefaultBehavior,poly,DefinitionBody Definition), "_subterm" in let id, goal_kind = name_op_to_name ~name_op ~name ~goal_kind suffix in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -158,7 +158,7 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = (* do not compute the implicit arguments, it may be costly *) let () = Impargs.make_implicit_args false in (* ppedrot: seems legit to have abstracted subproofs as local*) - Declare.declare_private_constant ~role:Entries.Subproof ~internal:Declare.InternalTacticRequest ~local:true id decl + Declare.declare_private_constant ~internal:Declare.InternalTacticRequest ~local:ImportNeedQualified id decl in let cst, eff = Impargs.with_implicit_protection cst () in let inst = match const.Entries.const_entry_universes with @@ -173,8 +173,7 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = in let lem = mkConstU (cst, inst) in let evd = Evd.set_universe_context evd ectx in - let open Safe_typing in - let effs = concat_private eff + let effs = Evd.concat_side_effects eff Entries.(snd (Future.force const.const_entry_body)) in let solve = Proofview.tclEFFECTS effs <*> diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 1170c1acd0..06449c38a8 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -51,7 +51,7 @@ let optimize_non_type_induction_scheme kind dep sort _ ind = else let sigma, pind = Evd.fresh_inductive_instance env sigma ind in let sigma, c = build_induction_scheme env sigma pind dep sort in - (c, Evd.evar_universe_context sigma), Safe_typing.empty_private_constants + (c, Evd.evar_universe_context sigma), Evd.empty_side_effects let build_induction_scheme_in_type dep sort ind = let env = Global.env () in @@ -59,18 +59,18 @@ let build_induction_scheme_in_type dep sort ind = let sigma, pind = Evd.fresh_inductive_instance env sigma ind in let sigma, c = build_induction_scheme env sigma pind dep sort in c, Evd.evar_universe_context sigma - + let rect_scheme_kind_from_type = declare_individual_scheme_object "_rect_nodep" - (fun _ x -> build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) + (fun _ x -> build_induction_scheme_in_type false InType x, Evd.empty_side_effects) let rect_scheme_kind_from_prop = declare_individual_scheme_object "_rect" ~aux:"_rect_from_prop" - (fun _ x -> build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) + (fun _ x -> build_induction_scheme_in_type false InType x, Evd.empty_side_effects) let rect_dep_scheme_kind_from_type = declare_individual_scheme_object "_rect" ~aux:"_rect_from_type" - (fun _ x -> build_induction_scheme_in_type true InType x, Safe_typing.empty_private_constants) + (fun _ x -> build_induction_scheme_in_type true InType x, Evd.empty_side_effects) let rec_scheme_kind_from_type = declare_individual_scheme_object "_rec_nodep" ~aux:"_rec_nodep_from_type" @@ -90,7 +90,7 @@ let ind_scheme_kind_from_type = let sind_scheme_kind_from_type = declare_individual_scheme_object "_sind_nodep" - (fun _ x -> build_induction_scheme_in_type false InSProp x, Safe_typing.empty_private_constants) + (fun _ x -> build_induction_scheme_in_type false InSProp x, Evd.empty_side_effects) let ind_dep_scheme_kind_from_type = declare_individual_scheme_object "_ind" ~aux:"_ind_from_type" @@ -98,7 +98,7 @@ let ind_dep_scheme_kind_from_type = let sind_dep_scheme_kind_from_type = declare_individual_scheme_object "_sind" ~aux:"_sind_from_type" - (fun _ x -> build_induction_scheme_in_type true InSProp x, Safe_typing.empty_private_constants) + (fun _ x -> build_induction_scheme_in_type true InSProp x, Evd.empty_side_effects) let ind_scheme_kind_from_prop = declare_individual_scheme_object "_ind" ~aux:"_ind_from_prop" @@ -106,8 +106,18 @@ let ind_scheme_kind_from_prop = let sind_scheme_kind_from_prop = declare_individual_scheme_object "_sind" ~aux:"_sind_from_prop" - (fun _ x -> build_induction_scheme_in_type false InSProp x, Safe_typing.empty_private_constants) - + (fun _ x -> build_induction_scheme_in_type false InSProp x, Evd.empty_side_effects) + +let nondep_elim_scheme from_kind to_kind = + match from_kind, to_kind with + | InProp, InProp -> ind_scheme_kind_from_prop + | InProp, InSProp -> sind_scheme_kind_from_prop + | InProp, InSet -> rec_scheme_kind_from_prop + | InProp, InType -> rect_scheme_kind_from_prop + | _ , InProp -> ind_scheme_kind_from_type + | _ , InSProp -> sind_scheme_kind_from_type + | _ , InSet -> rec_scheme_kind_from_type + | _ , InType -> rect_scheme_kind_from_type (* Case analysis *) @@ -120,24 +130,24 @@ let build_case_analysis_scheme_in_type dep sort ind = let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" - (fun _ x -> build_case_analysis_scheme_in_type false InType x, Safe_typing.empty_private_constants) + (fun _ x -> build_case_analysis_scheme_in_type false InType x, Evd.empty_side_effects) let case_scheme_kind_from_prop = declare_individual_scheme_object "_case" ~aux:"_case_from_prop" - (fun _ x -> build_case_analysis_scheme_in_type false InType x, Safe_typing.empty_private_constants) + (fun _ x -> build_case_analysis_scheme_in_type false InType x, Evd.empty_side_effects) let case_dep_scheme_kind_from_type = declare_individual_scheme_object "_case" ~aux:"_case_from_type" - (fun _ x -> build_case_analysis_scheme_in_type true InType x, Safe_typing.empty_private_constants) + (fun _ x -> build_case_analysis_scheme_in_type true InType x, Evd.empty_side_effects) let case_dep_scheme_kind_from_type_in_prop = declare_individual_scheme_object "_casep_dep" - (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Safe_typing.empty_private_constants) + (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Evd.empty_side_effects) let case_dep_scheme_kind_from_prop = declare_individual_scheme_object "_case_dep" - (fun _ x -> build_case_analysis_scheme_in_type true InType x, Safe_typing.empty_private_constants) + (fun _ x -> build_case_analysis_scheme_in_type true InType x, Evd.empty_side_effects) let case_dep_scheme_kind_from_prop_in_prop = declare_individual_scheme_object "_casep" - (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Safe_typing.empty_private_constants) + (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Evd.empty_side_effects) diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli index 4472792449..2b8a053cc0 100644 --- a/tactics/elimschemes.mli +++ b/tactics/elimschemes.mli @@ -18,7 +18,7 @@ val optimize_non_type_induction_scheme : Sorts.family -> 'b -> Names.inductive -> - (Constr.constr * UState.t) * Safe_typing.private_constants + (Constr.constr * UState.t) * Evd.side_effects val rect_scheme_kind_from_prop : individual scheme_kind val ind_scheme_kind_from_prop : individual scheme_kind @@ -33,6 +33,7 @@ val sind_dep_scheme_kind_from_type : individual scheme_kind val rec_scheme_kind_from_type : individual scheme_kind val rec_dep_scheme_kind_from_type : individual scheme_kind +val nondep_elim_scheme : Sorts.family -> Sorts.family -> individual scheme_kind (** Case analysis schemes *) diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 3fdd97616f..d66ae9cb24 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -229,7 +229,7 @@ let sym_scheme_kind = declare_individual_scheme_object "_sym_internal" (fun _ ind -> let c, ctx = build_sym_scheme (Global.env() (* side-effect! *)) ind in - (c, ctx), Safe_typing.empty_private_constants) + (c, ctx), Evd.empty_side_effects) (**********************************************************************) (* Build the involutivity of symmetry for an inductive type *) @@ -455,7 +455,7 @@ let build_l2r_rew_scheme dep env ind kind = else main_body)))))) in (c, UState.of_context_set ctx), - Safe_typing.concat_private eff' eff + Evd.concat_side_effects eff' eff (**********************************************************************) (* Build the left-to-right rewriting lemma for hypotheses associated *) @@ -708,7 +708,7 @@ let rew_l2r_dep_scheme_kind = (**********************************************************************) let rew_r2l_dep_scheme_kind = declare_individual_scheme_object "_rew_dep" - (fun _ ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) + (fun _ ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Evd.empty_side_effects) (**********************************************************************) (* Dependent rewrite from right-to-left in hypotheses *) @@ -718,7 +718,7 @@ let rew_r2l_dep_scheme_kind = (**********************************************************************) let rew_r2l_forward_dep_scheme_kind = declare_individual_scheme_object "_rew_fwd_dep" - (fun _ ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) + (fun _ ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Evd.empty_side_effects) (**********************************************************************) (* Dependent rewrite from left-to-right in hypotheses *) @@ -728,7 +728,7 @@ let rew_r2l_forward_dep_scheme_kind = (**********************************************************************) let rew_l2r_forward_dep_scheme_kind = declare_individual_scheme_object "_rew_fwd_r_dep" - (fun _ ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) + (fun _ ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Evd.empty_side_effects) (**********************************************************************) (* Non-dependent rewrite from either left-to-right in conclusion or *) @@ -742,7 +742,7 @@ let rew_l2r_forward_dep_scheme_kind = let rew_l2r_scheme_kind = declare_individual_scheme_object "_rew_r" (fun _ ind -> fix_r2l_forward_rew_scheme - (build_r2l_forward_rew_scheme false (Global.env()) ind InType), Safe_typing.empty_private_constants) + (build_r2l_forward_rew_scheme false (Global.env()) ind InType), Evd.empty_side_effects) (**********************************************************************) (* Non-dependent rewrite from either right-to-left in conclusion or *) @@ -752,7 +752,7 @@ let rew_l2r_scheme_kind = (**********************************************************************) let rew_r2l_scheme_kind = declare_individual_scheme_object "_rew" - (fun _ ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Safe_typing.empty_private_constants) + (fun _ ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Evd.empty_side_effects) (* End of rewriting schemes *) @@ -836,4 +836,4 @@ let congr_scheme_kind = declare_individual_scheme_object "_congr" (fun _ ind -> (* May fail if equality is not defined *) build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, - Safe_typing.empty_private_constants) + Evd.empty_side_effects) diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli index 4749aebd96..c15fa146d4 100644 --- a/tactics/eqschemes.mli +++ b/tactics/eqschemes.mli @@ -27,7 +27,7 @@ val rew_r2l_scheme_kind : individual scheme_kind val build_r2l_rew_scheme : bool -> env -> inductive -> Sorts.family -> constr Evd.in_evar_universe_context val build_l2r_rew_scheme : bool -> env -> inductive -> Sorts.family -> - constr Evd.in_evar_universe_context * Safe_typing.private_constants + constr Evd.in_evar_universe_context * Evd.side_effects val build_r2l_forward_rew_scheme : bool -> env -> inductive -> Sorts.family -> constr Evd.in_evar_universe_context val build_l2r_forward_rew_scheme : @@ -39,7 +39,7 @@ val build_sym_scheme : env -> inductive -> constr Evd.in_evar_universe_context val sym_scheme_kind : individual scheme_kind val build_sym_involutive_scheme : env -> inductive -> - constr Evd.in_evar_universe_context * Safe_typing.private_constants + constr Evd.in_evar_universe_context * Evd.side_effects val sym_involutive_scheme_kind : individual scheme_kind (** Builds a congruence scheme for an equality type *) diff --git a/tactics/equality.ml b/tactics/equality.ml index 51eee2a053..ec0876110b 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -352,35 +352,35 @@ let find_elim hdcncl lft2rgt dep cls ot = (is_global_exists "core.JMeq.type" hdcncl && jmeq_same_dom env sigma ot)) && not dep then - let c = + let c = match EConstr.kind sigma hdcncl with - | Ind (ind_sp,u) -> - let pr1 = + | Ind (ind_sp,u) -> + let pr1 = lookup_eliminator env ind_sp (elimination_sort_of_clause cls gl) - in + in begin match lft2rgt, cls with | Some true, None | Some false, Some _ -> - let c1 = destConstRef pr1 in + 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 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 - try - let _ = Global.lookup_constant c1' in - c1' - with Not_found -> + begin + try + 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 + | _ -> destConstRef pr1 end | _ -> (* cannot occur since we checked that we are in presence of Logic.eq or Jmeq just before *) assert false in - pf_constr_of_global (ConstRef c) + pf_constr_of_global (ConstRef c) else let scheme_name = match dep, lft2rgt, inccl with (* Non dependent case *) @@ -946,12 +946,12 @@ let build_coq_I () = pf_constr_of_global (lib_ref "core.True.I") let rec build_discriminator env sigma true_0 false_0 dirn c = function | [] -> let ind = get_type_of env sigma c in - build_selector env sigma dirn c ind true_0 false_0 + build_selector env sigma dirn c ind true_0 (fst false_0) | ((sp,cnum),argnum)::l -> let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in let subval = build_discriminator cnum_env sigma true_0 false_0 dirn newc l in - kont sigma subval (false_0,mkProp) + kont sigma subval false_0 (* Note: discrimination could be more clever: if some elimination is not allowed because of a large impredicative constructor in the @@ -983,25 +983,22 @@ let gen_absurdity id = absurd_term=False *) -let ind_scheme_of_eq lbeq = +let ind_scheme_of_eq lbeq to_kind = let (mib,mip) = Global.lookup_inductive (destIndRef lbeq.eq) in - let kind = inductive_sort_family mip in + let from_kind = inductive_sort_family mip in (* use ind rather than case by compatibility *) - let kind = - if kind == InProp then Elimschemes.ind_scheme_kind_from_prop - else Elimschemes.ind_scheme_kind_from_type in + let kind = Elimschemes.nondep_elim_scheme from_kind to_kind in let c, eff = find_scheme kind (destIndRef lbeq.eq) in ConstRef c, eff -let discrimination_pf e (t,t1,t2) discriminator lbeq = +let discrimination_pf e (t,t1,t2) discriminator lbeq to_kind = build_coq_I () >>= fun i -> - build_coq_False () >>= fun absurd_term -> - let eq_elim, eff = ind_scheme_of_eq lbeq in + let eq_elim, eff = ind_scheme_of_eq lbeq to_kind in Proofview.tclEFFECTS eff <*> pf_constr_of_global eq_elim >>= fun eq_elim -> Proofview.tclUNIT - (applist (eq_elim, [t;t1;mkNamedLambda (make_annot e Sorts.Relevant) t discriminator;i;t2]), absurd_term) + (applist (eq_elim, [t;t1;mkNamedLambda (make_annot e Sorts.Relevant) t discriminator;i;t2])) let eq_baseid = Id.of_string "e" @@ -1018,21 +1015,23 @@ let apply_on_clause (f,t) clause = let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = build_coq_True () >>= fun true_0 -> build_coq_False () >>= fun false_0 -> + let false_ty = Retyping.get_type_of env sigma false_0 in + let false_kind = Retyping.get_sort_family_of env sigma false_0 in let e = next_ident_away eq_baseid (vars_of_env env) in let e_env = push_named (Context.Named.Declaration.LocalAssum (make_annot e Sorts.Relevant,t)) env in let discriminator = try Proofview.tclUNIT - (build_discriminator e_env sigma true_0 false_0 dirn (mkVar e) cpath) + (build_discriminator e_env sigma true_0 (false_0,false_ty) dirn (mkVar e) cpath) with UserError _ as ex -> Proofview.tclZERO ex in discriminator >>= fun discriminator -> - discrimination_pf e (t,t1,t2) discriminator lbeq >>= fun (pf, absurd_term) -> - let pf_ty = mkArrow eqn Sorts.Relevant absurd_term in + discrimination_pf e (t,t1,t2) discriminator lbeq false_kind >>= fun pf -> + let pf_ty = mkArrow eqn Sorts.Relevant false_0 in let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in let pf = Clenvtac.clenv_value_cast_meta absurd_clause in - tclTHENS (assert_after Anonymous absurd_term) + tclTHENS (assert_after Anonymous false_0) [onLastHypId gen_absurdity; (Proofview.V82.tactic (Refiner.refiner ~check:true EConstr.Unsafe.(to_constr pf)))] let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = diff --git a/tactics/hints.ml b/tactics/hints.ml index cc56c1c425..6fcb37d87c 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1518,7 +1518,7 @@ let pr_hint_term env sigma cl = (* print all hints that apply to the concl of the current goal *) let pr_applicable_hint pf = let env = Global.env () in - let pts = Proof_global.give_me_the_proof pf in + let pts = Proof_global.get_proof pf in let Proof.{goals;sigma} = Proof.data pts in match goals with | [] -> CErrors.user_err Pp.(str "No focused goal.") diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index b9485b8823..539fe31416 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -31,9 +31,9 @@ open Pp (* Registering schemes in the environment *) type mutual_scheme_object_function = - internal_flag -> MutInd.t -> constr array Evd.in_evar_universe_context * Safe_typing.private_constants + internal_flag -> MutInd.t -> constr array Evd.in_evar_universe_context * Evd.side_effects type individual_scheme_object_function = - internal_flag -> inductive -> constr Evd.in_evar_universe_context * Safe_typing.private_constants + internal_flag -> inductive -> constr Evd.in_evar_universe_context * Evd.side_effects type 'a scheme_kind = string @@ -124,7 +124,7 @@ let define internal role id c poly univs = let entry = { const_entry_body = Future.from_val ((c,Univ.ContextSet.empty), - Safe_typing.empty_private_constants); + Evd.empty_side_effects); const_entry_secctx = None; const_entry_type = None; const_entry_universes = univs; @@ -145,10 +145,10 @@ let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = let id = match idopt with | Some id -> id | None -> add_suffix mib.mind_packets.(i).mind_typename suff in - let role = Entries.Schema (ind, kind) in + let role = Evd.Schema (ind, kind) in let const, neff = define mode role id c (Declareops.inductive_is_polymorphic mib) ctx in declare_scheme kind [|ind,const|]; - const, Safe_typing.concat_private neff eff + const, Evd.concat_side_effects neff eff let define_individual_scheme kind mode names (mind,i as ind) = match Hashtbl.find scheme_object_table kind with @@ -163,9 +163,9 @@ let define_mutual_scheme_base kind suff f mode names mind = try Int.List.assoc i names with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in let fold i effs id cl = - let role = Entries.Schema ((mind, i), kind)in + let role = Evd.Schema ((mind, i), kind)in let cst, neff = define mode role id cl (Declareops.inductive_is_polymorphic mib) ctx in - (Safe_typing.concat_private neff effs, cst) + (Evd.concat_side_effects neff effs, cst) in let (eff, consts) = Array.fold_left2_map_i fold eff ids cl in let schemes = Array.mapi (fun i cst -> ((mind,i),cst)) consts in @@ -180,7 +180,7 @@ let define_mutual_scheme kind mode names mind = let find_scheme_on_env_too kind ind = let s = String.Map.find kind (Indmap.find ind !scheme_map) in - s, Safe_typing.empty_private_constants + s, Evd.empty_side_effects let find_scheme ?(mode=InternalTacticRequest) kind (mind,i as ind) = try find_scheme_on_env_too kind ind diff --git a/tactics/ind_tables.mli b/tactics/ind_tables.mli index 0eb4e47aeb..460b1f1b07 100644 --- a/tactics/ind_tables.mli +++ b/tactics/ind_tables.mli @@ -22,9 +22,9 @@ type individual type 'a scheme_kind type mutual_scheme_object_function = - internal_flag -> MutInd.t -> constr array Evd.in_evar_universe_context * Safe_typing.private_constants + internal_flag -> MutInd.t -> constr array Evd.in_evar_universe_context * Evd.side_effects type individual_scheme_object_function = - internal_flag -> inductive -> constr Evd.in_evar_universe_context * Safe_typing.private_constants + internal_flag -> inductive -> constr Evd.in_evar_universe_context * Evd.side_effects (** Main functions to register a scheme builder *) @@ -39,13 +39,13 @@ val declare_individual_scheme_object : string -> ?aux:string -> val define_individual_scheme : individual scheme_kind -> internal_flag (** internal *) -> - Id.t option -> inductive -> Constant.t * Safe_typing.private_constants + Id.t option -> inductive -> Constant.t * Evd.side_effects val define_mutual_scheme : mutual scheme_kind -> internal_flag (** internal *) -> - (int * Id.t) list -> MutInd.t -> Constant.t array * Safe_typing.private_constants + (int * Id.t) list -> MutInd.t -> Constant.t array * Evd.side_effects (** Main function to retrieve a scheme in the cache or to generate it *) -val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> Constant.t * Safe_typing.private_constants +val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> Constant.t * Evd.side_effects val check_scheme : 'a scheme_kind -> inductive -> bool diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 59fd8b37d6..81700986ea 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -43,12 +43,8 @@ let tclTHENS = Refiner.tclTHENS let tclTHENSV = Refiner.tclTHENSV let tclTHENSFIRSTn = Refiner.tclTHENSFIRSTn let tclTHENSLASTn = Refiner.tclTHENSLASTn -let tclTHENFIRSTn = Refiner.tclTHENFIRSTn -let tclTHENLASTn = Refiner.tclTHENLASTn let tclREPEAT = Refiner.tclREPEAT -let tclREPEAT_MAIN = Refiner.tclREPEAT_MAIN let tclFIRST = Refiner.tclFIRST -let tclSOLVE = Refiner.tclSOLVE let tclTRY = Refiner.tclTRY let tclCOMPLETE = Refiner.tclCOMPLETE let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE @@ -58,10 +54,6 @@ let tclDO = Refiner.tclDO let tclPROGRESS = Refiner.tclPROGRESS let tclSHOWHYPS = Refiner.tclSHOWHYPS let tclTHENTRY = Refiner.tclTHENTRY -let tclIFTHENELSE = Refiner.tclIFTHENELSE -let tclIFTHENSELSE = Refiner.tclIFTHENSELSE -let tclIFTHENSVELSE = Refiner.tclIFTHENSVELSE -let tclIFTHENTRYELSEMUST = Refiner.tclIFTHENTRYELSEMUST (************************************************************************) (* Tacticals applying on hypotheses *) diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 201b7801c3..a9ccda527f 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -31,13 +31,9 @@ val tclTHENLAST : tactic -> tactic -> tactic val tclTHENS : tactic -> tactic list -> tactic val tclTHENSV : tactic -> tactic array -> tactic val tclTHENSLASTn : tactic -> tactic -> tactic array -> tactic -val tclTHENLASTn : tactic -> tactic array -> tactic val tclTHENSFIRSTn : tactic -> tactic array -> tactic -> tactic -val tclTHENFIRSTn : tactic -> tactic array -> tactic val tclREPEAT : tactic -> tactic -val tclREPEAT_MAIN : tactic -> tactic val tclFIRST : tactic list -> tactic -val tclSOLVE : tactic list -> tactic val tclTRY : tactic -> tactic val tclCOMPLETE : tactic -> tactic val tclAT_LEAST_ONCE : tactic -> tactic @@ -49,11 +45,6 @@ val tclSHOWHYPS : tactic -> tactic val tclTHENTRY : tactic -> tactic -> tactic val tclMAP : ('a -> tactic) -> 'a list -> tactic -val tclIFTHENELSE : tactic -> tactic -> tactic -> tactic -val tclIFTHENSELSE : tactic -> tactic list -> tactic -> tactic -val tclIFTHENSVELSE : tactic -> tactic array -> tactic -> tactic -val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic - (** {6 Tacticals applying to hypotheses } *) val onNthHypId : int -> (Id.t -> tactic) -> tactic diff --git a/test-suite/bugs/closed/bug_4798.v b/test-suite/bugs/closed/bug_4798.v deleted file mode 100644 index f238086633..0000000000 --- a/test-suite/bugs/closed/bug_4798.v +++ /dev/null @@ -1,5 +0,0 @@ -(* DO NOT MODIFY THIS FILE DIRECTLY *) -(* It is autogenerated by dev/tools/update-compat.py. *) -Check match 2 with 0 => 0 | S n => n end. -Notation "|" := 1 (compat "8.8"). -Check match 2 with 0 => 0 | S n => n end. (* fails *) diff --git a/test-suite/bugs/closed/bug_4869.v b/test-suite/bugs/closed/bug_4869.v index ac5d7ea287..1fe91de72d 100644 --- a/test-suite/bugs/closed/bug_4869.v +++ b/test-suite/bugs/closed/bug_4869.v @@ -6,7 +6,9 @@ Fail Constraint i = Set. Constraint Set <= i. Constraint Set < i. Fail Constraint i < j. (* undeclared j *) +(* Now a parsing error Fail Constraint i < Type. (* anonymous *) +*) Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/bug_8725.v b/test-suite/bugs/closed/bug_8725.v new file mode 100644 index 0000000000..c888b9e96d --- /dev/null +++ b/test-suite/bugs/closed/bug_8725.v @@ -0,0 +1,2 @@ +Set Warnings "+local-declaration". +Fail Let foo : True. diff --git a/test-suite/bugs/closed/bug_9166.v b/test-suite/bugs/closed/bug_9166.v index 21cd770cbb..cd594c660f 100644 --- a/test-suite/bugs/closed/bug_9166.v +++ b/test-suite/bugs/closed/bug_9166.v @@ -1,8 +1,7 @@ -(* DO NOT MODIFY THIS FILE DIRECTLY *) -(* It is autogenerated by dev/tools/update-compat.py. *) Set Warnings "+deprecated". -Notation bar := option (compat "8.8"). +#[deprecated(since = "X", note = "Y")] +Notation bar := option. Definition foo (x: nat) : nat := match x with diff --git a/test-suite/ltac2/notations.v b/test-suite/ltac2/notations.v new file mode 100644 index 0000000000..3d2a875e38 --- /dev/null +++ b/test-suite/ltac2/notations.v @@ -0,0 +1,24 @@ +From Ltac2 Require Import Ltac2. +From Coq Require Import ZArith String List. + +Open Scope Z_scope. + +Check 1 + 1 : Z. + +Ltac2 Notation "ex" arg(constr(nat,Z)) := arg. + +Check (1 + 1)%nat%Z = 1%nat. + +Lemma two : nat. + refine (ex (1 + 1)). +Qed. + +Import ListNotations. +Close Scope list_scope. + +Ltac2 Notation "sl" arg(constr(string,list)) := arg. + +Lemma maybe : list bool. +Proof. + refine (sl ["left" =? "right"]). +Qed. diff --git a/test-suite/ssr/case_polyuniv.v b/test-suite/ssr/case_polyuniv.v new file mode 100644 index 0000000000..8774e191c1 --- /dev/null +++ b/test-suite/ssr/case_polyuniv.v @@ -0,0 +1,12 @@ +Require Import ssreflect. + +Set Universe Polymorphism. + +Cumulative Variant paths {A} (x:A) : A -> Type + := idpath : paths x x. + +Register paths as core.eq.type. +Register idpath as core.eq.refl. + +Lemma case_test (b:bool) : paths b b. +Proof. case B:b; reflexivity. Qed. diff --git a/test-suite/ssr/unfold_fold_polyuniv.v b/test-suite/ssr/unfold_fold_polyuniv.v new file mode 100644 index 0000000000..1a9309bc79 --- /dev/null +++ b/test-suite/ssr/unfold_fold_polyuniv.v @@ -0,0 +1,40 @@ +Require Import ssreflect ssrbool. + +Set Universe Polymorphism. + +Cumulative Variant paths {A} (x:A) : A -> Type + := idpath : paths x x. + +Register paths as core.eq.type. +Register idpath as core.eq.refl. + +Structure type := Pack {sort; op : rel sort}. + +Example unfold_fold (T : type) (x : sort T) (a : op T x x) : op T x x. +Proof. + rewrite /op. rewrite -/(op _ _ _). assumption. +Qed. + +Example pattern_unfold_fold (b:bool) (a := b) : paths a b. +Proof. + rewrite [in X in paths X _]/a. + rewrite -[in X in paths X _]/a. + constructor. +Qed. + +Example unfold_in_hyp (b:bool) (a := b) : unit. +Proof. + assert (paths a a) as A by reflexivity. + rewrite [in X in paths X _]/a in A. + rewrite /a in (B := idpath a). + rewrite [in X in paths _ X]/a in (C := idpath a). + constructor. +Qed. + +Example fold_in_hyp (b:bool) (p := idpath b) : unit. +Proof. + assert (paths (idpath b) (idpath b)) as A by reflexivity. + rewrite -[in X in paths X _]/p in A. + rewrite -[in X in paths _ X]/p in (C := idpath (idpath b)). + constructor. +Qed. diff --git a/test-suite/success/Discriminate_HoTT.v b/test-suite/success/Discriminate_HoTT.v new file mode 100644 index 0000000000..2a5e083d56 --- /dev/null +++ b/test-suite/success/Discriminate_HoTT.v @@ -0,0 +1,89 @@ +(* -*- mode: coq; coq-prog-args: ("-noinit" "-indices-matter") -*- *) + +(* This file tests the discriminate tactic compatibility with HoTT. + The first part of the file will setup a mini HoTT environment. + Afterwards a number of tests are performed. The tests are basically + copied from the Discriminate.v test file. *) + +Unset Elimination Schemes. + +Set Universe Polymorphism. + +Declare ML Module "ltac_plugin". + +Global Set Default Proof Mode "Classic". + +Notation "x -> y" := (forall (_:x), y) (at level 99, right associativity, y at level 200). + +Cumulative Variant paths {A} (a:A) : A -> Type + := idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Scheme paths_ind := Induction for paths Sort Type. +Arguments paths_ind [A] a P f y p. + +Notation "x = y :> A" := (@paths A x y) (at level 70, y at next level, no associativity). +Notation "x = y" := (x = y :>_) (at level 70, no associativity). + +Register paths as core.identity.type. +Register idpath as core.identity.refl. +Register paths_ind as core.identity.ind. + +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. +Arguments inverse {A x y} p : simpl nomatch. +Register inverse as core.identity.sym. + +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. +Arguments concat {A x y z} p q : simpl nomatch. +Register concat as core.identity.trans. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. +Arguments ap {A B} f {x y} p. +Register ap as core.identity.congr. + +Variant Empty : Type :=. + +Register Empty as core.False.type. + +Variant Unit : Type := tt. + +Register Unit as core.True.type. +Register tt as core.True.I. + +Variant Bool : Type := true | false. + +Inductive nat : Type := O | S (n:nat). + +(*********** Test discriminate tactic below. ***************) + +Goal O = S O -> Empty. + discriminate 1. +Qed. + +Goal forall H : O = S O, H = H. + discriminate H. +Qed. + +Goal O = S O -> Unit. +intros. discriminate H. Qed. +Goal O = S O -> Unit. +intros. Ltac g x := discriminate x. g H. Qed. + +Goal (forall x y : nat, x = y -> x = S y) -> Unit. +intros. +try discriminate (H O) || exact tt. +Qed. + +Goal (forall x y : nat, x = y -> x = S y) -> Unit. +intros. ediscriminate (H O). instantiate (1:=O). Abort. + +(* Check discriminate on types with local definitions *) + +Inductive A := B (T := Unit) (x y : Bool) (z := x). +Goal forall x y, B x true = B y false -> Empty. +discriminate. +Qed. diff --git a/test-suite/success/LocalDefinition.v b/test-suite/success/LocalDefinition.v new file mode 100644 index 0000000000..22fb09526d --- /dev/null +++ b/test-suite/success/LocalDefinition.v @@ -0,0 +1,53 @@ +(* Test consistent behavior of Local Definition (#8722) *) + +(* Test consistent behavior of Local Definition wrt Admitted *) + +Module TestAdmittedVisibility. + Module A. + Let a1 : nat. Admitted. (* Suppose to behave like a "Local Definition" *) + Local Definition b1 : nat. Admitted. (* Told to be a "Local Definition" *) + Local Definition c1 := 0. + Local Parameter d1 : nat. + Section S. + Let a2 : nat. Admitted. (* Told to be turned into a toplevel assumption *) + Local Definition b2 : nat. Admitted. (* Told to be a "Local Definition" *) + Local Definition c2 := 0. + Local Parameter d2 : nat. + End S. + End A. + Import A. + Fail Check a1. (* used to be accepted *) + Fail Check b1. (* used to be accepted *) + Fail Check c1. + Fail Check d1. + Fail Check a2. (* used to be accepted *) + Fail Check b2. (* used to be accepted *) + Fail Check c2. + Fail Check d2. +End TestAdmittedVisibility. + +(* Test consistent behavior of Local Definition wrt automatic declaration of instances *) + +Module TestVariableAsInstances. + Module Test1. + Set Typeclasses Axioms Are Instances. + Class U. + Local Parameter b : U. + Definition testU := _ : U. (* _ resolved *) + + Class T. + Variable a : T. (* warned to be the same as "Local Parameter" *) + Definition testT := _ : T. (* _ resolved *) + End Test1. + + Module Test2. + Unset Typeclasses Axioms Are Instances. + Class U. + Local Parameter b : U. + Fail Definition testU := _ : U. (* _ unresolved *) + + Class T. + Variable a : T. (* warned to be the same as "Local Parameter" thus should not be an instance *) + Fail Definition testT := _ : T. (* used to succeed *) + End Test2. +End TestVariableAsInstances. diff --git a/test-suite/success/NotationDeprecation.v b/test-suite/success/NotationDeprecation.v new file mode 100644 index 0000000000..d313ba0aa4 --- /dev/null +++ b/test-suite/success/NotationDeprecation.v @@ -0,0 +1,62 @@ +Module Syndefs. + +#[deprecated(since = "8.8", note = "Do not use.")] +Notation foo := Prop. + +Notation bar := Prop (compat "8.8"). + +Fail +#[deprecated(since = "8.8", note = "Do not use.")] +Notation zar := Prop (compat "8.8"). + +Check foo. +Check bar. + +Set Warnings "+deprecated". + +Fail Check foo. +Fail Check bar. + +End Syndefs. + +Module Notations. + +#[deprecated(since = "8.8", note = "Do not use.")] +Notation "!!" := Prop. + +Notation "##" := Prop (compat "8.8"). + +Fail +#[deprecated(since = "8.8", note = "Do not use.")] +Notation "**" := Prop (compat "8.8"). + +Check !!. +Check ##. + +Set Warnings "+deprecated". + +Fail Check !!. +Fail Check ##. + +End Notations. + +Module Infix. + +#[deprecated(since = "8.8", note = "Do not use.")] +Infix "!!" := plus (at level 1). + +Infix "##" := plus (at level 1, compat "8.8"). + +Fail +#[deprecated(since = "8.8", note = "Do not use.")] +Infix "**" := plus (at level 1, compat "8.8"). + +Check (_ !! _). +Check (_ ## _). + +Set Warnings "+deprecated". + +Fail Check (_ !! _). +Fail Check (_ ## _). + +End Infix. diff --git a/test-suite/success/goal_selector.v b/test-suite/success/goal_selector.v index 0951c5c8d4..ae834e7696 100644 --- a/test-suite/success/goal_selector.v +++ b/test-suite/success/goal_selector.v @@ -13,13 +13,15 @@ Goal two false /\ two true /\ two false /\ two true /\ two true /\ two true. Proof. do 2 dup. - repeat split. - 2, 4-99, 100-3:idtac. + Fail 7:idtac. + Fail 2-1:idtac. + 1,2,4-6:idtac. 2-5:exact One. par:exact Zero. - repeat split. 3-6:swap 1 4. 1-5:swap 1 5. - 0-4:exact One. + 1-4:exact One. all:exact Zero. - repeat split. 1, 3:exact Zero. @@ -34,7 +36,7 @@ Qed. Goal True -> True. Proof. - intros y; only 1-2 : repeat idtac. + intros y. 1-1:match goal with y : _ |- _ => let x := y in idtac x end. Fail 1-1:let x := y in idtac x. 1:let x := y in idtac x. diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index 4576ff4cbe..bb4ed10bc9 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -149,6 +149,7 @@ apply AC_IF. Qed. -Notation classical_proof_irrelevence := classical_proof_irrelevance (compat "8.8"). +#[deprecated(since = "8.8", note = "Use classical_proof_irrelevance instead.")] +Notation classical_proof_irrelevence := classical_proof_irrelevance. End Berardis_paradox. diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index 6ddc503542..b5d1e01630 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -128,6 +128,7 @@ module Options = struct [ { enabled = false; cmd = "-debug"; } ; { enabled = false; cmd = "-native_compiler"; } ; { enabled = true; cmd = "-allow-sprop"; } + ; { enabled = true; cmd = "-w +default"; } ] let build_coq_flags () = diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index 7748134146..2e25066897 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -176,9 +176,9 @@ let compile opts copts ~echo ~f_in ~f_out = Dumpglob.noglob (); let long_f_dot_vio, long_f_dot_vo = ensure_exists_with_prefix f_in f_out ".vio" ".vo" in - let sum, lib, univs, disch, tasks, proofs = + let sum, lib, univs, tasks, proofs = Library.load_library_todo long_f_dot_vio in - let univs, proofs = Stm.finish_tasks long_f_dot_vo univs disch proofs tasks in + let univs, proofs = Stm.finish_tasks long_f_dot_vo univs proofs tasks in Library.save_library_raw long_f_dot_vo sum lib univs proofs let compile opts copts ~echo ~f_in ~f_out = diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 4ef31c73b7..9180cae389 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -184,6 +184,10 @@ let warn_deprecated_inputstate = CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" (fun () -> Pp.strbrk "The inputstate option is deprecated and discouraged.") +let warn_deprecated_simple_require = + CWarnings.create ~name:"deprecated-boot" ~category:"deprecated" + (fun () -> Pp.strbrk "The -require option is deprecated, please use -require-import instead.") + let set_inputstate opts s = warn_deprecated_inputstate (); { opts with inputstate = Some s } @@ -416,7 +420,22 @@ let parse_args ~help ~init arglist : t * string list = Flags.profile_ltac_cutoff := get_float opt (next ()); oval - |"-require" -> add_vo_require oval (next ()) None (Some false) + |"-rfrom" -> + let from = next () in add_vo_require oval (next ()) (Some from) None + + |"-require" -> + warn_deprecated_simple_require (); + add_vo_require oval (next ()) None (Some false) + + |"-require-import" | "-ri" -> add_vo_require oval (next ()) None (Some false) + + |"-require-export" | "-re" -> add_vo_require oval (next ()) None (Some true) + + |"-require-import-from" | "-rifrom" -> + let from = next () in add_vo_require oval (next ()) (Some from) (Some false) + + |"-require-export-from" | "-refrom" -> + let from = next () in add_vo_require oval (next ()) (Some from) (Some true) |"-top" -> let topname = Libnames.dirpath_of_string (next ()) in diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 29948d50b2..84d3992f5c 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -44,10 +44,23 @@ let print_usage_common co command = \n -load-ml-source f load ML file f\ \n -load-vernac-source f load Coq file f.v (Load \"f\".)\ \n -l f (idem)\ -\n -require path load Coq library path and import it (Require Import path.)\ \n -load-vernac-source-verbose f load Coq file f.v (Load Verbose \"f\".)\ \n -lv f (idem)\ -\n -load-vernac-object path load Coq library path (Require path)\ +\n -load-vernac-object lib, -r lib\ +\n load Coq library lib (Require lib)\ +\n -rfrom root lib load Coq library lib (From root Require lib.)\ +\n -require-import lib, -ri lib\ +\n load and import Coq library lib\ +\n (equivalent to Require Import lib.)\ +\n -require-export lib, -re lib\ +\n load and transitively import Coq library lib\ +\n (equivalent to Require Export lib.)\ +\n -require-import-from root lib, -rifrom lib\ +\n load and import Coq library lib\ +\n (equivalent to From root Require Import lib.)\ +\n -require-export-from root lib, -refrom lib\ +\n load and transitively import Coq library lib\ +\n (equivalent to From root Require Export lib.)\ \n\ \n -where print Coq's standard library location and exit\ \n -config, --config print Coq's configuration information and exit\ diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index da8600109e..e2bab96e20 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -1355,6 +1355,16 @@ let () = add_scope "thunk" begin function | arg -> scope_fail "thunk" arg end +let () = add_scope "constr" (fun arg -> + let delimiters = List.map (function + | SexprRec (_, { v = Some s }, []) -> s + | _ -> scope_fail "constr" arg) + arg + in + let act e = Tac2quote.of_constr ~delimiters e in + Tac2entries.ScopeRule (Extend.Aentry Pcoq.Constr.constr, act) + ) + let add_expr_scope name entry f = add_scope name begin function | [] -> Tac2entries.ScopeRule (Extend.Aentry entry, f) @@ -1382,7 +1392,6 @@ let () = add_expr_scope "assert" q_assert Tac2quote.of_assertion let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching let () = add_expr_scope "goal_matching" q_goal_matching Tac2quote.of_goal_matching -let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr let () = add_generic_scope "open_constr" Pcoq.Constr.constr Tac2quote.wit_open_constr let () = add_generic_scope "pattern" Pcoq.Constr.constr Tac2quote.wit_pattern diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 246fe47c4a..3ab82b6e9b 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -751,7 +751,7 @@ let perform_eval ~pstate e = Goal_select.SelectAll, Proof.start ~name ~poly sigma [] | Some pstate -> Goal_select.get_default_goal_selector (), - Proof_global.give_me_the_proof pstate + Proof_global.get_proof pstate in let v = match selector with | Goal_select.SelectNth i -> Proofview.tclFOCUS i i v @@ -856,7 +856,7 @@ let print_ltac qid = (** Calling tactics *) let solve ~pstate default tac = - let pstate, status = Proof_global.with_proof begin fun etac p -> + let pstate, status = Proof_global.map_fold_proof_endline begin fun etac p -> let with_end_tac = if default then Some etac else None in let g = Goal_select.get_default_goal_selector () in let (p, status) = Pfedit.solve g None tac ?with_end_tac p in diff --git a/user-contrib/Ltac2/tac2quote.ml b/user-contrib/Ltac2/tac2quote.ml index a98264745e..81442c9d6b 100644 --- a/user-contrib/Ltac2/tac2quote.ml +++ b/user-contrib/Ltac2/tac2quote.ml @@ -94,8 +94,14 @@ let of_anti f = function let of_ident {loc;v=id} = inj_wit ?loc wit_ident id -let of_constr c = +let of_constr ?delimiters c = let loc = Constrexpr_ops.constr_loc c in + let c = Option.cata + (List.fold_left (fun c d -> + CAst.make ?loc @@ Constrexpr.CDelimiters(Id.to_string d, c)) + c) + c delimiters + in inj_wit ?loc wit_constr c let of_open_constr c = diff --git a/user-contrib/Ltac2/tac2quote.mli b/user-contrib/Ltac2/tac2quote.mli index 1b03dad8ec..1c859063aa 100644 --- a/user-contrib/Ltac2/tac2quote.mli +++ b/user-contrib/Ltac2/tac2quote.mli @@ -32,7 +32,7 @@ val of_variable : Id.t CAst.t -> raw_tacexpr val of_ident : Id.t CAst.t -> raw_tacexpr -val of_constr : Constrexpr.constr_expr -> raw_tacexpr +val of_constr : ?delimiters:Id.t list -> Constrexpr.constr_expr -> raw_tacexpr val of_open_constr : Constrexpr.constr_expr -> raw_tacexpr diff --git a/vernac/attributes.ml b/vernac/attributes.ml index 1ad5862d5d..ab14974598 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -73,11 +73,6 @@ module Notations = struct end open Notations -type deprecation = { since : string option ; note : string option } - -let mk_deprecation ?(since=None) ?(note=None) () = - { since ; note } - let assert_empty k v = if v <> VernacFlagEmpty then user_err Pp.(str "Attribute " ++ str k ++ str " does not accept arguments") @@ -213,19 +208,16 @@ let polymorphic = universe_transform ~warn_unqualified:true >> qualify_attribute ukey polymorphic_base -let deprecation_parser : deprecation key_parser = fun orig args -> +let deprecation_parser : Deprecation.t key_parser = fun orig args -> assert_once ~name:"deprecation" orig; match args with | VernacFlagList [ "since", VernacFlagLeaf since ; "note", VernacFlagLeaf note ] | VernacFlagList [ "note", VernacFlagLeaf note ; "since", VernacFlagLeaf since ] -> - let since = Some since and note = Some note in - mk_deprecation ~since ~note () + Deprecation.make ~since ~note () | VernacFlagList [ "since", VernacFlagLeaf since ] -> - let since = Some since in - mk_deprecation ~since () + Deprecation.make ~since () | VernacFlagList [ "note", VernacFlagLeaf note ] -> - let note = Some note in - mk_deprecation ~note () + Deprecation.make ~note () | _ -> CErrors.user_err (Pp.str "Ill formed “deprecated” attribute") let deprecation = attribute_of_list ["deprecated",deprecation_parser] diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 44688ddafc..53caf49efd 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -43,15 +43,11 @@ end (** Definitions for some standard attributes. *) -type deprecation = { since : string option ; note : string option } - -val mk_deprecation : ?since: string option -> ?note: string option -> unit -> deprecation - val polymorphic : bool attribute val program : bool attribute val template : bool option attribute val locality : bool option attribute -val deprecation : deprecation option attribute +val deprecation : Deprecation.t option attribute val canonical : bool attribute val program_mode_option_name : string list diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 5aec5cac2c..2e84c3275b 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -195,7 +195,7 @@ let build_beq_scheme mode kn = let (c,a) = Reductionops.whd_betaiota_stack Evd.empty EConstr.(of_constr c) in let (c,a) = EConstr.Unsafe.(to_constr c, List.map to_constr a) in match Constr.kind c with - | Rel x -> mkRel (x-nlist+ndx), Safe_typing.empty_private_constants + | Rel x -> mkRel (x-nlist+ndx), Evd.empty_side_effects | Var x -> (* Support for working in a context with "eq_x : x -> x -> bool" *) let eid = Id.of_string ("eq_"^(Id.to_string x)) in @@ -203,11 +203,11 @@ let build_beq_scheme mode kn = try ignore (Environ.lookup_named eid env) with Not_found -> raise (ParameterWithoutEquality (VarRef x)) in - mkVar eid, Safe_typing.empty_private_constants + mkVar eid, Evd.empty_side_effects | Cast (x,_,_) -> aux (Term.applist (x,a)) | App _ -> assert false | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> - if MutInd.equal kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Safe_typing.empty_private_constants + if MutInd.equal kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Evd.empty_side_effects else begin try let eq, eff = @@ -216,7 +216,7 @@ let build_beq_scheme mode kn = let eqa, eff = let eqa, effs = List.split (List.map aux a) in Array.of_list eqa, - List.fold_left Safe_typing.concat_private eff (List.rev effs) + List.fold_left Evd.concat_side_effects eff (List.rev effs) in let args = Array.append @@ -239,7 +239,7 @@ let build_beq_scheme mode kn = let kneq = Constant.change_label kn eq_lbl in try let _ = Environ.constant_opt_value_in env (kneq, u) in Term.applist (mkConst kneq,a), - Safe_typing.empty_private_constants + Evd.empty_side_effects with Not_found -> raise (ParameterWithoutEquality (ConstRef kn))) | Proj _ -> raise (EqUnknown "projection") | Construct _ -> raise (EqUnknown "constructor") @@ -270,7 +270,7 @@ let build_beq_scheme mode kn = let constrsi = constrs (3+nparrec) in let n = Array.length constrsi in let ar = Array.make n (ff ()) in - let eff = ref Safe_typing.empty_private_constants in + let eff = ref Evd.empty_side_effects in for i=0 to n-1 do let nb_cstr_args = List.length constrsi.(i).cs_args in let ar2 = Array.make n (ff ()) in @@ -288,7 +288,7 @@ let build_beq_scheme mode kn = (nb_cstr_args+ndx+1) cc in - eff := Safe_typing.concat_private eff' !eff; + eff := Evd.concat_side_effects eff' !eff; Array.set eqs ndx (mkApp (eqA, [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|] @@ -320,7 +320,7 @@ let build_beq_scheme mode kn = let names = Array.make nb_ind (make_annot Anonymous Sorts.Relevant) and types = Array.make nb_ind mkSet and cores = Array.make nb_ind mkSet in - let eff = ref Safe_typing.empty_private_constants in + let eff = ref Evd.empty_side_effects in let u = Univ.Instance.empty in for i=0 to (nb_ind-1) do names.(i) <- make_annot (Name (Id.of_string (rec_name i))) Sorts.Relevant; @@ -328,7 +328,7 @@ let build_beq_scheme mode kn = (mkArrow (mkFullInd ((kn,i),u) 1) Sorts.Relevant (bb ())); let c, eff' = make_one_eq i in cores.(i) <- c; - eff := Safe_typing.concat_private eff' !eff + eff := Evd.concat_side_effects eff' !eff done; (Array.init nb_ind (fun i -> let kelim = Inductive.elim_sort (mib,mib.mind_packets.(i)) in @@ -938,7 +938,7 @@ let compute_dec_tact ind lnamesparrec nparrec = Not_found -> Tacticals.New.tclZEROMSG (str "Error during the decidability part, leibniz to boolean equality is required.") end >>= fun (lbI,eff'') -> - let eff = (Safe_typing.concat_private eff'' (Safe_typing.concat_private eff' eff)) in + let eff = (Evd.concat_side_effects eff'' (Evd.concat_side_effects eff' eff)) in Tacticals.New.tclTHENLIST [ Proofview.tclEFFECTS eff; intros_using fresh_first_intros; @@ -1005,7 +1005,7 @@ let make_eq_decidability mode mind = (EConstr.of_constr (compute_dec_goal (ind,u) lnamesparrec nparrec)) (compute_dec_tact ind lnamesparrec nparrec) in - ([|ans|], ctx), Safe_typing.empty_private_constants + ([|ans|], ctx), Evd.empty_side_effects let eq_dec_scheme_kind = declare_mutual_scheme_object "_eq_dec" make_eq_decidability diff --git a/vernac/class.ml b/vernac/class.ml index f3a279eab1..58cef5db4f 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -358,9 +358,9 @@ let try_add_new_coercion_with_source ref ~local poly ~source = let add_coercion_hook poly _uctx _trans local ref = let local = match local with - | Discharge - | Local -> true - | Global -> false + | Discharge -> assert false (* Local Coercion in section behaves like Local Definition *) + | Global ImportNeedQualified -> true + | Global ImportDefaultBehavior -> false in let () = try_add_new_coercion ref ~local poly in let msg = Nametab.pr_global_env Id.Set.empty ref ++ str " is now a coercion" in @@ -370,9 +370,9 @@ let add_coercion_hook poly = Lemmas.mk_hook (add_coercion_hook poly) let add_subclass_hook poly _uctx _trans local ref = let stre = match local with - | Local -> true - | Global -> false - | Discharge -> assert false + | Discharge -> assert false (* Local Subclass in section behaves like Local Definition *) + | Global ImportNeedQualified -> true + | Global ImportDefaultBehavior -> false in let cl = class_of_global ref in try_add_new_coercion_subclass cl ~local:stre poly diff --git a/vernac/classes.ml b/vernac/classes.ml index 9cc8467c57..b64af52b6e 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -367,7 +367,7 @@ let declare_instance_program env sigma ~global ~poly id pri imps decl term termt let hook = Lemmas.mk_hook hook in let ctx = Evd.evar_universe_context sigma in ignore(Obligations.add_definition id ?term:constr - ~univdecl:decl typ ctx ~kind:(Global,poly,Instance) ~hook obls) + ~univdecl:decl typ ctx ~kind:(Global ImportDefaultBehavior,poly,Instance) ~hook obls) let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps decl ids term termtype = @@ -377,12 +377,12 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps decl ids te the refinement manually.*) let gls = List.rev (Evd.future_goals sigma) in let sigma = Evd.reset_future_goals sigma in - let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in - let pstate = Lemmas.start_proof id ~pl:decl kind sigma (EConstr.of_constr termtype) + let kind = Decl_kinds.(Global ImportDefaultBehavior, poly, DefinitionBody Instance) in + let lemma = Lemmas.start_lemma id ~pl:decl kind sigma (EConstr.of_constr termtype) ~hook:(Lemmas.mk_hook (fun _ _ _ -> instance_hook pri global imps ?hook)) in (* spiwack: I don't know what to do with the status here. *) - let pstate = + let lemma = if not (Option.is_empty term) then let init_refine = Tacticals.New.tclTHENLIST [ @@ -391,18 +391,18 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps decl ids te Tactics.New.reduce_after_refine; ] in - let pstate, _ = Pfedit.by init_refine pstate in - pstate + let lemma, _ = Lemmas.by init_refine lemma in + lemma else - let pstate, _ = Pfedit.by (Tactics.auto_intros_tac ids) pstate in - pstate + let lemma, _ = Lemmas.by (Tactics.auto_intros_tac ids) lemma in + lemma in match tac with | Some tac -> - let pstate, _ = Pfedit.by tac pstate in - pstate + let lemma, _ = Lemmas.by tac lemma in + lemma | None -> - pstate + lemma let do_instance_subst_constructor_and_ty subst k u ctx = let subst = diff --git a/vernac/classes.mli b/vernac/classes.mli index e61935c87a..ace9096469 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -31,8 +31,8 @@ val declare_instance : ?warn:bool -> env -> Evd.evar_map -> val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit (** globality, reference, optional priority and pattern information *) -val new_instance_interactive : - ?global:bool (** Not global by default. *) +val new_instance_interactive + : ?global:bool (** Not global by default. *) -> Decl_kinds.polymorphic -> name_decl -> local_binder_expr list @@ -41,10 +41,10 @@ val new_instance_interactive : -> ?tac:unit Proofview.tactic -> ?hook:(GlobRef.t -> unit) -> Hints.hint_info_expr - -> Id.t * Proof_global.t + -> Id.t * Lemmas.t -val new_instance : - ?global:bool (** Not global by default. *) +val new_instance + : ?global:bool (** Not global by default. *) -> Decl_kinds.polymorphic -> name_decl -> local_binder_expr list @@ -55,8 +55,8 @@ val new_instance : -> Hints.hint_info_expr -> Id.t -val new_instance_program : - ?global:bool (** Not global by default. *) +val new_instance_program + : ?global:bool (** Not global by default. *) -> Decl_kinds.polymorphic -> name_decl -> local_binder_expr list diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index c37e90650a..591e4b130f 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -37,15 +37,15 @@ let () = optwrite = (:=) axiom_into_instance; } let should_axiom_into_instance = function - | Discharge -> + | Context -> (* The typeclass behaviour of Variable and Context doesn't depend on section status *) true - | Global | Local -> !axiom_into_instance + | Definitional | Logical | Conjectural -> !axiom_into_instance let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl {CAst.v=ident} = match local with -| Discharge when Lib.sections_are_opened () -> +| Discharge -> let ctx = match ctx with | Monomorphic_entry ctx -> ctx | Polymorphic_entry (_, ctx) -> Univ.ContextSet.of_context ctx @@ -61,9 +61,8 @@ match local with let () = if is_coe then Class.try_add_new_coercion r ~local:true false in (r,Univ.Instance.empty,true) -| Global | Local | Discharge -> - let do_instance = should_axiom_into_instance local in - let local = DeclareDef.get_locality ident ~kind:"axiom" local in +| Global local -> + let do_instance = should_axiom_into_instance kind in let inl = let open Declaremods in match nl with | NoInline -> None | DefaultInline -> Some (Flags.get_inline_level()) @@ -78,6 +77,7 @@ match local with let env = Global.env () in let sigma = Evd.from_env env in let () = if do_instance then Classes.declare_instance env sigma None false gr in + let local = match local with ImportNeedQualified -> true | ImportDefaultBehavior -> false in let () = if is_coe then Class.try_add_new_coercion gr ~local p in let inst = match ctx with | Polymorphic_entry (_, ctx) -> Univ.UContext.instance ctx @@ -124,7 +124,7 @@ let process_assumptions_udecls kind l = | (_, ([], _))::_ | [] -> assert false in let () = match kind, udecl with - | (Discharge, _, _), Some _ when Lib.sections_are_opened () -> + | (Discharge, _, _), Some _ -> let loc = first_id.CAst.loc in let msg = Pp.str "Section variables cannot be polymorphic." in user_err ?loc msg @@ -288,7 +288,9 @@ let context poly l = | _ -> false in let impl = List.exists test impls in - let decl = (Discharge, poly, Definitional) in + let persistence = + if Lib.sections_are_opened () then Discharge else Global ImportDefaultBehavior in + let decl = (persistence, poly, Context) in let nstatus = match b with | None -> pi3 (declare_assumption false decl (t, univs) UnivNames.empty_binders [] impl diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 4cae4b8a74..1046e354a7 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -86,7 +86,7 @@ let do_definition ~program_mode ?hook ident k univdecl bl red_option c ctypopt = if program_mode then let env = Global.env () in let (c,ctx), sideff = Future.force ce.const_entry_body in - assert(Safe_typing.empty_private_constants = sideff); + assert(Safe_typing.empty_private_constants = sideff.Evd.seff_private); assert(Univ.ContextSet.is_empty ctx); Obligations.check_evars env evd; let c = EConstr.of_constr c in diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index fa4860b079..0d9df47ee8 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -33,7 +33,13 @@ val do_definition (************************************************************************) (** Not used anywhere. *) -val interp_definition : program_mode:bool -> - universe_decl_expr option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr -> - constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map * - UState.universe_decl * Impargs.manual_implicits +val interp_definition + : program_mode:bool + -> universe_decl_expr option + -> local_binder_expr list + -> polymorphic + -> red_expr option + -> constr_expr + -> constr_expr option + -> Evd.side_effects definition_entry * + Evd.evar_map * UState.universe_decl * Impargs.manual_implicits diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 7a4e6d8698..6068cd90f1 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -267,10 +267,10 @@ let declare_fixpoint_interactive local poly ((fixnames,fixrs,fixdefs,fixtypes),p Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in - let pstate = Lemmas.start_proof_with_initialization (local,poly,DefinitionBody Fixpoint) + let lemma = Lemmas.start_lemma_with_initialization (local,poly,DefinitionBody Fixpoint) evd pl (Some(false,indexes,init_tac)) thms None in declare_fixpoint_notations ntns; - pstate + lemma let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = (* We shortcut the proof process *) @@ -286,7 +286,8 @@ let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximp let evd = Evd.restrict_universe_context evd vars in let ctx = Evd.check_univ_decl ~poly evd pl in let pl = Evd.universe_binders evd in - let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in + let mk_pure c = (c, Univ.ContextSet.empty), Evd.empty_side_effects in + let fixdecls = List.map mk_pure fixdecls in ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) @@ -304,11 +305,11 @@ let declare_cofixpoint_interactive local poly ((fixnames,fixrs,fixdefs,fixtypes) Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in - let pstate = Lemmas.start_proof_with_initialization - (Global,poly, DefinitionBody CoFixpoint) + let lemma = Lemmas.start_lemma_with_initialization + (Global ImportDefaultBehavior,poly, DefinitionBody CoFixpoint) evd pl (Some(true,[],init_tac)) thms None in declare_cofixpoint_notations ntns; - pstate + lemma let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = (* We shortcut the proof process *) @@ -316,7 +317,8 @@ let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fixi let fixdecls = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in let vars = Vars.universes_of_constr (List.hd fixdecls) in - let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in + let mk_pure c = (c, Univ.ContextSet.empty), Evd.empty_side_effects in + let fixdecls = List.map mk_pure fixdecls in let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in let evd = Evd.from_ctx ctx in let evd = Evd.restrict_universe_context evd vars in diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index c8d617da5f..a31f3c34e0 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -19,13 +19,13 @@ open Vernacexpr (** Entry points for the vernacular commands Fixpoint and CoFixpoint *) val do_fixpoint_interactive : - locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Proof_global.t + locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> Lemmas.t val do_fixpoint : locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit val do_cofixpoint_interactive : - locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Proof_global.t + locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> Lemmas.t val do_cofixpoint : locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 977e804da2..5bebf955ec 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -121,7 +121,7 @@ let mk_mltype_data sigma env assums arity indname = let rec check_anonymous_type ind = let open Glob_term in match DAst.get ind with - | GSort (GType []) -> true + | GSort (UAnonymous {rigid=true}) -> true | GProd ( _, _, _, e) | GLetIn (_, _, _, e) | GLambda (_, _, _, e) @@ -495,7 +495,7 @@ let extract_params indl = let extract_inductive indl = List.map (fun ({CAst.v=indname},_,ar,lc) -> { ind_name = indname; - ind_arity = Option.cata (fun x -> x) (CAst.make @@ CSort (Glob_term.GType [])) ar; + ind_arity = Option.cata (fun x -> x) (CAst.make @@ CSort (Glob_term.UAnonymous {rigid=true})) ar; ind_lc = List.map (fun (_,({CAst.v=id},t)) -> (id,t)) lc }) indl diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index bdda3314ca..652dbf0858 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -14,27 +14,13 @@ open Entries open Globnames open Impargs -let warn_local_declaration = - CWarnings.create ~name:"local-declaration" ~category:"scope" - Pp.(fun (id,kind) -> - Names.Id.print id ++ strbrk " is declared as a local " ++ str kind) - -let get_locality id ~kind = function -| Discharge -> - (* If a Let is defined outside a section, then we consider it as a local definition *) - warn_local_declaration (id,kind); - true -| Local -> true -| Global -> false - let declare_definition ident (local, p, k) ?hook_data ce pl imps = let fix_exn = Future.fix_exn_of ce.const_entry_body in let gr = match local with - | Discharge when Lib.sections_are_opened () -> + | Discharge -> let _ = declare_variable ident (Lib.cwd(), SectionLocalDef ce, IsDefinition k) in VarRef ident - | Discharge | Local | Global -> - let local = get_locality ident ~kind:"definition" local in + | Global local -> let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in let gr = ConstRef kn in let () = Declare.declare_univ_binders gr pl in diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index c4500d0a6b..909aa41a30 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -11,13 +11,11 @@ open Names open Decl_kinds -val get_locality : Id.t -> kind:string -> Decl_kinds.locality -> bool - val declare_definition : Id.t -> definition_kind -> ?hook_data:(Lemmas.declaration_hook * UState.t * (Id.t * Constr.t) list) - -> Safe_typing.private_constants Entries.definition_entry + -> Evd.side_effects Entries.definition_entry -> UnivNames.universe_binders -> Impargs.manual_implicits -> GlobRef.t @@ -29,7 +27,7 @@ val declare_fix -> UnivNames.universe_binders -> Entries.universes_entry -> Id.t - -> Safe_typing.private_constants Entries.proof_output + -> Evd.side_effects Entries.proof_output -> Constr.types -> Impargs.manual_implicits -> GlobRef.t @@ -38,7 +36,7 @@ val prepare_definition : allow_evars:bool -> ?opaque:bool -> ?inline:bool -> poly:bool -> Evd.evar_map -> UState.universe_decl -> types:EConstr.t option -> body:EConstr.t -> - Evd.evar_map * Safe_typing.private_constants Entries.definition_entry + Evd.evar_map * Evd.side_effects Entries.definition_entry val prepare_parameter : allow_evars:bool -> poly:bool -> Evd.evar_map -> UState.universe_decl -> EConstr.types -> diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 63e6dd247f..cec68b89bc 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -295,8 +295,8 @@ GRAMMAR EXTEND Gram | -> { NoInline } ] ] ; univ_constraint: - [ [ l = universe_level; ord = [ "<" -> { Univ.Lt } | "=" -> { Univ.Eq } | "<=" -> { Univ.Le } ]; - r = universe_level -> { (l, ord, r) } ] ] + [ [ l = universe_name; ord = [ "<" -> { Univ.Lt } | "=" -> { Univ.Eq } | "<=" -> { Univ.Le } ]; + r = universe_name -> { (l, ord, r) } ] ] ; univ_decl : [ [ "@{" ; l = LIST0 identref; ext = [ "+" -> { true } | -> { false } ]; diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index de7d2fd49a..f18cf17bf9 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -414,7 +414,7 @@ let do_mutual_induction_scheme ?(force_mutual=false) lnamedepindsort = let declare decl fi lrecref = let decltype = Retyping.get_type_of env0 sigma (EConstr.of_constr decl) in let decltype = EConstr.to_constr sigma decltype in - let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in + let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Evd.empty_side_effects) in let cst = define ~poly fi UserIndividualRequest sigma proof_output (Some decltype) in ConstRef cst :: lrecref in @@ -536,7 +536,7 @@ let do_combined_scheme name schemes = schemes in let sigma,body,typ = build_combined_scheme (Global.env ()) csts in - let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in + let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Evd.empty_side_effects) in (* It is possible for the constants to have different universe polymorphism from each other, however that is only when the user manually defined at least one of them (as Scheme would pick the diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index d14c7ddf8f..a7366b2c56 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -26,7 +26,6 @@ open Decl_kinds open Declare open Pretyping open Termops -open Namegen open Reductionops open Constrintern open Impargs @@ -46,6 +45,44 @@ let call_hook ?hook ?fix_exn uctx trans l c = let e = Option.cata (fun fix -> fix e) e fix_exn in iraise e +(* Support for terminators and proofs with an associated constant + [that can be saved] *) + +type proof_ending = + | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * UState.t + | Proved of Proof_global.opacity_flag * + lident option * + Proof_global.proof_object + +type proof_terminator = (proof_ending -> unit) CEphemeron.key + +(* Proofs with a save constant function *) +type t = + { proof : Proof_global.t + ; terminator : proof_terminator + } + +let pf_map f { proof; terminator} = { proof = f proof; terminator } +let pf_fold f ps = f ps.proof + +let set_endline_tactic t = pf_map (Proof_global.set_endline_tactic t) + +(* To be removed *) +module Internal = struct + +let make_terminator f = CEphemeron.create f +let apply_terminator f = CEphemeron.get f + +(** Gets the current terminator without checking that the proof has + been completed. Useful for the likes of [Admitted]. *) +let get_terminator ps = ps.terminator + +end + +let by tac { proof; terminator } = + let proof, res = Pfedit.by tac proof in + { proof; terminator}, res + (* Support for mutually proved theorems *) let retrieve_first_recthm uctx = function @@ -75,7 +112,7 @@ let adjust_guardness_conditions const = function List.interval 0 (List.length ((lam_assum c)))) lemma_guard (Array.to_list fixdefs) in *) - let env = Safe_typing.push_private_constants env eff in + let env = Safe_typing.push_private_constants env eff.Evd.seff_private in let indexes = search_guard env possible_indexes fixdecls in @@ -178,18 +215,14 @@ let save ?export_seff id const uctx do_guard (locality,poly,kind) hook universes let k = Kindops.logical_kind_of_goal_kind kind in let should_suggest = const.const_entry_opaque && Option.is_empty const.const_entry_secctx in let r = match locality with - | Discharge when Lib.sections_are_opened () -> + | Discharge -> let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in let () = if should_suggest then Proof_using.suggest_variable (Global.env ()) id in VarRef id - | Local | Global | Discharge -> - let local = match locality with - | Local | Discharge -> true - | Global -> false - in + | Global local -> let kn = declare_constant ?export_seff id ~local (DefinitionEntry const, k) in let () = if should_suggest @@ -207,13 +240,10 @@ let save ?export_seff id const uctx do_guard (locality,poly,kind) hook universes let default_thm_id = Id.of_string "Unnamed_thm" -let fresh_name_for_anonymous_theorem () = - next_global_ident_away default_thm_id Id.Set.empty - let check_name_freshness locality {CAst.loc;v=id} : unit = (* We check existence here: it's a bit late at Qed time *) if Nametab.exists_cci (Lib.make_path id) || is_section_variable id || - locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) + locality <> Discharge && Nametab.exists_cci (Lib.make_path_except_section id) then user_err ?loc (Id.print id ++ str " already exists.") @@ -233,16 +263,12 @@ let save_remaining_recthms env sigma (locality,p,kind) norm univs body opaq i (i in let c = SectionLocalAssum ((t_i, univs),p,impl) in let _ = declare_variable id (Lib.cwd(),c,k) in - (Discharge, VarRef id,imps) - | Local | Global -> - let local = match locality with - | Local -> true - | Global -> false - | Discharge -> assert false - in + (VarRef id,imps) + | Global local -> + let k = IsAssumption Conjectural in let decl = (ParameterEntry (None,(t_i,univs),None), k) in let kn = declare_constant id ~local decl in - (locality,ConstRef kn,imps)) + (ConstRef kn,imps)) | Some body -> let body = norm body in let k = Kindops.logical_kind_of_goal_kind kind in @@ -260,45 +286,39 @@ let save_remaining_recthms env sigma (locality,p,kind) norm univs body opaq i (i let const = definition_entry ~types:t_i ~opaque:opaq ~univs body_i in let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in - (Discharge,VarRef id,imps) - | Local | Global -> - let local = match locality with - | Local -> true - | Global -> false - | Discharge -> assert false - in + (VarRef id,imps) + | Global local -> let const = Declare.definition_entry ~types:t_i ~univs ~opaque:opaq body_i in let kn = declare_constant id ~local (DefinitionEntry const, k) in - (locality,ConstRef kn,imps) + (ConstRef kn,imps) let check_anonymity id save_ident = if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then user_err Pp.(str "This command can only be used for unnamed theorem.") (* Admitted *) - let warn_let_as_axiom = CWarnings.create ~name:"let-as-axiom" ~category:"vernacular" (fun id -> strbrk "Let definition" ++ spc () ++ Id.print id ++ - spc () ++ strbrk "declared as an axiom.") + spc () ++ strbrk "declared as a local axiom.") let admit ?hook ctx (id,k,e) pl () = - let kn = declare_constant id (ParameterEntry e, IsAssumption Conjectural) in - let () = match k with - | Global, _, _ -> () - | Local, _, _ | Discharge, _, _ -> warn_let_as_axiom id + let local = match k with + | Global local, _, _ -> local + | Discharge, _, _ -> warn_let_as_axiom id; ImportNeedQualified in + let kn = declare_constant id ~local (ParameterEntry e, IsAssumption Conjectural) in let () = assumption_message id in Declare.declare_univ_binders (ConstRef kn) pl; - call_hook ?hook ctx [] Global (ConstRef kn) + call_hook ?hook ctx [] (Global local) (ConstRef kn) (* Starting a goal *) let standard_proof_terminator ?(hook : declaration_hook option) compute_guard = let open Proof_global in - make_terminator begin function + CEphemeron.create begin function | Admitted (id,k,pe,ctx) -> let () = admit ?hook ctx (id,k,pe) (UState.universe_binders ctx) () in Feedback.feedback Feedback.AddedAxiom @@ -325,7 +345,41 @@ let initialize_named_context_for_proof () = let d = if variable_opacity id then NamedDecl.drop_body d else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val -let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?hook c = +module Stack = struct + + type lemma = t + type nonrec t = t * t list + + let map f (pf, pfl) = (f pf, List.map f pfl) + + let map_top ~f (pf, pfl) = (f pf, pfl) + let map_top_pstate ~f (pf, pfl) = (pf_map f pf, pfl) + + let pop (ps, p) = match p with + | [] -> ps, None + | pp :: p -> ps, Some (pp, p) + + let with_top (p, _) ~f = f p + let with_top_pstate (p, _) ~f = f p.proof + + let push ontop a = + match ontop with + | None -> a , [] + | Some (l,ls) -> a, (l :: ls) + + let get_all_proof_names (pf : t) = + let prj x = Proof_global.get_proof x in + let (pn, pns) = map Proof.(function pf -> (data (prj pf.proof)).name) pf in + pn :: pns + + let copy_terminators ~src ~tgt = + let (ps, psl), (ts,tsl) = src, tgt in + assert(List.length psl = List.length tsl); + {ts with terminator = ps.terminator}, List.map2 (fun op p -> { p with terminator = op.terminator }) psl tsl + +end + +let start_lemma id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?hook c = let terminator = match terminator with | None -> standard_proof_terminator ?hook compute_guard | Some terminator -> terminator ?hook compute_guard @@ -336,7 +390,16 @@ let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?hook c | None -> initialize_named_context_for_proof () in let goals = [ Global.env_of_context sign , c ] in - Proof_global.start_proof sigma id ?pl kind goals terminator + let proof = Proof_global.start_proof sigma id ?pl kind goals in + { proof ; terminator } + +let start_dependent_lemma id ?pl kind ?terminator ?sign ?(compute_guard=[]) ?hook telescope = + let terminator = match terminator with + | None -> standard_proof_terminator ?hook compute_guard + | Some terminator -> terminator ?hook compute_guard + in + let proof = Proof_global.start_dependent_proof id ?pl kind telescope in + { proof ; terminator } let rec_tac_initializer finite guard thms snl = if finite then @@ -352,7 +415,7 @@ let rec_tac_initializer finite guard thms snl = | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false -let start_proof_with_initialization ?hook kind sigma decl recguard thms snl = +let start_lemma_with_initialization ?hook kind sigma decl recguard thms snl = let intro_tac (_, (_, (ids, _))) = Tactics.auto_intros_tac ids in let init_tac,guard = match recguard with | Some (finite,guard,init_tac) -> @@ -380,18 +443,18 @@ let start_proof_with_initialization ?hook kind sigma decl recguard thms snl = let uctx = UState.check_univ_decl ~poly:(pi2 kind) ctx decl in let env = Global.env () in List.map_i (save_remaining_recthms env sigma kind norm uctx body opaq) 1 other_thms in - let thms_data = (strength,ref,imps)::other_thms_data in - List.iter (fun (strength,ref,imps) -> + let thms_data = (ref,imps)::other_thms_data in + List.iter (fun (ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook ?hook ctx [] strength ref) thms_data in - let pstate = start_proof id ~pl:decl kind sigma t ~hook ~compute_guard:guard in - let pstate = Proof_global.modify_proof (fun p -> + let lemma = start_lemma id ~pl:decl kind sigma t ~hook ~compute_guard:guard in + let lemma = pf_map (Proof_global.map_proof (fun p -> match init_tac with | None -> p - | Some tac -> pi1 @@ Proof.run_tactic Global.(env ()) tac p) pstate in - pstate + | Some tac -> pi1 @@ Proof.run_tactic Global.(env ()) tac p)) lemma in + lemma -let start_proof_com ~program_mode ?inference_hook ?hook kind thms = +let start_lemma_com ~program_mode ?inference_hook ?hook kind thms = let env0 = Global.env () in let decl = fst (List.hd thms) in let evd, decl = Constrexpr_ops.interp_univ_decl_opt env0 (snd decl) in @@ -423,7 +486,7 @@ let start_proof_com ~program_mode ?inference_hook ?hook kind thms = else (* We fix the variables to ensure they won't be lowered to Set *) Evd.fix_undefined_variables evd in - start_proof_with_initialization ?hook kind evd decl recguard thms snl + start_lemma_with_initialization ?hook kind evd decl recguard thms snl (* Saving a proof *) @@ -438,7 +501,7 @@ let () = optread = (fun () -> !keep_admitted_vars); optwrite = (fun b -> keep_admitted_vars := b) } -let save_proof_admitted ?proof ~pstate = +let save_lemma_admitted ?proof ~(lemma : t) = let pe = let open Proof_global in match proof with @@ -453,8 +516,8 @@ let save_proof_admitted ?proof ~pstate = let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in Admitted(id, k, (sec_vars, (typ, ctx), None), universes) | None -> - let pftree = Proof_global.give_me_the_proof pstate in - let gk = Proof_global.get_current_persistence pstate in + let pftree = Proof_global.get_proof lemma.proof in + let gk = Proof_global.get_persistence lemma.proof in let Proof.{ name; poly; entry } = Proof.data pftree in let typ = match Proofview.initial_goals entry with | [typ] -> snd typ @@ -466,10 +529,10 @@ let save_proof_admitted ?proof ~pstate = let universes = Proof.((data pftree).initial_euctx) in (* This will warn if the proof is complete *) let pproofs, _univs = - Proof_global.return_proof ~allow_partial:true pstate in + Proof_global.return_proof ~allow_partial:true lemma.proof in let sec_vars = if not !keep_admitted_vars then None - else match Proof_global.get_used_variables pstate, pproofs with + else match Proof_global.get_used_variables lemma.proof, pproofs with | Some _ as x, _ -> x | None, (pproof, _) :: _ -> let env = Global.env () in @@ -477,32 +540,23 @@ let save_proof_admitted ?proof ~pstate = let ids_def = Environ.global_vars_set env pproof in Some (Environ.keep_hyps env (Id.Set.union ids_typ ids_def)) | _ -> None in - let decl = Proof_global.get_universe_decl pstate in + let decl = Proof_global.get_universe_decl lemma.proof in let ctx = UState.check_univ_decl ~poly universes decl in Admitted(name,gk,(sec_vars, (typ, ctx), None), universes) in - Proof_global.apply_terminator (Proof_global.get_terminator pstate) pe - -let save_pstate_proved ~pstate ~opaque ~idopt = - let obj, terminator = Proof_global.close_proof ~opaque - ~keep_body_ucst_separate:false (fun x -> x) pstate - in - Proof_global.(apply_terminator terminator (Proved (opaque, idopt, obj))) + CEphemeron.get lemma.terminator pe -let save_proof_proved ?proof ?ontop ~opaque ~idopt = +let save_lemma_proved ?proof ?lemma ~opaque ~idopt = (* Invariant (uh) *) - if Option.is_empty ontop && Option.is_empty proof then + if Option.is_empty lemma && Option.is_empty proof then user_err (str "No focused proof (No proof-editing in progress)."); let (proof_obj,terminator) = match proof with | None -> (* XXX: The close_proof and proof state API should be refactored so it is possible to insert proofs properly into the state *) - let pstate = Proof_global.get_current_pstate @@ Option.get ontop in - Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) pstate + let { proof; terminator } = Option.get lemma in + Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) proof, terminator | Some proof -> proof in - (* if the proof is given explicitly, nothing has to be deleted *) - let ontop = if Option.is_empty proof then Proof_global.discard_current Option.(get ontop) else ontop in - Proof_global.(apply_terminator terminator (Proved (opaque,idopt,proof_obj))); - ontop + CEphemeron.get terminator (Proved (opaque,idopt,proof_obj)) diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 3df543156d..ac647af8b5 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -11,6 +11,7 @@ open Names open Decl_kinds +(* Declaration hooks *) type declaration_hook (* Hooks allow users of the API to perform arbitrary actions at @@ -37,53 +38,120 @@ val call_hook -> ?fix_exn:Future.fix_exn -> hook_type -val start_proof : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> - ?terminator:(?hook:declaration_hook -> Proof_global.lemma_possible_guards -> Proof_global.proof_terminator) -> - ?sign:Environ.named_context_val -> - ?compute_guard:Proof_global.lemma_possible_guards -> - ?hook:declaration_hook -> EConstr.types -> Proof_global.t +(* Proofs that define a constant + terminators *) +type t +type proof_terminator -val start_proof_com +module Stack : sig + + type lemma = t + type t + + val pop : t -> lemma * t option + val push : t option -> lemma -> t + + val map_top : f:(lemma -> lemma) -> t -> t + val map_top_pstate : f:(Proof_global.t -> Proof_global.t) -> t -> t + + val with_top : t -> f:(lemma -> 'a ) -> 'a + val with_top_pstate : t -> f:(Proof_global.t -> 'a ) -> 'a + + val get_all_proof_names : t -> Names.Id.t list + + val copy_terminators : src:t -> tgt:t -> t + (** Gets the current terminator without checking that the proof has + been completed. Useful for the likes of [Admitted]. *) + +end + +val standard_proof_terminator + : ?hook:declaration_hook + -> Proof_global.lemma_possible_guards + -> proof_terminator + +val set_endline_tactic : Genarg.glob_generic_argument -> t -> t +val pf_map : (Proof_global.t -> Proof_global.t) -> t -> t +val pf_fold : (Proof_global.t -> 'a) -> t -> 'a + +val by : unit Proofview.tactic -> t -> t * bool + +(* Start of high-level proofs with an associated constant *) + +val start_lemma + : Id.t + -> ?pl:UState.universe_decl + -> goal_kind + -> Evd.evar_map + -> ?terminator:(?hook:declaration_hook -> Proof_global.lemma_possible_guards -> proof_terminator) + -> ?sign:Environ.named_context_val + -> ?compute_guard:Proof_global.lemma_possible_guards + -> ?hook:declaration_hook + -> EConstr.types + -> t + +val start_dependent_lemma + : Id.t + -> ?pl:UState.universe_decl + -> goal_kind + -> ?terminator:(?hook:declaration_hook -> Proof_global.lemma_possible_guards -> proof_terminator) + -> ?sign:Environ.named_context_val + -> ?compute_guard:Proof_global.lemma_possible_guards + -> ?hook:declaration_hook + -> Proofview.telescope + -> t + +val start_lemma_com : program_mode:bool -> ?inference_hook:Pretyping.inference_hook -> ?hook:declaration_hook -> goal_kind -> Vernacexpr.proof_expr list - -> Proof_global.t - -val start_proof_with_initialization : - ?hook:declaration_hook -> - goal_kind -> Evd.evar_map -> UState.universe_decl -> - (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option -> - (Id.t (* name of thm *) * - (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list - -> int list option -> Proof_global.t + -> t -val standard_proof_terminator : - ?hook:declaration_hook -> Proof_global.lemma_possible_guards -> - Proof_global.proof_terminator +val start_lemma_with_initialization + : ?hook:declaration_hook + -> goal_kind -> Evd.evar_map -> UState.universe_decl + -> (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option + -> (Id.t (* name of thm *) * + (EConstr.types (* type of thm *) * + (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list + -> int list option + -> t -val fresh_name_for_anonymous_theorem : unit -> Id.t +val default_thm_id : Names.Id.t (* Prepare global named context for proof session: remove proofs of opaque section definitions and remove vm-compiled code *) val initialize_named_context_for_proof : unit -> Environ.named_context_val -(** {6 ... } *) +(** {6 Saving proofs } *) -val save_proof_admitted - : ?proof:Proof_global.closed_proof - -> pstate:Proof_global.t +val save_lemma_admitted + : ?proof:(Proof_global.proof_object * proof_terminator) + -> lemma:t -> unit -val save_proof_proved - : ?proof:Proof_global.closed_proof - -> ?ontop:Proof_global.stack - -> opaque:Proof_global.opacity_flag - -> idopt:Names.lident option - -> Proof_global.stack option - -val save_pstate_proved - : pstate:Proof_global.t +val save_lemma_proved + : ?proof:(Proof_global.proof_object * proof_terminator) + -> ?lemma:t -> opaque:Proof_global.opacity_flag -> idopt:Names.lident option -> unit + +(* API to build a terminator, should go away *) +type proof_ending = + | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * UState.t + | Proved of Proof_global.opacity_flag * + Names.lident option * + Proof_global.proof_object + +(** This stuff is internal and will be removed in the future. *) +module Internal : sig + + (** Only needed due to the Proof_global compatibility layer. *) + val get_terminator : t -> proof_terminator + + (** Only needed by obligations, should be reified soon *) + val make_terminator : (proof_ending -> unit) -> proof_terminator + val apply_terminator : proof_terminator -> proof_ending -> unit + +end diff --git a/vernac/locality.ml b/vernac/locality.ml index 21be73b39c..465f04bc6e 100644 --- a/vernac/locality.ml +++ b/vernac/locality.ml @@ -12,10 +12,9 @@ open Decl_kinds (** * Managing locality *) -let local_of_bool = function - | true -> Local - | false -> Global - +let importability_of_bool = function + | true -> ImportNeedQualified + | false -> ImportDefaultBehavior (** Positioning locality for commands supporting discharging and export outside of modules *) @@ -28,10 +27,22 @@ let make_non_locality = function Some false -> false | _ -> true let make_locality = function Some true -> true | _ -> false +let warn_local_declaration = + CWarnings.create ~name:"local-declaration" ~category:"scope" + Pp.(fun () -> + Pp.strbrk "Interpreting this declaration as if " ++ + strbrk "a global declaration prefixed by \"Local\", " ++ + strbrk "i.e. as a global declaration which shall not be " ++ + strbrk "available without qualification when imported.") + let enforce_locality_exp locality_flag discharge = match locality_flag, discharge with - | Some b, NoDischarge -> local_of_bool b - | None, NoDischarge -> Global + | Some b, NoDischarge -> Global (importability_of_bool b) + | None, NoDischarge -> Global ImportDefaultBehavior + | None, DoDischarge when not (Lib.sections_are_opened ()) -> + (* If a Let/Variable is defined outside a section, then we consider it as a local definition *) + warn_local_declaration (); + Global ImportNeedQualified | None, DoDischarge -> Discharge | Some true, DoDischarge -> CErrors.user_err Pp.(str "Local not allowed in this case") | Some false, DoDischarge -> CErrors.user_err Pp.(str "Global not allowed in this case") diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 50914959dc..b96f500beb 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -732,13 +732,8 @@ type syntax_extension = { synext_notgram : notation_grammar; synext_unparsing : unparsing list; synext_extra : (string * string) list; - synext_compat : Flags.compat_version option; } -let is_active_compat = function -| None -> true -| Some v -> 0 <= Flags.version_compare v !Flags.compat_version - type syntax_extension_obj = locality_flag * syntax_extension let check_and_extend_constr_grammar ntn rule = @@ -759,7 +754,7 @@ let cache_one_syntax_extension se = let oldprec = Notgram_ops.level_of_notation ~onlyprint ntn in if not (Notgram_ops.level_eq prec oldprec) then error_incompatible_level ntn oldprec prec; with Not_found -> - if is_active_compat se.synext_compat then begin + begin (* Reserve the notation level *) Notgram_ops.declare_notation_level ntn prec ~onlyprint; (* Declare the parsing rule *) @@ -934,10 +929,6 @@ let is_only_printing mods = let test = function SetOnlyPrinting -> true | _ -> false in List.exists test mods -let get_compat_version mods = - let test = function SetCompatVersion v -> Some v | _ -> None in - try Some (List.find_map test mods) with Not_found -> None - (* Compute precedences from modifiers (or find default ones) *) let set_entry_type from etyps (x,typ) = @@ -1177,7 +1168,7 @@ module SynData = struct (* Fields coming from the vernac-level modifiers *) only_parsing : bool; only_printing : bool; - compat : Flags.compat_version option; + deprecation : Deprecation.t option; format : lstring option; extra : (string * string) list; @@ -1222,12 +1213,32 @@ let check_locality_compatibility local custom i_typs = strbrk " which is local.")) (List.uniquize allcustoms) -let compute_syntax_data local df modifiers = +let warn_deprecated_compat = + CWarnings.create ~name:"deprecated-compat" ~category:"deprecated" + (fun () -> Pp.(str"The \"compat\" modifier is deprecated." ++ spc () ++ + str"Please use the \"deprecated\" attributed instead.")) + +(* Returns the new deprecation and the onlyparsing status. This should be +removed together with the compat syntax modifier. *) +let merge_compat_deprecation compat deprecation = + match compat, deprecation with + | Some Flags.Current, _ -> deprecation, true + | Some _, Some _ -> + CErrors.user_err Pp.(str"The \"compat\" modifier cannot be used with the \"deprecated\" attribute." + ++ spc () ++ str"Please use only the latter.") + | Some v, None -> + warn_deprecated_compat (); + Some (Deprecation.make ~since:(Flags.pr_version v) ()), true + | None, Some _ -> deprecation, true + | None, None -> deprecation, false + +let compute_syntax_data ~local deprecation df modifiers = let open SynData in let open NotationMods in let mods = interp_modifiers modifiers in let onlyprint = mods.only_printing in let onlyparse = mods.only_parsing in + let deprecation, _ = merge_compat_deprecation mods.compat deprecation in if onlyprint && onlyparse then user_err (str "A notation cannot be both 'only printing' and 'only parsing'."); let assoc = Option.append mods.assoc (Some Gramlib.Gramext.NonA) in let (recvars,mainvars,symbols) = analyze_notation_tokens ~onlyprint df in @@ -1265,7 +1276,7 @@ let compute_syntax_data local df modifiers = only_parsing = mods.only_parsing; only_printing = mods.only_printing; - compat = mods.compat; + deprecation; format = mods.format; extra = mods.extra; @@ -1281,9 +1292,9 @@ let compute_syntax_data local df modifiers = not_data = sy_fulldata; } -let compute_pure_syntax_data local df mods = +let compute_pure_syntax_data ~local df mods = let open SynData in - let sd = compute_syntax_data local df mods in + let sd = compute_syntax_data ~local None df mods in let msgs = if sd.only_parsing then (Feedback.msg_warning ?loc:None, @@ -1301,7 +1312,7 @@ type notation_obj = { notobj_coercion : entry_coercion_kind option; notobj_onlyparse : bool; notobj_onlyprint : bool; - notobj_compat : Flags.compat_version option; + notobj_deprecation : Deprecation.t option; notobj_notation : notation * notation_location; } @@ -1323,11 +1334,11 @@ let open_notation i (_, nobj) = let (ntn, df) = nobj.notobj_notation in let pat = nobj.notobj_interp in let onlyprint = nobj.notobj_onlyprint in + let deprecation = nobj.notobj_deprecation in let fresh = not (Notation.exists_notation_in_scope scope ntn onlyprint pat) in - let active = is_active_compat nobj.notobj_compat in - if Int.equal i 1 && fresh && active then begin + if Int.equal i 1 && fresh then begin (* Declare the interpretation *) - let () = Notation.declare_notation_interpretation ntn scope pat df ~onlyprint in + let () = Notation.declare_notation_interpretation ntn scope pat df ~onlyprint deprecation in (* Declare the uninterpretation *) if not nobj.notobj_onlyparse then Notation.declare_uninterpretation (NotationRule (scope, ntn)) pat; @@ -1388,7 +1399,6 @@ let recover_notation_syntax ntn = synext_notgram = pa_rule; synext_unparsing = pp_rule; synext_extra = pp_extra_rules; - synext_compat = None; } with Not_found -> raise NoSyntaxRule @@ -1437,7 +1447,6 @@ let make_syntax_rules (sd : SynData.syn_data) = let open SynData in synext_notgram = { notgram_onlyprinting = sd.only_printing; notgram_rules = pa_rule }; synext_unparsing = pp_rule; synext_extra = sd.extra; - synext_compat = sd.compat; } (**********************************************************************) @@ -1447,9 +1456,9 @@ let to_map l = let fold accu (x, v) = Id.Map.add x v accu in List.fold_left fold Id.Map.empty l -let add_notation_in_scope local df env c mods scope = +let add_notation_in_scope ~local deprecation df env c mods scope = let open SynData in - let sd = compute_syntax_data local df mods in + let sd = compute_syntax_data ~local deprecation df mods in (* Prepare the interpretation *) (* Prepare the parsing and printing rules *) let sy_rules = make_syntax_rules sd in @@ -1470,7 +1479,7 @@ let add_notation_in_scope local df env c mods scope = notobj_onlyparse = onlyparse; notobj_coercion = coe; notobj_onlyprint = sd.only_printing; - notobj_compat = sd.compat; + notobj_deprecation = sd.deprecation; notobj_notation = sd.info; } in (* Ready to change the global state *) @@ -1479,7 +1488,7 @@ let add_notation_in_scope local df env c mods scope = Lib.add_anonymous_leaf (inNotation notation); sd.info -let add_notation_interpretation_core local df env ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat = +let add_notation_interpretation_core ~local df env ?(impls=empty_internalization_env) c scope onlyparse onlyprint deprecation = let (recvars,mainvars,symbs) = analyze_notation_tokens ~onlyprint df in (* Recover types of variables and pa/pp rules; redeclare them if needed *) let level, i_typs, onlyprint = if not (is_numeral symbs) then begin @@ -1510,7 +1519,7 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_ notobj_onlyparse = onlyparse; notobj_coercion = coe; notobj_onlyprint = onlyprint; - notobj_compat = compat; + notobj_deprecation = deprecation; notobj_notation = df'; } in Lib.add_anonymous_leaf (inNotation notation); @@ -1518,41 +1527,40 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_ (* Notations without interpretation (Reserved Notation) *) -let add_syntax_extension local ({CAst.loc;v=df},mods) = let open SynData in - let psd = compute_pure_syntax_data local df mods in - let sy_rules = make_syntax_rules {psd with compat = None} in +let add_syntax_extension ~local ({CAst.loc;v=df},mods) = let open SynData in + let psd = compute_pure_syntax_data ~local df mods in + let sy_rules = make_syntax_rules {psd with deprecation = None} in Flags.if_verbose (List.iter (fun (f,x) -> f x)) psd.msgs; Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)) (* Notations with only interpretation *) let add_notation_interpretation env ({CAst.loc;v=df},c,sc) = - let df' = add_notation_interpretation_core false df env c sc false false None in + let df' = add_notation_interpretation_core ~local:false df env c sc false false None in Dumpglob.dump_notation (loc,df') sc true let set_notation_for_interpretation env impls ({CAst.v=df},c,sc) = (try ignore - (Flags.silently (fun () -> add_notation_interpretation_core false df env ~impls c sc false false None) ()); + (Flags.silently (fun () -> add_notation_interpretation_core ~local:false df env ~impls c sc false false None) ()); with NoSyntaxRule -> user_err Pp.(str "Parsing rule for this notation has to be previously declared.")); Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc (* Main entry point *) -let add_notation local env c ({CAst.loc;v=df},modifiers) sc = +let add_notation ~local deprecation env c ({CAst.loc;v=df},modifiers) sc = let df' = if no_syntax_modifiers modifiers then (* No syntax data: try to rely on a previously declared rule *) let onlyparse = is_only_parsing modifiers in let onlyprint = is_only_printing modifiers in - let compat = get_compat_version modifiers in - try add_notation_interpretation_core local df env c sc onlyparse onlyprint compat + try add_notation_interpretation_core ~local df env c sc onlyparse onlyprint deprecation with NoSyntaxRule -> (* Try to determine a default syntax rule *) - add_notation_in_scope local df env c modifiers sc + add_notation_in_scope ~local deprecation df env c modifiers sc else (* Declare both syntax and interpretation *) - add_notation_in_scope local df env c modifiers sc + add_notation_in_scope ~local deprecation df env c modifiers sc in Dumpglob.dump_notation (loc,df') sc true @@ -1566,7 +1574,7 @@ let add_notation_extra_printing_rule df k v = let inject_var x = CAst.make @@ CRef (qualid_of_ident x,None) -let add_infix local env ({CAst.loc;v=inf},modifiers) pr sc = +let add_infix ~local deprecation env ({CAst.loc;v=inf},modifiers) pr sc = check_infix_modifiers modifiers; (* check the precedence *) let vars = names_of_constr_expr pr in @@ -1575,7 +1583,7 @@ let add_infix local env ({CAst.loc;v=inf},modifiers) pr sc = let metas = [inject_var x; inject_var y] in let c = mkAppC (pr,metas) in let df = CAst.make ?loc @@ Id.to_string x ^" "^(quote_notation_token inf)^" "^Id.to_string y in - add_notation local env c (df,modifiers) sc + add_notation ~local deprecation env c (df,modifiers) sc (**********************************************************************) (* Scopes, delimiters and classes bound to scopes *) @@ -1651,7 +1659,7 @@ let try_interp_name_alias = function | [], { CAst.v = CRef (ref,_) } -> intern_reference ref | _ -> raise Not_found -let add_syntactic_definition env ident (vars,c) local onlyparse = +let add_syntactic_definition ~local deprecation env ident (vars,c) compat = let vars,reversibility,pat = try [], APrioriReversible, NRef (try_interp_name_alias (vars,c)) with Not_found -> @@ -1665,11 +1673,9 @@ let add_syntactic_definition env ident (vars,c) local onlyparse = let map id = let (_,sc) = Id.Map.find id nvars in (id, sc) in List.map map vars, reversibility, pat in - let onlyparse = match onlyparse with - | None when fst (printability None false reversibility pat) -> Some Flags.Current - | p -> p - in - Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat) + let deprecation, onlyparsing = merge_compat_deprecation compat deprecation in + let onlyparsing = onlyparsing || fst (printability None false reversibility pat) in + Syntax_def.declare_syntactic_definition ~local deprecation ident ~onlyparsing (vars,pat) (**********************************************************************) (* Declaration of custom entry *) diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli index 6435df23c7..6532cee367 100644 --- a/vernac/metasyntax.mli +++ b/vernac/metasyntax.mli @@ -19,10 +19,10 @@ val add_token_obj : string -> unit (** Adding a (constr) notation in the environment*) -val add_infix : locality_flag -> env -> (lstring * syntax_modifier list) -> +val add_infix : local:bool -> Deprecation.t option -> env -> (lstring * syntax_modifier list) -> constr_expr -> scope_name option -> unit -val add_notation : locality_flag -> env -> constr_expr -> +val add_notation : local:bool -> Deprecation.t option -> env -> constr_expr -> (lstring * syntax_modifier list) -> scope_name option -> unit val add_notation_extra_printing_rule : string -> string -> string -> unit @@ -47,12 +47,12 @@ val set_notation_for_interpretation : env -> Constrintern.internalization_env -> (** Add only the parsing/printing rule of a notation *) val add_syntax_extension : - locality_flag -> (lstring * syntax_modifier list) -> unit + local:bool -> (lstring * syntax_modifier list) -> unit (** Add a syntactic definition (as in "Notation f := ...") *) -val add_syntactic_definition : env -> Id.t -> Id.t list * constr_expr -> - bool -> Flags.compat_version option -> unit +val add_syntactic_definition : local:bool -> Deprecation.t option -> env -> + Id.t -> Id.t list * constr_expr -> Flags.compat_version option -> unit (** Print the Camlp5 state of a grammar *) diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 0d93e19723..50d24c20c9 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -497,7 +497,7 @@ let compute_possible_guardness_evidences n fixbody fixtype = let ctx = fst (decompose_prod_n_assum m fixtype) in List.map_i (fun i _ -> i) 0 ctx -let mk_proof c = ((c, Univ.ContextSet.empty), Safe_typing.empty_private_constants) +let mk_proof c = ((c, Univ.ContextSet.empty), Evd.empty_side_effects) let declare_mutual_definition l = let len = List.length l in @@ -632,7 +632,7 @@ let declare_obligation prg obl body ty uctx = if get_shrink_obligations () && not poly then shrink_body body ty else [], body, ty, [||] in - let body = ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in + let body = ((body,Univ.ContextSet.empty), Evd.empty_side_effects) in let ce = { const_entry_body = Future.from_val ~fix_exn:(fun x -> x) body; const_entry_secctx = None; @@ -643,7 +643,7 @@ let declare_obligation prg obl body ty uctx = const_entry_feedback = None; } in (* ppedrot: seems legit to have obligations as local *) - let constant = Declare.declare_constant obl.obl_name ~local:true + let constant = Declare.declare_constant obl.obl_name ~local:ImportNeedQualified (DefinitionEntry ce,IsProof Property) in if not opaque then add_hint (Locality.make_section_locality None) prg constant; @@ -787,9 +787,11 @@ let dependencies obls n = obls; !res -let goal_kind poly = Decl_kinds.Local, poly, Decl_kinds.DefinitionBody Decl_kinds.Definition +let goal_kind poly = + Decl_kinds.(Global ImportNeedQualified, poly, DefinitionBody Definition) -let goal_proof_kind poly = Decl_kinds.Local, poly, Decl_kinds.Proof Decl_kinds.Lemma +let goal_proof_kind poly = + Decl_kinds.(Global ImportNeedQualified, poly, Proof Lemma) let kind_of_obligation poly o = match o with @@ -820,8 +822,8 @@ let solve_by_tac ?loc name evi t poly ctx = Pfedit.build_constant_by_tactic id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps evi.evar_concl t in let env = Global.env () in - let body = Future.force entry.const_entry_body in - let body = Safe_typing.inline_private_constants env body in + let (body, eff) = Future.force entry.const_entry_body in + let body = Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) in let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in Inductiveops.control_only_guard env ctx' (EConstr.of_constr (fst body)); Some (fst body, entry.const_entry_type, Evd.evar_universe_context ctx') @@ -839,14 +841,15 @@ let solve_by_tac ?loc name evi t poly ctx = let obligation_terminator ?hook name num guard auto pf = let open Proof_global in - let term = Lemmas.standard_proof_terminator ?hook guard in + let open Lemmas in + let term = standard_proof_terminator ?hook guard in match pf with - | Admitted _ -> apply_terminator term pf + | Admitted _ -> Internal.apply_terminator term pf | Proved (opq, id, { entries=[entry]; universes=uctx } ) -> begin let env = Global.env () in let ty = entry.Entries.const_entry_type in - let body = Future.force entry.const_entry_body in - let (body, cstr) = Safe_typing.inline_private_constants env body in + let body, eff = Future.force entry.const_entry_body in + let (body, cstr) = Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) in let sigma = Evd.from_ctx uctx in let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in Inductiveops.control_only_guard (Global.env ()) sigma (EConstr.of_constr body); @@ -962,13 +965,13 @@ let rec solve_obligation prg num tac = let evd = Evd.update_sigma_env evd (Global.env ()) in let auto n tac oblset = auto_solve_obligations n ~oblset tac in let terminator ?hook guard = - Proof_global.make_terminator + Lemmas.Internal.make_terminator (obligation_terminator prg.prg_name num guard ?hook auto) in let hook = Lemmas.mk_hook (obligation_hook prg obl num auto) in - let pstate = Lemmas.start_proof ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator ~hook in - let pstate = fst @@ Pfedit.by !default_tactic pstate in - let pstate = Option.cata (fun tac -> Proof_global.set_endline_tactic tac pstate) pstate tac in - pstate + let lemma = Lemmas.start_lemma ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator ~hook in + let lemma = fst @@ Lemmas.by !default_tactic lemma in + let lemma = Option.cata (fun tac -> Lemmas.set_endline_tactic tac lemma) lemma tac in + lemma and obligation (user_num, name, typ) tac = let num = pred user_num in @@ -1102,7 +1105,7 @@ let show_term n = ++ Printer.pr_constr_env env sigma prg.prg_body) let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) - ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic + ?(implicits=[]) ?(kind=Global ImportDefaultBehavior,false,Definition) ?tactic ?(reduce=reduce) ?hook ?(opaque = false) obls = let sign = Lemmas.initialize_named_context_for_proof () in let info = Id.print n ++ str " has type-checked" in @@ -1122,7 +1125,7 @@ let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) | _ -> res) let add_mutual_definitions l ctx ?(univdecl=UState.default_univ_decl) ?tactic - ?(kind=Global,false,Definition) ?(reduce=reduce) + ?(kind=Global ImportDefaultBehavior,false,Definition) ?(reduce=reduce) ?hook ?(opaque = false) notations fixkind = let sign = Lemmas.initialize_named_context_for_proof () in let deps = List.map (fun (n, b, t, imps, obls) -> n) l in @@ -1153,7 +1156,7 @@ let admit_prog prg = | None -> let x = subst_deps_obl obls x in let ctx = UState.univ_entry ~poly:false prg.prg_ctx in - let kn = Declare.declare_constant x.obl_name ~local:true + let kn = Declare.declare_constant x.obl_name ~local:ImportNeedQualified (ParameterEntry (None,(x.obl_type,ctx),None), IsAssumption Conjectural) in assumption_message x.obl_name; diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 3b77039de5..8734d82970 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -86,14 +86,14 @@ val add_mutual_definitions : fixpoint_kind -> unit val obligation - : int * Names.Id.t option * Constrexpr.constr_expr option + : int * Names.Id.t option * Constrexpr.constr_expr option -> Genarg.glob_generic_argument option - -> Proof_global.t + -> Lemmas.t val next_obligation - : Names.Id.t option + : Names.Id.t option -> Genarg.glob_generic_argument option - -> Proof_global.t + -> Lemmas.t val solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> progress (* Number of remaining obligations to be solved for this program *) diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 535a0fa02c..fda1e2afea 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -39,8 +39,8 @@ open Pputils pr_sep_com spc @@ pr_lconstr_expr env sigma let pr_uconstraint (l, d, r) = - pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ - pr_glob_level r + pr_glob_sort_name l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ + pr_glob_sort_name r let pr_univ_name_list = function | None -> mt () @@ -359,6 +359,8 @@ open Pputils keyword (if many then "Variables" else "Variable") | (DoDischarge,Conjectural) -> anomaly (Pp.str "Don't know how to beautify a local conjecture.") + | (_,Context) -> + anomaly (Pp.str "Context is used only internally.") let pr_params pr_c (xl,(c,t)) = hov 2 (prlist_with_sep sep pr_lident xl ++ spc() ++ diff --git a/vernac/record.ml b/vernac/record.ml index d617b13db4..c777ef2c2b 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -125,7 +125,7 @@ let typecheck_params_and_fields finite def poly pl ps records = let env = EConstr.push_rel_context newps env0 in let poly = match t with - | { CAst.v = CSort (Glob_term.GType []) } -> true | _ -> false in + | { CAst.v = CSort (Glob_term.UAnonymous {rigid=true}) } -> true | _ -> false in let sigma, s = interp_type_evars ~program_mode:false env sigma ~impls:empty_internalization_env t in let sred = Reductionops.whd_allnolet env sigma s in (match EConstr.kind sigma sred with @@ -344,7 +344,7 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name flags f try let entry = { const_entry_body = - Future.from_val (Safe_typing.mk_pure_proof proj); + Future.from_val ((proj, Univ.ContextSet.empty), Evd.empty_side_effects); const_entry_secctx = None; const_entry_type = Some projtyp; const_entry_universes = ctx; diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 18e0fde296..112c4b6451 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -38,28 +38,24 @@ module NamedDecl = Context.Named.Declaration let (f_interp_redexp, interp_redexp_hook) = Hook.make () let debug = false + (* XXX Should move to a common library *) let vernac_pperr_endline pp = if debug then Format.eprintf "@[%a@]@\n%!" Pp.pp_with (pp ()) else () -(* Misc *) - -let there_are_pending_proofs ~pstate = - not Option.(is_empty pstate) +(* Utility functions, at some point they should all disappear and + instead enviroment/state selection should be done at the Vernac DSL + level. *) -(* EJGA: Only used in close_proof 2, can remove once ?proof hack is away *) -let vernac_require_open_proof ~pstate f = - match pstate with - | Some pstate -> f ~pstate +(* EJGA: Only used in close_proof, can remove once the ?proof hack is no more *) +let vernac_require_open_lemma ~stack f = + match stack with + | Some stack -> f ~stack | None -> user_err Pp.(str "Command not supported (No proof-editing in progress)") -let with_pstate ~pstate f = - vernac_require_open_proof ~pstate - (fun ~pstate -> f ~pstate:(Proof_global.get_current_pstate pstate)) - - let modify_pstate ~pstate f = - vernac_require_open_proof ~pstate (fun ~pstate -> - Some (Proof_global.modify_current_pstate (fun pstate -> f ~pstate) pstate)) +let with_pstate ~stack f = + vernac_require_open_lemma ~stack + (fun ~stack -> Stack.with_top_pstate stack ~f:(fun pstate -> f ~pstate)) let get_current_or_global_context ~pstate = match pstate with @@ -85,7 +81,7 @@ module DefAttributes = struct locality : bool option; polymorphic : bool; program : bool; - deprecated : deprecation option; + deprecated : Deprecation.t option; } let parse f = @@ -96,6 +92,8 @@ module DefAttributes = struct { polymorphic; program; locality; deprecated } end +let module_locality = Attributes.Notations.(locality >>= fun l -> return (make_module_locality l)) + let with_locality ~atts f = let local = Attributes.(parse locality atts) in f ~local @@ -106,8 +104,7 @@ let with_section_locality ~atts f = f ~section_local let with_module_locality ~atts f = - let local = Attributes.(parse locality atts) in - let module_local = make_module_locality local in + let module_local = Attributes.(parse module_locality atts) in f ~module_local let with_def_attributes ~atts f = @@ -122,7 +119,7 @@ let show_proof ~pstate = (* spiwack: this would probably be cooler with a bit of polishing. *) try let pstate = Option.get pstate in - let p = Proof_global.give_me_the_proof pstate in + let p = Proof_global.get_proof pstate in let sigma, env = Pfedit.get_current_context pstate in let pprf = Proof.partial_proof p in Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf @@ -132,24 +129,21 @@ let show_proof ~pstate = | Option.IsNone -> user_err (str "No goals to show.") -let show_top_evars ~pstate = +let show_top_evars ~proof = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) - let pfts = Proof_global.give_me_the_proof pstate in - let Proof.{goals;shelf;given_up;sigma} = Proof.data pfts in + let Proof.{goals;shelf;given_up;sigma} = Proof.data proof in pr_evars_int sigma ~shelf ~given_up 1 (Evd.undefined_map sigma) -let show_universes ~pstate = - let pfts = Proof_global.give_me_the_proof pstate in - let Proof.{goals;sigma} = Proof.data pfts in +let show_universes ~proof = + let Proof.{goals;sigma} = Proof.data proof in let ctx = Evd.universe_context_set (Evd.minimize_universes sigma) in Termops.pr_evar_universe_context (Evd.evar_universe_context sigma) ++ fnl () ++ str "Normalized constraints: " ++ Univ.pr_universe_context_set (Termops.pr_evd_level sigma) ctx (* Simulate the Intro(s) tactic *) -let show_intro ~pstate all = +let show_intro ~proof all = let open EConstr in - let pf = Proof_global.give_me_the_proof pstate in - let Proof.{goals;sigma} = Proof.data pf in + let Proof.{goals;sigma} = Proof.data proof in if not (List.is_empty goals) then begin let gl = {Evd.it=List.hd goals ; sigma = sigma; } in let l,_= decompose_prod_assum sigma (Termops.strip_outer_cast sigma (pf_concl gl)) in @@ -429,7 +423,7 @@ let universe_subgraph ?loc g univ = let open Univ in let sigma = Evd.from_env (Global.env()) in let univs_of q = - let q = Glob_term.(GType (UNamed q)) in + let q = Glob_term.(GType q) in (* this function has a nice error message for not found univs *) LSet.singleton (Pretyping.interp_known_glob_level ?loc sigma q) in @@ -511,7 +505,7 @@ let dump_global r = let vernac_syntax_extension ~module_local infix l = if infix then Metasyntax.check_infix_modifiers (snd l); - Metasyntax.add_syntax_extension module_local l + Metasyntax.add_syntax_extension ~local:module_local l let vernac_declare_scope ~module_local sc = Metasyntax.declare_scope module_local sc @@ -530,11 +524,13 @@ let vernac_open_close_scope ~section_local (b,s) = let vernac_arguments_scope ~section_local r scl = Notation.declare_arguments_scope section_local (smart_global r) scl -let vernac_infix ~module_local = - Metasyntax.add_infix module_local (Global.env()) +let vernac_infix ~atts = + let module_local, deprecation = Attributes.(parse Notations.(module_locality ++ deprecation) atts) in + Metasyntax.add_infix ~local:module_local deprecation (Global.env()) -let vernac_notation ~module_local = - Metasyntax.add_notation module_local (Global.env()) +let vernac_notation ~atts = + let module_local, deprecation = Attributes.(parse Notations.(module_locality ++ deprecation) atts) in + Metasyntax.add_notation ~local:module_local deprecation (Global.env()) let vernac_custom_entry ~module_local s = Metasyntax.declare_custom_entry module_local s @@ -586,7 +582,7 @@ let start_proof_and_print ~program_mode ?hook k l = in Some hook else None in - start_proof_com ~program_mode ?inference_hook ?hook k l + start_lemma_com ~program_mode ?inference_hook ?hook k l let vernac_definition_hook p = function | Coercion -> @@ -597,6 +593,9 @@ let vernac_definition_hook p = function Some (Class.add_subclass_hook p) | _ -> None +let fresh_name_for_anonymous_theorem () = + Namegen.next_global_ident_away Lemmas.default_thm_id Id.Set.empty + let vernac_definition_name lid local = let lid = match lid with @@ -606,7 +605,7 @@ let vernac_definition_name lid local = let () = match local with | Discharge -> Dumpglob.dump_definition lid true "var" - | Local | Global -> Dumpglob.dump_definition lid false "def" + | Global _ -> Dumpglob.dump_definition lid false "def" in lid @@ -641,30 +640,39 @@ let vernac_start_proof ~atts kind l = List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; start_proof_and_print ~program_mode:atts.program (local, atts.polymorphic, Proof kind) l -let vernac_end_proof ?pstate:ontop ?proof = function +let vernac_end_proof ?stack ?proof = let open Vernacexpr in function | Admitted -> - with_pstate ~pstate:ontop (save_proof_admitted ?proof); - ontop + vernac_require_open_lemma ~stack (fun ~stack -> + let lemma, stack = Stack.pop stack in + save_lemma_admitted ?proof ~lemma; + stack) | Proved (opaque,idopt) -> - save_proof_proved ?ontop ?proof ~opaque ~idopt + let lemma, stack = match stack with + | None -> None, None + | Some stack -> + let lemma, stack = Stack.pop stack in + Some lemma, stack + in + save_lemma_proved ?lemma ?proof ~opaque ~idopt; + stack -let vernac_exact_proof ~pstate c = +let vernac_exact_proof ~lemma c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the beginning of a proof. *) - let pstate, status = Pfedit.by (Tactics.exact_proof c) pstate in - let () = save_pstate_proved ~pstate ~opaque:Proof_global.Opaque ~idopt:None in + let lemma, status = Lemmas.by (Tactics.exact_proof c) lemma in + let () = save_lemma_proved ?proof:None ~lemma ~opaque:Proof_global.Opaque ~idopt:None in if not status then Feedback.feedback Feedback.AddedAxiom let vernac_assumption ~atts discharge kind l nl = let open DefAttributes in let local = enforce_locality_exp atts.locality discharge in - let global = local == Global in let kind = local, atts.polymorphic, kind in List.iter (fun (is_coe,(idl,c)) -> if Dumpglob.dump () then List.iter (fun (lid, _) -> - if global then Dumpglob.dump_definition lid false "ax" - else Dumpglob.dump_definition lid true "var") idl) l; + match local with + | Global _ -> Dumpglob.dump_definition lid false "ax" + | Discharge -> Dumpglob.dump_definition lid true "var") idl) l; let status = ComAssumption.do_assumptions ~program_mode:atts.program kind nl l in if not status then Feedback.feedback Feedback.AddedAxiom @@ -1157,7 +1165,7 @@ let focus_command_cond = Proof.no_cond command_focus all tactics fail if there are no further goals to prove. *) let vernac_solve_existential ~pstate n com = - Proof_global.modify_proof (fun p -> + Proof_global.map_proof (fun p -> let intern env sigma = Constrintern.intern_constr env sigma com in Proof.V82.instantiate_evar (Global.env ()) n intern p) pstate @@ -1167,15 +1175,14 @@ let vernac_set_end_tac ~pstate tac = (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) Proof_global.set_endline_tactic tac pstate -let vernac_set_used_variables ~(pstate : Proof_global.t) e : Proof_global.t = +let vernac_set_used_variables ~pstate e : Proof_global.t = let env = Global.env () in let initial_goals pf = Proofview.initial_goals Proof.(data pf).Proof.entry in - let tys = - List.map snd (initial_goals (Proof_global.give_me_the_proof pstate)) in + let tys = List.map snd (initial_goals (Proof_global.get_proof pstate)) in let tys = List.map EConstr.Unsafe.to_constr tys in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in - List.iter (fun id -> + List.iter (fun id -> if not (List.exists (NamedDecl.get_id %> Id.equal id) vars) then user_err ~hdr:"vernac_set_used_variables" (str "Unknown variable: " ++ Id.print id)) @@ -1261,9 +1268,10 @@ let vernac_hints ~atts dbnames h = let local = enforce_module_locality local in Hints.add_hints ~local dbnames (Hints.interp_hints poly h) -let vernac_syntactic_definition ~module_local lid x y = +let vernac_syntactic_definition ~atts lid x compat = + let module_local, deprecation = Attributes.(parse Notations.(module_locality ++ deprecation) atts) in Dumpglob.dump_definition lid false "syndef"; - Metasyntax.add_syntactic_definition (Global.env()) lid.v x module_local y + Metasyntax.add_syntactic_definition ~local:module_local deprecation (Global.env()) lid.v x compat let cache_bidi_hints (_name, (gr, ohint)) = match ohint with @@ -1878,10 +1886,10 @@ let get_current_context_of_args ~pstate = match pstate with | None -> fun _ -> let env = Global.env () in Evd.(from_env env, env) - | Some pstate -> + | Some lemma -> function - | Some n -> Pfedit.get_goal_context pstate n - | None -> Pfedit.get_current_context pstate + | Some n -> Pfedit.get_goal_context lemma n + | None -> Pfedit.get_current_context lemma let query_command_selector ?loc = function | None -> None @@ -1946,7 +1954,7 @@ let vernac_global_check c = let get_nth_goal ~pstate n = - let pf = Proof_global.give_me_the_proof pstate in + let pf = Proof_global.get_proof pstate in let Proof.{goals;sigma} = Proof.data pf in let gl = {Evd.it=List.nth goals (n-1) ; sigma = sigma; } in gl @@ -2022,9 +2030,9 @@ let vernac_print ~pstate ~atts = | PrintHintGoal -> begin match pstate with | Some pstate -> - Hints.pr_applicable_hint pstate + Hints.pr_applicable_hint pstate | None -> - str "No proof in progress" + str "No proof in progress" end | PrintHintDbName s -> Hints.pr_hint_db_by_name env sigma s | PrintHintDb -> Hints.pr_searchtable env sigma @@ -2176,7 +2184,7 @@ let vernac_register qid r = (* Proof management *) let vernac_focus ~pstate gln = - Proof_global.modify_proof (fun p -> + Proof_global.map_proof (fun p -> match gln with | None -> Proof.focus focus_command_cond () 1 p | Some 0 -> @@ -2187,19 +2195,18 @@ let vernac_focus ~pstate gln = (* Unfocuses one step in the focus stack. *) let vernac_unfocus ~pstate = - Proof_global.modify_proof + Proof_global.map_proof (fun p -> Proof.unfocus command_focus p ()) pstate (* Checks that a proof is fully unfocused. Raises an error if not. *) let vernac_unfocused ~pstate = - let p = Proof_global.give_me_the_proof pstate in + let p = Proof_global.get_proof pstate in if Proof.unfocused p then str"The proof is indeed fully unfocused." else user_err Pp.(str "The proof is not fully unfocused.") - (* "{" focuses on the first goal, "n: {" focuses on the n-th goal "}" unfocuses, provided that the proof of the goal has been completed. *) @@ -2207,7 +2214,7 @@ let subproof_kind = Proof.new_focus_kind () let subproof_cond = Proof.done_cond subproof_kind let vernac_subproof gln ~pstate = - Proof_global.modify_proof (fun p -> + Proof_global.map_proof (fun p -> match gln with | None -> Proof.focus subproof_cond () 1 p | Some (Goal_select.SelectNth n) -> Proof.focus subproof_cond () n p @@ -2217,12 +2224,12 @@ let vernac_subproof gln ~pstate = pstate let vernac_end_subproof ~pstate = - Proof_global.modify_proof (fun p -> + Proof_global.map_proof (fun p -> Proof.unfocus subproof_kind p ()) pstate let vernac_bullet (bullet : Proof_bullet.t) ~pstate = - Proof_global.modify_proof (fun p -> + Proof_global.map_proof (fun p -> Proof_bullet.put p bullet) pstate (* Stack is needed due to show proof names, should deprecate / remove @@ -2239,25 +2246,26 @@ let vernac_show ~pstate = end (* Show functions that require a proof state *) | Some pstate -> + let proof = Proof_global.get_proof pstate in begin function | ShowGoal goalref -> - let proof = Proof_global.give_me_the_proof pstate in begin match goalref with | OpenSubgoals -> pr_open_subgoals ~proof | NthGoal n -> pr_nth_open_subgoal ~proof n | GoalId id -> pr_goal_by_id ~proof id end - | ShowExistentials -> show_top_evars ~pstate - | ShowUniverses -> show_universes ~pstate + | ShowExistentials -> show_top_evars ~proof + | ShowUniverses -> show_universes ~proof + (* Deprecate *) | ShowProofNames -> - Id.print (Proof_global.get_current_proof_name pstate) - | ShowIntros all -> show_intro ~pstate all + Id.print (Proof_global.get_proof_name pstate) + | ShowIntros all -> show_intro ~proof all | ShowProof -> show_proof ~pstate:(Some pstate) | ShowMatch id -> show_match id end let vernac_check_guard ~pstate = - let pts = Proof_global.give_me_the_proof pstate in + let pts = Proof_global.get_proof pstate in let pfterm = List.hd (Proof.partial_proof pts) in let message = try @@ -2322,30 +2330,31 @@ let locate_if_not_already ?loc (e, info) = exception End_of_input -let interp_typed_vernac c ~pstate = - let open Proof_global in +let interp_typed_vernac c ~stack = let open Vernacextend in match c with - | VtDefault f -> f (); pstate + | VtDefault f -> f (); stack | VtNoProof f -> - if there_are_pending_proofs ~pstate then + if Option.has_some stack then user_err Pp.(str "Command not supported (Open proofs remain)"); let () = f () in - pstate + stack | VtCloseProof f -> - vernac_require_open_proof ~pstate (fun ~pstate -> - f ~pstate:(Proof_global.get_current_pstate pstate); - Proof_global.discard_current pstate) + vernac_require_open_lemma ~stack (fun ~stack -> + let lemma, stack = Stack.pop stack in + f ~lemma; + stack) | VtOpenProof f -> - Some (push ~ontop:pstate (f ())) + Some (Stack.push stack (f ())) | VtModifyProof f -> - modify_pstate f ~pstate + Option.map (Stack.map_top_pstate ~f:(fun pstate -> f ~pstate)) stack | VtReadProofOpt f -> - f ~pstate:(Option.map get_current_pstate pstate); - pstate + let pstate = Option.map (Stack.with_top_pstate ~f:(fun x -> x)) stack in + f ~pstate; + stack | VtReadProof f -> - with_pstate ~pstate f; - pstate + with_pstate ~stack f; + stack (* We interpret vernacular commands to a DSL that specifies their allowed actions on proof states *) @@ -2374,9 +2383,9 @@ let translate_vernac ~atts v = let open Vernacextend in match v with | VernacOpenCloseScope (b, s) -> VtDefault(fun () -> with_section_locality ~atts vernac_open_close_scope (b,s)) | VernacInfix (mv,qid,sc) -> - VtDefault(fun () -> with_module_locality ~atts vernac_infix mv qid sc) + VtDefault(fun () -> vernac_infix ~atts mv qid sc) | VernacNotation (c,infpl,sc) -> - VtDefault(fun () -> with_module_locality ~atts vernac_notation c infpl sc) + VtDefault(fun () -> vernac_notation ~atts c infpl sc) | VernacNotationAddFormat(n,k,v) -> VtDefault(fun () -> unsupported_attributes atts; @@ -2398,9 +2407,9 @@ let translate_vernac ~atts v = let open Vernacextend in match v with | VernacStartTheoremProof (k,l) -> VtOpenProof(fun () -> with_def_attributes ~atts vernac_start_proof k l) | VernacExactProof c -> - VtCloseProof(fun ~pstate -> + VtCloseProof (fun ~lemma -> unsupported_attributes atts; - vernac_exact_proof ~pstate c) + vernac_exact_proof ~lemma c) | VernacDefineModule (export,lid,bl,mtys,mexprl) -> let i () = @@ -2554,8 +2563,7 @@ let translate_vernac ~atts v = let open Vernacextend in match v with VtDefault(fun () -> vernac_hints ~atts dbnames hints) | VernacSyntacticDefinition (id,c,b) -> - VtDefault(fun () -> - with_module_locality ~atts vernac_syntactic_definition id c b) + VtDefault(fun () -> vernac_syntactic_definition ~atts id c b) | VernacArguments (qid, args, more_implicits, nargs, bidi, flags) -> VtDefault(fun () -> with_section_locality ~atts (vernac_arguments qid args more_implicits nargs bidi flags)) @@ -2671,7 +2679,7 @@ let translate_vernac ~atts v = let open Vernacextend in match v with * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) let rec interp_expr ?proof ~atts ~st c = - let pstate = st.Vernacstate.proof in + let stack = st.Vernacstate.lemmas in vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); match c with @@ -2694,16 +2702,16 @@ let rec interp_expr ?proof ~atts ~st c = [vernac_load] is mutually-recursive with [interp_expr] *) | VernacLoad (verbosely,fname) -> unsupported_attributes atts; - vernac_load ?proof ~verbosely ~st fname + vernac_load ~verbosely ~st fname (* Special: ?proof parameter doesn't allow for uniform pstate pop :S *) | VernacEndProof e -> unsupported_attributes atts; - vernac_end_proof ?proof ?pstate e + vernac_end_proof ?proof ?stack e | v -> let fv = translate_vernac ~atts v in - interp_typed_vernac ~pstate fv + interp_typed_vernac ~stack fv (* XXX: This won't properly set the proof mode, as of today, it is controlled by the STM. Thus, we would need access information from @@ -2711,9 +2719,10 @@ let rec interp_expr ?proof ~atts ~st c = the way the proof mode is set there makes the task non trivial without a considerable amount of refactoring. *) -and vernac_load ?proof ~verbosely ~st fname = - let pstate = st.Vernacstate.proof in - if there_are_pending_proofs ~pstate then +and vernac_load ~verbosely ~st fname = + let there_are_pending_proofs ~stack = not Option.(is_empty stack) in + let stack = st.Vernacstate.lemmas in + if there_are_pending_proofs ~stack then CErrors.user_err Pp.(str "Load is not supported inside proofs."); (* Open the file *) let fname = @@ -2730,29 +2739,29 @@ and vernac_load ?proof ~verbosely ~st fname = match Pcoq.Entry.parse (Pvernac.main_entry proof_mode) po with | Some x -> x | None -> raise End_of_input) in - let rec load_loop ~pstate = + let rec load_loop ~stack = try - let proof_mode = Option.map (fun _ -> get_default_proof_mode ()) pstate in - let pstate = - v_mod (interp_control ?proof ~st:{ st with Vernacstate.proof = pstate }) + 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 }) (parse_sentence proof_mode input) in - load_loop ~pstate + load_loop ~stack with End_of_input -> - pstate + stack in - let pstate = load_loop ~pstate in + let stack = load_loop ~stack in (* If Load left a proof open, we fail too. *) - if there_are_pending_proofs ~pstate then + if there_are_pending_proofs ~stack then CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); - pstate + stack and interp_control ?proof ~st v = match v with | { v=VernacExpr (atts, cmd) } -> interp_expr ?proof ~atts ~st cmd | { v=VernacFail v } -> with_fail ~st (fun () -> interp_control ?proof ~st v); - st.Vernacstate.proof + st.Vernacstate.lemmas | { v=VernacTimeout (timeout,v) } -> vernac_timeout ~timeout (interp_control ?proof ~st) v | { v=VernacRedirect (s, v) } -> @@ -2774,8 +2783,8 @@ let interp ?(verbosely=true) ?proof ~st cmd = Vernacstate.unfreeze_interp_state st; try vernac_timeout (fun st -> let v_mod = if verbosely then Flags.verbosely else Flags.silently in - let pstate = v_mod (interp_control ?proof ~st) cmd in - Vernacstate.Proof_global.set pstate [@ocaml.warning "-3"]; + let ontop = v_mod (interp_control ?proof ~st) cmd in + Vernacstate.Proof_global.set ontop [@ocaml.warning "-3"]; Vernacstate.freeze_interp_state ~marshallable:false ) st with exn -> diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index d94ddc1aaf..f1c8b29313 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -22,7 +22,7 @@ val vernac_require : (** The main interpretation function of vernacular expressions *) val interp : ?verbosely:bool -> - ?proof:Proof_global.closed_proof -> + ?proof:(Proof_global.proof_object * Lemmas.proof_terminator) -> st:Vernacstate.t -> Vernacexpr.vernac_control -> Vernacstate.t (** Prepare a "match" template for a given inductive type. @@ -41,13 +41,6 @@ val command_focus : unit Proof.focus_kind val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr -> Evd.evar_map * Redexpr.red_expr) Hook.t -(** Helper *) -val vernac_require_open_proof : pstate:Proof_global.stack option -> (pstate:Proof_global.stack -> 'a) -> 'a - -val with_pstate : pstate:Proof_global.stack option -> (pstate:Proof_global.t -> 'a) -> 'a - -val modify_pstate : pstate:Proof_global.stack option -> (pstate:Proof_global.t -> Proof_global.t) -> Proof_global.stack option - (* Flag set when the test-suite is called. Its only effect to display verbose information for `Fail` *) val test_mode : bool ref diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 6f8a4e8a3c..6a52177dd5 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -55,9 +55,10 @@ type vernac_classification = vernac_type * vernac_when type typed_vernac = | VtDefault of (unit -> unit) + | VtNoProof of (unit -> unit) - | VtCloseProof of (pstate:Proof_global.t -> unit) - | VtOpenProof of (unit -> Proof_global.t) + | VtCloseProof of (lemma:Lemmas.t -> unit) + | VtOpenProof of (unit -> Lemmas.t) | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) | VtReadProofOpt of (pstate:Proof_global.t option -> unit) | VtReadProof of (pstate:Proof_global.t -> unit) diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 60e371a6d9..78b7f21b0d 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -74,8 +74,8 @@ type vernac_classification = vernac_type * vernac_when type typed_vernac = | VtDefault of (unit -> unit) | VtNoProof of (unit -> unit) - | VtCloseProof of (pstate:Proof_global.t -> unit) - | VtOpenProof of (unit -> Proof_global.t) + | VtCloseProof of (lemma:Lemmas.t -> unit) + | VtOpenProof of (unit -> Lemmas.t) | VtModifyProof of (pstate:Proof_global.t -> Proof_global.t) | VtReadProofOpt of (pstate:Proof_global.t option -> unit) | VtReadProof of (pstate:Proof_global.t -> unit) diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index 0fbde1ade5..c51d3c30f4 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -30,18 +30,16 @@ end type t = { parsing : Parser.state; system : States.state; (* summary + libstack *) - proof : Proof_global.stack option; (* proof state *) + lemmas : Lemmas.Stack.t option; (* proofs of lemmas currently opened *) shallow : bool (* is the state trimmed down (libstack) *) } -let pstate st = Option.map Proof_global.get_current_pstate st.proof - let s_cache = ref None -let s_proof = ref None +let s_lemmas = ref None let invalidate_cache () = s_cache := None; - s_proof := None + s_lemmas := None let update_cache rf v = rf := Some v; v @@ -57,14 +55,14 @@ let do_if_not_cached rf f v = let freeze_interp_state ~marshallable = { system = update_cache s_cache (States.freeze ~marshallable); - proof = !s_proof; + lemmas = !s_lemmas; shallow = false; parsing = Parser.cur_state (); } -let unfreeze_interp_state { system; proof; parsing } = +let unfreeze_interp_state { system; lemmas; parsing } = do_if_not_cached s_cache States.unfreeze system; - s_proof := proof; + s_lemmas := lemmas; Pcoq.unfreeze parsing let make_shallow st = @@ -77,11 +75,16 @@ let make_shallow st = (* Compatibility module *) module Proof_global = struct - let get () = !s_proof - let set x = s_proof := x + type t = Lemmas.Stack.t + + let get () = !s_lemmas + let set x = s_lemmas := x + + let get_pstate () = + Option.map (Lemmas.Stack.with_top ~f:(Lemmas.pf_fold (fun x -> x))) !s_lemmas let freeze ~marshallable:_ = get () - let unfreeze x = s_proof := Some x + let unfreeze x = s_lemmas := Some x exception NoCurrentProof @@ -92,53 +95,62 @@ module Proof_global = struct | _ -> raise CErrors.Unhandled end + open Lemmas open Proof_global - let cc f = match !s_proof with + let cc f = match !s_lemmas with | None -> raise NoCurrentProof - | Some x -> f x - - let cc1 f = cc (fun p -> f (Proof_global.get_current_pstate p)) + | Some x -> Stack.with_top_pstate ~f x - let dd f = match !s_proof with + let cc_lemma f = match !s_lemmas with | None -> raise NoCurrentProof - | Some x -> s_proof := Some (f x) + | Some x -> Stack.with_top ~f x - let dd1 f = dd (fun p -> Proof_global.modify_current_pstate f p) + let cc_stack f = match !s_lemmas with + | None -> raise NoCurrentProof + | Some x -> f x - let there_are_pending_proofs () = !s_proof <> None - let get_open_goals () = cc1 get_open_goals + let dd f = match !s_lemmas with + | None -> raise NoCurrentProof + | Some x -> s_lemmas := Some (Stack.map_top_pstate ~f x) - let set_terminator x = dd1 (set_terminator x) - let give_me_the_proof_opt () = Option.map (fun p -> give_me_the_proof (Proof_global.get_current_pstate p)) !s_proof - let give_me_the_proof () = cc1 give_me_the_proof - let get_current_proof_name () = cc1 get_current_proof_name + let there_are_pending_proofs () = !s_lemmas <> None + let get_open_goals () = cc get_open_goals - let simple_with_current_proof f = - dd (simple_with_current_proof f) + let give_me_the_proof_opt () = Option.map (Stack.with_top_pstate ~f:get_proof) !s_lemmas + let give_me_the_proof () = cc get_proof + let get_current_proof_name () = cc get_proof_name + let map_proof f = dd (map_proof f) let with_current_proof f = - let pf, res = cc (with_current_proof f) in - s_proof := Some pf; res + match !s_lemmas with + | None -> raise NoCurrentProof + | Some stack -> + let pf, res = Stack.with_top_pstate stack ~f:(map_fold_proof_endline f) in + let stack = Stack.map_top_pstate stack ~f:(fun _ -> pf) in + s_lemmas := Some stack; + res + + type closed_proof = Proof_global.proof_object * Lemmas.proof_terminator - let install_state s = s_proof := Some s - let return_proof ?allow_partial () = - cc1 (return_proof ?allow_partial) + let return_proof ?allow_partial () = cc (return_proof ?allow_partial) let close_future_proof ~opaque ~feedback_id pf = - cc1 (fun st -> close_future_proof ~opaque ~feedback_id st pf) + cc_lemma (fun pt -> pf_fold (fun st -> close_future_proof ~opaque ~feedback_id st pf) pt, + Internal.get_terminator pt) let close_proof ~opaque ~keep_body_ucst_separate f = - cc1 (close_proof ~opaque ~keep_body_ucst_separate f) + cc_lemma (fun pt -> pf_fold ((close_proof ~opaque ~keep_body_ucst_separate f)) pt, + Internal.get_terminator pt) - let discard_all () = s_proof := None - let update_global_env () = dd1 update_global_env + let discard_all () = s_lemmas := None + let update_global_env () = dd (update_global_env) - let get_current_context () = cc1 Pfedit.get_current_context + let get_current_context () = cc Pfedit.get_current_context let get_all_proof_names () = - try cc get_all_proof_names + try cc_stack Lemmas.Stack.get_all_proof_names with NoCurrentProof -> [] let copy_terminators ~src ~tgt = @@ -146,6 +158,6 @@ module Proof_global = struct | None, None -> None | Some _ , None -> None | None, Some x -> Some x - | Some src, Some tgt -> Some (copy_terminators ~src ~tgt) + | Some src, Some tgt -> Some (Stack.copy_terminators ~src ~tgt) end diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index b0f3c572e5..9f4e366e1c 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -18,14 +18,12 @@ module Parser : sig end -type t = { - parsing : Parser.state; - system : States.state; (* summary + libstack *) - proof : Proof_global.stack option; (* proof state *) - shallow : bool (* is the state trimmed down (libstack) *) -} - -val pstate : t -> Proof_global.t option +type t = + { parsing : Parser.state + ; system : States.state (* summary + libstack *) + ; lemmas : Lemmas.Stack.t option (* proofs of lemmas currently opened *) + ; shallow : bool (* is the state trimmed down (libstack) *) + } val freeze_interp_state : marshallable:bool -> t val unfreeze_interp_state : t -> unit @@ -38,41 +36,29 @@ val invalidate_cache : unit -> unit (* Compatibility module: Do Not Use *) module Proof_global : sig - open Proof_global - - (* Low-level stuff *) - val get : unit -> stack option - val set : stack option -> unit - - val freeze : marshallable:bool -> stack option - val unfreeze : stack -> unit - exception NoCurrentProof val there_are_pending_proofs : unit -> bool val get_open_goals : unit -> int - val set_terminator : proof_terminator -> unit val give_me_the_proof : unit -> Proof.t val give_me_the_proof_opt : unit -> Proof.t option val get_current_proof_name : unit -> Names.Id.t - val simple_with_current_proof : - (unit Proofview.tactic -> Proof.t -> Proof.t) -> unit - + val map_proof : (Proof.t -> Proof.t) -> unit val with_current_proof : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a - val install_state : stack -> unit + val return_proof : ?allow_partial:bool -> unit -> Proof_global.closed_proof_output - val return_proof : ?allow_partial:bool -> unit -> closed_proof_output + type closed_proof = Proof_global.proof_object * Lemmas.proof_terminator val close_future_proof : - opaque:opacity_flag -> + opaque:Proof_global.opacity_flag -> feedback_id:Stateid.t -> - closed_proof_output Future.computation -> closed_proof + Proof_global.closed_proof_output Future.computation -> closed_proof - val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof + val close_proof : opaque:Proof_global.opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof val discard_all : unit -> unit val update_global_env : unit -> unit @@ -81,7 +67,19 @@ module Proof_global : sig val get_all_proof_names : unit -> Names.Id.t list - val copy_terminators : src:stack option -> tgt:stack option -> stack option + val copy_terminators : src:Lemmas.Stack.t option -> tgt:Lemmas.Stack.t option -> Lemmas.Stack.t option + + (* Handling of the imperative state *) + type t = Lemmas.Stack.t + + (* Low-level stuff *) + val get : unit -> t option + val set : t option -> unit + + val get_pstate : unit -> Proof_global.t option + + val freeze : marshallable:bool -> t option + val unfreeze : t -> unit end [@@ocaml.deprecated "This module is internal and should not be used, instead, thread the proof state"] |