diff options
285 files changed, 4547 insertions, 4718 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 0ebac839fc..2444e3982e 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -15,7 +15,7 @@ variables: OPAM_SWITCH: "base" # Used to select special compiler switches such as flambda, 32bits, etc... OPAM_VARIANT: "" - GIT_DEPTH: "1" + GIT_DEPTH: "10" docker-boot: stage: docker @@ -436,9 +436,6 @@ ci-mtac2: ci-paramcoq: <<: *ci-template -ci-pidetop: - <<: *ci-template - ci-plugin_tutorial: <<: *ci-template diff --git a/CHANGES.md b/CHANGES.md index ef5ad9adce..75a29de8e9 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -123,6 +123,10 @@ Universes - Added `Print Universes Subgraph` variant of `Print Universes`. Try for instance `Print Universes Subgraph(sigT2.u1 sigT_of_sigT2.u1 projT3_eq.u1 eq_sigT2_rect.u1).` +- Added private universes for opaque polymorphic constants, see doc + for the "Private Polymorphic Universes" option (and Unset it to get + the previous behaviour). + Misc - Option "Typeclasses Axioms Are Instances" is deprecated. Use Declare Instance for axioms which should be instances. @@ -147,6 +151,11 @@ Notations that will do it automatically, using the output of coqc. The script contains documentation on its usage in a comment at the top. +- When several notations are available for the same expression, + priority is given to latest notations defined in the scopes being + opened, in order, rather than to the latest notations defined + independently of whether they are in an opened scope or not. + Tactics - Added toplevel goal selector `!` which expects a single focused goal. @@ -86,6 +86,7 @@ list of persons and groups: J.-P. Jouannaud, S. Lescuyer, A. Miquel, J.-F. Monin, P.-Y. Strub the Foundations Group (Radboud University, Nijmegen, The Netherlands), Laboratoire J.-A. Dieudonné (University of Nice-Sophia Antipolis), + L. Lee (https://orcid.org/0000-0002-7128-9257, 2018), INRIA-Gallium project, the CS dept at Yale, the CIS dept at U. Penn, the CSE dept at Harvard, the CS dept at Princeton, the CS dept at MIT diff --git a/META.coq.in b/META.coq.in index 181887bc3d..b3a96a8303 100644 --- a/META.coq.in +++ b/META.coq.in @@ -22,7 +22,7 @@ package "clib" ( version = "8.10" directory = "clib" - requires = "num, str, unix, threads" + requires = "str, unix, threads" archive(byte) = "clib.cma" archive(native) = "clib.cmxa" @@ -35,7 +35,7 @@ package "lib" ( directory = "lib" - requires = "coq.clib, coq.config" + requires = "coq.clib, coq.config, dynlink" archive(byte) = "lib.cma" archive(native) = "lib.cmxa" @@ -68,7 +68,7 @@ package "kernel" ( directory = "kernel" - requires = "dynlink, coq.lib, coq.vm" + requires = "coq.lib, coq.vm" archive(byte) = "kernel.cma" archive(native) = "kernel.cmxa" @@ -146,7 +146,7 @@ package "gramlib" ( description = "Coq Grammar Engine" version = "8.10" - requires = "" + requires = "coq.lib" directory = "gramlib__pack" archive(byte) = "gramlib.cma" @@ -223,7 +223,7 @@ package "toplevel" ( description = "Coq Toplevel" version = "8.10" - requires = "coq.stm" + requires = "num, coq.stm" directory = "toplevel" archive(byte) = "toplevel.cma" diff --git a/Makefile.ci b/Makefile.ci index 88ea64974a..d0b87fc58b 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -37,7 +37,6 @@ CI_TARGETS= \ ci-math-comp \ ci-mtac2 \ ci-paramcoq \ - ci-pidetop \ ci-plugin_tutorial \ ci-quickchick \ ci-sf \ diff --git a/appveyor.yml b/appveyor.yml index c9c6bc0684..7420856214 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -2,8 +2,7 @@ version: '{branch}~{build}' clone_depth: 10 cache: - - C:\cygwin64 -> dev\ci\appveyor.bat - - C:\cygwin64\home\appveyor\.opam -> dev\ci\appveyor.sh + - C:\cygwin64 -> dev\ci\appveyor.bat, dev\ci\appveyor.sh platform: - x64 diff --git a/checker/check.ml b/checker/check.ml index e3a4bda8ec..30437e8bd0 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -136,36 +136,9 @@ type logical_path = DirPath.t let load_paths = ref ([],[] : CUnix.physical_path list * logical_path list) -(* Hints to partially detects if two paths refer to the same repertory *) -let rec remove_path_dot p = - let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *) - let n = String.length curdir in - if String.length p > n && String.sub p 0 n = curdir then - remove_path_dot (String.sub p n (String.length p - n)) - else - p - -let strip_path p = - let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *) - let n = String.length cwd in - if String.length p > n && String.sub p 0 n = cwd then - remove_path_dot (String.sub p n (String.length p - n)) - else - remove_path_dot p - -let canonical_path_name p = - let current = Sys.getcwd () in - try - Sys.chdir p; - let p' = Sys.getcwd () in - Sys.chdir current; - p' - with Sys_error _ -> - (* We give up to find a canonical name and just simplify it... *) - strip_path p let find_logical_path phys_dir = - let phys_dir = canonical_path_name phys_dir in + let phys_dir = CUnix.canonical_path_name phys_dir in let physical, logical = !load_paths in match List.filter2 (fun p d -> p = phys_dir) physical logical with | _,[dir] -> dir @@ -180,14 +153,14 @@ let add_load_path (phys_path,coq_path) = if !Flags.debug then Feedback.msg_notice (str "path: " ++ pr_dirpath coq_path ++ str " ->" ++ spc() ++ str phys_path); - let phys_path = canonical_path_name phys_path in + let phys_path = CUnix.canonical_path_name phys_path in let physical, logical = !load_paths in match List.filter2 (fun p d -> p = phys_path) physical logical with | _,[dir] -> if coq_path <> dir (* If this is not the default -I . to coqtop *) && not - (phys_path = canonical_path_name Filename.current_dir_name + (phys_path = CUnix.canonical_path_name Filename.current_dir_name && coq_path = default_root_prefix) then begin diff --git a/checker/checker.ml b/checker/checker.ml index 346ae5fffb..da6a61de1c 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -138,13 +138,16 @@ let set_debug () = Flags.debug := true let impredicative_set = ref Declarations.PredicativeSet let set_impredicative_set () = impredicative_set := Declarations.ImpredicativeSet -let engage = Safe_typing.set_engagement (!impredicative_set) -let disable_compilers senv = +let indices_matter = ref false + +let make_senv () = + let senv = Safe_typing.empty_environment in + let senv = Safe_typing.set_engagement !impredicative_set senv in + let senv = Safe_typing.set_indices_matter !indices_matter senv in let senv = Safe_typing.set_VM false senv in Safe_typing.set_native_compiler false senv - let admit_list = ref ([] : object_file list) let add_admit s = admit_list := path_of_string s :: !admit_list @@ -318,6 +321,9 @@ let parse_args argv = | "-impredicative-set" :: rem -> set_impredicative_set (); parse rem + | "-indices-matter" :: rem -> + indices_matter:=true; parse rem + | "-coqlib" :: s :: rem -> if not (exists_dir s) then fatal_error (str "Directory '" ++ str s ++ str "' does not exist") false; @@ -377,8 +383,7 @@ let init_with_argv argv = Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); Flags.if_verbose print_header (); init_load_path (); - let senv = Safe_typing.empty_environment in - disable_compilers (engage senv) + make_senv () with e -> fatal_error (str "Error during initialization :" ++ (explain_exn e)) (is_anomaly e) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index ed617d73c2..b83fe831bb 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -3,7 +3,6 @@ open Util open Names open Reduction open Typeops -open Subtyping open Declarations open Environ @@ -20,7 +19,13 @@ let check_constant_declaration env kn cb = | Monomorphic_const ctx -> false, push_context_set ~strict:true ctx env | Polymorphic_const auctx -> let ctx = Univ.AUContext.repr auctx in - true, push_context ~strict:false ctx env + let env = push_context ~strict:false ctx env in + true, env + in + let env' = match cb.const_private_poly_univs, (cb.const_body, poly) with + | None, _ -> env' + | Some local, (OpaqueDef _, true) -> push_subgraph local env' + | Some _, _ -> assert false in let ty = cb.const_type in let _ = infer_type env' ty in @@ -65,17 +70,17 @@ let rec check_module env mp mb = check_signature env mb.mod_type mb.mod_mp mb.mod_delta in let optsign = match mb.mod_expr with - |Struct sign -> Some (check_signature env sign mb.mod_mp mb.mod_delta) + |Struct sign -> Some (check_signature env sign mb.mod_mp mb.mod_delta, mb.mod_delta) |Algebraic me -> Some (check_mexpression env me mb.mod_mp mb.mod_delta) |Abstract|FullStruct -> None in match optsign with |None -> () - |Some sign -> - let mtb1 = mk_mtb mp sign mb.mod_delta + |Some (sign,delta) -> + let mtb1 = mk_mtb mp sign delta and mtb2 = mk_mtb mp mb.mod_type mb.mod_delta in let env = Modops.add_module_type mp mtb1 env in - let cu = check_subtypes env mtb1 mtb2 in + let cu = Subtyping.check_subtypes env mtb1 mtb2 in if not (Environ.check_constraints cu env) then CErrors.user_err Pp.(str "Incorrect universe constraints for module subtyping"); @@ -103,15 +108,17 @@ and check_structure_field env mp lab res = function and check_mexpr env mse mp_mse res = match mse with | MEident mp -> let mb = lookup_module mp env in - (Modops.strengthen_and_subst_mb mb mp_mse false).mod_type + let mb = Modops.strengthen_and_subst_mb mb mp_mse false in + mb.mod_type, mb.mod_delta | MEapply (f,mp) -> - let sign = check_mexpr env f mp_mse res in + let sign, delta = check_mexpr env f mp_mse res in let farg_id, farg_b, fbody_b = Modops.destr_functor sign in let mtb = Modops.module_type_of_module (lookup_module mp env) in - let cu = check_subtypes env mtb farg_b in + let cu = Subtyping.check_subtypes env mtb farg_b in if not (Environ.check_constraints cu env) then CErrors.user_err Pp.(str "Incorrect universe constraints for module subtyping"); - Modops.subst_signature (Mod_subst.map_mbid farg_id mp Mod_subst.empty_delta_resolver) fbody_b + let subst = Mod_subst.map_mbid farg_id mp Mod_subst.empty_delta_resolver in + Modops.subst_signature subst fbody_b, Mod_subst.subst_codom_delta_resolver subst delta | MEwith _ -> CErrors.user_err Pp.(str "Unsupported 'with' constraint in module implementation") @@ -119,8 +126,8 @@ and check_mexpression env sign mp_mse res = match sign with | MoreFunctor (arg_id, mtb, body) -> check_module_type env mtb; let env' = Modops.add_module_type (MPbound arg_id) mtb env in - let body = check_mexpression env' body mp_mse res in - MoreFunctor(arg_id,mtb,body) + let body, delta = check_mexpression env' body mp_mse res in + MoreFunctor(arg_id,mtb,body), delta | NoFunctor me -> check_mexpr env me mp_mse res and check_signature env sign mp_mse res = match sign with diff --git a/checker/values.ml b/checker/values.ml index 0de8a3e03f..dcb2bca81a 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -217,7 +217,7 @@ let v_cst_def = [|[|Opt Int|]; [|v_cstr_subst|]; [|v_lazy_constr|]|] let v_typing_flags = - v_tuple "typing_flags" [|v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool|] + v_tuple "typing_flags" [|v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool; v_bool|] let v_const_univs = v_sum "constant_universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] @@ -227,6 +227,7 @@ let v_cb = v_tuple "constant_body" v_constr; Any; v_const_univs; + Opt v_context_set; v_bool; v_typing_flags|] @@ -4,5 +4,5 @@ (public_name coq.clib) (wrapped false) (modules_without_implementation cSig) - (libraries threads str unix dynlink)) + (libraries str unix threads)) diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 8da4c6db13..8d728b5b51 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -139,23 +139,23 @@ let print_local fmt ext = match locals with | [] -> () | e :: locals -> - let mk_e fmt e = fprintf fmt "%s.Entry.create \"%s\"" ext.gramext_name e in + let mk_e fmt e = fprintf fmt "Pcoq.Entry.create \"%s\"" e in let () = fprintf fmt "@[<hv 2>let %s =@ @[%a@]@]@ " e mk_e e in let iter e = fprintf fmt "@[<hv 2>and %s =@ @[%a@]@]@ " e mk_e e in let () = List.iter iter locals in fprintf fmt "in@ " let print_position fmt pos = match pos with -| First -> fprintf fmt "Extend.First" -| Last -> fprintf fmt "Extend.Last" -| Before s -> fprintf fmt "Extend.Before@ \"%s\"" s -| After s -> fprintf fmt "Extend.After@ \"%s\"" s -| Level s -> fprintf fmt "Extend.Level@ \"%s\"" s +| First -> fprintf fmt "Gramlib.Gramext.First" +| Last -> fprintf fmt "Gramlib.Gramext.Last" +| Before s -> fprintf fmt "Gramlib.Gramext.Before@ \"%s\"" s +| After s -> fprintf fmt "Gramlib.Gramext.After@ \"%s\"" s +| Level s -> fprintf fmt "Gramlib.Gramext.Level@ \"%s\"" s let print_assoc fmt = function -| LeftA -> fprintf fmt "Extend.LeftA" -| RightA -> fprintf fmt "Extend.RightA" -| NonA -> fprintf fmt "Extend.NonA" +| LeftA -> fprintf fmt "Gramlib.Gramext.LeftA" +| RightA -> fprintf fmt "Gramlib.Gramext.RightA" +| NonA -> fprintf fmt "Gramlib.Gramext.NonA" let is_token s = match string_split s with | [s] -> is_uident s @@ -277,16 +277,16 @@ let print_rule fmt r = let pr_prd fmt prd = print_list fmt print_prod prd in fprintf fmt "@[(%a,@ %a,@ %a)@]" pr_lvl r.grule_label pr_asc r.grule_assoc pr_prd (List.rev r.grule_prods) -let print_entry fmt gram e = +let print_entry fmt e = let print_position_opt fmt pos = print_opt fmt print_position pos in let print_rules fmt rules = print_list fmt print_rule rules in - fprintf fmt "let () =@ @[%s.gram_extend@ %s@ @[(%a, %a)@]@]@ in@ " - gram e.gentry_name print_position_opt e.gentry_pos print_rules e.gentry_rules + fprintf fmt "let () =@ @[Pcoq.grammar_extend@ %s@ None@ @[(%a, %a)@]@]@ in@ " + e.gentry_name print_position_opt e.gentry_pos print_rules e.gentry_rules let print_ast fmt ext = let () = fprintf fmt "let _ = @[" in let () = fprintf fmt "@[<v>%a@]" print_local ext in - let () = List.iter (fun e -> print_entry fmt ext.gramext_name e) ext.gramext_entries in + let () = List.iter (fun e -> print_entry fmt e) ext.gramext_entries in let () = fprintf fmt "()@]@\n" in () diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index d0b5f4be47..b202635714 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1905,6 +1905,9 @@ function make_addon_quickchick { function make_addons { # Note: ':' is the empty command, which does not produce any output : > "/build/filelists/addon_dependencies.nsh" + : > "/build/filelists/addon_strings.nsh" + : > "/build/filelists/addon_descriptions.nsh" + : > "/build/filelists/addon_sections.nsh" for addon in $COQ_ADDONS; do "make_addon_$addon" diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md new file mode 100644 index 0000000000..6ca3aa2981 --- /dev/null +++ b/dev/ci/README-developers.md @@ -0,0 +1,165 @@ +Information for developers about the CI system +---------------------------------------------- + +When you submit a pull request (PR) on the Coq GitHub repository, this will +automatically launch a battery of CI tests. The PR will not be integrated +unless these tests pass. + +We are currently running tests on the following platforms: + +- GitLab CI is the main CI platform. It tests the compilation of Coq, + of the documentation, and of CoqIDE on Linux with several versions + of OCaml and with warnings as errors; it runs the test-suite and + tests the compilation of several external developments. + +- Travis CI is used to test the compilation of Coq and run the test-suite on + macOS. It also runs a linter that checks whitespace discipline. A + [pre-commit hook](../tools/pre-commit) is automatically installed by + `./configure`. It should allow complying with this discipline without pain. + +- AppVeyor is used to test the compilation of Coq and run the test-suite on + Windows. + +You can anticipate the results of most of these tests prior to submitting your +PR by running GitLab CI on your private branches. To do so follow these steps: + +1. Log into GitLab CI (the easiest way is to sign in with your GitHub account). +2. Click on "New Project". +3. Choose "CI / CD for external repository" then click on "GitHub". +4. Find your fork of the Coq repository and click on "Connect". +5. If GitLab did not do so automatically, [enable the Container Registry](https://docs.gitlab.com/ee/user/project/container_registry.html#enable-the-container-registry-for-your-project). +6. You are encouraged to go to the CI / CD general settings and increase the + timeout from 1h to 2h for better reliability. + +Now everytime you push (including force-push unless you changed the default +GitLab setting) to your fork on GitHub, it will be synchronized on GitLab and +CI will be run. You will receive an e-mail with a report of the failures if +there are some. + +You can also run one CI target locally (using `make ci-somedev`). + +See also [`test-suite/README.md`](../../test-suite/README.md) for information about adding new tests to the test-suite. + +### Breaking changes + +When your PR breaks an external project we test in our CI, you must +prepare a patch (or ask someone to prepare a patch) to fix the +project. There is experimental support for an improved workflow, see +[the next section](#experimental-automatic-overlay-creation-and-building), below +are the steps to manually prepare a patch: + +1. Fork the external project, create a new branch, push a commit adapting + the project to your changes. +2. Test your pull request with your adapted version of the external project by + adding an overlay file to your pull request (cf. + [`dev/ci/user-overlays/README.md`](user-overlays/README.md)). +3. Fixes to external libraries (pure Coq projects) *must* be backward + compatible (i.e. they should also work with the development version of Coq, + and the latest stable version). This will allow you to open a PR on the + external project repository to have your changes merged *before* your PR on + Coq can be integrated. + + On the other hand, patches to plugins (projects linking to the Coq ML API) + can very rarely be made backward compatible and plugins we test will + generally have a dedicated branch per Coq version. + You can still open a pull request but the merging will be requested by the + developer who merges the PR on Coq. There are plans to improve this, cf. + [#6724](https://github.com/coq/coq/issues/6724). + +Moreover your PR must absolutely update the [`CHANGES.md`](../../CHANGES.md) file. + +### Experimental automatic overlay creation and building + +If you break external projects that are hosted on GitHub, you can use +the `create-overlays.sh` script to automatically perform most of the +above steps. In order to do so, call the script as: +``` +./dev/tools/create-overlays.sh ejgallego 9873 aac_tactics elpi ltac +``` +replacing `ejgallego` by your GitHub nickname and `9873` by the actual PR +number. The script will: + +- checkout the contributions and prepare the branch/remote so you can + just commit the fixes and push, +- add the corresponding overlay file in `dev/ci/user-overlays`. + +For problems related to ML-plugins, if you use `dune build` to build +Coq, it will actually be aware of the broken contributions and perform +a global build. This is very convenient when using `merlin` as you +will get a coherent view of all the broken plugins, with full +incremental cross-project rebuild. + +Advanced GitLab CI information +------------------------------ + +GitLab CI is set up to use the "build artifact" feature to avoid +rebuilding Coq. In one job, Coq is built with `./configure -prefix _install_ci` +and `make install` is run, then the `_install_ci` directory +persists to and is used by the next jobs. + +### Artifacts + +Build artifacts from GitLab can be linked / downloaded in a systematic +way, see [GitLab's documentation](https://docs.gitlab.com/ce/user/project/pipelines/job_artifacts.html#downloading-the-latest-job-artifacts) +for more information. For example, to access the documentation of the +`master` branch, you can do: + +https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/sphinx/html/index.html?job=doc:refman + +Browsing artifacts is also possible: +https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_install_ci/?job=build:base + +Above, you can replace `master` and `job` by the desired GitLab branch and job name. + +Currently available artifacts are: + +- the Coq executables and stdlib, in four copies varying in + architecture and OCaml version used to build Coq: + https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_install_ci/?job=build:base + + Additionally, an experimental Dune build is provided: + https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_build/?job=build:edge:dune:dev + +- the Coq documentation, built in the `doc:*` jobs. When submitting + a documentation PR, this can help reviewers checking the rendered result: + + + Coq's Reference Manual [master branch] + https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/sphinx/html/index.html?job=doc:refman + + Coq's Standard Library Documentation [master branch] + https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/html/stdlib/index.html?job=build:base + + Coq's ML API Documentation [master branch] + https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_build/default/_doc/_html/index.html?job=doc:ml-api:odoc + +### GitLab and Windows + +If your repository has access to runners tagged `windows`, setting the +secret variable `WINDOWS` to `enabled` will add jobs building Windows +versions of Coq (32bit and 64bit). + +If the secret variable `WINDOWS` is set to `enabled_all_addons`, +an extended set of addons will be added to the Windows installer. +This leads to a considerable runtime in CI so this is not enabled +by default for pipelines for pull requests. + +The Windows jobs are enabled on Coq's repository, where pipelines for +pull requests run. + +### GitLab and Docker + +System and opam packages are installed in a Docker image. The image is +automatically built and uploaded to your GitLab registry, and is +loaded by subsequent jobs. + +**IMPORTANT**: When updating Coq's CI docker image, you must modify +the `CACHEKEY` variable in [`.gitlab-ci.yml`](../../.gitlab-ci.yml) +and [`Dockerfile`](docker/bionic_coq/Dockerfile) + +The Docker building job reuses the uploaded image if it is available, +but if you wish to save more time you can skip the job by setting +`SKIP_DOCKER` to `true`. + +This means you will need to change its value when the Docker image +needs to be updated. You can do so for a single pipeline by starting +it through the web interface. + +See also [`docker/README.md`](docker/README.md). diff --git a/dev/ci/README-users.md b/dev/ci/README-users.md new file mode 100644 index 0000000000..01769aeddb --- /dev/null +++ b/dev/ci/README-users.md @@ -0,0 +1,85 @@ +Information for external library / Coq plugin authors +----------------------------------------------------- + +You are encouraged to consider submitting your development for addition to +Coq's CI. This means that: + +- Any time that a proposed change is breaking your development, Coq developers + will send you patches to adapt it or, at the very least, will work with you + to see how to adapt it. + +On the condition that: + +- At the time of the submission, your development works with Coq's + `master` branch. + +- Your development is publicly available in a git repository and we can easily + send patches to you (e.g. through pull / merge requests). + +- You react in a timely manner to discuss / integrate those patches. + +- You do not push, to the branches that we test, commits that haven't been + first tested to compile with the corresponding branch(es) of Coq. + + For that, we recommend setting a CI system for you development, see + [supported CI images for Coq](#supported-ci-images-for-coq) below. + +- You maintain a reasonable build time for your development, or you provide + a "lite" target that we can use. + +In case you forget to comply with these last three conditions, we would reach +out to you and give you a 30-day grace period during which your development +would be moved into our "allow failure" category. At the end of the grace +period, in the absence of progress, the development would be removed from our +CI. + +### Timely merging of overlays + +A pitfall of the current CI setup is that when a breaking change is +merged in Coq upstream, CI for your contrib will be broken until you +merge the corresponding pull request with the fix for your contribution. + +As of today, you have to worry about synchronizing with Coq upstream +every once in a while; we hope we will improve this in the future by +using [coqbot](https://github.com/coq/bot); meanwhile, a workaround is +to give merge permissions to someone from the Coq team as to help with +these kind of merges. + +### Add your development by submitting a pull request + +Add a new `ci-mydev.sh` script to [`dev/ci`](.); set the corresponding +variables in [`ci-basic-overlay.sh`](ci-basic-overlay.sh); add the +corresponding target to [`Makefile.ci`](../../Makefile.ci) and a new job to +[`.gitlab-ci.yml`](../../.gitlab-ci.yml) so that this new target is run. +Have a look at [#7656](https://github.com/coq/coq/pull/7656/files) for an +example. **Do not hesitate to submit an incomplete pull request if you need +help to finish it.** + +You may also be interested in having your development tested in our +performance benchmark. Currently this is done by providing an OPAM package +in https://github.com/coq/opam-coq-archive and opening an issue at +https://github.com/coq/coq-bench/issues. + +### Recommended branching policy. + +It is sometimes the case that you will need to maintain a branch of +your development for particular Coq versions. This is in fact very +likely if your development includes a Coq ML plugin. + +We thus recommend a branching convention that mirrors Coq's branching +policy. Then, you would have a `master` branch that follows Coq's +`master`, a `v8.8` branch that works with Coq's `v8.8` branch and so +on. + +This convention will be supported by tools in the future to make some +developer commands work more seamlessly. + +### Supported CI images for Coq + +The Coq developers and contributors provide official Docker and Nix +images for testing against Coq master. Using these images is highly +recommended: + +- For Docker, see: https://github.com/coq-community/docker-coq +- For Nix, see the setup at + https://github.com/coq-community/manifesto/wiki/Continuous-Integration-with-Nix diff --git a/dev/ci/README.md b/dev/ci/README.md index bc49e3e76b..afbfab3ac6 100644 --- a/dev/ci/README.md +++ b/dev/ci/README.md @@ -6,213 +6,15 @@ breakage on our Continuous Integration (CI) platforms *before* integration, so as to ensure better robustness and catch problems as early as possible. These tests include the compilation of several external libraries / plugins. -This document contains information for both external library / plugin authors, -who might be interested in having their development tested, and for Coq -developers / contributors, who must ensure that they don't break these -external developments accidentally. +This README is split into two specific documents: -*Remark:* the CI policy outlined in this document is susceptible to evolve and -specific accommodations are of course possible. +- [README-users.md](./README-users.md) which contains information for + authors of external libraries and plugins who might be interested in + having their development tested in our CI system. -Information for external library / plugin authors -------------------------------------------------- +- [README-developers.md](./README-developers.md) for Coq developers / + contributors, who must ensure that they don't break these external + developments accidentally. -You are encouraged to consider submitting your development for addition to -our CI. This means that: - -- Any time that a proposed change is breaking your development, Coq developers - will send you patches to adapt it or, at the very least, will work with you - to see how to adapt it. - -On the condition that: - -- At the time of the submission, your development works with Coq's - `master` branch. - -- Your development is publicly available in a git repository and we can easily - send patches to you (e.g. through pull / merge requests). - -- You react in a timely manner to discuss / integrate those patches. - -- You do not push, to the branches that we test, commits that haven't been - first tested to compile with the corresponding branch(es) of Coq. - -- You maintain a reasonable build time for your development, or you provide - a "lite" target that we can use. - -In case you forget to comply with these last three conditions, we would reach -out to you and give you a 30-day grace period during which your development -would be moved into our "allow failure" category. At the end of the grace -period, in the absence of progress, the development would be removed from our -CI. - -### Add your development by submitting a pull request - -Add a new `ci-mydev.sh` script to [`dev/ci`](.); set the corresponding -variables in [`ci-basic-overlay.sh`](ci-basic-overlay.sh); add the -corresponding target to [`Makefile.ci`](../../Makefile.ci) and a new job to -[`.gitlab-ci.yml`](../../.gitlab-ci.yml) so that this new target is run. -Have a look at [#7656](https://github.com/coq/coq/pull/7656/files) for an -example. **Do not hesitate to submit an incomplete pull request if you need -help to finish it.** - -You may also be interested in having your development tested in our -performance benchmark. Currently this is done by providing an OPAM package -in https://github.com/coq/opam-coq-archive and opening an issue at -https://github.com/coq/coq-bench/issues. - -### Recommended branching policy. - -It is sometimes the case that you will need to maintain a branch of -your development for particular Coq versions. This is in fact very -likely if your development includes a Coq ML plugin. - -We thus recommend a branching convention that mirrors Coq's branching -policy. Then, you would have a `master` branch that follows Coq's -`master`, a `v8.8` branch that works with Coq's `v8.8` branch and so -on. - -This convention will be supported by tools in the future to make some -developer commands work more seamlessly. - -Information for developers --------------------------- - -When you submit a pull request (PR) on Coq GitHub repository, this will -automatically launch a battery of CI tests. The PR will not be integrated -unless these tests pass. - -We are currently running tests on the following platforms: - -- GitLab CI is the main CI platform. It tests the compilation of Coq, - of the documentation, and of CoqIDE on Linux with several versions - of OCaml and with warnings as errors; it runs the test-suite and - tests the compilation of several external developments. - -- Travis CI is used to test the compilation of Coq and run the test-suite on - macOS. It also runs a linter that checks whitespace discipline. A - [pre-commit hook](../tools/pre-commit) is automatically installed by - `./configure`. It should allow complying with this discipline without pain. - -- AppVeyor is used to test the compilation of Coq and run the test-suite on - Windows. - -You can anticipate the results of most of these tests prior to submitting your -PR by running GitLab CI on your private branches. To do so follow these steps: - -1. Log into GitLab CI (the easiest way is to sign in with your GitHub account). -2. Click on "New Project". -3. Choose "CI / CD for external repository" then click on "GitHub". -4. Find your fork of the Coq repository and click on "Connect". -5. If GitLab did not do so automatically, [enable the Container Registry](https://docs.gitlab.com/ee/user/project/container_registry.html#enable-the-container-registry-for-your-project). -6. You are encouraged to go to the CI / CD general settings and increase the - timeout from 1h to 2h for better reliability. - -Now everytime you push (including force-push unless you changed the default -GitLab setting) to your fork on GitHub, it will be synchronized on GitLab and -CI will be run. You will receive an e-mail with a report of the failures if -there are some. - -You can also run one CI target locally (using `make ci-somedev`). - -See also [`test-suite/README.md`](../../test-suite/README.md) for information about adding new tests to the test-suite. - -### Breaking changes - -When your PR breaks an external project we test in our CI, you must prepare a -patch (or ask someone to prepare a patch) to fix the project: - -1. Fork the external project, create a new branch, push a commit adapting - the project to your changes. -2. Test your pull request with your adapted version of the external project by - adding an overlay file to your pull request (cf. - [`dev/ci/user-overlays/README.md`](user-overlays/README.md)). -3. Fixes to external libraries (pure Coq projects) *must* be backward - compatible (i.e. they should also work with the development version of Coq, - and the latest stable version). This will allow you to open a PR on the - external project repository to have your changes merged *before* your PR on - Coq can be integrated. - - On the other hand, patches to plugins (projects linking to the Coq ML API) - can very rarely be made backward compatible and plugins we test will - generally have a dedicated branch per Coq version. - You can still open a pull request but the merging will be requested by the - developer who merges the PR on Coq. There are plans to improve this, cf. - [#6724](https://github.com/coq/coq/issues/6724). - -Moreover your PR must absolutely update the [`CHANGES.md`](../../CHANGES.md) file. - -Advanced GitLab CI information ------------------------------- - -GitLab CI is set up to use the "build artifact" feature to avoid -rebuilding Coq. In one job, Coq is built with `./configure -prefix _install_ci` -and `make install` is run, then the `_install_ci` directory -persists to and is used by the next jobs. - -### Artifacts - -Build artifacts from GitLab can be linked / downloaded in a systematic -way, see [GitLab's documentation](https://docs.gitlab.com/ce/user/project/pipelines/job_artifacts.html#downloading-the-latest-job-artifacts) -for more information. For example, to access the documentation of the -`master` branch, you can do: - -https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/sphinx/html/index.html?job=doc:refman - -Browsing artifacts is also possible: -https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_install_ci/?job=build:base - -Above, you can replace `master` and `job` by the desired GitLab branch and job name. - -Currently available artifacts are: - -- the Coq executables and stdlib, in four copies varying in - architecture and OCaml version used to build Coq: - https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_install_ci/?job=build:base - - Additionally, an experimental Dune build is provided: - https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_build/?job=build:edge:dune:dev - -- the Coq documentation, built in the `doc:*` jobs. When submitting - a documentation PR, this can help reviewers checking the rendered result: - - + Coq's Reference Manual [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/sphinx/html/index.html?job=doc:refman - + Coq's Standard Library Documentation [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/html/stdlib/index.html?job=build:base - + Coq's ML API Documentation [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_build/default/_doc/_html/index.html?job=doc:ml-api:odoc - -### GitLab and Windows - -If your repository has access to runners tagged `windows`, setting the -secret variable `WINDOWS` to `enabled` will add jobs building Windows -versions of Coq (32bit and 64bit). - -If the secret variable `WINDOWS` is set to `enabled_all_addons`, -an extended set of addons will be added to the Windows installer. -This leads to a considerable runtime in CI so this is not enabled -by default for pipelines for pull requests. - -The Windows jobs are enabled on Coq's repository, where pipelines for -pull requests run. - -### GitLab and Docker - -System and opam packages are installed in a Docker image. The image is -automatically built and uploaded to your GitLab registry, and is -loaded by subsequent jobs. - -**IMPORTANT**: When updating Coq's CI docker image, you must modify -the `CACHEKEY` variable in [`.gitlab-ci.yml`](../../.gitlab-ci.yml) -and [`Dockerfile`](docker/bionic_coq/Dockerfile) - -The Docker building job reuses the uploaded image if it is available, -but if you wish to save more time you can skip the job by setting -`SKIP_DOCKER` to `true`. - -This means you will need to change its value when the Docker image -needs to be updated. You can do so for a single pipeline by starting -it through the web interface. - -See also [`docker/README.md`](docker/README.md). +*Remark:* the CI policy outlined in these documents is susceptible to +evolve and specific accommodations are of course possible. diff --git a/dev/ci/appveyor.sh b/dev/ci/appveyor.sh index abeb039c0e..cda369fb1b 100644 --- a/dev/ci/appveyor.sh +++ b/dev/ci/appveyor.sh @@ -2,14 +2,15 @@ set -e -x -APPVEYOR_OPAM_SWITCH=4.07.0+mingw64c +APPVEYOR_OPAM_VARIANT=ocaml-variants.4.07.1+mingw64c -wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.1/opam64.tar.xz +wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.2/opam64.tar.xz -O opam64.tar.xz tar -xf opam64.tar.xz bash opam64/install.sh -opam init -a mingw https://github.com/fdopen/opam-repository-mingw.git --comp $APPVEYOR_OPAM_SWITCH --switch $APPVEYOR_OPAM_SWITCH -eval "$(opam config env)" +opam init default -a -y "https://github.com/fdopen/opam-repository-mingw.git#opam2" -c $APPVEYOR_OPAM_VARIANT --disable-sandboxing +eval "$(opam env)" opam install -y num ocamlfind ounit +# Full regular Coq Build cd "$APPVEYOR_BUILD_FOLDER" && ./configure -local && make && make byte && make -C test-suite all INTERACTIVE= # && make validate diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 4d5834eeb6..9727d42a90 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -13,6 +13,10 @@ : "${mathcomp_CI_GITURL:=https://github.com/math-comp/math-comp}" : "${mathcomp_CI_ARCHIVEURL:=${mathcomp_CI_GITURL}/archive}" +: "${fourcolor_CI_REF:=master}" +: "${fourcolor_CI_GITURL:=https://github.com/math-comp/fourcolor}" +: "${fourcolor_CI_ARCHIVEURL:=${fourcolor_CI_GITURL}/archive}" + : "${oddorder_CI_REF:=master}" : "${oddorder_CI_GITURL:=https://github.com/math-comp/odd-order}" : "${oddorder_CI_ARCHIVEURL:=${oddorder_CI_GITURL}/archive}" @@ -215,13 +219,6 @@ : "${fcsl_pcm_CI_ARCHIVEURL:=${fcsl_pcm_CI_GITURL}/archive}" ######################################################################## -# pidetop -######################################################################## -: "${pidetop_CI_REF:=v8.9}" -: "${pidetop_CI_GITURL:=https://bitbucket.org/coqpide/pidetop}" -: "${pidetop_CI_ARCHIVEURL:=${pidetop_CI_GITURL}/get}" - -######################################################################## # ext-lib ######################################################################## : "${ext_lib_CI_REF:=master}" @@ -231,7 +228,7 @@ ######################################################################## # simple-io ######################################################################## -: "${simple_io_CI_REF:=master}" +: "${simple_io_CI_REF:=dev}" : "${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-math-comp.sh b/dev/ci/ci-math-comp.sh index a74f9fa4d3..cae127ee7b 100755 --- a/dev/ci/ci-math-comp.sh +++ b/dev/ci/ci-math-comp.sh @@ -8,6 +8,10 @@ git_download mathcomp ( cd "${CI_BUILD_DIR}/mathcomp/mathcomp" && make && make install ) +git_download fourcolor + +( cd "${CI_BUILD_DIR}/fourcolor" && make && make install ) + git_download oddorder ( cd "${CI_BUILD_DIR}/oddorder" && make ) diff --git a/dev/ci/ci-pidetop.sh b/dev/ci/ci-pidetop.sh deleted file mode 100755 index 1a9a26843c..0000000000 --- a/dev/ci/ci-pidetop.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -git_download pidetop - -# Travis / Gitlab have different filesystem layout due to use of -# `-local`. We need to improve this divergence but if we use Dune this -# "local" oddity goes away automatically so not bothering... -if [ -d "$COQBIN/../lib/coq" ]; then - COQLIB="$COQBIN/../lib/coq/" -else - COQLIB="$COQBIN/../" -fi - -( cd "${CI_BUILD_DIR}/pidetop" && dune build -p pidetop @install ) - -echo -en '4\nexit' | "${CI_BUILD_DIR}/pidetop/_build/install/default/bin/pidetop" -coqlib "$COQLIB" -main-channel stdfds diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat index 918d289ae2..386a3de204 100755 --- a/dev/ci/gitlab.bat +++ b/dev/ci/gitlab.bat @@ -39,6 +39,10 @@ SET PATH=%PATH%;C:\Program Files\7-Zip\;C:\Program Files\Microsoft SDKs\Windows\ IF "%WINDOWS%" == "enabled_all_addons" (
SET EXTRA_ADDONS=^
+ -addon=bignums ^
+ -addon=equations ^
+ -addon=ltac2 ^
+ -addon=mtac2 ^
-addon=mathcomp ^
-addon=menhir ^
-addon=menhirlib ^
@@ -56,10 +60,6 @@ IF "%WINDOWS%" == "enabled_all_addons" ( call %CI_PROJECT_DIR%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^
-arch=%ARCH% -installer=Y -coqver=%CI_PROJECT_DIR_CFMT% ^
-destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^
- -addon=bignums ^
- -addon=equations ^
- -addon=ltac2 ^
- -addon=mtac2 ^
%EXTRA_ADDONS% ^
-make=N ^
-setup %CI_PROJECT_DIR%\%SETUP% || GOTO ErrorCopyLogFilesAndExit
diff --git a/dev/ci/nix/README.md b/dev/ci/nix/README.md new file mode 100644 index 0000000000..1685b084e9 --- /dev/null +++ b/dev/ci/nix/README.md @@ -0,0 +1,19 @@ +# Working on third-party developments with *this* version of Coq + +Aim: getting an environment suitable for working on a third-party development +using the current version of Coq (i.e., built from the current state of this +repository). + +Dive into such an environment, for the project `example` by running, from the +root of this repository: + + ./dev/ci/nix/shell example + +This will build Coq and the other dependencies of the `example` project, then +open a shell with all these dependencies available (e.g., `coqtop` is in path). + +Additionally, three environment variables are set, to abstract over the +build-system of that project: `configure`, `make`, and `clean`. Therefore, after +changing the working directory to the root of the sources of that project, the +contents of these variables can be evaluated to respectively set-up, build, and +clean the project. diff --git a/dev/ci/nix/unicoq.nix b/dev/ci/nix/unicoq.nix index f10afd5680..093c262cde 100644 --- a/dev/ci/nix/unicoq.nix +++ b/dev/ci/nix/unicoq.nix @@ -1,11 +1,8 @@ -{ stdenv, fetchzip, coq }: +{ stdenv, coq }: stdenv.mkDerivation { name = "coq${coq.coq-version}-unicoq-0.0-git"; - src = fetchzip { - url = "https://github.com/vbgl/unicoq/archive/8b33e37700e92bfd404bf8bf9fe03f1be8928d97.tar.gz"; - sha256 = "0s4z0wjxlp56ccgzxgk04z7skw90rdnz39v730ffkgrjl38rr9il"; - }; + src = fetchTarball https://github.com/unicoq/unicoq/archive/master.tar.gz; buildInputs = [ coq ] ++ (with coq.ocamlPackages; [ ocaml findlib camlp5 num ]); diff --git a/dev/ci/user-overlays/08705-ejgallego-vernac+remove_empty_hooks.sh b/dev/ci/user-overlays/08705-ejgallego-vernac+remove_empty_hooks.sh new file mode 100644 index 0000000000..3600f1cd3e --- /dev/null +++ b/dev/ci/user-overlays/08705-ejgallego-vernac+remove_empty_hooks.sh @@ -0,0 +1,18 @@ +if [ "$CI_PULL_REQUEST" = "8705" ] || [ "$CI_BRANCH" = "vernac+remove_empty_hooks" ]; then + + elpi_CI_REF=vernac+remove_empty_hooks + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + + equations_CI_REF=vernac+remove_empty_hooks + equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + paramcoq_CI_REF=vernac+remove_empty_hooks + paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq + + plugin_tutorial_CI_REF=vernac+remove_empty_hooks + plugin_tutorial_CI_GITURL=https://github.com/ejgallego/plugin_tutorials + + mtac2_CI_REF=vernac+remove_empty_hooks + mtac2_CI_GITURL=https://github.com/ejgallego/mtac2 + +fi diff --git a/dev/ci/user-overlays/08850-poly-local-univs.sh b/dev/ci/user-overlays/08850-poly-local-univs.sh new file mode 100644 index 0000000000..482792d7cd --- /dev/null +++ b/dev/ci/user-overlays/08850-poly-local-univs.sh @@ -0,0 +1,9 @@ +#!/bin/sh + +if [ "$CI_PULL_REQUEST" = "8850" ] || [ "$CI_BRANCH" = "poly-local-univs" ]; then + formal_topology_CI_REF=poly-local-univs + formal_topology_CI_GITURL=https://github.com/SkySkimmer/topology + + paramcoq_CI_REF=poly-local-univs + paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq +fi diff --git a/dev/ci/user-overlays/08933-solve-remaining-evars-initial-arg.sh b/dev/ci/user-overlays/08933-solve-remaining-evars-initial-arg.sh new file mode 100644 index 0000000000..e74e53fa40 --- /dev/null +++ b/dev/ci/user-overlays/08933-solve-remaining-evars-initial-arg.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +if [ "$CI_PULL_REQUEST" = "8933" ] || [ "$CI_BRANCH" = "solve-remaining-evars-initial-arg" ]; then + plugin_tutorial_CI_REF=solve-remaining-evars-initial-arg + plugin_tutorial_CI_GITURL=https://github.com/SkySkimmer/plugin_tutorials +fi diff --git a/dev/ci/user-overlays/09051-ppedrot-camlp5-safe-api-strikes-back.sh b/dev/ci/user-overlays/09051-ppedrot-camlp5-safe-api-strikes-back.sh new file mode 100644 index 0000000000..14e7c0d7f0 --- /dev/null +++ b/dev/ci/user-overlays/09051-ppedrot-camlp5-safe-api-strikes-back.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "9051" ] || [ "$CI_BRANCH" = "camlp5-safe-api-strikes-back" ]; then + + equations_CI_REF=camlp5-safe-api-strikes-back + equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations + + ltac2_CI_REF=camlp5-safe-api-strikes-back + ltac2_CI_GITURL=https://github.com/ppedrot/ltac2 + +fi diff --git a/dev/ci/user-overlays/09065-ejgallego-gramlib+no_ploc.sh b/dev/ci/user-overlays/09065-ejgallego-gramlib+no_ploc.sh new file mode 100644 index 0000000000..e9daa7a44e --- /dev/null +++ b/dev/ci/user-overlays/09065-ejgallego-gramlib+no_ploc.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "9065" ] || [ "$CI_BRANCH" = "gramlib+no_ploc" ]; then + + elpi_CI_REF=gramlib+no_ploc + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + +fi diff --git a/dev/ci/user-overlays/09102-ejgallego-ltac+remove_aliases.sh b/dev/ci/user-overlays/09102-ejgallego-ltac+remove_aliases.sh new file mode 100644 index 0000000000..2df8affd14 --- /dev/null +++ b/dev/ci/user-overlays/09102-ejgallego-ltac+remove_aliases.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "9102" ] || [ "$CI_BRANCH" = "ltac+remove_aliases" ]; then + + elpi_CI_REF=ltac+remove_aliases + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + +fi diff --git a/dev/doc/MERGING.md b/dev/doc/MERGING.md index 318562338d..56fdab0c26 100644 --- a/dev/doc/MERGING.md +++ b/dev/doc/MERGING.md @@ -150,3 +150,24 @@ simplest way of getting them is to run `nix-shell` first. is not out of the box. Installing explicitly "pinentry-mac" seems important for typing of passphrase to work correctly (see also this [Stack Overflow Q-and-A](https://stackoverflow.com/questions/39494631/gpg-failed-to-sign-the-data-fatal-failed-to-write-commit-object-git-2-10-0)). + +## Addendum for organization admins + +### Adding a new code owner individual + +If someone is added to the [`CODEOWNERS`](../../.github/CODEOWNERS) file and +they did not have merging rights before, they should also be added to the +**@coq/pushers** team. You may do so using +[this link](https://github.com/orgs/coq/teams/pushers/members?add=true). + +Before adding someone to the **@coq/pushers** team, you should ensure that they +have read the present merging documentation, and explicitly tell them not to +use the merging button on the GitHub web interface. + +### Adding a new code owner team + +Go to [that page](https://github.com/orgs/coq/teams/pushers/teams) and click on +the green "Add a team" button. Use a "-maintainer" suffix for the name of your +team. You may then add new members to this team (you don't need to add them to +the **@coq/pushers** team first as this will be done automatically because the +team you created is a sub-team of **@coq/pushers**). diff --git a/dev/doc/about-hints b/dev/doc/about-hints deleted file mode 100644 index 95712c3cf9..0000000000 --- a/dev/doc/about-hints +++ /dev/null @@ -1,454 +0,0 @@ -An investigation of how ZArith lemmas could be classified in different -automation classes - -- Reversible lemmas relating operators (to be declared as hints but - needing precedences) -- Equivalent notions (one has to be considered as primitive and the - other rewritten into the canonical one) -- Isomorphisms between structure (one structure has to be considered - as more primitive than the other for a give operator) -- Irreversible simplifications (to be declared with precedences) -- Reversible bottom-up simplifications (to be used in hypotheses) -- Irreversible bottom-up simplifications (to be used in hypotheses - with precedences) -- Rewriting rules (relevant for autorewrite, or for an improved auto) - -Note: this analysis, made in 2001, was previously stored in -theories/ZArith/Zhints.v. It has been moved here to avoid obfuscating -the standard library. - -(**********************************************************************) -(** * Reversible lemmas relating operators *) -(** Probably to be declared as hints but need to define precedences *) - -(** ** Conversion between comparisons/predicates and arithmetic operators *) - -(** Lemmas ending by eq *) -(** -<< -Zegal_left: (x,y:Z)`x = y`->`x+(-y) = 0` -Zabs_eq: (x:Z)`0 <= x`->`|x| = x` -Zeven_div2: (x:Z)(Zeven x)->`x = 2*(Zdiv2 x)` -Zodd_div2: (x:Z)`x >= 0`->(Zodd x)->`x = 2*(Zdiv2 x)+1` ->> -*) - -(** Lemmas ending by Zgt *) -(** -<< -Zgt_left_rev: (x,y:Z)`x+(-y) > 0`->`x > y` -Zgt_left_gt: (x,y:Z)`x > y`->`x+(-y) > 0` ->> -*) - -(** Lemmas ending by Zlt *) -(** -<< -Zlt_left_rev: (x,y:Z)`0 < y+(-x)`->`x < y` -Zlt_left_lt: (x,y:Z)`x < y`->`0 < y+(-x)` -Zlt_O_minus_lt: (n,m:Z)`0 < n-m`->`m < n` ->> -*) - -(** Lemmas ending by Zle *) -(** -<< -Zle_left: (x,y:Z)`x <= y`->`0 <= y+(-x)` -Zle_left_rev: (x,y:Z)`0 <= y+(-x)`->`x <= y` -Zlt_left: (x,y:Z)`x < y`->`0 <= y+(-1)+(-x)` -Zge_left: (x,y:Z)`x >= y`->`0 <= x+(-y)` -Zgt_left: (x,y:Z)`x > y`->`0 <= x+(-1)+(-y)` ->> -*) - -(** ** Conversion between nat comparisons and Z comparisons *) - -(** Lemmas ending by eq *) -(** -<< -inj_eq: (x,y:nat)x=y->`(inject_nat x) = (inject_nat y)` ->> -*) - -(** Lemmas ending by Zge *) -(** -<< -inj_ge: (x,y:nat)(ge x y)->`(inject_nat x) >= (inject_nat y)` ->> -*) - -(** Lemmas ending by Zgt *) -(** -<< -inj_gt: (x,y:nat)(gt x y)->`(inject_nat x) > (inject_nat y)` ->> -*) - -(** Lemmas ending by Zlt *) -(** -<< -inj_lt: (x,y:nat)(lt x y)->`(inject_nat x) < (inject_nat y)` ->> -*) - -(** Lemmas ending by Zle *) -(** -<< -inj_le: (x,y:nat)(le x y)->`(inject_nat x) <= (inject_nat y)` ->> -*) - -(** ** Conversion between comparisons *) - -(** Lemmas ending by Zge *) -(** -<< -not_Zlt: (x,y:Z)~`x < y`->`x >= y` -Zle_ge: (m,n:Z)`m <= n`->`n >= m` ->> -*) - -(** Lemmas ending by Zgt *) -(** -<< -Zle_gt_S: (n,p:Z)`n <= p`->`(Zs p) > n` -not_Zle: (x,y:Z)~`x <= y`->`x > y` -Zlt_gt: (m,n:Z)`m < n`->`n > m` -Zle_S_gt: (n,m:Z)`(Zs n) <= m`->`m > n` ->> -*) - -(** Lemmas ending by Zlt *) -(** -<< -not_Zge: (x,y:Z)~`x >= y`->`x < y` -Zgt_lt: (m,n:Z)`m > n`->`n < m` -Zle_lt_n_Sm: (n,m:Z)`n <= m`->`n < (Zs m)` ->> -*) - -(** Lemmas ending by Zle *) -(** -<< -Zlt_ZERO_pred_le_ZERO: (x:Z)`0 < x`->`0 <= (Zpred x)` -not_Zgt: (x,y:Z)~`x > y`->`x <= y` -Zgt_le_S: (n,p:Z)`p > n`->`(Zs n) <= p` -Zgt_S_le: (n,p:Z)`(Zs p) > n`->`n <= p` -Zge_le: (m,n:Z)`m >= n`->`n <= m` -Zlt_le_S: (n,p:Z)`n < p`->`(Zs n) <= p` -Zlt_n_Sm_le: (n,m:Z)`n < (Zs m)`->`n <= m` -Zlt_le_weak: (n,m:Z)`n < m`->`n <= m` -Zle_refl: (n,m:Z)`n = m`->`n <= m` ->> -*) - -(** ** Irreversible simplification involving several comparaisons *) -(** useful with clear precedences *) - -(** Lemmas ending by Zlt *) -(** -<< -Zlt_le_reg :(a,b,c,d:Z)`a < b`->`c <= d`->`a+c < b+d` -Zle_lt_reg : (a,b,c,d:Z)`a <= b`->`c < d`->`a+c < b+d` ->> -*) - -(** ** What is decreasing here ? *) - -(** Lemmas ending by eq *) -(** -<< -Zplus_minus: (n,m,p:Z)`n = m+p`->`p = n-m` ->> -*) - -(** Lemmas ending by Zgt *) -(** -<< -Zgt_pred: (n,p:Z)`p > (Zs n)`->`(Zpred p) > n` ->> -*) - -(** Lemmas ending by Zlt *) -(** -<< -Zlt_pred: (n,p:Z)`(Zs n) < p`->`n < (Zpred p)` ->> -*) - -(**********************************************************************) -(** * Useful Bottom-up lemmas *) - -(** ** Bottom-up simplification: should be used *) - -(** Lemmas ending by eq *) -(** -<< -Zeq_add_S: (n,m:Z)`(Zs n) = (Zs m)`->`n = m` -Zsimpl_plus_l: (n,m,p:Z)`n+m = n+p`->`m = p` -Zplus_unit_left: (n,m:Z)`n+0 = m`->`n = m` -Zplus_unit_right: (n,m:Z)`n = m+0`->`n = m` ->> -*) - -(** Lemmas ending by Zgt *) -(** -<< -Zsimpl_gt_plus_l: (n,m,p:Z)`p+n > p+m`->`n > m` -Zsimpl_gt_plus_r: (n,m,p:Z)`n+p > m+p`->`n > m` -Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n` ->> -*) - -(** Lemmas ending by Zlt *) -(** -<< -Zsimpl_lt_plus_l: (n,m,p:Z)`p+n < p+m`->`n < m` -Zsimpl_lt_plus_r: (n,m,p:Z)`n+p < m+p`->`n < m` -Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m` ->> -*) - -(** Lemmas ending by Zle *) -(** << Zsimpl_le_plus_l: (p,n,m:Z)`p+n <= p+m`->`n <= m` -Zsimpl_le_plus_r: (p,n,m:Z)`n+p <= m+p`->`n <= m` -Zle_S_n: (n,m:Z)`(Zs m) <= (Zs n)`->`m <= n` >> *) - -(** ** Bottom-up irreversible (syntactic) simplification *) - -(** Lemmas ending by Zle *) -(** -<< -Zle_trans_S: (n,m:Z)`(Zs n) <= m`->`n <= m` ->> -*) - -(** ** Other unclearly simplifying lemmas *) - -(** Lemmas ending by Zeq *) -(** -<< -Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0` ->> -*) - -(* Lemmas ending by Zgt *) -(** -<< -Zmult_gt: (x,y:Z)`x > 0`->`x*y > 0`->`y > 0` ->> -*) - -(* Lemmas ending by Zlt *) -(** -<< -pZmult_lt: (x,y:Z)`x > 0`->`0 < y*x`->`0 < y` ->> -*) - -(* Lemmas ending by Zle *) -(** -<< -Zmult_le: (x,y:Z)`x > 0`->`0 <= y*x`->`0 <= y` -OMEGA1: (x,y:Z)`x = y`->`0 <= x`->`0 <= y` ->> -*) - - -(**********************************************************************) -(** * Irreversible lemmas with meta-variables *) -(** To be used by EAuto *) - -(* Hints Immediate *) -(** Lemmas ending by eq *) -(** -<< -Zle_antisym: (n,m:Z)`n <= m`->`m <= n`->`n = m` ->> -*) - -(** Lemmas ending by Zge *) -(** -<< -Zge_trans: (n,m,p:Z)`n >= m`->`m >= p`->`n >= p` ->> -*) - -(** Lemmas ending by Zgt *) -(** -<< -Zgt_trans: (n,m,p:Z)`n > m`->`m > p`->`n > p` -Zgt_trans_S: (n,m,p:Z)`(Zs n) > m`->`m > p`->`n > p` -Zle_gt_trans: (n,m,p:Z)`m <= n`->`m > p`->`n > p` -Zgt_le_trans: (n,m,p:Z)`n > m`->`p <= m`->`n > p` ->> -*) - -(** Lemmas ending by Zlt *) -(** -<< -Zlt_trans: (n,m,p:Z)`n < m`->`m < p`->`n < p` -Zlt_le_trans: (n,m,p:Z)`n < m`->`m <= p`->`n < p` -Zle_lt_trans: (n,m,p:Z)`n <= m`->`m < p`->`n < p` ->> -*) - -(** Lemmas ending by Zle *) -(** -<< -Zle_trans: (n,m,p:Z)`n <= m`->`m <= p`->`n <= p` ->> -*) - - -(**********************************************************************) -(** * Unclear or too specific lemmas *) -(** Not to be used ? *) - -(** ** Irreversible and too specific (not enough regular) *) - -(** Lemmas ending by Zle *) -(** -<< -Zle_mult: (x,y:Z)`x > 0`->`0 <= y`->`0 <= y*x` -Zle_mult_approx: (x,y,z:Z)`x > 0`->`z > 0`->`0 <= y`->`0 <= y*x+z` -OMEGA6: (x,y,z:Z)`0 <= x`->`y = 0`->`0 <= x+y*z` -OMEGA7: (x,y,z,t:Z)`z > 0`->`t > 0`->`0 <= x`->`0 <= y`->`0 <= x*z+y*t` ->> -*) - -(** ** Expansion and too specific ? *) - -(** Lemmas ending by Zge *) -(** -<< -Zge_mult_simpl: (a,b,c:Z)`c > 0`->`a*c >= b*c`->`a >= b` ->> -*) - -(** Lemmas ending by Zgt *) -(** -<< -Zgt_mult_simpl: (a,b,c:Z)`c > 0`->`a*c > b*c`->`a > b` -Zgt_square_simpl: (x,y:Z)`x >= 0`->`y >= 0`->`x*x > y*y`->`x > y` ->> -*) - -(** Lemmas ending by Zle *) -(** -<< -Zle_mult_simpl: (a,b,c:Z)`c > 0`->`a*c <= b*c`->`a <= b` -Zmult_le_approx: (x,y,z:Z)`x > 0`->`x > z`->`0 <= y*x+z`->`0 <= y` ->> -*) - -(** ** Reversible but too specific ? *) - -(** Lemmas ending by Zlt *) -(** -<< -Zlt_minus: (n,m:Z)`0 < m`->`n-m < n` ->> -*) - -(**********************************************************************) -(** * Lemmas to be used as rewrite rules *) -(** but can also be used as hints *) - -(** Left-to-right simplification lemmas (a symbol disappears) *) - -(** -<< -Zcompare_n_S: (n,m:Z)(Zcompare (Zs n) (Zs m))=(Zcompare n m) -Zmin_n_n: (n:Z)`(Zmin n n) = n` -Zmult_1_n: (n:Z)`1*n = n` -Zmult_n_1: (n:Z)`n*1 = n` -Zminus_plus: (n,m:Z)`n+m-n = m` -Zle_plus_minus: (n,m:Z)`n+(m-n) = m` -Zopp_Zopp: (x:Z)`(-(-x)) = x` -Zero_left: (x:Z)`0+x = x` -Zero_right: (x:Z)`x+0 = x` -Zplus_inverse_r: (x:Z)`x+(-x) = 0` -Zplus_inverse_l: (x:Z)`(-x)+x = 0` -Zopp_intro: (x,y:Z)`(-x) = (-y)`->`x = y` -Zmult_one: (x:Z)`1*x = x` -Zero_mult_left: (x:Z)`0*x = 0` -Zero_mult_right: (x:Z)`x*0 = 0` -Zmult_Zopp_Zopp: (x,y:Z)`(-x)*(-y) = x*y` ->> -*) - -(** Right-to-left simplification lemmas (a symbol disappears) *) - -(** -<< -Zpred_Sn: (m:Z)`m = (Zpred (Zs m))` -Zs_pred: (n:Z)`n = (Zs (Zpred n))` -Zplus_n_O: (n:Z)`n = n+0` -Zmult_n_O: (n:Z)`0 = n*0` -Zminus_n_O: (n:Z)`n = n-0` -Zminus_n_n: (n:Z)`0 = n-n` -Zred_factor6: (x:Z)`x = x+0` -Zred_factor0: (x:Z)`x = x*1` ->> -*) - -(** Unclear orientation (no symbol disappears) *) - -(** -<< -Zplus_n_Sm: (n,m:Z)`(Zs (n+m)) = n+(Zs m)` -Zmult_n_Sm: (n,m:Z)`n*m+n = n*(Zs m)` -Zmin_SS: (n,m:Z)`(Zs (Zmin n m)) = (Zmin (Zs n) (Zs m))` -Zplus_assoc_l: (n,m,p:Z)`n+(m+p) = n+m+p` -Zplus_assoc_r: (n,m,p:Z)`n+m+p = n+(m+p)` -Zplus_permute: (n,m,p:Z)`n+(m+p) = m+(n+p)` -Zplus_Snm_nSm: (n,m:Z)`(Zs n)+m = n+(Zs m)` -Zminus_plus_simpl: (n,m,p:Z)`n-m = p+n-(p+m)` -Zminus_Sn_m: (n,m:Z)`(Zs (n-m)) = (Zs n)-m` -Zmult_plus_distr_l: (n,m,p:Z)`(n+m)*p = n*p+m*p` -Zmult_minus_distr: (n,m,p:Z)`(n-m)*p = n*p-m*p` -Zmult_assoc_r: (n,m,p:Z)`n*m*p = n*(m*p)` -Zmult_assoc_l: (n,m,p:Z)`n*(m*p) = n*m*p` -Zmult_permute: (n,m,p:Z)`n*(m*p) = m*(n*p)` -Zmult_Sm_n: (n,m:Z)`n*m+m = (Zs n)*m` -Zmult_Zplus_distr: (x,y,z:Z)`x*(y+z) = x*y+x*z` -Zmult_plus_distr: (n,m,p:Z)`(n+m)*p = n*p+m*p` -Zopp_Zplus: (x,y:Z)`(-(x+y)) = (-x)+(-y)` -Zplus_sym: (x,y:Z)`x+y = y+x` -Zplus_assoc: (x,y,z:Z)`x+(y+z) = x+y+z` -Zmult_sym: (x,y:Z)`x*y = y*x` -Zmult_assoc: (x,y,z:Z)`x*(y*z) = x*y*z` -Zopp_Zmult: (x,y:Z)`(-x)*y = (-(x*y))` -Zplus_S_n: (x,y:Z)`(Zs x)+y = (Zs (x+y))` -Zopp_one: (x:Z)`(-x) = x*(-1)` -Zopp_Zmult_r: (x,y:Z)`(-(x*y)) = x*(-y)` -Zmult_Zopp_left: (x,y:Z)`(-x)*y = x*(-y)` -Zopp_Zmult_l: (x,y:Z)`(-(x*y)) = (-x)*y` -Zred_factor1: (x:Z)`x+x = x*2` -Zred_factor2: (x,y:Z)`x+x*y = x*(1+y)` -Zred_factor3: (x,y:Z)`x*y+x = x*(1+y)` -Zred_factor4: (x,y,z:Z)`x*y+x*z = x*(y+z)` -Zminus_Zplus_compatible: (x,y,n:Z)`x+n-(y+n) = x-y` -Zmin_plus: (x,y,n:Z)`(Zmin (x+n) (y+n)) = (Zmin x y)+n` ->> -*) - -(** nat <-> Z *) -(** -<< -inj_S: (y:nat)`(inject_nat (S y)) = (Zs (inject_nat y))` -inj_plus: (x,y:nat)`(inject_nat (plus x y)) = (inject_nat x)+(inject_nat y)` -inj_mult: (x,y:nat)`(inject_nat (mult x y)) = (inject_nat x)*(inject_nat y)` -inj_minus1: - (x,y:nat)(le y x)->`(inject_nat (minus x y)) = (inject_nat x)-(inject_nat y)` -inj_minus2: (x,y:nat)(gt y x)->`(inject_nat (minus x y)) = 0` ->> -*) - -(** Too specific ? *) -(** -<< -Zred_factor5: (x,y:Z)`x*0+y = y` ->> -*) diff --git a/dev/doc/changes.md b/dev/doc/changes.md index acb0d80c18..c0f15f02a5 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -152,6 +152,12 @@ Termops - Internal printing functions have been placed under the `Termops.Internal` namespace. +Notations: + +- Notation.availability_of_notation is not anymore needed: if a + delimiter is needed, it is provided by Notation.uninterp_notation + which fails in case the notation is not available. + ### Unit testing The test suite now allows writing unit tests against OCaml code in the Coq diff --git a/dev/doc/cic.dtd b/dev/doc/cic.dtd deleted file mode 100644 index cc33efd483..0000000000 --- a/dev/doc/cic.dtd +++ /dev/null @@ -1,231 +0,0 @@ -<?xml encoding="ISO-8859-1"?> - -<!-- DTD FOR CIC OBJECTS: --> - -<!-- CIC term declaration --> - -<!ENTITY % term '(LAMBDA|CAST|PROD|REL|SORT|APPLY|VAR|META|IMPLICIT|CONST| - LETIN|MUTIND|MUTCONSTRUCT|MUTCASE|FIX|COFIX|instantiate)'> - -<!-- CIC sorts --> - -<!ENTITY % sort '(Prop|Set|Type)'> - -<!-- CIC sequents --> - -<!ENTITY % sequent '((Decl|Def|Hidden)*,Goal)'> - -<!-- CIC objects: --> - -<!ELEMENT ConstantType %term;> -<!ATTLIST ConstantType - name CDATA #REQUIRED - id ID #REQUIRED> - -<!ELEMENT ConstantBody %term;> -<!ATTLIST ConstantBody - for CDATA #REQUIRED - params CDATA #REQUIRED - id ID #REQUIRED> - -<!ELEMENT CurrentProof (Conjecture*,body)> -<!ATTLIST CurrentProof - of CDATA #REQUIRED - id ID #REQUIRED> - -<!ELEMENT InductiveDefinition (InductiveType+)> -<!ATTLIST InductiveDefinition - noParams NMTOKEN #REQUIRED - params CDATA #REQUIRED - id ID #REQUIRED> - -<!ELEMENT Variable (body?,type)> -<!ATTLIST Variable - name CDATA #REQUIRED - id ID #REQUIRED> - -<!ELEMENT Sequent %sequent;> -<!ATTLIST Sequent - no NMTOKEN #REQUIRED - id ID #REQUIRED> - -<!-- Elements used in CIC objects, which are not terms: --> - -<!ELEMENT InductiveType (arity,Constructor*)> -<!ATTLIST InductiveType - name CDATA #REQUIRED - inductive (true|false) #REQUIRED> - -<!ELEMENT Conjecture %sequent;> -<!ATTLIST Conjecture - no NMTOKEN #REQUIRED - id ID #REQUIRED> - -<!ELEMENT Constructor %term;> -<!ATTLIST Constructor - name CDATA #REQUIRED> - -<!ELEMENT Decl %term;> -<!ATTLIST Decl - name CDATA #IMPLIED - id ID #REQUIRED> - -<!ELEMENT Def %term;> -<!ATTLIST Def - name CDATA #IMPLIED - id ID #REQUIRED> - -<!ELEMENT Hidden EMPTY> -<!ATTLIST Hidden - id ID #REQUIRED> - -<!ELEMENT Goal %term;> - -<!-- CIC terms: --> - -<!ELEMENT LAMBDA (decl*,target)> -<!ATTLIST LAMBDA - sort %sort; #REQUIRED> - -<!ELEMENT LETIN (def*,target)> -<!ATTLIST LETIN - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT PROD (decl*,target)> -<!ATTLIST PROD - type %sort; #REQUIRED> - -<!ELEMENT CAST (term,type)> -<!ATTLIST CAST - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT REL EMPTY> -<!ATTLIST REL - value NMTOKEN #REQUIRED - binder CDATA #REQUIRED - id ID #REQUIRED - idref IDREF #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT SORT EMPTY> -<!ATTLIST SORT - value CDATA #REQUIRED - id ID #REQUIRED> - -<!ELEMENT APPLY (%term;)+> -<!ATTLIST APPLY - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT VAR EMPTY> -<!ATTLIST VAR - relUri CDATA #REQUIRED - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!-- The substitutions are ordered by increasing de Bruijn --> -<!-- index. An empty substitution means that that index is --> -<!-- not accessible. --> -<!ELEMENT META (substitution*)> -<!ATTLIST META - no NMTOKEN #REQUIRED - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT IMPLICIT EMPTY> -<!ATTLIST IMPLICIT - id ID #REQUIRED> - -<!ELEMENT CONST EMPTY> -<!ATTLIST CONST - uri CDATA #REQUIRED - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT MUTIND EMPTY> -<!ATTLIST MUTIND - uri CDATA #REQUIRED - noType NMTOKEN #REQUIRED - id ID #REQUIRED> - -<!ELEMENT MUTCONSTRUCT EMPTY> -<!ATTLIST MUTCONSTRUCT - uri CDATA #REQUIRED - noType NMTOKEN #REQUIRED - noConstr NMTOKEN #REQUIRED - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT MUTCASE (patternsType,inductiveTerm,pattern*)> -<!ATTLIST MUTCASE - uriType CDATA #REQUIRED - noType NMTOKEN #REQUIRED - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT FIX (FixFunction+)> -<!ATTLIST FIX - noFun NMTOKEN #REQUIRED - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!ELEMENT COFIX (CofixFunction+)> -<!ATTLIST COFIX - noFun NMTOKEN #REQUIRED - id ID #REQUIRED - sort %sort; #REQUIRED> - -<!-- Elements used in CIC terms: --> - -<!ELEMENT FixFunction (type,body)> -<!ATTLIST FixFunction - name CDATA #REQUIRED - recIndex NMTOKEN #REQUIRED> - -<!ELEMENT CofixFunction (type,body)> -<!ATTLIST CofixFunction - name CDATA #REQUIRED> - -<!ELEMENT substitution ((%term;)?)> - -<!-- Explicit named substitutions: --> - -<!ELEMENT instantiate ((CONST|MUTIND|MUTCONSTRUCT),arg+)> -<!ATTLIST instantiate - id ID #IMPLIED> - -<!-- Sintactic sugar for CIC terms and for CIC objects: --> - -<!ELEMENT arg %term;> -<!ATTLIST arg - relUri CDATA #REQUIRED> - -<!ELEMENT decl %term;> -<!ATTLIST decl - id ID #REQUIRED - type %sort; #REQUIRED - binder CDATA #IMPLIED> - -<!ELEMENT def %term;> -<!ATTLIST def - id ID #REQUIRED - sort %sort; #REQUIRED - binder CDATA #IMPLIED> - -<!ELEMENT target %term;> - -<!ELEMENT term %term;> - -<!ELEMENT type %term;> - -<!ELEMENT arity %term;> - -<!ELEMENT patternsType %term;> - -<!ELEMENT inductiveTerm %term;> - -<!ELEMENT pattern %term;> - -<!ELEMENT body %term;> diff --git a/dev/doc/minicoq.tex b/dev/doc/minicoq.tex deleted file mode 100644 index a34b03a491..0000000000 --- a/dev/doc/minicoq.tex +++ /dev/null @@ -1,98 +0,0 @@ -\documentclass{article} - -\usepackage{fullpage} -\input{./macros.tex} -\newcommand{\minicoq}{\textsf{minicoq}} -\newcommand{\nonterm}[1]{\textit{#1}} -\newcommand{\terminal}[1]{\textsf{#1}} -\newcommand{\listzero}{\textit{LIST$_0$}} -\newcommand{\listun}{\textit{LIST$_1$}} -\newcommand{\sep}{\textit{SEP}} - -\title{Minicoq: a type-checker for the pure \\ - Calculus of Inductive Constructions} - - -\begin{document} - -\maketitle - -\section{Introduction} - -\minicoq\ is a minimal toplevel for the \Coq\ kernel. - - -\section{Grammar of terms} - -The grammar of \minicoq's terms is given in Figure~\ref{fig:terms}. - -\begin{figure}[htbp] - \hrulefill - \begin{center} - \begin{tabular}{lrl} - term & ::= & identifier \\ - & $|$ & \terminal{Rel} integer \\ - & $|$ & \terminal{Set} \\ - & $|$ & \terminal{Prop} \\ - & $|$ & \terminal{Type} \\ - & $|$ & \terminal{Const} identifier \\ - & $|$ & \terminal{Ind} identifier integer \\ - & $|$ & \terminal{Construct} identifier integer integer \\ - & $|$ & \terminal{[} name \terminal{:} term - \terminal{]} term \\ - & $|$ & \terminal{(} name \terminal{:} term - \terminal{)} term \\ - & $|$ & term \verb!->! term \\ - & $|$ & \terminal{(} \listun\ term \terminal{)} \\ - & $|$ & \terminal{(} term \terminal{::} term \terminal{)} \\ - & $|$ & \verb!<! term \verb!>! \terminal{Case} - term \terminal{of} \listzero\ term \terminal{end} - \\[1em] - name & ::= & \verb!_! \\ - & $|$ & identifier - \end{tabular} - \end{center} - \hrulefill - \caption{Grammar of terms} - \label{fig:terms} -\end{figure} - -\section{Commands} -The grammar of \minicoq's commands are given in -Figure~\ref{fig:commands}. All commands end with a dot. - -\begin{figure}[htbp] - \hrulefill - \begin{center} - \begin{tabular}{lrl} - command & ::= & \terminal{Definition} identifier \terminal{:=} term. \\ - & $|$ & \terminal{Definition} identifier \terminal{:} term - \terminal{:=} term. \\ - & $|$ & \terminal{Parameter} identifier \terminal{:} term. \\ - & $|$ & \terminal{Variable} identifier \terminal{:} term. \\ - & $|$ & \terminal{Inductive} \terminal{[} \listzero\ param - \terminal{]} \listun\ inductive \sep\ - \terminal{with}. \\ - & $|$ & \terminal{Check} term. - \\[1em] - param & ::= & identifier - \\[1em] - inductive & ::= & identifier \terminal{:} term \terminal{:=} - \listzero\ constructor \sep\ \terminal{$|$} - \\[1em] - constructor & ::= & identifier \terminal{:} term - \end{tabular} - \end{center} - \hrulefill - \caption{Commands} - \label{fig:commands} -\end{figure} - - -\end{document} - - -%%% Local Variables: -%%% mode: latex -%%% TeX-master: t -%%% End: diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index b33a1cbd73..b1c111685b 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -64,10 +64,8 @@ ## On the date of the feature freeze ## -- [ ] Create the new version branch `vX.X` and - [protect it](https://github.com/coq/coq/settings/branches) - (activate the "Protect this branch", "Require pull request reviews before - merging" and "Restrict who can push to this branch" guards). +- [ ] Create the new version branch `vX.X` (using this name will ensure that + the branch will be automatically protected). - [ ] Remove all remaining unmerged feature PRs from the beta milestone. - [ ] Start a new project to track PR backporting. The proposed model is to have a "X.X-only PRs" column for the rare PRs on the stable branch, a diff --git a/dev/doc/transition-V5.10-V6 b/dev/doc/transition-V5.10-V6 deleted file mode 100644 index df7b65dd8b..0000000000 --- a/dev/doc/transition-V5.10-V6 +++ /dev/null @@ -1,5 +0,0 @@ -The V5.10 archive has been created with cvs in February 1995 by -Jean-Christophe Filliâtre. It was moved to archive V6 in March 1996. -At this occasion, the contrib directory (user-contributions) were -moved to a separate directory and some theories (like ALGEBRA) moved -to the user-contributions directory too. diff --git a/dev/doc/transition-V6-V7 b/dev/doc/transition-V6-V7 deleted file mode 100644 index e477c9ff9d..0000000000 --- a/dev/doc/transition-V6-V7 +++ /dev/null @@ -1,8 +0,0 @@ -The V6 archive has been created in March 1996 with files from the -former V5.10 archive and has been abandoned in 2000. - -A new archive named V7 has been created in August 1999 by -Jean-Christophe Filliâtre with a new architecture placing the -type-checking at the kernel of Coq. This new architecture came with a -"cleaner" organization of files, a uniform indentation style, uniform -headers, etc. diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index 707c7f07ce..c1dcabb743 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -17,6 +17,7 @@ exec $OCAMLDEBUG \ -I +threads \ -I $COQTOP \ -I $COQTOP/config -I $COQTOP/printing -I $COQTOP/grammar -I $COQTOP/clib \ + -I $COQTOP/gramlib__pack \ -I $COQTOP/lib -I $COQTOP/kernel -I $COQTOP/kernel/byterun \ -I $COQTOP/library -I $COQTOP/engine \ -I $COQTOP/pretyping -I $COQTOP/parsing -I $COQTOP/vernac \ diff --git a/dev/tools/create_overlays.sh b/dev/tools/create_overlays.sh index 314ac07e68..41392be5d7 100755 --- a/dev/tools/create_overlays.sh +++ b/dev/tools/create_overlays.sh @@ -75,4 +75,4 @@ done # End the file; copy to overlays folder. echo "fi" >> $OVERLAY_FILE PR_NUMBER=$(printf '%05d' "$PR_NUMBER") -mv $OVERLAY_FILE dev/ci/user-overlays/$PR_NUMBER-$DEVELOPER_NAME-$OVERLAY_BRANCH.sh +mv $OVERLAY_FILE dev/ci/user-overlays/$PR_NUMBER-$DEVELOPER_NAME-${OVERLAY_BRANCH///}.sh diff --git a/dev/tools/merge-pr.sh b/dev/tools/merge-pr.sh index 320ef6ed07..5fd8a3b7d9 100755 --- a/dev/tools/merge-pr.sh +++ b/dev/tools/merge-pr.sh @@ -202,9 +202,8 @@ info "merging" git merge -v -S --no-ff FETCH_HEAD -m "Merge PR #$PR: $TITLE" -e # TODO: improve this check -if ! git diff --quiet "$REMOTE/$CURRENT_LOCAL_BRANCH" -- dev/ci/user-overlays; then - warning "this PR may have overlays (sorry the check is not perfect)" - warning "if it has overlays please check the following:" +if ! git diff --quiet --diff-filter=A "$REMOTE/$CURRENT_LOCAL_BRANCH" -- dev/ci/user-overlays; then + warning "this PR has overlays, please check the following:" warning "- each overlay has a corresponding open PR on the upstream repo" warning "- after merging please notify the upstream they can merge the PR" fi diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 4287702b3a..b90a53220d 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -20,13 +20,12 @@ open Univ open Environ open Printer open Constr -open Goptions open Genarg open Clenv let _ = Detyping.print_evar_arguments := true let _ = Detyping.print_universes := true -let _ = set_bool_option_value ["Printing";"Matching"] false +let _ = Goptions.set_bool_option_value ["Printing";"Matching"] false let _ = Detyping.set_detype_anonymous (fun ?loc _ -> raise Not_found) (* std_ppcmds *) diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index 01240a062c..a20b74822c 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -32,7 +32,7 @@ Names (link targets) are auto-generated for most simple objects, though they can - Vernacs (commands) have their name set to the first word of their signature. For example, the auto-generated name of ``Axiom @ident : @term`` is ``Axiom``, and a link to it would take the form ``:cmd:`Axiom```. - Vernac variants, tactic notations, and tactic variants do not have a default name. -Most objects should have a body (i.e. a block of indented text following the signature, called “contents” in Sphinx terms). Undocumented objects should have the `:undocumented:` flag instead, as shown above. When multiple objects have a single description, they can be grouped into a single object, like this (semicolons can be used to separate the names of the objects; names starting with ``_`` will be omitted from the indexes):: +Most objects should have a body (i.e. a block of indented text following the signature, called “contents” in Sphinx terms). Undocumented objects should have the ``:undocumented:`` flag instead, as shown above. When multiple objects have a single description, they can be grouped into a single object, like this (semicolons can be used to separate the names of the objects; names starting with ``_`` will be omitted from the indexes):: .. cmdv:: Lemma @ident {? @binders} : @type Remark @ident {? @binders} : @type @@ -382,7 +382,7 @@ DO DON'T .. code:: - This is equivalent to ``Axiom`` :token`ident` : :token:`term`. + This is equivalent to ``Axiom`` :token:`ident` : :token:`term`. .. diff --git a/doc/sphinx/README.template.rst b/doc/sphinx/README.template.rst index 86914a71df..11f0cdc008 100644 --- a/doc/sphinx/README.template.rst +++ b/doc/sphinx/README.template.rst @@ -32,7 +32,7 @@ Names (link targets) are auto-generated for most simple objects, though they can - Vernacs (commands) have their name set to the first word of their signature. For example, the auto-generated name of ``Axiom @ident : @term`` is ``Axiom``, and a link to it would take the form ``:cmd:`Axiom```. - Vernac variants, tactic notations, and tactic variants do not have a default name. -Most objects should have a body (i.e. a block of indented text following the signature, called “contents” in Sphinx terms). Undocumented objects should have the `:undocumented:` flag instead, as shown above. When multiple objects have a single description, they can be grouped into a single object, like this (semicolons can be used to separate the names of the objects; names starting with ``_`` will be omitted from the indexes):: +Most objects should have a body (i.e. a block of indented text following the signature, called “contents” in Sphinx terms). Undocumented objects should have the ``:undocumented:`` flag instead, as shown above. When multiple objects have a single description, they can be grouped into a single object, like this (semicolons can be used to separate the names of the objects; names starting with ``_`` will be omitted from the indexes):: .. cmdv:: Lemma @ident {? @binders} : @type Remark @ident {? @binders} : @type @@ -138,7 +138,7 @@ DO DON'T .. code:: - This is equivalent to ``Axiom`` :token`ident` : :token:`term`. + This is equivalent to ``Axiom`` :token:`ident` : :token:`term`. .. diff --git a/doc/sphinx/_static/notations.css b/doc/sphinx/_static/notations.css index f899945a35..dcb47d1786 100644 --- a/doc/sphinx/_static/notations.css +++ b/doc/sphinx/_static/notations.css @@ -60,9 +60,10 @@ margin-right: 0.4em; /* Space for the right half of the sub- and sup-scripts */ } -.notation .hole { +.notation .hole, .std-token .pre { color: #4e9a06; font-style: italic; + font-weight: bold; } /***********************/ diff --git a/doc/sphinx/addendum/extended-pattern-matching.rst b/doc/sphinx/addendum/extended-pattern-matching.rst index cb267576b2..7b8a86d1ab 100644 --- a/doc/sphinx/addendum/extended-pattern-matching.rst +++ b/doc/sphinx/addendum/extended-pattern-matching.rst @@ -31,9 +31,9 @@ A variable pattern matches any value, and the identifier is bound to that value. The pattern “``_``” (called “don't care” or “wildcard” symbol) also matches any value, but does not bind anything. It may occur an arbitrary number of times in a pattern. Alias patterns written -:n:`(@pattern as @identifier)` are also accepted. This pattern matches the -same values as ``pattern`` does and ``identifier`` is bound to the matched -value. A pattern of the form :n:`pattern | pattern` is called disjunctive. A +:n:`(@pattern as @ident)` are also accepted. This pattern matches the +same values as :token:`pattern` does and :token:`ident` is bound to the matched +value. A pattern of the form :n:`@pattern | @pattern` is called disjunctive. A list of patterns separated with commas is also considered as a pattern and is called *multiple pattern*. However multiple patterns can only occur at the root of pattern matching equations. Disjunctions of diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index 3d58f522dd..e93b01f14d 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -28,7 +28,7 @@ Generating ML Code .. note:: - In the following, a qualified identifier `qualid` + In the following, a qualified identifier :token:`qualid` can be used to refer to any kind of |Coq| global "object" : constant, inductive type, inductive constructor or module name. @@ -47,30 +47,30 @@ extraction. They both display extracted term(s) inside |Coq|. All the following commands produce real ML files. User can choose to produce one monolithic file or one file per |Coq| library. -.. cmd:: Extraction "@file" {+ @qualid } +.. cmd:: Extraction @string {+ @qualid } Recursive extraction of all the mentioned objects and all - their dependencies in one monolithic `file`. + their dependencies in one monolithic file :token:`string`. Global and local identifiers are renamed according to the chosen ML language to fulfill its syntactic conventions, keeping original names as much as possible. .. cmd:: Extraction Library @ident - Extraction of the whole |Coq| library ``ident.v`` to an ML module - ``ident.ml``. In case of name clash, identifiers are here renamed + Extraction of the whole |Coq| library :n:`@ident.v` to an ML module + :n:`@ident.ml`. In case of name clash, identifiers are here renamed using prefixes ``coq_`` or ``Coq_`` to ensure a session-independent renaming. .. cmd:: Recursive Extraction Library @ident - Extraction of the |Coq| library ``ident.v`` and all other modules - ``ident.v`` depends on. + Extraction of the |Coq| library :n:`@ident.v` and all other modules + :n:`@ident.v` depends on. .. cmd:: Separate Extraction {+ @qualid } Recursive extraction of all the mentioned objects and all - their dependencies, just as ``Extraction "file"``, + their dependencies, just as :n:`Extraction @string {+ @qualid }`, but instead of producing one monolithic file, this command splits the produced code in separate ML files, one per corresponding Coq ``.v`` file. This command is hence quite similar to @@ -99,12 +99,12 @@ Extraction Options Setting the target language ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ability to fix target language is the first and more important -of the extraction options. Default is ``OCaml``. +.. cmd:: Extraction Language ( OCaml | Haskell | Scheme ) + :name: Extraction Language + + The ability to fix target language is the first and more important + of the extraction options. Default is ``OCaml``. -.. cmd:: Extraction Language OCaml -.. cmd:: Extraction Language Haskell -.. cmd:: Extraction Language Scheme Inlining and optimizations ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -164,7 +164,7 @@ The type-preserving optimizations are controlled by the following |Coq| options: .. cmd:: Extraction Inline {+ @qualid } In addition to the automatic inline feature, the constants - mentionned by this command will always be inlined during extraction. + mentioned by this command will always be inlined during extraction. .. cmd:: Extraction NoInline {+ @qualid } @@ -214,9 +214,9 @@ principles of extraction (logical parts and types). .. cmd:: Extraction Implicit @qualid [ {+ @ident } ] This experimental command allows declaring some arguments of - `qualid` as implicit, i.e. useless in extracted code and hence to - be removed by extraction. Here `qualid` can be any function or - inductive constructor, and the given `ident` are the names of + :token:`qualid` as implicit, i.e. useless in extracted code and hence to + be removed by extraction. Here :token:`qualid` can be any function or + inductive constructor, and the given :token:`ident` are the names of the concerned arguments. In fact, an argument can also be referred by a number indicating its position, starting from 1. @@ -253,7 +253,7 @@ what ML term corresponds to a given axiom. .. cmd:: Extract Constant @qualid => @string Give an ML extraction for the given constant. - The `string` may be an identifier or a quoted string. + The :token:`string` may be an identifier or a quoted string. .. cmd:: Extract Inlined Constant @qualid => @string @@ -283,6 +283,7 @@ arity, that is a sequence of product finished by a sort), then some type variables have to be given (as quoted strings). The syntax is then: .. cmdv:: Extract Constant @qualid @string ... @string => @string + :undocumented: The number of type variables is checked by the system. For example: @@ -314,24 +315,24 @@ native boolean type instead of the |Coq| one. The syntax is the following: .. cmd:: Extract Inductive @qualid => @string [ {+ @string } ] Give an ML extraction for the given inductive type. You must specify - extractions for the type itself (first `string`) and all its - constructors (all the `string` between square brackets). In this form, + extractions for the type itself (first :token:`string`) and all its + constructors (all the :token:`string` between square brackets). In this form, the ML extraction must be an ML inductive datatype, and the native pattern matching of the language will be used. .. cmdv:: Extract Inductive @qualid => @string [ {+ @string } ] @string - Same as before, with a final extra `string` that indicates how to + Same as before, with a final extra :token:`string` that indicates how to perform pattern matching over this inductive type. In this form, the ML extraction could be an arbitrary type. - For an inductive type with `k` constructors, the function used to - emulate the pattern matching should expect `(k+1)` arguments, first the `k` + For an inductive type with :math:`k` constructors, the function used to + emulate the pattern matching should expect :math:`k+1` arguments, first the :math:`k` branches in functional form, and then the inductive element to destruct. For instance, the match branch ``| S n => foo`` gives the functional form ``(fun n -> foo)``. Note that a constructor with no arguments is considered to have one unit argument, in order to block early evaluation of the branch: ``| O => bar`` leads to the functional - form ``(fun () -> bar)``. For instance, when extracting ``nat`` + form ``(fun () -> bar)``. For instance, when extracting :g:`nat` into |OCaml| ``int``, the code to be provided has type: ``(unit->'a)->(int->'a)->int->'a``. @@ -409,6 +410,52 @@ It is possible to instruct the extraction not to use particular filenames. For |OCaml|, a typical use of these commands is ``Extraction Blacklist String List``. +Additional settings +~~~~~~~~~~~~~~~~~~~ + +.. opt:: Extraction File Comment @string + :name: Extraction File Comment + + Provides a comment that is included at the beginning of the output files. + +.. opt:: Extraction Flag @num + :name: Extraction Flag + + Controls which optimizations are used during extraction, providing a finer-grained + control than :flag:`Extraction Optimize`. The bits of :token:`num` are used as a bit mask. + Keeping an option off keeps the extracted ML more similar to the Coq term. + Values are: + + +-----+-------+----------------------------------------------------------------+ + | Bit | Value | Optimization (default is on unless noted otherwise) | + +-----+-------+----------------------------------------------------------------+ + | 0 | 1 | Remove local dummy variables | + +-----+-------+----------------------------------------------------------------+ + | 1 | 2 | Use special treatment for fixpoints | + +-----+-------+----------------------------------------------------------------+ + | 2 | 4 | Simplify case with iota-redux | + +-----+-------+----------------------------------------------------------------+ + | 3 | 8 | Factor case branches as functions | + +-----+-------+----------------------------------------------------------------+ + | 4 | 16 | (not available, default false) | + +-----+-------+----------------------------------------------------------------+ + | 5 | 32 | Simplify case as function of one argument | + +-----+-------+----------------------------------------------------------------+ + | 6 | 64 | Simplify case by swapping case and lambda | + +-----+-------+----------------------------------------------------------------+ + | 7 | 128 | Some case optimization | + +-----+-------+----------------------------------------------------------------+ + | 8 | 256 | Push arguments inside a letin | + +-----+-------+----------------------------------------------------------------+ + | 9 | 512 | Use linear let reduction (default false) | + +-----+-------+----------------------------------------------------------------+ + | 10 | 1024 | Use linear beta reduction (default false) | + +-----+-------+----------------------------------------------------------------+ + +.. flag:: Extraction TypeExpand + + If set, fully expand Coq types in ML. See the Coq source code to learn more. + Differences between |Coq| and ML type systems ---------------------------------------------- diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index 403b163196..e468cc63cd 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -530,19 +530,11 @@ Notice, however, that using the prefixed tactics it is possible to pass additional arguments such as ``using relation``. .. tacv:: setoid_reflexivity - :name: setoid_reflexivity - -.. tacv:: setoid_symmetry {? in @ident} - :name: setoid_symmetry - -.. tacv:: setoid_transitivity - :name: setoid_transitivity - -.. tacv:: setoid_rewrite {? @orientation} @term {? at @occs} {? in @ident} - :name: setoid_rewrite - -.. tacv:: setoid_replace @term with @term {? using relation @term} {? in @ident} {? by @tactic} - :name: setoid_replace + setoid_symmetry {? in @ident} + setoid_transitivity + setoid_rewrite {? @orientation} @term {? at @occs} {? in @ident} + setoid_replace @term with @term {? using relation @term} {? in @ident} {? by @tactic} + :name: setoid_reflexivity; setoid_symmetry; setoid_transitivity; setoid_rewrite; setoid_replace The ``using relation`` arguments cannot be passed to the unprefixed form. The latter argument tells the tactic what parametric relation should diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index fc5a366caf..64e2d7c4ab 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -25,10 +25,10 @@ typed modulo insertion of appropriate coercions. We allow to write: Classes ------- -A class with `n` parameters is any defined name with a type -:g:`forall (x₁:A₁)..(xₙ:Aₙ),s` where ``s`` is a sort. Thus a class with +A class with :math:`n` parameters is any defined name with a type +:n:`forall (@ident__1 : @type__1)..(@ident__n:@type__n), @sort`. Thus a class with parameters is considered as a single class and not as a family of -classes. An object of a class ``C`` is any term of type :g:`C t₁ .. tₙ`. +classes. An object of a class is any term of type :n:`@class @term__1 .. @term__n`. In addition to these user-defined classes, we have two built-in classes: @@ -40,20 +40,20 @@ In addition to these user-defined classes, we have two built-in classes: Formally, the syntax of a classes is defined as: .. productionlist:: - class: qualid - : | `Sortclass` - : | `Funclass` + class: `qualid` + : | Sortclass + : | Funclass Coercions --------- A name ``f`` can be declared as a coercion between a source user-defined class -``C`` with `n` parameters and a target class ``D`` if one of these +``C`` with :math:`n` parameters and a target class ``D`` if one of these conditions holds: * ``D`` is a user-defined class, then the type of ``f`` must have the form - :g:`forall (x₁:A₁)..(xₙ:Aₙ)(y:C x₁..xₙ), D u₁..uₘ` where `m` + :g:`forall (x₁:A₁)..(xₙ:Aₙ)(y:C x₁..xₙ), D u₁..uₘ` where :math:`m` is the number of parameters of ``D``. * ``D`` is ``Funclass``, then the type of ``f`` must have the form :g:`forall (x₁:A₁)..(xₙ:Aₙ)(y:C x₁..xₙ)(x:A), B`. @@ -124,17 +124,32 @@ Declaring Coercions .. cmd:: Coercion @qualid : @class >-> @class - Declares the construction denoted by `qualid` as a coercion between + Declares the construction denoted by :token:`qualid` as a coercion between the two given classes. .. exn:: @qualid not declared. + :undocumented: + .. exn:: @qualid is already a coercion. + :undocumented: + .. exn:: Funclass cannot be a source class. + :undocumented: + .. exn:: @qualid is not a function. + :undocumented: + .. exn:: Cannot find the source class of @qualid. + :undocumented: + .. exn:: Cannot recognize @class as a source class of @qualid. + :undocumented: + .. exn:: @qualid does not respect the uniform inheritance condition. + :undocumented: + .. exn:: Found target class ... instead of ... + :undocumented: .. warn:: Ambiguous path. @@ -144,23 +159,18 @@ Declaring Coercions .. cmdv:: Local Coercion @qualid : @class >-> @class - Declares the construction denoted by `qualid` as a coercion local to + Declares the construction denoted by :token:`qualid` as a coercion local to the current section. - .. cmdv:: Coercion @ident := @term - - This defines `ident` just like ``Definition`` `ident` ``:=`` `term`, - and then declares `ident` as a coercion between it source and its target. - - .. cmdv:: Coercion @ident := @term : @type + .. cmdv:: Coercion @ident := @term {? @type } - This defines `ident` just like ``Definition`` `ident` : `type` ``:=`` `term`, - and then declares `ident` as a coercion between it source and its target. + This defines :token:`ident` just like :n:`Definition @ident := term {? @type }`, + and then declares :token:`ident` as a coercion between it source and its target. - .. cmdv:: Local Coercion @ident := @term + .. cmdv:: Local Coercion @ident := @term {? @type } - This defines `ident` just like ``Let`` `ident` ``:=`` `term`, - and then declares `ident` as a coercion between it source and its target. + This defines :token:`ident` just like :n:`Let @ident := @term {? @type }`, + and then declares :token:`ident` as a coercion between it source and its target. Assumptions can be declared as coercions at declaration time. This extends the grammar of assumptions from @@ -192,44 +202,44 @@ grammar of inductive types from Figure :ref:`vernacular` as follows: \comindex{CoInductive \mbox{\rm (and coercions)}} .. productionlist:: - inductive : `Inductive` ind_body `with` ... `with` ind_body - : | `CoInductive` ind_body `with` ... `with` ind_body - ind_body : ident [binders] : term := [[|] constructor | ... | constructor] - constructor : ident [binders] [:[>] term] + inductive : Inductive `ind_body` with ... with `ind_body` + : | CoInductive `ind_body` with ... with `ind_body` + ind_body : `ident` [ `binders` ] : `term` := [[|] `constructor` | ... | `constructor` ] + constructor : `ident` [ `binders` ] [:[>] `term` ] Especially, if the extra ``>`` is present in a constructor declaration, this constructor is declared as a coercion. .. cmd:: Identity Coercion @ident : @class >-> @class - If ``C`` is the source `class` and ``D`` the destination, we check - that ``C`` is a constant with a body of the form - :g:`fun (x₁:T₁)..(xₙ:Tₙ) => D t₁..tₘ` where `m` is the - number of parameters of ``D``. Then we define an identity - function with type :g:`forall (x₁:T₁)..(xₙ:Tₙ)(y:C x₁..xₙ),D t₁..tₘ`, - and we declare it as an identity coercion between ``C`` and ``D``. + If ``C`` is the source `class` and ``D`` the destination, we check + that ``C`` is a constant with a body of the form + :g:`fun (x₁:T₁)..(xₙ:Tₙ) => D t₁..tₘ` where `m` is the + number of parameters of ``D``. Then we define an identity + function with type :g:`forall (x₁:T₁)..(xₙ:Tₙ)(y:C x₁..xₙ),D t₁..tₘ`, + and we declare it as an identity coercion between ``C`` and ``D``. - .. exn:: @class must be a transparent constant. + .. exn:: @class must be a transparent constant. + :undocumented: - .. cmdv:: Local Identity Coercion @ident : @ident >-> @ident + .. cmdv:: Local Identity Coercion @ident : @ident >-> @ident - Same as ``Identity Coercion`` but locally to the current section. + Same as :cmd:`Identity Coercion` but locally to the current section. - .. cmdv:: SubClass @ident := @type - :name: SubClass + .. cmdv:: SubClass @ident := @type + :name: SubClass - If `type` is a class `ident'` applied to some arguments then - `ident` is defined and an identity coercion of name - `Id_ident_ident'` is - declared. Otherwise said, this is an abbreviation for + If :n:`@type` is a class :n:`@ident'` applied to some arguments then + :n:`@ident` is defined and an identity coercion of name + :n:`Id_@ident_@ident'` is + declared. Otherwise said, this is an abbreviation for - ``Definition`` `ident` ``:=`` `type`. + :n:`Definition @ident := @type.` + :n:`Identity Coercion Id_@ident_@ident' : @ident >-> @ident'`. - ``Identity Coercion`` `Id_ident_ident'` : `ident` ``>->`` `ident'`. + .. cmdv:: Local SubClass @ident := @type - .. cmdv:: Local SubClass @ident := @type - - Same as before but locally to the current section. + Same as before but locally to the current section. Displaying Available Coercions @@ -237,19 +247,19 @@ Displaying Available Coercions .. cmd:: Print Classes - Print the list of declared classes in the current context. + Print the list of declared classes in the current context. .. cmd:: Print Coercions - Print the list of declared coercions in the current context. + Print the list of declared coercions in the current context. .. cmd:: Print Graph - Print the list of valid coercion paths in the current context. + Print the list of valid coercion paths in the current context. .. cmd:: Print Coercion Paths @class @class - Print the list of valid coercion paths between the two given classes. + Print the list of valid coercion paths between the two given classes. Activating the Printing of Coercions ------------------------------------- @@ -270,19 +280,21 @@ Activating the Printing of Coercions Classes as Records ------------------ +.. index:: :> (coercion) + We allow the definition of *Structures with Inheritance* (or classes as records) by extending the existing :cmd:`Record` macro. Its new syntax is: .. cmdv:: Record {? >} @ident {? @binders} : @sort := {? @ident} { {+; @ident :{? >} @term } } - The first identifier `ident` is the name of the defined record and - `sort` is its type. The optional identifier after ``:=`` is the name - of the constuctor (it will be ``Build_``\ `ident` if not given). - The other identifiers are the names of the fields, and the `term` + The first identifier :token:`ident` is the name of the defined record and + :token:`sort` is its type. The optional identifier after ``:=`` is the name + of the constuctor (it will be :n:`Build_@ident` if not given). + The other identifiers are the names of the fields, and :token:`term` are their respective types. If ``:>`` is used instead of ``:`` in the declaration of a field, then the name of this field is automatically declared as a coercion from the record name to the class of this - field type. Remark that the fields always verify the uniform + field type. Note that the fields always verify the uniform inheritance condition. If the optional ``>`` is given before the record name, then the constructor name is automatically declared as a coercion from the class of the last field type to the record name @@ -322,9 +334,9 @@ Coercions and Modules .. warn:: Coercion used but not in scope: @qualid. If you want to use this coercion, please Import the module that contains it. - This warning is emitted when typechecking relies on a coercion - contained in a module that has not been explicitely imported. It helps - migrating code and stop relying on the option above. + This warning is emitted when typechecking relies on a coercion + contained in a module that has not been explicitely imported. It helps + migrating code and stop relying on the option above. Examples -------- diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index 5d219ebd0d..fd66de427c 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -248,7 +248,7 @@ cone expression :math:`2 \times (x-1) + (\mathbf{x-1}) \times (\mathbf{x−1}) + belongs to :math:`\mathit{Cone}({−x^2,x -1})`. Moreover, by running :tacn:`ring` we obtain :math:`-1`. By Theorem :ref:`Psatz <psatz_thm>`, the goal is valid. -.. [#] Support for `nat` and :math:`\mathbb{N}` is obtained by pre-processing the goal with +.. [#] Support for :g:`nat` and :g:`N` is obtained by pre-processing the goal with the ``zify`` tactic. .. [#] Sources and binaries can be found at https://projects.coin-or.org/Csdp .. [#] Variants deal with equalities and strict inequalities. diff --git a/doc/sphinx/addendum/miscellaneous-extensions.rst b/doc/sphinx/addendum/miscellaneous-extensions.rst index 2cde65dcdc..db8c09d88f 100644 --- a/doc/sphinx/addendum/miscellaneous-extensions.rst +++ b/doc/sphinx/addendum/miscellaneous-extensions.rst @@ -12,22 +12,22 @@ of program refinements. To use the Derive extension it must first be required with ``Require Coq.derive.Derive``. When the extension is loaded, it provides the following command: -.. cmd:: Derive @ident SuchThat @term As @ident - -The first `ident` can appear in `term`. This command opens a new proof -presenting the user with a goal for term in which the name `ident` is -bound to an existential variable `?x` (formally, there are other goals -standing for the existential variables but they are shelved, as -described in :tacn:`shelve`). - -When the proof ends two constants are defined: - -+ The first one is named using the first `ident` and is defined as the proof of the - shelved goal (which is also the value of `?x`). It is always - transparent. -+ The second one is named using the second `ident`. It has type `term`, and its body is - the proof of the initially visible goal. It is opaque if the proof - ends with ``Qed``, and transparent if the proof ends with ``Defined``. +.. cmd:: Derive @ident__1 SuchThat @type As @ident__2 + + :n:`@ident__1` can appear in :n:`@type`. This command opens a new proof + presenting the user with a goal for :n:`@type` in which the name :n:`@ident__1` is + bound to an existential variable :g:`?x` (formally, there are other goals + standing for the existential variables but they are shelved, as + described in :tacn:`shelve`). + + When the proof ends two constants are defined: + + + The first one is named :n:`@ident__1` and is defined as the proof of the + shelved goal (which is also the value of :g:`?x`). It is always + transparent. + + The second one is named :n:`@ident__2`. It has type :n:`@type`, and its body is + the proof of the initially visible goal. It is opaque if the proof + ends with :cmd:`Qed`, and transparent if the proof ends with :cmd:`Defined`. .. example:: diff --git a/doc/sphinx/addendum/nsatz.rst b/doc/sphinx/addendum/nsatz.rst index e7a8c238ac..ed2e1ea58c 100644 --- a/doc/sphinx/addendum/nsatz.rst +++ b/doc/sphinx/addendum/nsatz.rst @@ -81,7 +81,7 @@ performed using :ref:`typeclasses`. produces a goal which states that :math:`c` is not zero. * `variables` is the list of the variables in the decreasing order in - which they will be used in the Buchberger algorithm. If `variables` = `(@nil R)`, + which they will be used in the Buchberger algorithm. If `variables` = :g:`(@nil R)`, then `lvar` is replaced by all the variables which are not in `parameters`. diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst index 03d4f148e3..b008508bbc 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -67,16 +67,22 @@ is generated: :tacn:`intro` as many times as needed. .. exn:: omega: Unrecognized predicate or connective: @ident. + :undocumented: .. exn:: omega: Unrecognized atomic proposition: ... + :undocumented: .. exn:: omega: Can't solve a goal with proposition variables. + :undocumented: .. exn:: omega: Unrecognized proposition. + :undocumented: .. exn:: omega: Can't solve a goal with non-linear products. + :undocumented: .. exn:: omega: Can't solve a goal with equality on type ... + :undocumented: Using ``omega`` diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index fad45995d2..56f84d0ff0 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -95,6 +95,14 @@ coercions. (the option is on by default). Coercion of subset types and pairs is still active in this case. +.. flag:: Program Mode + + Enables the program mode, in which 1) typechecking allows subset coercions and + 2) the elaboration of pattern matching of :cmd:`Program Fixpoint` and + :cmd:`Program Definition` act + like Program Fixpoint/Definition, generating obligations if there are + unresolved holes after typechecking. + .. _syntactic_control: Syntactic control over equalities @@ -102,7 +110,7 @@ Syntactic control over equalities To give more control over the generation of equalities, the type checker will fall back directly to |Coq|’s usual typing of dependent -pattern matching if a return or in clause is specified. Likewise, the +pattern matching if a ``return`` or ``in`` clause is specified. Likewise, the if construct is not treated specially by |Program| so boolean tests in the code are not automatically reflected in the obligations. One can use the :g:`dec` combinator to get the correct hypotheses as in: @@ -118,8 +126,9 @@ use the :g:`dec` combinator to get the correct hypotheses as in: else S (pred n). The :g:`let` tupling construct :g:`let (x1, ..., xn) := t in b` does not -produce an equality, contrary to the let pattern construct :g:`let ’(x1, -..., xn) := t in b`. Also, :g:`term :>` explicitly asks the system to +produce an equality, contrary to the let pattern construct +:g:`let '(x1,..., xn) := t in b`. +Also, :g:`term :>` explicitly asks the system to coerce term to its support type. It can be useful in notations, for example: @@ -150,6 +159,7 @@ Program Definition .. exn:: @ident already exists. :name: @ident already exists. (Program Definition) + :undocumented: .. cmdv:: Program Definition @ident : @type := @term @@ -162,7 +172,7 @@ Program Definition and the aforementioned coercion derivation are solved. .. exn:: In environment … the term: @term does not have type @type. Actually, it has type ... - + :undocumented: .. cmdv:: Program Definition @ident @binders : @type := @term @@ -179,23 +189,23 @@ Program Definition Program Fixpoint ~~~~~~~~~~~~~~~~ -.. cmd:: Program Fixpoint @ident @params {? {@order}} : @type := @term +.. cmd:: Program Fixpoint @ident @binders {? {@order}} : @type := @term -The optional order annotation follows the grammar: + The optional order annotation follows the grammar: -.. productionlist:: orderannot - order : measure `term` (`term`)? | wf `term` `term` + .. productionlist:: orderannot + order : measure `term` (`term`)? | wf `term` `term` -+ :g:`measure f ( R )` where :g:`f` is a value of type :g:`X` computed on - any subset of the arguments and the optional (parenthesised) term - ``(R)`` is a relation on ``X``. By default ``X`` defaults to ``nat`` and ``R`` - to ``lt``. + + :g:`measure f ( R )` where :g:`f` is a value of type :g:`X` computed on + any subset of the arguments and the optional (parenthesised) term + ``(R)`` is a relation on ``X``. By default ``X`` defaults to ``nat`` and ``R`` + to ``lt``. -+ :g:`wf R x` which is equivalent to :g:`measure x (R)`. + + :g:`wf R x` which is equivalent to :g:`measure x (R)`. -The structural fixpoint operator behaves just like the one of |Coq| (see -:cmd:`Fixpoint`), except it may also generate obligations. It works -with mutually recursive definitions too. + The structural fixpoint operator behaves just like the one of |Coq| (see + :cmd:`Fixpoint`), except it may also generate obligations. It works + with mutually recursive definitions too. .. coqtop:: reset in diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index 58617916c0..99d689132d 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -100,26 +100,26 @@ Concrete usage in Coq .. tacn:: ring -The ``ring`` tactic solves equations upon polynomial expressions of a ring -(or semiring) structure. It proceeds by normalizing both sides -of the equation (w.r.t. associativity, commutativity and -distributivity, constant propagation, rewriting of monomials) and -comparing syntactically the results. + This tactic solves equations upon polynomial expressions of a ring + (or semiring) structure. It proceeds by normalizing both sides + of the equation (w.r.t. associativity, commutativity and + distributivity, constant propagation, rewriting of monomials) and + comparing syntactically the results. .. tacn:: ring_simplify -``ring_simplify`` applies the normalization procedure described above to -the given terms. The tactic then replaces all occurrences of the terms -given in the conclusion of the goal by their normal forms. If no term -is given, then the conclusion should be an equation and both -sides are normalized. The tactic can also be applied in a hypothesis. + This tactic applies the normalization procedure described above to + the given terms. The tactic then replaces all occurrences of the terms + given in the conclusion of the goal by their normal forms. If no term + is given, then the conclusion should be an equation and both + sides are normalized. The tactic can also be applied in a hypothesis. -The tactic must be loaded by ``Require Import Ring``. The ring structures -must be declared with the ``Add Ring`` command (see below). The ring of -booleans is predefined; if one wants to use the tactic on |nat| one must -first require the module ``ArithRing`` exported by ``Arith``); for |Z|, do -``Require Import ZArithRing`` or simply ``Require Import ZArith``; for |N|, do -``Require Import NArithRing`` or ``Require Import NArith``. + The tactic must be loaded by ``Require Import Ring``. The ring structures + must be declared with the ``Add Ring`` command (see below). The ring of + booleans is predefined; if one wants to use the tactic on |nat| one must + first require the module ``ArithRing`` exported by ``Arith``); for |Z|, do + ``Require Import ZArithRing`` or simply ``Require Import ZArith``; for |N|, do + ``Require Import NArithRing`` or ``Require Import NArith``. .. example:: @@ -141,25 +141,24 @@ first require the module ``ArithRing`` exported by ``Arith``); for |Z|, do .. tacv:: ring [{* @term }] -decides the equality of two terms modulo ring operations and -the equalities defined by the :n:`@term`\ s. -Each :n:`@term` has to be a proof of some equality `m = p`, where `m` is a monomial (after “abstraction”), `p` a polynomial and `=` the corresponding equality of the ring structure. + This tactic decides the equality of two terms modulo ring operations and + the equalities defined by the :token:`term`\ s. + Each :token:`term` has to be a proof of some equality :g:`m = p`, where :g:`m` + is a monomial (after “abstraction”), :g:`p` a polynomial and :g:`=` the + corresponding equality of the ring structure. .. tacv:: ring_simplify [{* @term }] {* @term } in @ident -performs the simplification in the hypothesis named :n:`@ident`. + This tactic performs the simplification in the hypothesis named :token:`ident`. .. note:: - .. tacn:: ring_simplify @term1; ring_simplify @term2 + :n:`ring_simplify @term__1; ring_simplify @term__2` is not equivalent to + :n:`ring_simplify @term__1 @term__2`. - is not equivalent to - - .. tacn:: ring_simplify @term1 @term2 - - In the latter case the variables map - is shared between the two terms, and common subterm `t` of :n:`@term1` and :n:`@term2` + In the latter case the variables map is shared between the two terms, and + common subterm :g:`t` of :n:`@term__1` and :n:`@term__2` will have the same associated variable number. So the first alternative should be avoided for terms belonging to the same ring theory. @@ -174,17 +173,17 @@ Error messages: .. exn:: Arguments of ring_simplify do not have all the same type. - ``ring_simplify`` cannot simplify terms of several rings at the same + :tacn:`ring_simplify` cannot simplify terms of several rings at the same time. Invoke the tactic once per ring structure. .. exn:: Cannot find a declared ring structure over @term. No ring has been declared for the type of the terms to be simplified. - Use ``Add Ring`` first. + Use :cmd:`Add Ring` first. .. exn:: Cannot find a declared ring structure for equality @term. - Same as above in the case of the ``ring`` tactic. + Same as above in the case of the :tacn:`ring` tactic. Adding a ring structure @@ -302,93 +301,93 @@ The syntax for adding a new ring is .. cmd:: Add Ring @ident : @term {? ( @ring_mod {* , @ring_mod } )} -The :n:`@ident` is not relevant. It is used just for error messages. The -:n:`@term` is a proof that the ring signature satisfies the (semi-)ring -axioms. The optional list of modifiers is used to tailor the behavior -of the tactic. The following list describes their syntax and effects: - -.. productionlist:: coq - ring_mod : abstract | decidable `term` | morphism `term` - : | setoid `term` `term` - : | constants [`ltac`] - : | preprocess [`ltac`] - : | postprocess [`ltac`] - : | power_tac `term` [`ltac`] - : | sign `term` - : | div `term` - -abstract - declares the ring as abstract. This is the default. - -decidable :n:`@term` - declares the ring as computational. The expression - :n:`@term` is the correctness proof of an equality test ``?=!`` - (which hould be evaluable). Its type should be of the form - ``forall x y, x ?=! y = true → x == y``. - -morphism :n:`@term` - declares the ring as a customized one. The expression - :n:`@term` is a proof that there exists a morphism between a set of - coefficient and the ring carrier (see ``Ring_theory.ring_morph`` and - ``Ring_theory.semi_morph``). - -setoid :n:`@term` :n:`@term` - forces the use of given setoid. The first - :n:`@term` is a proof that the equality is indeed a setoid (see - ``Setoid.Setoid_Theory``), and the second :n:`@term` a proof that the - ring operations are morphisms (see ``Ring_theory.ring_eq_ext`` and - ``Ring_theory.sring_eq_ext``). - This modifier needs not be used if the setoid and morphisms have been - declared. - -constants [:n:`@ltac`] - specifies a tactic expression :n:`@ltac` that, given a - term, returns either an object of the coefficient set that is mapped - to the expression via the morphism, or returns - ``InitialRing.NotConstant``. The default behavior is to map only 0 and 1 - to their counterpart in the coefficient set. This is generally not - desirable for non trivial computational rings. - -preprocess [:n:`@ltac`] - specifies a tactic :n:`@ltac` that is applied as a - preliminary step for ``ring`` and ``ring_simplify``. It can be used to - transform a goal so that it is better recognized. For instance, ``S n`` - can be changed to ``plus 1 n``. - -postprocess [:n:`@ltac`] - specifies a tactic :n:`@ltac` that is applied as a final - step for ``ring_simplify``. For instance, it can be used to undo - modifications of the preprocessor. - -power_tac :n:`@term` [:n:`@ltac`] - allows ``ring`` and ``ring_simplify`` to recognize - power expressions with a constant positive integer exponent (example: - ::math:`x^2` ). The term :n:`@term` is a proof that a given power function satisfies - the specification of a power function (term has to be a proof of - ``Ring_theory.power_theory``) and :n:`@ltac` specifies a tactic expression - that, given a term, “abstracts” it into an object of type |N| whose - interpretation via ``Cp_phi`` (the evaluation function of power - coefficient) is the original term, or returns ``InitialRing.NotConstant`` - if not a constant coefficient (i.e. |L_tac| is the inverse function of - ``Cp_phi``). See files ``plugins/setoid_ring/ZArithRing.v`` - and ``plugins/setoid_ring/RealField.v`` for examples. By default the tactic - does not recognize power expressions as ring expressions. - -sign :n:`@term` - allows ``ring_simplify`` to use a minus operation when - outputting its normal form, i.e writing ``x − y`` instead of ``x + (− y)``. The - term `:n:`@term` is a proof that a given sign function indicates expressions - that are signed (`term` has to be a proof of ``Ring_theory.get_sign``). See - ``plugins/setoid_ring/InitialRing.v`` for examples of sign function. - -div :n:`@term` - allows ``ring`` and ``ring_simplify`` to use monomials with - coefficients other than 1 in the rewriting. The term :n:`@term` is a proof - that a given division function satisfies the specification of an - euclidean division function (:n:`@term` has to be a proof of - ``Ring_theory.div_theory``). For example, this function is called when - trying to rewrite :math:`7x` by :math:`2x = z` to tell that :math:`7 = 3 \times 2 + 1`. See - ``plugins/setoid_ring/InitialRing.v`` for examples of div function. + The :token:`ident` is not relevant. It is used just for error messages. The + :token:`term` is a proof that the ring signature satisfies the (semi-)ring + axioms. The optional list of modifiers is used to tailor the behavior + of the tactic. The following list describes their syntax and effects: + + .. productionlist:: coq + ring_mod : abstract | decidable `term` | morphism `term` + : | setoid `term` `term` + : | constants [`ltac`] + : | preprocess [`ltac`] + : | postprocess [`ltac`] + : | power_tac `term` [`ltac`] + : | sign `term` + : | div `term` + + abstract + declares the ring as abstract. This is the default. + + decidable :n:`@term` + declares the ring as computational. The expression + :n:`@term` is the correctness proof of an equality test ``?=!`` + (which hould be evaluable). Its type should be of the form + ``forall x y, x ?=! y = true → x == y``. + + morphism :n:`@term` + declares the ring as a customized one. The expression + :n:`@term` is a proof that there exists a morphism between a set of + coefficient and the ring carrier (see ``Ring_theory.ring_morph`` and + ``Ring_theory.semi_morph``). + + setoid :n:`@term` :n:`@term` + forces the use of given setoid. The first + :n:`@term` is a proof that the equality is indeed a setoid (see + ``Setoid.Setoid_Theory``), and the second :n:`@term` a proof that the + ring operations are morphisms (see ``Ring_theory.ring_eq_ext`` and + ``Ring_theory.sring_eq_ext``). + This modifier needs not be used if the setoid and morphisms have been + declared. + + constants [ :n:`@ltac` ] + specifies a tactic expression :n:`@ltac` that, given a + term, returns either an object of the coefficient set that is mapped + to the expression via the morphism, or returns + ``InitialRing.NotConstant``. The default behavior is to map only 0 and 1 + to their counterpart in the coefficient set. This is generally not + desirable for non trivial computational rings. + + preprocess [ :n:`@ltac` ] + specifies a tactic :n:`@ltac` that is applied as a + preliminary step for :tacn:`ring` and :tacn:`ring_simplify`. It can be used to + transform a goal so that it is better recognized. For instance, ``S n`` + can be changed to ``plus 1 n``. + + postprocess [ :n:`@ltac` ] + specifies a tactic :n:`@ltac` that is applied as a final + step for :tacn:`ring_simplify`. For instance, it can be used to undo + modifications of the preprocessor. + + power_tac :n:`@term` [ :n:`@ltac` ] + allows :tacn:`ring` and :tacn:`ring_simplify` to recognize + power expressions with a constant positive integer exponent (example: + :math:`x^2` ). The term :n:`@term` is a proof that a given power function satisfies + the specification of a power function (term has to be a proof of + ``Ring_theory.power_theory``) and :n:`@ltac` specifies a tactic expression + that, given a term, “abstracts” it into an object of type |N| whose + interpretation via ``Cp_phi`` (the evaluation function of power + coefficient) is the original term, or returns ``InitialRing.NotConstant`` + if not a constant coefficient (i.e. |L_tac| is the inverse function of + ``Cp_phi``). See files ``plugins/setoid_ring/ZArithRing.v`` + and ``plugins/setoid_ring/RealField.v`` for examples. By default the tactic + does not recognize power expressions as ring expressions. + + sign :n:`@term` + allows :tacn:`ring_simplify` to use a minus operation when + outputting its normal form, i.e writing ``x − y`` instead of ``x + (− y)``. The + term :token:`term` is a proof that a given sign function indicates expressions + that are signed (:token:`term` has to be a proof of ``Ring_theory.get_sign``). See + ``plugins/setoid_ring/InitialRing.v`` for examples of sign function. + + div :n:`@term` + allows :tacn:`ring` and :tacn:`ring_simplify` to use monomials with + coefficients other than 1 in the rewriting. The term :n:`@term` is a proof + that a given division function satisfies the specification of an + euclidean division function (:n:`@term` has to be a proof of + ``Ring_theory.div_theory``). For example, this function is called when + trying to rewrite :math:`7x` by :math:`2x = z` to tell that :math:`7 = 3 \times 2 + 1`. See + ``plugins/setoid_ring/InitialRing.v`` for examples of div function. Error messages: @@ -477,8 +476,8 @@ So now, what is the scheme for a normalization proof? Let p be the polynomial expression that the user wants to normalize. First a little piece of |ML| code guesses the type of `p`, the ring theory `T` to use, an abstract polynomial `ap` and a variables map `v` such that `p` is |bdi|- -equivalent to ``(PEeval`` `v` `ap`\ ``)``. Then we replace it by ``(Pphi_dev`` `v` -``(norm`` `ap`\ ``))``, using the main correctness theorem and we reduce it to a +equivalent to `(PEeval v ap)`. Then we replace it by `(Pphi_dev v (norm ap))`, +using the main correctness theorem and we reduce it to a concrete expression `p’`, which is the concrete normal form of `p`. This is summarized in this diagram: ========= ====== ==== @@ -497,30 +496,31 @@ Dealing with fields .. tacn:: field -The ``field`` tactic is an extension of the ``ring`` tactic that deals with rational -expressions. Given a rational expression :math:`F = 0`. It first reduces the -expression `F` to a common denominator :math:`N/D = 0` where `N` and `D` -are two ring expressions. For example, if we take :math:`F = (1 − 1/x) x − x + 1`, this -gives :math:`N = (x − 1) x − x^2 + x` and :math:`D = x`. It then calls ring to solve -:math:`N = 0`. -Note that ``field`` also generates nonzero conditions for all the -denominators it encounters in the reduction. In our example, it -generates the condition :math:`x \neq 0`. These conditions appear as one subgoal -which is a conjunction if there are several denominators. Nonzero -conditions are always polynomial expressions. For example when -reducing the expression :math:`1/(1 + 1/x)`, two side conditions are -generated: :math:`x \neq 0` and :math:`x + 1 \neq 0`. Factorized expressions are broken since -a field is an integral domain, and when the equality test on -coefficients is complete w.r.t. the equality of the target field, -constants can be proven different from zero automatically. - -The tactic must be loaded by ``Require Import Field``. New field -structures can be declared to the system with the ``Add Field`` command -(see below). The field of real numbers is defined in module ``RealField`` -(in ``plugins/setoid_ring``). It is exported by module ``Rbase``, so -that requiring ``Rbase`` or ``Reals`` is enough to use the field tactics on -real numbers. Rational numbers in canonical form are also declared as -a field in the module ``Qcanon``. + This tactic is an extension of the :tacn:`ring` tactic that deals with rational + expressions. Given a rational expression :math:`F = 0`. It first reduces the + expression `F` to a common denominator :math:`N/D = 0` where `N` and `D` + are two ring expressions. For example, if we take :math:`F = (1 − 1/x) x − x + 1`, this + gives :math:`N = (x − 1) x − x^2 + x` and :math:`D = x`. It then calls ring to solve + :math:`N = 0`. + + Note that :n:`field` also generates nonzero conditions for all the + denominators it encounters in the reduction. In our example, it + generates the condition :math:`x \neq 0`. These conditions appear as one subgoal + which is a conjunction if there are several denominators. Nonzero + conditions are always polynomial expressions. For example when + reducing the expression :math:`1/(1 + 1/x)`, two side conditions are + generated: :math:`x \neq 0` and :math:`x + 1 \neq 0`. Factorized expressions are broken since + a field is an integral domain, and when the equality test on + coefficients is complete w.r.t. the equality of the target field, + constants can be proven different from zero automatically. + + The tactic must be loaded by ``Require Import Field``. New field + structures can be declared to the system with the ``Add Field`` command + (see below). The field of real numbers is defined in module ``RealField`` + (in ``plugins/setoid_ring``). It is exported by module ``Rbase``, so + that requiring ``Rbase`` or ``Reals`` is enough to use the field tactics on + real numbers. Rational numbers in canonical form are also declared as + a field in the module ``Qcanon``. .. example:: @@ -540,15 +540,15 @@ a field in the module ``Qcanon``. .. tacv:: field [{* @term}] - decides the equality of two terms modulo - field operations and the equalities defined - by the :n:`@term`\ s. Each :n:`@term` has to be a proof of some equality - `m` ``=`` `p`, where `m` is a monomial (after “abstraction”), `p` a polynomial - and ``=`` the corresponding equality of the field structure. + This tactic decides the equality of two terms modulo + field operations and the equalities defined + by the :token:`term`\s. Each :token:`term` has to be a proof of some equality + :g:`m = p`, where :g:`m` is a monomial (after “abstraction”), :g:`p` a polynomial + and :g:`=` the corresponding equality of the field structure. .. note:: - rewriting works with the equality `m` ``=`` `p` only if `p` is a polynomial since + Rewriting works with the equality :g:`m = p` only if :g:`p` is a polynomial since rewriting is handled by the underlying ring tactic. .. tacv:: field_simplify @@ -562,27 +562,28 @@ a field in the module ``Qcanon``. .. tacv:: field_simplify [{* @term }] - performs the simplification in the conclusion of the goal using the equalities - defined by the :n:`@term`\ s. + This variant performs the simplification in the conclusion of the goal using the equalities + defined by the :token:`term`\s. .. tacv:: field_simplify [{* @term }] {* @term } - performs the simplification in the terms :n:`@terms` of the conclusion of the goal - using the equalities defined by :n:`@term`\ s inside the brackets. + This variant performs the simplification in the terms :token:`term`\s of the conclusion of the goal + using the equalities defined by :token:`term`\s inside the brackets. -.. tacv :: field_simplify in @ident +.. tacv:: field_simplify in @ident - performs the simplification in the assumption :n:`@ident`. + This variant performs the simplification in the assumption :token:`ident`. -.. tacv :: field_simplify [{* @term }] in @ident +.. tacv:: field_simplify [{* @term }] in @ident - performs the simplification - in the assumption :n:`@ident` using the equalities defined by the :n:`@term`\ s. + This variant performs the simplification + in the assumption :token:`ident` using the equalities defined by the :token:`term`\s. .. tacv:: field_simplify [{* @term }] {* @term } in @ident - performs the simplification in the :n:`@term`\ s of the assumption :n:`@ident` using the - equalities defined by the :n:`@term`\ s inside the brackets. + This variant performs the simplification in the :token:`term`\s of the + assumption :token:`ident` using the + equalities defined by the :token:`term`\s inside the brackets. .. tacv:: field_simplify_eq @@ -591,18 +592,17 @@ a field in the module ``Qcanon``. .. tacv:: field_simplify_eq [ {* @term }] - performs the simplification in - the conclusion of the goal using the equalities defined by - :n:`@term`\ s. + This variant performs the simplification in + the conclusion of the goal using the equalities defined by :token:`term`\s. .. tacv:: field_simplify_eq in @ident - performs the simplification in the assumption :n:`@ident`. + This variant performs the simplification in the assumption :token:`ident`. .. tacv:: field_simplify_eq [{* @term}] in @ident - performs the simplification in the assumption :n:`@ident` using the equalities defined by - :n:`@terms`\ s and removing the denominator. + This variant performs the simplification in the assumption :token:`ident` + using the equalities defined by :token:`term`\s and removing the denominator. Adding a new field structure @@ -654,27 +654,25 @@ The syntax for adding a new field is .. cmd:: Add Field @ident : @term {? ( @field_mod {* , @field_mod } )} -The :n:`@ident` is not relevant. It is used just for error -messages. :n:`@term` is a proof that the field signature satisfies the -(semi-)field axioms. The optional list of modifiers is used to tailor -the behavior of the tactic. - -.. productionlist:: coq - field_mod : `ring_mod` | completeness `term` - -Since field tactics are built upon ``ring`` -tactics, all modifiers of the ``Add Ring`` apply. There is only one -specific modifier: - -completeness :n:`@term` - allows the field tactic to prove automatically - that the image of nonzero coefficients are mapped to nonzero - elements of the field. :n:`@term` is a proof of - - ``forall x y, [x] == [y] -> x ?=! y = true``, - - which is the completeness of equality on coefficients - w.r.t. the field equality. + The :n:`@ident` is not relevant. It is used just for error + messages. :n:`@term` is a proof that the field signature satisfies the + (semi-)field axioms. The optional list of modifiers is used to tailor + the behavior of the tactic. + + .. productionlist:: coq + field_mod : `ring_mod` | completeness `term` + + Since field tactics are built upon ``ring`` + tactics, all modifiers of the ``Add Ring`` apply. There is only one + specific modifier: + + completeness :n:`@term` + allows the field tactic to prove automatically + that the image of nonzero coefficients are mapped to nonzero + elements of the field. :n:`@term` is a proof of + :g:`forall x y, [x] == [y] -> x ?=! y = true`, + which is the completeness of equality on coefficients + w.r.t. the field equality. History of ring diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 369dae0ead..43d302114e 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -228,6 +228,8 @@ mechanism if available, as shown in the example. Substructures ~~~~~~~~~~~~~ +.. index:: :> (substructure) + Substructures are components of a class which are instances of a class themselves. They often arise when using classes for logical properties, e.g.: @@ -260,6 +262,12 @@ preorder can be used instead. This is very similar to the coercion mechanism of ``Structure`` declarations. The implementation simply declares each projection as an instance. +.. warn:: Ignored instance declaration for “@ident”: “@term” is not a class + + Using this ``:>`` syntax with a right-hand-side that is not itself a Class + has no effect (apart from emitting this warning). In particular, is does not + declare a coercion. + One can also declare existing objects or structure projections using the Existing Instance command to achieve the same effect. @@ -298,24 +306,24 @@ Variants: This command has no effect when used on a typeclass. -.. cmd:: Instance @ident {? @binders} : Class t1 … tn [| priority] := { field1 := b1 ; …; fieldi := bi } +.. cmd:: Instance @ident {? @binders} : @class t1 … tn [| priority] := { field1 := b1 ; …; fieldi := bi } -The :cmd:`Instance` command is used to declare a typeclass instance named -``ident`` of the class :cmd:`Class` with parameters ``t1`` to ``tn`` and -fields ``b1`` to ``bi``, where each field must be a declared field of -the class. Missing fields must be filled in interactive proof mode. + This command is used to declare a typeclass instance named + :token:`ident` of the class :token:`class` with parameters ``t1`` to ``tn`` and + fields ``b1`` to ``bi``, where each field must be a declared field of + the class. Missing fields must be filled in interactive proof mode. -An arbitrary context of ``binders`` can be put after the name of the -instance and before the colon to declare a parameterized instance. An -optional priority can be declared, 0 being the highest priority as for -:tacn:`auto` hints. If the priority is not specified, it defaults to the number -of non-dependent binders of the instance. + An arbitrary context of :token:`binders` can be put after the name of the + instance and before the colon to declare a parameterized instance. An + optional priority can be declared, 0 being the highest priority as for + :tacn:`auto` hints. If the priority is not specified, it defaults to the number + of non-dependent binders of the instance. -.. cmdv:: Instance @ident {? @binders} : forall {? @binders}, Class t1 … tn [| priority] := @term +.. cmdv:: Instance @ident {? @binders} : forall {? @binders}, @class @term__1 … @term__n [| priority] := @term This syntax is used for declaration of singleton class instances or - for directly giving an explicit term of type ``forall binders, Class - t1 … tn``. One need not even mention the unique field name for + for directly giving an explicit term of type :n:`forall @binders, @class + @term__1 … @term__n`. One need not even mention the unique field name for singleton classes. .. cmdv:: Global Instance @@ -453,12 +461,12 @@ type, like: This is equivalent to ``Hint Transparent, Opaque ident : typeclass_instances``. -Options -~~~~~~~ +Settings +~~~~~~~~ .. flag:: Typeclasses Dependency Order - This option (on by default since 8.6) respects the dependency order + This flag (on by default since 8.6) respects the dependency order between subgoals, meaning that subgoals on which other subgoals depend come first, while the non-dependent subgoals were put before the dependent ones previously (Coq 8.5 and below). This can result in @@ -467,7 +475,7 @@ Options .. flag:: Typeclasses Filtered Unification - This option, available since Coq 8.6 and off by default, switches the + This flag, available since Coq 8.6 and off by default, switches the hint application procedure to a filter-then-unify strategy. To apply a hint, we first check that the goal *matches* syntactically the inferred or specified pattern of the hint, and only then try to @@ -475,13 +483,13 @@ Options improve performance by calling unification less often, matching syntactic patterns being very quick. This also provides more control on the triggering of instances. For example, forcing a constant to - explicitely appear in the pattern will make it never apply on a goal + explicitly appear in the pattern will make it never apply on a goal where there is a hole in that place. .. flag:: Typeclasses Limit Intros - This option (on by default) controls the ability to apply hints while + This flag (on by default) controls the ability to apply hints while avoiding (functional) eta-expansions in the generated proof term. It does so by allowing hints that conclude in a product to apply to a goal with a matching product directly, avoiding an introduction. @@ -495,16 +503,16 @@ Options .. flag:: Typeclass Resolution For Conversion - This option (on by default) controls the use of typeclass resolution + This flag (on by default) controls the use of typeclass resolution when a unification problem cannot be solved during elaboration/type - inference. With this option on, when a unification fails, typeclass + inference. With this flag on, when a unification fails, typeclass resolution is tried before launching unification once again. .. flag:: Typeclasses Strict Resolution - Typeclass declarations introduced when this option is set have a - stricter resolution behavior (the option is off by default). When + Typeclass declarations introduced when this flag is set have a + stricter resolution behavior (the flag is off by default). When looking for unifications of a goal with an instance of this class, we “freeze” all the existentials appearing in the goals, meaning that they are considered rigid during unification and cannot be @@ -520,26 +528,40 @@ Options .. flag:: Typeclasses Unique Instances - Typeclass declarations introduced when this option is set have a more - efficient resolution behavior (the option is off by default). When a + Typeclass declarations introduced when this flag is set have a more + efficient resolution behavior (the flag is off by default). When a solution to the typeclass goal of this class is found, we never backtrack on it, assuming that it is canonical. +.. flag:: Typeclasses Iterative Deepening + + When this flag is set, the proof search strategy is breadth-first search. + Otherwise, the search strategy is depth-first search. The default is off. + :cmd:`Typeclasses eauto` is another way to set this flag. + +.. opt:: Typeclasses Depth @num + :name: Typeclasses Depth + + Sets the maximum proof search depth. The default is unbounded. + :cmd:`Typeclasses eauto` is another way to set this option. + .. flag:: Typeclasses Debug Controls whether typeclass resolution steps are shown during search. Setting this flag - also sets :opt:`Typeclasses Debug Verbosity` to 1. + also sets :opt:`Typeclasses Debug Verbosity` to 1. :cmd:`Typeclasses eauto` + is another way to set this flag. .. opt:: Typeclasses Debug Verbosity @num :name: Typeclasses Debug Verbosity Determines how much information is shown for typeclass resolution steps during search. 1 is the default level. 2 shows additional information such as tried tactics and shelving - of goals. Setting this option also sets :flag:`Typeclasses Debug`. + of goals. Setting this option to 1 or 2 turns on :flag:`Typeclasses Debug`; setting this + option to 0 turns that option off. .. flag:: Refine Instance Mode - This option allows to switch the behavior of instance declarations made through + This flag allows to switch the behavior of instance declarations made through the Instance command. + When it is on (the default), instances that have unsolved holes in @@ -552,14 +574,17 @@ Typeclasses eauto `:=` ~~~~~~~~~~~~~~~~~~~~~~ .. cmd:: Typeclasses eauto := {? debug} {? {dfs | bfs}} depth + :name: Typeclasses eauto This command allows more global customization of the typeclass resolution tactic. The semantics of the options are: + ``debug`` In debug mode, the trace of successfully applied tactics is - printed. + printed. This value can also be set with :flag:`Typeclasses Debug`. + ``dfs, bfs`` This sets the search strategy to depth-first search (the - default) or breadth-first search. + default) or breadth-first search. This value can also be set with + :flag:`Typeclasses Iterative Deepening`. - + ``depth`` This sets the depth limit of the search. + + ``depth`` This sets the depth limit of the search. This value can also be set with + :opt:`Typeclasses Depth`. diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 41afe3c312..04aedd0cf6 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -386,8 +386,10 @@ to universes and explicitly instantiate polymorphic definitions. global constraint on polymorphic universes. .. exn:: Undeclared universe @ident. + :undocumented: .. exn:: Universe inconsistency. + :undocumented: Polymorphic definitions @@ -441,3 +443,60 @@ underscore or by omitting the annotation to a polymorphic definition. semantics that the first use declares it. In this mode, the universe names are not associated with the definition or proof once it has been defined. This is meant mainly for debugging purposes. + +.. flag:: Private Polymorphic Universes + + This option, on by default, removes universes which appear only in + the body of an opaque polymorphic definition from the definition's + universe arguments. As such, no value needs to be provided for + these universes when instanciating the definition. Universe + constraints are automatically adjusted. + + Consider the following definition: + + .. coqtop:: all + + Lemma foo@{i} : Type@{i}. + Proof. exact Type. Qed. + Print foo. + + The universe :g:`Top.xxx` for the :g:`Type` in the body cannot be accessed, we + only care that one exists for any instantiation of the universes + appearing in the type of :g:`foo`. This is guaranteed when the + transitive constraint ``Set <= Top.xxx < i`` is verified. Then when + using the constant we don't need to put a value for the inner + universe: + + .. coqtop:: all + + Check foo@{_}. + + and when not looking at the body we don't mention the private + universe: + + .. coqtop:: all + + About foo. + + To recover the same behaviour with regard to universes as + :g:`Defined`, the option :flag:`Private Polymorphic Universes` may + be unset: + + .. coqtop:: all + + Unset Private Polymorphic Universes. + + Lemma bar : Type. Proof. exact Type. Qed. + About bar. + Fail Check bar@{_}. + Check bar@{_ _}. + + Note that named universes are always public. + + .. coqtop:: all + + Set Private Polymorphic Universes. + Unset Strict Universe Declaration. + + Lemma baz : Type@{outer}. Proof. exact Type@{inner}. Qed. + About baz. diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index d98b8641e9..e681d0f3ff 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -147,7 +147,7 @@ exclude_patterns = [ # The reST default role (used for this markup: `text`) to use for all # documents. -#default_role = None +default_role = 'literal' # Use the Coq domain primary_domain = 'coq' diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index 85474a3e98..10650af1d1 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -97,8 +97,8 @@ Logic The basic library of |Coq| comes with the definitions of standard (intuitionistic) logical connectives (they are defined as inductive constructions). They are equipped with an appealing syntax enriching the -subclass `form` of the syntactic class `term`. The syntax of `form` -is shown below: +subclass :token:`form` of the syntactic class :token:`term`. The syntax of +:token:`form` is shown below: .. /!\ Please keep the blanks in the lines below, experimentally they produce a nice last column. Or even better, find a proper way to do this! diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 391afcb1f7..376a6b8eed 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -27,46 +27,45 @@ expressions. In this sense, the :cmd:`Record` construction allows defining field : `ident` [ `binders` ] : `type` [ where `notation` ] : | `ident` [ `binders` ] [: `type` ] := `term` -In the expression: - .. cmd:: Record @ident @binders {? : @sort} := {? @ident} { {*; @ident @binders : @type } } -the first identifier :token:`ident` is the name of the defined record and :token:`sort` is its -type. The optional identifier following ``:=`` is the name of its constructor. If it is omitted, -the default name ``Build_``\ :token:`ident`, where :token:`ident` is the record name, is used. If :token:`sort` is -omitted, the default sort is `\Type`. The identifiers inside the brackets are the names of -fields. For a given field :token:`ident`, its type is :g:`forall binders, type`. -Remark that the type of a particular identifier may depend on a previously-given identifier. Thus the -order of the fields is important. Finally, :token:`binders` are parameters of the record. + The first identifier :token:`ident` is the name of the defined record and :token:`sort` is its + type. The optional identifier following ``:=`` is the name of its constructor. If it is omitted, + the default name :n:`Build_@ident`, where :token:`ident` is the record name, is used. If :token:`sort` is + omitted, the default sort is :math:`\Type`. The identifiers inside the brackets are the names of + fields. For a given field :token:`ident`, its type is :n:`forall @binders, @type`. + Remark that the type of a particular identifier may depend on a previously-given identifier. Thus the + order of the fields is important. Finally, :token:`binders` are parameters of the record. More generally, a record may have explicitly defined (a.k.a. manifest) fields. For instance, we might have: -:n:`Record @ident @binders : @sort := { @ident₁ : @type₁ ; @ident₂ := @term₂ ; @ident₃ : @type₃ }`. -in which case the correctness of :n:`@type₃` may rely on the instance :n:`@term₂` of :n:`@ident₂` and :n:`@term₂` may in turn depend on :n:`@ident₁`. +:n:`Record @ident @binders : @sort := { @ident__1 : @type__1 ; @ident__2 := @term__2 ; @ident__3 : @type__3 }`. +in which case the correctness of :n:`@type__3` may rely on the instance :n:`@term__2` of :n:`@ident__2` and :n:`@term__2` may in turn depend on :n:`@ident__1`. .. example:: The set of rational numbers may be defined as: - .. coqtop:: reset all + .. coqtop:: reset all - Record Rat : Set := mkRat - {sign : bool; - top : nat; - bottom : nat; - Rat_bottom_cond : 0 <> bottom; - Rat_irred_cond : - forall x y z:nat, (x * y) = top /\ (x * z) = bottom -> x = 1}. + Record Rat : Set := mkRat + { sign : bool + ; top : nat + ; bottom : nat + ; Rat_bottom_cond : 0 <> bottom + ; Rat_irred_cond : + forall x y z:nat, (x * y) = top /\ (x * z) = bottom -> x = 1 + }. -Remark here that the fields ``Rat_bottom_cond`` depends on the field ``bottom`` and ``Rat_irred_cond`` -depends on both ``top`` and ``bottom``. + Note here that the fields ``Rat_bottom_cond`` depends on the field ``bottom`` + and ``Rat_irred_cond`` depends on both ``top`` and ``bottom``. Let us now see the work done by the ``Record`` macro. First the macro generates a variant type definition with just one constructor: -:n:`Variant @ident {? @binders } : @sort := @ident₀ {? @binders }`. +:n:`Variant @ident {? @binders } : @sort := @ident__0 {? @binders }`. -To build an object of type :n:`@ident`, one should provide the constructor -:n:`@ident₀` with the appropriate number of terms filling the fields of the record. +To build an object of type :token:`ident`, one should provide the constructor +:n:`@ident__0` with the appropriate number of terms filling the fields of the record. .. example:: @@ -131,7 +130,7 @@ This syntax can also be used for pattern matching. end). The macro generates also, when it is possible, the projection -functions for destructuring an object of type `\ident`. These +functions for destructuring an object of type :token:`ident`. These projection functions are given the names of the corresponding fields. If a field is named `_` then no projection is built for it. In our example: @@ -149,33 +148,33 @@ available: Eval compute in half.(top). -It can be activated for printing with - .. flag:: Printing Projections -.. example:: + This flag activates the dot notation for printing. - .. coqtop:: all + .. example:: + + .. coqtop:: all - Set Printing Projections. - Check top half. + Set Printing Projections. + Check top half. .. FIXME: move this to the main grammar in the spec chapter .. _record_projections_grammar: .. productionlist:: terms - projection : projection `.` ( `qualid` ) - : | projection `.` ( `qualid` `arg` … `arg` ) - : | projection `.` ( @`qualid` `term` … `term` ) + projection : `term` `.` ( `qualid` ) + : | `term` `.` ( `qualid` `arg` … `arg` ) + : | `term` `.` ( @`qualid` `term` … `term` ) Syntax of Record projections -The corresponding grammar rules are given in the preceding grammar. When `qualid` -denotes a projection, the syntax `term.(qualid)` is equivalent to `qualid term`, -the syntax `term.(qualid` |arg_1| |arg_n| `)` to `qualid` |arg_1| `…` |arg_n| `term`, -and the syntax `term.(@qualid` |term_1| |term_n| `)` to `@qualid` |term_1| `…` |term_n| `term`. -In each case, `term` is the object projected and the +The corresponding grammar rules are given in the preceding grammar. When :token:`qualid` +denotes a projection, the syntax :n:`@term.(@qualid)` is equivalent to :n:`@qualid @term`, +the syntax :n:`@term.(@qualid {+ @arg })` to :n:`@qualid {+ @arg } @term`. +and the syntax :n:`@term.(@@qualid {+ @term })` to :n:`@@qualid {+ @term } @term`. +In each case, :token:`term` is the object projected and the other arguments are the parameters of the inductive type. @@ -199,22 +198,22 @@ other arguments are the parameters of the inductive type. This message is followed by an explanation of this impossibility. There may be three reasons: - #. The name `ident` already exists in the environment (see :cmd:`Axiom`). - #. The body of `ident` uses an incorrect elimination for - `ident` (see :cmd:`Fixpoint` and :ref:`Destructors`). - #. The type of the projections `ident` depends on previous + #. The name :token:`ident` already exists in the environment (see :cmd:`Axiom`). + #. The body of :token:`ident` uses an incorrect elimination for + :token:`ident` (see :cmd:`Fixpoint` and :ref:`Destructors`). + #. The type of the projections :token:`ident` depends on previous projections which themselves could not be defined. .. exn:: Records declared with the keyword Record or Structure cannot be recursive. - The record name `ident` appears in the type of its fields, but uses - the keyword ``Record``. Use the keyword ``Inductive`` or ``CoInductive`` instead. + The record name :token:`ident` appears in the type of its fields, but uses + the keyword ``Record``. Use the keyword ``Inductive`` or ``CoInductive`` instead. .. exn:: Cannot handle mutually (co)inductive records. - Records cannot be defined as part of mutually inductive (or - co-inductive) definitions, whether with records only or mixed with - standard definitions. + Records cannot be defined as part of mutually inductive (or + co-inductive) definitions, whether with records only or mixed with + standard definitions. During the definition of the one-constructor inductive definition, all the errors of inductive definitions, as described in Section @@ -310,7 +309,7 @@ an object of the record type as arguments, and whose body is an application of the unfolded primitive projection of the same name. These constants are used when elaborating partial applications of the projection. One can distinguish them from applications of the primitive -projection if the :flag`Printing Primitive Projection Parameters` option +projection if the :flag:`Printing Primitive Projection Parameters` option is off: For a primitive projection application, parameters are printed as underscores while for the compatibility projections they are printed as usual. @@ -382,7 +381,7 @@ we have the following equivalence | right _ => false end). -Notice that the printing uses the :g:`if` syntax because `sumbool` is +Notice that the printing uses the :g:`if` syntax because :g:`sumbool` is declared as such (see :ref:`controlling-match-pp`). .. _irrefutable-patterns: @@ -601,17 +600,17 @@ The following experimental command is available when the ``FunInd`` library has .. cmd:: Function @ident {* @binder} { @decrease_annot } : @type := @term -This command can be seen as a generalization of ``Fixpoint``. It is actually a wrapper -for several ways of defining a function *and other useful related -objects*, namely: an induction principle that reflects the recursive -structure of the function (see :tacn:`function induction`) and its fixpoint equality. -The meaning of this declaration is to define a function ident, -similarly to ``Fixpoint``. Like in ``Fixpoint``, the decreasing argument must -be given (unless the function is not recursive), but it might not -necessarily be *structurally* decreasing. The point of the {} annotation -is to name the decreasing argument *and* to describe which kind of -decreasing criteria must be used to ensure termination of recursive -calls. + This command can be seen as a generalization of ``Fixpoint``. It is actually a wrapper + for several ways of defining a function *and other useful related + objects*, namely: an induction principle that reflects the recursive + structure of the function (see :tacn:`function induction`) and its fixpoint equality. + The meaning of this declaration is to define a function ident, + similarly to ``Fixpoint``. Like in ``Fixpoint``, the decreasing argument must + be given (unless the function is not recursive), but it might not + necessarily be *structurally* decreasing. The point of the {} annotation + is to name the decreasing argument *and* to describe which kind of + decreasing criteria must be used to ensure termination of recursive + calls. The ``Function`` construction also enjoys the ``with`` extension to define mutually recursive definitions. However, this feature does not work @@ -655,8 +654,7 @@ with applications only *at the end* of each branch. Function does not support partial application of the function being defined. Thus, the following example cannot be accepted due to the -presence of partial application of `wrong` in the body of -`wrong` : +presence of partial application of :g:`wrong` in the body of :g:`wrong`: .. coqtop:: all @@ -667,27 +665,32 @@ For now, dependent cases are not treated for non structurally terminating functions. .. exn:: The recursive argument must be specified. + :undocumented: + .. exn:: No argument name @ident. + :undocumented: + .. exn:: Cannot use mutual definition with well-founded recursion or measure. + :undocumented: .. warn:: Cannot define graph for @ident. - The generation of the graph relation (`R_ident`) used to compute the induction scheme of ident - raised a typing error. Only `ident` is defined; the induction scheme - will not be generated. This error happens generally when: + The generation of the graph relation (:n:`R_@ident`) used to compute the induction scheme of ident + raised a typing error. Only :token:`ident` is defined; the induction scheme + will not be generated. This error happens generally when: - - the definition uses pattern matching on dependent types, - which ``Function`` cannot deal with yet. - - the definition is not a *pattern matching tree* as explained above. + - the definition uses pattern matching on dependent types, + which ``Function`` cannot deal with yet. + - the definition is not a *pattern matching tree* as explained above. .. warn:: Cannot define principle(s) for @ident. - The generation of the graph relation (`R_ident`) succeeded but the induction principle - could not be built. Only `ident` is defined. Please report. + The generation of the graph relation (:n:`R_@ident`) succeeded but the induction principle + could not be built. Only :token:`ident` is defined. Please report. .. warn:: Cannot build functional inversion principle. - `functional inversion` will not be available for the function. + :tacn:`functional inversion` will not be available for the function. .. seealso:: :ref:`functional-scheme` and :tacn:`function induction` @@ -696,39 +699,40 @@ used by ``Function``. A more precise description is given below. .. cmdv:: Function @ident {* @binder } : @type := @term - Defines the not recursive function `ident` as if declared with `Definition`. Moreover - the following are defined: + Defines the not recursive function :token:`ident` as if declared with + :cmd:`Definition`. Moreover the following are defined: - + `ident_rect`, `ident_rec` and `ident_ind`, which reflect the pattern - matching structure of `term` (see :cmd:`Inductive`); - + The inductive `R_ident` corresponding to the graph of `ident` (silently); - + `ident_complete` and `ident_correct` which are inversion information - linking the function and its graph. + + :token:`ident`\ ``_rect``, :token:`ident`\ ``_rec`` and :token:`ident`\ ``_ind``, + which reflect the pattern matching structure of :token:`term` (see :cmd:`Inductive`); + + The inductive :n:`R_@ident` corresponding to the graph of :token:`ident` (silently); + + :token:`ident`\ ``_complete`` and :token:`ident`\ ``_correct`` which + are inversion information linking the function and its graph. .. cmdv:: Function @ident {* @binder } { struct @ident } : @type := @term - Defines the structural recursive function `ident` as if declared with ``Fixpoint``. Moreover the following are defined: + Defines the structural recursive function :token:`ident` as if declared + with :cmd:`Fixpoint`. Moreover the following are defined: + The same objects as above; - + The fixpoint equation of `ident`: `ident_equation`. + + The fixpoint equation of :token:`ident`: :n:`@ident_equation`. .. cmdv:: Function @ident {* @binder } { measure @term @ident } : @type := @term -.. cmdv:: Function @ident {* @binder } { wf @term @ident } : @type := @term + Function @ident {* @binder } { wf @term @ident } : @type := @term Defines a recursive function by well-founded recursion. The module ``Recdef`` of the standard library must be loaded for this feature. The ``{}`` annotation is mandatory and must be one of the following: - + ``{measure`` `term` `ident` ``}`` with `ident` being the decreasing argument - and `term` being a function from type of `ident` to ``nat`` for which - value on the decreasing argument decreases (for the ``lt`` order on ``nat``) - at each recursive call of `term`. Parameters of the function are - bound in `term`\ ; - + ``{wf`` `term` `ident` ``}`` with `ident` being the decreasing argument and - `term` an ordering relation on the type of `ident` (i.e. of type + + :n:`{measure @term @ident }` with :token:`ident` being the decreasing argument + and :token:`term` being a function from type of :token:`ident` to :g:`nat` for which + value on the decreasing argument decreases (for the :g:`lt` order on :g:`nat`) + at each recursive call of :token:`term`. Parameters of the function are + bound in :token:`term`; + + :n:`{wf @term @ident }` with :token:`ident` being the decreasing argument and + :token:`term` an ordering relation on the type of :token:`ident` (i.e. of type `T`\ :math:`_{\sf ident}` → `T`\ :math:`_{\sf ident}` → ``Prop``) for which the decreasing argument - decreases at each recursive call of `term`. The order must be well-founded. - Parameters of the function are bound in `term`. + decreases at each recursive call of :token:`term`. The order must be well-founded. + Parameters of the function are bound in :token:`term`. Depending on the annotation, the user is left with some proof obligations that will be used to define the function. These proofs @@ -767,42 +771,42 @@ Section :ref:`gallina-definitions`). .. cmd:: End @ident - This command closes the section named `ident`. After closing of the - section, the local declarations (variables and local definitions) get - *discharged*, meaning that they stop being visible and that all global - objects defined in the section are generalized with respect to the - variables and local definitions they each depended on in the section. + This command closes the section named :token:`ident`. After closing of the + section, the local declarations (variables and local definitions) get + *discharged*, meaning that they stop being visible and that all global + objects defined in the section are generalized with respect to the + variables and local definitions they each depended on in the section. - .. example:: - - .. coqtop:: all + .. example:: - Section s1. + .. coqtop:: all - Variables x y : nat. + Section s1. - Let y' := y. + Variables x y : nat. - Definition x' := S x. + Let y' := y. - Definition x'' := x' + y'. + Definition x' := S x. - Print x'. + Definition x'' := x' + y'. - End s1. + Print x'. - Print x'. + End s1. - Print x''. + Print x'. - Notice the difference between the value of `x’` and `x’’` inside section - `s1` and outside. + Print x''. - .. exn:: This is not the last opened section. + Notice the difference between the value of :g:`x'` and :g:`x''` inside section + :g:`s1` and outside. -**Remarks:** + .. exn:: This is not the last opened section. + :undocumented: -#. Most commands, like ``Hint``, ``Notation``, option management, … which +.. note:: + Most commands, like :cmd:`Hint`, :cmd:`Notation`, option management, … which appear inside a section are canceled when the section is closed. @@ -813,26 +817,26 @@ The module system provides a way of packaging related elements together, as well as a means of massive abstraction. .. productionlist:: modules - module_type : qualid - : | `module_type` with Definition qualid := term - : | `module_type` with Module qualid := qualid - : | qualid qualid … qualid - : | !qualid qualid … qualid - module_binding : ( [Import|Export] ident … ident : module_type ) + module_type : `qualid` + : | `module_type` with Definition `qualid` := `term` + : | `module_type` with Module `qualid` := `qualid` + : | `qualid` `qualid` … `qualid` + : | !`qualid` `qualid` … `qualid` + module_binding : ( [Import|Export] `ident` … `ident` : `module_type` ) module_bindings : `module_binding` … `module_binding` - module_expression : qualid … qualid - : | !qualid … qualid + module_expression : `qualid` … `qualid` + : | !`qualid` … `qualid` Syntax of modules In the syntax of module application, the ! prefix indicates that any `Inline` directive in the type of the functor arguments will be ignored -(see the ``Module Type`` command below). +(see the :cmd:`Module Type` command below). .. cmd:: Module @ident - This command is used to start an interactive module named `ident`. + This command is used to start an interactive module named :token:`ident`. .. cmdv:: Module @ident {* @module_binding} @@ -845,21 +849,22 @@ In the syntax of module application, the ! prefix indicates that any .. cmdv:: Module @ident {* @module_binding} : @module_type - Starts an interactive functor with parameters given by the list of `module binding`, and output module - type `module_type`. + Starts an interactive functor with parameters given by the list of + :token:`module_bindings`, and output module type :token:`module_type`. .. cmdv:: Module @ident <: {+<: @module_type } - Starts an interactive module satisfying each `module_type`. + Starts an interactive module satisfying each :token:`module_type`. .. cmdv:: Module @ident {* @module_binding} <: {+<: @module_type }. - Starts an interactive functor with parameters given by the list of `module_binding`. The output module type - is verified against each `module_type`. + Starts an interactive functor with parameters given by the list of + :token:`module_binding`. The output module type + is verified against each :token:`module_type`. .. cmdv:: Module [ Import | Export ] - Behaves like ``Module``, but automatically imports or exports the module. + Behaves like :cmd:`Module`, but automatically imports or exports the module. Reserved commands inside an interactive module ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -874,52 +879,55 @@ Reserved commands inside an interactive module .. cmd:: Include {+<+ @module} - is a shortcut for the commands ``Include`` `module` for each `module`. + is a shortcut for the commands :n:`Include @module` for each :token:`module`. .. cmd:: End @ident - This command closes the interactive module `ident`. If the module type + This command closes the interactive module :token:`ident`. If the module type was given the content of the module is matched against it and an error is signaled if the matching fails. If the module is basic (is not a functor) its components (constants, inductive types, submodules etc.) are now available through the dot notation. .. exn:: No such label @ident. + :undocumented: .. exn:: Signature components for label @ident do not match. + :undocumented: .. exn:: This is not the last opened module. + :undocumented: .. cmd:: Module @ident := @module_expression - This command defines the module identifier `ident` to be equal - to `module_expression`. + This command defines the module identifier :token:`ident` to be equal + to :token:`module_expression`. .. cmdv:: Module @ident {* @module_binding} := @module_expression - Defines a functor with parameters given by the list of `module_binding` and body `module_expression`. + Defines a functor with parameters given by the list of :token:`module_binding` and body :token:`module_expression`. .. cmdv:: Module @ident {* @module_binding} : @module_type := @module_expression - Defines a functor with parameters given by the list of `module_binding` (possibly none), and output module type `module_type`, - with body `module_expression`. + Defines a functor with parameters given by the list of :token:`module_binding` (possibly none), and output module type :token:`module_type`, + with body :token:`module_expression`. .. cmdv:: Module @ident {* @module_binding} <: {+<: @module_type} := @module_expression - Defines a functor with parameters given by module_bindings (possibly none) with body `module_expression`. - The body is checked against each |module_type_i|. + Defines a functor with parameters given by module_bindings (possibly none) with body :token:`module_expression`. + The body is checked against each :n:`@module_type__i`. .. cmdv:: Module @ident {* @module_binding} := {+<+ @module_expression} - is equivalent to an interactive module where each `module_expression` is included. + is equivalent to an interactive module where each :token:`module_expression` is included. .. cmd:: Module Type @ident -This command is used to start an interactive module type `ident`. + This command is used to start an interactive module type :token:`ident`. - .. cmdv:: Module Type @ident {* @module_binding} + .. cmdv:: Module Type @ident {* @module_binding} - Starts an interactive functor type with parameters given by `module_bindings`. + Starts an interactive functor type with parameters given by :token:`module_bindings`. Reserved commands inside an interactive module type: @@ -931,7 +939,7 @@ Reserved commands inside an interactive module type: .. cmd:: Include {+<+ @module} - is a shortcut for the command ``Include`` `module` for each `module`. + This is a shortcut for the command :n:`Include @module` for each :token:`module`. .. cmd:: @assumption_keyword Inline @assums :name: Inline @@ -941,31 +949,32 @@ Reserved commands inside an interactive module type: .. cmd:: End @ident - This command closes the interactive module type `ident`. + This command closes the interactive module type :token:`ident`. .. exn:: This is not the last opened module type. + :undocumented: .. cmd:: Module Type @ident := @module_type - Defines a module type `ident` equal to `module_type`. + Defines a module type :token:`ident` equal to :token:`module_type`. .. cmdv:: Module Type @ident {* @module_binding} := @module_type - Defines a functor type `ident` specifying functors taking arguments `module_bindings` and - returning `module_type`. + Defines a functor type :token:`ident` specifying functors taking arguments :token:`module_bindings` and + returning :token:`module_type`. .. cmdv:: Module Type @ident {* @module_binding} := {+<+ @module_type } - is equivalent to an interactive module type were each `module_type` is included. + is equivalent to an interactive module type were each :token:`module_type` is included. .. cmd:: Declare Module @ident : @module_type - Declares a module `ident` of type `module_type`. + Declares a module :token:`ident` of type :token:`module_type`. .. cmdv:: Declare Module @ident {* @module_binding} : @module_type - Declares a functor with parameters given by the list of `module_binding` and output module type - `module_type`. + Declares a functor with parameters given by the list of :token:`module_binding` and output module type + :token:`module_type`. .. example:: @@ -1045,8 +1054,8 @@ specification: the y component is dropped as well as the body of x. End SIG. -The definition of ``N`` using the module type expression ``SIG`` with -``Definition T := nat`` is equivalent to the following one: +The definition of :g:`N` using the module type expression :g:`SIG` with +:g:`Definition T := nat` is equivalent to the following one: .. coqtop:: all @@ -1131,7 +1140,7 @@ component is equal ``nat`` and hence ``M1.T`` as specified. #. Modules and module types can be nested components of each other. #. One can have sections inside a module or a module type, but not a module or a module type inside a section. - #. Commands like ``Hint`` or ``Notation`` can also appear inside modules and + #. Commands like :cmd:`Hint` or :cmd:`Notation` can also appear inside modules and module types. Note that in case of a module definition like: :: @@ -1150,71 +1159,73 @@ component is equal ``nat`` and hence ``M1.T`` as specified. .. cmd:: Import @qualid - If `qualid` denotes a valid basic module (i.e. its module type is a - signature), makes its components available by their short names. + If :token:`qualid` denotes a valid basic module (i.e. its module type is a + signature), makes its components available by their short names. - .. example:: + .. example:: - .. coqtop:: reset all + .. coqtop:: reset all - Module Mod. + Module Mod. - Definition T:=nat. + Definition T:=nat. - Check T. + Check T. - End Mod. + End Mod. - Check Mod.T. + Check Mod.T. - Fail Check T. + Fail Check T. - Import Mod. + Import Mod. - Check T. + Check T. - Some features defined in modules are activated only when a module is - imported. This is for instance the case of notations (see :ref:`Notations`). + Some features defined in modules are activated only when a module is + imported. This is for instance the case of notations (see :ref:`Notations`). - Declarations made with the ``Local`` flag are never imported by the :cmd:`Import` - command. Such declarations are only accessible through their fully - qualified name. + Declarations made with the ``Local`` flag are never imported by the :cmd:`Import` + command. Such declarations are only accessible through their fully + qualified name. - .. example:: + .. example:: - .. coqtop:: all + .. coqtop:: all - Module A. + Module A. - Module B. + Module B. - Local Definition T := nat. + Local Definition T := nat. - End B. + End B. - End A. + End A. - Import A. + Import A. - Fail Check B.T. + Fail Check B.T. - .. cmdv:: Export @qualid - :name: Export + .. cmdv:: Export @qualid + :name: Export - When the module containing the command Export qualid - is imported, qualid is imported as well. + When the module containing the command ``Export`` qualid + is imported, qualid is imported as well. - .. exn:: @qualid is not a module. + .. exn:: @qualid is not a module. + :undocumented: - .. warn:: Trying to mask the absolute name @qualid! + .. warn:: Trying to mask the absolute name @qualid! + :undocumented: .. cmd:: Print Module @ident - Prints the module type and (optionally) the body of the module :n:`@ident`. + Prints the module type and (optionally) the body of the module :token:`ident`. .. cmd:: Print Module Type @ident - Prints the module type corresponding to :n:`@ident`. + Prints the module type corresponding to :token:`ident`. .. flag:: Short Module Printing @@ -1365,7 +1376,7 @@ OCaml object files (``.cmo`` or ``.cmxs``) rather than |Coq| object files as described above. The OCaml loadpath is managed using the option ``-I`` `path` (in the OCaml world, there is neither a notion of logical name prefix nor a way to access files in -subdirectories of path). See the command ``Declare`` ``ML`` ``Module`` in +subdirectories of path). See the command :cmd:`Declare ML Module` in :ref:`compiled-files` to understand the need of the OCaml loadpath. See :ref:`command-line-options` for a more general view over the |Coq| command @@ -1566,38 +1577,39 @@ usual implicit arguments disambiguation syntax. Declaring Implicit Arguments ++++++++++++++++++++++++++++ -To set implicit arguments *a posteriori*, one can use the command: -.. cmd:: Arguments @qualid {* @possibly_bracketed_ident } - :name: Arguments (implicits) -where the list of `possibly_bracketed_ident` is a prefix of the list of -arguments of `qualid` where the ones to be declared implicit are -surrounded by square brackets and the ones to be declared as maximally -inserted implicits are surrounded by curly braces. +.. cmd:: Arguments @qualid {* [ @ident ] | @ident } + :name: Arguments (implicits) -After the above declaration is issued, implicit arguments can just -(and have to) be skipped in any expression involving an application -of `qualid`. + This command is used to set implicit arguments *a posteriori*, + where the list of possibly bracketed :token:`ident` is a prefix of the list of + arguments of :token:`qualid` where the ones to be declared implicit are + surrounded by square brackets and the ones to be declared as maximally + inserted implicits are surrounded by curly braces. -Implicit arguments can be cleared with the following syntax: + After the above declaration is issued, implicit arguments can just + (and have to) be skipped in any expression involving an application + of :token:`qualid`. .. cmd:: Arguments @qualid : clear implicits -.. cmdv:: Global Arguments @qualid {* @possibly_bracketed_ident } + This command clears implicit arguments. + +.. cmdv:: Global Arguments @qualid {* [ @ident ] | @ident } - Says to recompute the implicit arguments of - `qualid` after ending of the current section if any, enforcing the + This command is used to recompute the implicit arguments of + :token:`qualid` after ending of the current section if any, enforcing the implicit arguments known from inside the section to be the ones declared by the command. -.. cmdv:: Local Arguments @qualid {* @possibly_bracketed_ident } +.. cmdv:: Local Arguments @qualid {* [ @ident ] | @ident } When in a module, tell not to activate the - implicit arguments ofqualid declared by this command to contexts that + implicit arguments of :token:`qualid` declared by this command to contexts that require the module. -.. cmdv:: {? Global | Local } Arguments @qualid {*, {+ @possibly_bracketed_ident } } +.. cmdv:: {? Global | Local } Arguments @qualid {*, {+ [ @ident ] | @ident } } For names of constants, inductive types, constructors, lemmas which can only be applied to a fixed number of @@ -1639,33 +1651,34 @@ Implicit arguments can be cleared with the following syntax: Check (fun l => map length l = map (list nat) nat length l). -Remark: To know which are the implicit arguments of an object, use the -command ``Print Implicit`` (see :ref:`displaying-implicit-args`). +.. note:: + To know which are the implicit arguments of an object, use the + command :cmd:`Print Implicit` (see :ref:`displaying-implicit-args`). Automatic declaration of implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -|Coq| can also automatically detect what are the implicit arguments of a -defined object. The command is just - .. cmd:: Arguments @qualid : default implicits -The auto-detection is governed by options telling if strict, -contextual, or reversible-pattern implicit arguments must be -considered or not (see :ref:`controlling-strict-implicit-args`, :ref:`controlling-strict-implicit-args`, -:ref:`controlling-rev-pattern-implicit-args`, and also :ref:`controlling-insertion-implicit-args`). + This command tells |Coq| to automatically detect what are the implicit arguments of a + defined object. -.. cmdv:: Global Arguments @qualid : default implicits + The auto-detection is governed by options telling if strict, + contextual, or reversible-pattern implicit arguments must be + considered or not (see :ref:`controlling-strict-implicit-args`, :ref:`controlling-strict-implicit-args`, + :ref:`controlling-rev-pattern-implicit-args`, and also :ref:`controlling-insertion-implicit-args`). - Tell to recompute the - implicit arguments of qualid after ending of the current section if - any. + .. cmdv:: Global Arguments @qualid : default implicits -.. cmdv:: Local Arguments @qualid : default implicits + Tell to recompute the + implicit arguments of qualid after ending of the current section if + any. - When in a module, tell not to activate the implicit arguments of `qualid` computed by this - declaration to contexts that requires the module. + .. cmdv:: Local Arguments @qualid : default implicits + + When in a module, tell not to activate the implicit arguments of :token:`qualid` computed by this + declaration to contexts that requires the module. .. example:: @@ -1791,20 +1804,20 @@ Explicit applications In presence of non-strict or contextual argument, or in presence of partial applications, the synthesis of implicit arguments may fail, so one may have to give explicitly certain implicit arguments of an -application. The syntax for this is ``(`` `ident` ``:=`` `term` ``)`` where `ident` is the +application. The syntax for this is :n:`(@ident := @term)` where :token:`ident` is the name of the implicit argument and term is its corresponding explicit term. Alternatively, one can locally deactivate the hiding of implicit -arguments of a function by using the notation `@qualid` |term_1| … |term_n|. +arguments of a function by using the notation :n:`@qualid {+ @term }`. This syntax extension is given in the following grammar: .. _explicit_app_grammar: .. productionlist:: explicit_apps - term : @ qualid term … `term` - : | @ qualid - : | qualid `argument` … `argument` + term : @ `qualid` `term` … `term` + : | @ `qualid` + : | `qualid` `argument` … `argument` argument : `term` - : | (ident := `term`) + : | (`ident` := `term`) Syntax for explicitly giving implicit arguments @@ -1820,10 +1833,10 @@ This syntax extension is given in the following grammar: Renaming implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Implicit arguments names can be redefined using the following syntax: - .. cmd:: Arguments @qualid {* @name} : @rename + This command is used to redefine the names of implicit arguments. + With the assert flag, ``Arguments`` can be used to assert that a given object has the expected number of arguments and that these arguments are named as expected. @@ -1845,11 +1858,12 @@ are named as expected. Displaying what the implicit arguments are ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To display the implicit arguments associated to an object, and to know -if each of them is to be used maximally or not, use the command - .. cmd:: Print Implicit @qualid + Use this command to display the implicit arguments associated to an object, + and to know if each of them is to be used maximally or not. + + Explicit displaying of implicit arguments for pretty-printing ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1984,16 +1998,16 @@ Implicit types of variables ~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is possible to bind variable names to a given type (e.g. in a -development using arithmetic, it may be convenient to bind the names `n` -or `m` to the type ``nat`` of natural numbers). The command for that is +development using arithmetic, it may be convenient to bind the names :g:`n` +or :g:`m` to the type :g:`nat` of natural numbers). .. cmd:: Implicit Types {+ @ident } : @type -The effect of the command is to automatically set the type of bound -variables starting with `ident` (either `ident` itself or `ident` followed by -one or more single quotes, underscore or digits) to be `type` (unless -the bound variable is already declared with an explicit type in which -case, this latter type is considered). + The effect of the command is to automatically set the type of bound + variables starting with :token:`ident` (either :token:`ident` itself or + :token:`ident` followed by one or more single quotes, underscore or + digits) to be :token:`type` (unless the bound variable is already declared + with an explicit type in which case, this latter type is considered). .. example:: @@ -2137,29 +2151,29 @@ Printing universes terms apparently identical but internally different in the Calculus of Inductive Constructions. -The constraints on the internal level of the occurrences of Type -(see :ref:`Sorts`) can be printed using the command - .. cmd:: Print {? Sorted} Universes :name: Print Universes -If the optional ``Sorted`` option is given, each universe will be made -equivalent to a numbered label reflecting its level (with a linear -ordering) in the universe hierarchy. + This command can be used to print the constraints on the internal level + of the occurrences of :math:`\Type` (see :ref:`Sorts`). + + If the optional ``Sorted`` option is given, each universe will be made + equivalent to a numbered label reflecting its level (with a linear + ordering) in the universe hierarchy. -This command also accepts an optional output filename: + .. cmdv:: Print {? Sorted} Universes @string -.. cmdv:: Print {? Sorted} Universes @string + This variant accepts an optional output filename. -If `string` ends in ``.dot`` or ``.gv``, the constraints are printed in the DOT -language, and can be processed by Graphviz tools. The format is -unspecified if `string` doesn’t end in ``.dot`` or ``.gv``. + If :token:`string` ends in ``.dot`` or ``.gv``, the constraints are printed in the DOT + language, and can be processed by Graphviz tools. The format is + unspecified if `string` doesn’t end in ``.dot`` or ``.gv``. .. cmdv:: Print Universes Subgraph(@names) -Prints the graph restricted to the requested names (adjusting -constraints to preserve the implied transitive constraints between -kept universes). + Prints the graph restricted to the requested names (adjusting + constraints to preserve the implied transitive constraints between + kept universes). .. _existential-variables: @@ -2195,13 +2209,10 @@ existential variable is represented by “?” followed by an identifier. Check identity _ (fun x => _). -In the general case, when an existential variable ``?``\ `ident` appears +In the general case, when an existential variable :n:`?@ident` appears outside of its context of definition, its instance, written under the -form - -| ``{`` :n:`{*; @ident:=@term}` ``}`` - -is appending to its name, indicating how the variables of its defining context are instantiated. +form :n:`{ {*; @ident := @term} }` is appending to its name, indicating +how the variables of its defining context are instantiated. The variables of the context of the existential variables which are instantiated by themselves are not written, unless the flag :flag:`Printing Existential Instances` is on (see Section :ref:`explicit-display-existentials`), and this is why an diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index de9e327740..9bc67147f7 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -198,10 +198,10 @@ and ``coqtop``, unless stated otherwise: :-type-in-type: Collapse the universe hierarchy of |Coq|. .. warning:: This makes the logic inconsistent. -:-mangle-names *ident*: Experimental: Do not depend on this option. Replace +:-mangle-names *ident*: *Experimental.* Do not depend on this option. Replace Coq's auto-generated name scheme with names of the form *ident0*, *ident1*, - etc. The command ``Set Mangle Names`` turns the behavior on in a document, - and ``Set Mangle Names Prefix "ident"`` changes the used prefix. This feature + etc. Within Coq, the flag :flag:`Mangle Names` turns this behavior on, + and the :opt:`Mangle Names Prefix` option sets the prefix to use. This feature is intended to be used as a linter for developments that want to be robust to changes in the auto-generated name scheme. The options are provided to facilitate tracking down problems. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index edd83b7cee..1071682ead 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -292,6 +292,7 @@ focused goals with: .. exn:: No such goal. :name: No such goal. (Goal selector) + :undocumented: .. TODO change error message index entry @@ -351,6 +352,7 @@ We can check if a tactic made progress with: goals (up to syntactical equality), then an error of level 0 is raised. .. exn:: Failed to progress. + :undocumented: Backtracking branching ~~~~~~~~~~~~~~~~~~~~~~ @@ -393,6 +395,7 @@ tactic to work (i.e. which does not fail) among a panel of tactics: :n:`v__i` to have *at least* one success. .. exn:: No applicable tactic. + :undocumented: .. tacv:: first @expr @@ -482,6 +485,7 @@ one* success: immediately. .. exn:: This tactic has more than one success. + :undocumented: Checking the failure ~~~~~~~~~~~~~~~~~~~~ @@ -521,6 +525,7 @@ among a panel of tactics: apply :n:`v__2` and so on. It fails if there is no solving tactic. .. exn:: Cannot solve the goal. + :undocumented: .. tacv:: solve @expr @@ -576,8 +581,7 @@ Failing goals left. See the example for clarification. .. tacv:: gfail {* message_token} - - .. tacv:: gfail @num {* message_token} + gfail @num {* message_token} These variants fail with an error message or an error level even if there are no goals left. Be careful however if Coq terms have to be @@ -586,9 +590,11 @@ Failing evaluated, a tactic call like :n:`let x := H in fail 0 x` will succeed. .. exn:: Tactic Failure message (level @num). + :undocumented: .. exn:: No such goal. :name: No such goal. (fail) + :undocumented: .. example:: @@ -670,24 +676,24 @@ tactic This tactic currently does not support nesting, and will report times based on the innermost execution. This is due to the fact that it is - implemented using the tactics + implemented using the following internal tactics: .. tacn:: restart_timer @string :name: restart_timer - and + Reset a timer - .. tacn:: finish_timing {? @string} @string + .. tacn:: finish_timing {? (@string)} @string :name: finish_timing - which (re)set and display an optionally named timer, respectively. The - parenthesized string argument to :n:`finish_timing` is also optional, and - determines the label associated with the timer for printing. + Display an optionally named timer. The parenthesized string argument + is also optional, and determines the label associated with the timer + for printing. - By copying the definition of :n:`time_constr` from the standard library, + By copying the definition of :tacn:`time_constr` from the standard library, users can achive support for a fixed pattern of nesting by passing - different :n:`@string` parameters to :n:`restart_timer` and :n:`finish_timing` - at each level of nesting. + different :token:`string` parameters to :tacn:`restart_timer` and + :tacn:`finish_timing` at each level of nesting. .. example:: @@ -967,10 +973,10 @@ Evaluation of a term can be performed with: Recovering the type of a term ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The following returns the type of term: - .. tacn:: type of @term + This tactic returns the type of :token:`term`. + Manipulating untyped terms ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1041,6 +1047,7 @@ Testing boolean expressions Fail all:let n:= numgoals in guard n=2. .. exn:: Condition not satisfied. + :undocumented: Proving a subgoal as a separate lemma ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1092,6 +1099,7 @@ Proving a subgoal as a separate lemma .. exn:: Proof is not complete. :name: Proof is not complete. (abstract) + :undocumented: Tactic toplevel definitions --------------------------- @@ -1200,7 +1208,7 @@ Interactive debugger .. flag:: Ltac Debug - This option governs the step-by-step debugger that comes with the |Ltac| interpreter + This option governs the step-by-step debugger that comes with the |Ltac| interpreter. When the debugger is activated, it stops at every step of the evaluation of the current |Ltac| expression and prints information on what it is doing. @@ -1348,6 +1356,6 @@ Run-time optimization tactic .. tacn:: optimize_heap :name: optimize_heap -This tactic behaves like :n:`idtac`, except that running it compacts the -heap in the OCaml run-time system. It is analogous to the Vernacular -command :cmd:`Optimize Heap`. + This tactic behaves like :n:`idtac`, except that running it compacts the + heap in the OCaml run-time system. It is analogous to the Vernacular + command :cmd:`Optimize Heap`. diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 0b059f92ee..590d71b5f3 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -67,6 +67,7 @@ list of assertion commands is given in :ref:`Assertions`. The command added to the environment as an opaque constant. .. exn:: Attempt to save an incomplete proof. + :undocumented: .. note:: @@ -106,6 +107,7 @@ list of assertion commands is given in :ref:`Assertions`. The command proof was edited. .. exn:: No focused proof (No proof-editing in progress). + :undocumented: .. cmdv:: Abort @ident @@ -282,6 +284,7 @@ Navigation in the proof tree This command restores the proof editing process to the original goal. .. exn:: No focused proof to restart. + :undocumented: .. cmd:: Focus @@ -473,13 +476,14 @@ Requesting information This command displays the current goals. .. exn:: No focused proof. + :undocumented: .. cmdv:: Show @num Displays only the :token:`num`\-th subgoal. .. exn:: No such goal. - + :undocumented: .. cmdv:: Show @ident @@ -565,6 +569,7 @@ Requesting information Show Match nat. .. exn:: Unknown inductive type. + :undocumented: .. cmdv:: Show Universes :name: Show Universes diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 3ca0ffe678..9fbac95f0c 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -157,14 +157,24 @@ compatible with the rest of |Coq|, up to a few discrepancies: (see :ref:`pattern_conditional_ssr`). To use the generalized form, turn off the |SSR| Boolean ``if`` notation using the command: ``Close Scope boolean_if_scope``. -+ The following two options can be unset to disable the incompatible - rewrite syntax and allow reserved identifiers to appear in scripts. ++ The following flags can be unset to make |SSR| more compatible with + parts of Coq: - .. coqtop:: in +.. flag:: SsrRewrite + + Controls whether the incompatible rewrite syntax is enabled (the default). + Disabling the flag makes the syntax compatible with other parts of Coq. + +.. flag:: SsrIdents - Unset SsrRewrite. - Unset SsrIdents. + Controls whether tactics can refer to |SSR|-generated variables that are + in the form _xxx_. Scripts with explicit references to such variables + are fragile; they are prone to failure if the proof is later modified or + if the details of variable name generation change in future releases of Coq. + The default is on, which gives an error message when the user tries to + create such identifiers. Disabling the flag generates a warning instead, + increasing compatibility with other parts of Coq. |Gallina| extensions -------------------- @@ -3063,6 +3073,17 @@ An :token:`r_item` can be: rewrite -[f y x]/(y + _). +.. flag:: SsrOldRewriteGoalsOrder + + Controls the order in which generated subgoals (side conditions) + are added to the + proof context. The flag is off by default, which puts subgoals generated + by conditional rules first, followed by the main goal. When it is on, + the main goal appears first. If your proofs are organized to complete + proving the main goal before side conditions, turning the flag on will save you + from having to add :tacn:`last first` tactics that would be needed + to keep the main goal as the currently focused goal. + Remarks and examples ~~~~~~~~~~~~~~~~~~~~ @@ -5428,6 +5449,17 @@ right hand side double , view hint declaration see :ref:`declaring_new_hints_ssr prenex implicits declaration see :ref:`parametric_polymorphism_ssr` +Settings +~~~~~~~~ + +.. flag:: Debug Ssreflect + + *Developer only.* Print debug information on reflect. + +.. flag:: Debug SsrMatching + + *Developer only.* Print debug information on SSR matching. + .. rubric:: Footnotes .. [#1] Unfortunately, even after a call to the Set Printing All command, diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 041f1bc966..ad80cb62e1 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -91,6 +91,7 @@ bindings_list`` where ``bindings_list`` may be of two different forms: of ``term``. .. exn:: No such binder. + :undocumented: + A bindings list can also be a simple list of terms :n:`{* term}`. In that case the references to which these terms correspond are @@ -102,6 +103,7 @@ bindings_list`` where ``bindings_list`` may be of two different forms: are required. .. exn:: Not the right number of missing arguments. + :undocumented: .. _occurrencessets: @@ -262,6 +264,11 @@ Applying theorems This tactic behaves like :tacn:`simple refine` except it performs type checking without resolution of typeclasses. + .. flag:: Debug Unification + + Enables printing traces of unification steps used during + elaboration/typechecking and the :tacn:`refine` tactic. + .. tacn:: apply @term :name: apply @@ -589,6 +596,7 @@ Applying theorems :n:`constructor 2 {? with @bindings_list }`. .. exn:: Not an inductive goal with 2 constructors. + :undocumented: .. tacv:: econstructor eexists @@ -603,6 +611,10 @@ Applying theorems when the instantiation of a variable cannot be found (cf. :tacn:`eapply` and :tacn:`apply`). +.. flag:: Debug Tactic Unification + + Enables printing traces of unification steps in tactic unification. + Tactic unification is used in tactics such as :tacn:`apply` and :tacn:`rewrite`. .. _managingthelocalcontext: @@ -1081,8 +1093,8 @@ Managing the local context generated by Coq. .. tacv:: epose (@ident {? @binders} := @term) - .. tacv:: epose term - :name: epose + epose @term + :name: epose; _ While the different variants of :tacn:`pose` expect that no existential variables are generated by the tactic, :tacn:`epose` @@ -1124,7 +1136,7 @@ Managing the local context Controlling the proof flow ------------------------------ -.. tacn:: assert (@ident : form) +.. tacn:: assert (@ident : @type) :name: assert This tactic applies to any goal. :n:`assert (H : U)` adds a new hypothesis @@ -1132,106 +1144,104 @@ Controlling the proof flow :g:`U` [2]_. The subgoal :g:`U` comes first in the list of subgoals remaining to prove. -.. exn:: Not a proposition or a type. + .. exn:: Not a proposition or a type. - Arises when the argument form is neither of type :g:`Prop`, :g:`Set` nor - :g:`Type`. + Arises when the argument :token:`type` is neither of type :g:`Prop`, + :g:`Set` nor :g:`Type`. -.. tacv:: assert form + .. tacv:: assert @type - This behaves as :n:`assert (@ident : form)` but :n:`@ident` is generated by - Coq. + This behaves as :n:`assert (@ident : @type)` but :n:`@ident` is + generated by Coq. -.. tacv:: assert @form by @tactic + .. tacv:: assert @type by @tactic - This tactic behaves like :n:`assert` but applies tactic to solve the subgoals - generated by assert. + This tactic behaves like :tacn:`assert` but applies tactic to solve the + subgoals generated by assert. - .. exn:: Proof is not complete. - :name: Proof is not complete. (assert) + .. exn:: Proof is not complete. + :name: Proof is not complete. (assert) + :undocumented: -.. tacv:: assert @form as @intro_pattern + .. tacv:: assert @type as @intro_pattern - If :n:`intro_pattern` is a naming introduction pattern (see :tacn:`intro`), - the hypothesis is named after this introduction pattern (in particular, if - :n:`intro_pattern` is :n:`@ident`, the tactic behaves like - :n:`assert (@ident : form)`). If :n:`intro_pattern` is an action - introduction pattern, the tactic behaves like :n:`assert form` followed by - the action done by this introduction pattern. + If :n:`intro_pattern` is a naming introduction pattern (see :tacn:`intro`), + the hypothesis is named after this introduction pattern (in particular, if + :n:`intro_pattern` is :n:`@ident`, the tactic behaves like + :n:`assert (@ident : @type)`). If :n:`intro_pattern` is an action + introduction pattern, the tactic behaves like :n:`assert @type` followed by + the action done by this introduction pattern. -.. tacv:: assert @form as @intro_pattern by @tactic + .. tacv:: assert @type as @intro_pattern by @tactic - This combines the two previous variants of :n:`assert`. + This combines the two previous variants of :tacn:`assert`. -.. tacv:: assert (@ident := @term ) + .. tacv:: assert (@ident := @term) - This behaves as :n:`assert (@ident : type) by exact @term` where :g:`type` is - the type of :g:`term`. This is deprecated in favor of :n:`pose proof`. If the - head of term is :n:`@ident`, the tactic behaves as :n:`specialize @term`. + This behaves as :n:`assert (@ident : @type) by exact @term` where + :token:`type` is the type of :token:`term`. This is equivalent to using + :tacn:`pose proof`. If the head of term is :token:`ident`, the tactic + behaves as :tacn:`specialize`. - .. exn:: Variable @ident is already declared. + .. exn:: Variable @ident is already declared. + :undocumented: -.. tacv:: eassert form as intro_pattern by tactic +.. tacv:: eassert @type as @intro_pattern by @tactic :name: eassert -.. tacv:: assert (@ident := @term) - - While the different variants of :n:`assert` expect that no existential - variables are generated by the tactic, :n:`eassert` removes this constraint. + While the different variants of :tacn:`assert` expect that no existential + variables are generated by the tactic, :tacn:`eassert` removes this constraint. This allows not to specify the asserted statement completeley before starting to prove it. -.. tacv:: pose proof @term {? as intro_pattern} +.. tacv:: pose proof @term {? as @intro_pattern} :name: pose proof - This tactic behaves like :n:`assert T {? as intro_pattern} by exact @term` - where :g:`T` is the type of :g:`term`. In particular, + This tactic behaves like :n:`assert @type {? as @intro_pattern} by exact @term` + where :token:`type` is the type of :token:`term`. In particular, :n:`pose proof @term as @ident` behaves as :n:`assert (@ident := @term)` - and :n:`pose proof @term as intro_pattern` is the same as applying the - intro_pattern to :n:`@term`. + and :n:`pose proof @term as @intro_pattern` is the same as applying the + :token:`intro_pattern` to :token:`term`. -.. tacv:: epose proof term {? as intro_pattern} +.. tacv:: epose proof @term {? as @intro_pattern} + :name: epose proof - While :n:`pose proof` expects that no existential variables are generated by - the tactic, :n:`epose proof` removes this constraint. + While :tacn:`pose proof` expects that no existential variables are generated by + the tactic, :tacn:`epose proof` removes this constraint. -.. tacv:: enough (@ident : form) +.. tacv:: enough (@ident : @type) :name: enough - This adds a new hypothesis of name :n:`@ident` asserting :n:`form` to the - goal the tactic :n:`enough` is applied to. A new subgoal stating :n:`form` is - inserted after the initial goal rather than before it as :n:`assert` would do. + This adds a new hypothesis of name :token:`ident` asserting :token:`type` to the + goal the tactic :tacn:`enough` is applied to. A new subgoal stating :token:`type` is + inserted after the initial goal rather than before it as :tacn:`assert` would do. -.. tacv:: enough form +.. tacv:: enough @type - This behaves like :n:`enough (@ident : form)` with the name :n:`@ident` of + This behaves like :n:`enough (@ident : @type)` with the name :token:`ident` of the hypothesis generated by Coq. -.. tacv:: enough form as intro_pattern +.. tacv:: enough @type as @intro_pattern - This behaves like :n:`enough form` using :n:`intro_pattern` to name or + This behaves like :n:`enough @type` using :token:`intro_pattern` to name or destruct the new hypothesis. -.. tacv:: enough (@ident : @form) by @tactic -.. tacv:: enough @form by @tactic -.. tacv:: enough @form as @intro_pattern by @tactic +.. tacv:: enough (@ident : @type) by @tactic + enough @type {? as @intro_pattern } by @tactic - This behaves as above but with :n:`tactic` expected to solve the initial goal - after the extra assumption :n:`form` is added and possibly destructed. If the - :n:`as intro_pattern` clause generates more than one subgoal, :n:`tactic` is + This behaves as above but with :token:`tactic` expected to solve the initial goal + after the extra assumption :token:`type` is added and possibly destructed. If the + :n:`as @intro_pattern` clause generates more than one subgoal, :token:`tactic` is applied to all of them. -.. tacv:: eenough (@ident : form) by tactic - :name: eenough - -.. tacv:: eenough form by tactic +.. tacv:: eenough @type {? as @intro_pattern } {? by @tactic } + eenough (@ident : @type) {? by @tactic } + :name: eenough; _ -.. tacv:: eenough form as intro_pattern by tactic + While the different variants of :tacn:`enough` expect that no existential + variables are generated by the tactic, :tacn:`eenough` removes this constraint. - While the different variants of :n:`enough` expect that no existential - variables are generated by the tactic, :n:`eenough` removes this constraint. - -.. tacv:: cut @form +.. tacv:: cut @type :name: cut This tactic applies to any goal. It implements the non-dependent case of @@ -1240,11 +1250,11 @@ Controlling the proof flow subgoals: :g:`U -> T` and :g:`U`. The subgoal :g:`U -> T` comes first in the list of remaining subgoal to prove. -.. tacv:: specialize (ident {* @term}) {? as intro_pattern} -.. tacv:: specialize ident with @bindings_list {? as intro_pattern} - :name: specialize +.. tacv:: specialize (@ident {* @term}) {? as @intro_pattern} + specialize @ident with @bindings_list {? as @intro_pattern} + :name: specialize; _ - The tactic :n:`specialize` works on local hypothesis :n:`@ident`. The + This tactic works on local hypothesis :n:`@ident`. The premises of this hypothesis (either universal quantifications or non-dependent implications) are instantiated by concrete terms coming either from arguments :n:`{* @term}` or from a :ref:`bindings list <bindingslist>`. @@ -1254,15 +1264,18 @@ Controlling the proof flow uninstantiated arguments are inferred by unification if possible or left quantified in the hypothesis otherwise. With the :n:`as` clause, the local hypothesis :n:`@ident` is left unchanged and instead, the modified hypothesis - is introduced as specified by the :n:`intro_pattern`. The name :n:`@ident` + is introduced as specified by the :token:`intro_pattern`. The name :n:`@ident` can also refer to a global lemma or hypothesis. In this case, for - compatibility reasons, the behavior of :n:`specialize` is close to that of - :n:`generalize`: the instantiated statement becomes an additional premise of - the goal. The :n:`as` clause is especially useful in this case to immediately + compatibility reasons, the behavior of :tacn:`specialize` is close to that of + :tacn:`generalize`: the instantiated statement becomes an additional premise of + the goal. The ``as`` clause is especially useful in this case to immediately introduce the instantiated statement as a local hypothesis. .. exn:: @ident is used in hypothesis @ident. + :undocumented: + .. exn:: @ident is used in conclusion. + :undocumented: .. tacn:: generalize @term :name: generalize @@ -1343,8 +1356,8 @@ name of the variable (here :g:`n`) is chosen based on :g:`T`. changes in the goal, its use is strongly discouraged. .. tacv:: instantiate ( @num := @term ) in @ident -.. tacv:: instantiate ( @num := @term ) in ( value of @ident ) -.. tacv:: instantiate ( @num := @term ) in ( type of @ident ) + instantiate ( @num := @term ) in ( value of @ident ) + instantiate ( @num := @term ) in ( type of @ident ) These allow to refer respectively to existential variables occurring in a hypothesis or in the body or the type of a local definition. @@ -1360,13 +1373,13 @@ name of the variable (here :g:`n`) is chosen based on :g:`T`. .. tacn:: admit :name: admit -The admit tactic allows temporarily skipping a subgoal so as to -progress further in the rest of the proof. A proof containing admitted -goals cannot be closed with :g:`Qed` but only with :g:`Admitted`. + This tactic allows temporarily skipping a subgoal so as to + progress further in the rest of the proof. A proof containing admitted + goals cannot be closed with :cmd:`Qed` but only with :cmd:`Admitted`. .. tacv:: give_up - Synonym of :n:`admit`. + Synonym of :tacn:`admit`. .. tacn:: absurd @term :name: absurd @@ -1387,7 +1400,8 @@ goals cannot be closed with :g:`Qed` but only with :g:`Admitted`. a singleton inductive type (e.g. :g:`True` or :g:`x=x`), or two contradictory hypotheses. -.. exn:: No such assumption. + .. exn:: No such assumption. + :undocumented: .. tacv:: contradiction @ident @@ -1602,6 +1616,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) induction n. .. exn:: Not an inductive product. + :undocumented: .. exn:: Unable to find an instance for the variables @ident ... @ident. @@ -1672,10 +1687,9 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) Show 2. .. tacv:: induction @term with @bindings_list as @disj_conj_intro_pattern using @term with @bindings_list in @goal_occurrences + einduction @term with @bindings_list as @disj_conj_intro_pattern using @term with @bindings_list in @goal_occurrences -.. tacv:: einduction @term with @bindings_list as @disj_conj_intro_pattern using @term with @bindings_list in @goal_occurrences - - These are the most general forms of ``induction`` and ``einduction``. It combines the + These are the most general forms of :tacn:`induction` and :tacn:`einduction`. It combines the effects of the with, as, using, and in clauses. .. tacv:: elim @term @@ -1709,7 +1723,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) existential variables to be resolved later on. .. tacv:: elim @term using @term -.. tacv:: elim @term using @term with @bindings_list + elim @term using @term with @bindings_list Allows the user to give explicitly an induction principle :n:`@term` that is not the standard one for the underlying inductive type of :n:`@term`. The @@ -1717,15 +1731,15 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) :n:`@term`. .. tacv:: elim @term with @bindings_list using @term with @bindings_list -.. tacv:: eelim @term with @bindings_list using @term with @bindings_list + eelim @term with @bindings_list using @term with @bindings_list - These are the most general forms of ``elim`` and ``eelim``. It combines the + These are the most general forms of :tacn:`elim` and :tacn:`eelim`. It combines the effects of the ``using`` clause and of the two uses of the ``with`` clause. -.. tacv:: elimtype @form +.. tacv:: elimtype @type :name: elimtype - The argument :n:`form` must be inductively defined. :n:`elimtype I` is + The argument :token:`type` must be inductively defined. :n:`elimtype I` is equivalent to :n:`cut I. intro Hn; elim Hn; clear Hn.` Therefore the hypothesis :g:`Hn` will not appear in the context(s) of the subgoal(s). Conversely, if :g:`t` is a :n:`@term` of (inductive) type :g:`I` that does @@ -1879,7 +1893,10 @@ and an explanation of the underlying technique. .. seealso:: :ref:`advanced-recursive-functions`, :ref:`functional-scheme` and :tacn:`inversion` .. exn:: Cannot find induction information on @qualid. + :undocumented: + .. exn:: Not the right number of induction arguments. + :undocumented: .. tacv:: functional induction (@qualid {+ @term}) as @disj_conj_intro_pattern using @term with @bindings_list @@ -1913,7 +1930,10 @@ and an explanation of the underlying technique. :n:`intros until @ident`. .. exn:: No primitive equality found. + :undocumented: + .. exn:: Not a discriminable equality. + :undocumented: .. tacv:: discriminate @num @@ -1927,11 +1947,11 @@ and an explanation of the underlying technique. bindings to instantiate parameters or hypotheses of :n:`@term`. .. tacv:: ediscriminate @num -.. tacv:: ediscriminate @term {? with @bindings_list} - :name: ediscriminate + ediscriminate @term {? with @bindings_list} + :name: ediscriminate; _ - This works the same as ``discriminate`` but if the type of :n:`@term`, or the - type of the hypothesis referred to by :n:`@num`, has uninstantiated + This works the same as :tacn:`discriminate` but if the type of :token:`term`, or the + type of the hypothesis referred to by :token:`num`, has uninstantiated parameters, these parameters are left as existential variables. .. tacv:: discriminate @@ -1942,6 +1962,7 @@ and an explanation of the underlying technique. :n:`intro @ident; discriminate @ident`. .. exn:: No discriminable equalities. + :undocumented: .. tacn:: injection @term :name: injection @@ -1994,9 +2015,16 @@ and an explanation of the underlying technique. context using :n:`intros until @ident`. .. exn:: Not a projectable equality but a discriminable one. - .. exn:: Nothing to do, it is an equality between convertible @terms. + :undocumented: + + .. exn:: Nothing to do, it is an equality between convertible terms. + :undocumented: + .. exn:: Not a primitive equality. + :undocumented: + .. exn:: Nothing to inject. + :undocumented: .. tacv:: injection @num @@ -2010,8 +2038,8 @@ and an explanation of the underlying technique. instantiate parameters or hypotheses of :n:`@term`. .. tacv:: einjection @num - :name: einjection - .. tacv:: einjection @term {? with @bindings_list} + einjection @term {? with @bindings_list} + :name: einjection; _ This works the same as :n:`injection` but if the type of :n:`@term`, or the type of the hypothesis referred to by :n:`@num`, has uninstantiated @@ -2023,21 +2051,22 @@ and an explanation of the underlying technique. :n:`intro @ident; injection @ident`. .. exn:: goal does not satisfy the expected preconditions. + :undocumented: .. tacv:: injection @term {? with @bindings_list} as {+ @intro_pattern} - .. tacv:: injection @num as {+ intro_pattern} - .. tacv:: injection as {+ intro_pattern} - .. tacv:: einjection @term {? with @bindings_list} as {+ intro_pattern} - .. tacv:: einjection @num as {+ intro_pattern} - .. tacv:: einjection as {+ intro_pattern} - - These variants apply :n:`intros {+ @intro_pattern}` after the call to - :tacn:`injection` or :tacn:`einjection` so that all equalities generated are moved in - the context of hypotheses. The number of :n:`@intro_pattern` must not exceed - the number of equalities newly generated. If it is smaller, fresh - names are automatically generated to adjust the list of :n:`@intro_pattern` - to the number of new equalities. The original equality is erased if it - corresponds to a hypothesis. + injection @num as {+ intro_pattern} + injection as {+ intro_pattern} + einjection @term {? with @bindings_list} as {+ intro_pattern} + einjection @num as {+ intro_pattern} + einjection as {+ intro_pattern} + + These variants apply :n:`intros {+ @intro_pattern}` after the call to + :tacn:`injection` or :tacn:`einjection` so that all equalities generated are moved in + the context of hypotheses. The number of :n:`@intro_pattern` must not exceed + the number of equalities newly generated. If it is smaller, fresh + names are automatically generated to adjust the list of :n:`@intro_pattern` + to the number of new equalities. The original equality is erased if it + corresponds to a hypothesis. .. flag:: Structural Injection @@ -2076,9 +2105,9 @@ and an explanation of the underlying technique. Part of the behavior of the ``inversion`` tactic is to generate equalities between expressions that appeared in the hypothesis that is being processed. By default, no equalities are generated if they - relate two proofs (i.e. equalities between :n:`@terms` whose type is in sort - :g:`Prop`). This behavior can be turned off by using the option - :flag`Keep Proof Equalities`. + relate two proofs (i.e. equalities between :token:`term`\s whose type is in sort + :g:`Prop`). This behavior can be turned off by using the + :flag:`Keep Proof Equalities` setting. .. tacv:: inversion @num @@ -2444,8 +2473,10 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. subgoals. .. exn:: The @term provided does not end with an equation. + :undocumented: .. exn:: Tactic generated a subgoal identical to the original goal. This happens if @term does not occur in the goal. + :undocumented: .. tacv:: rewrite -> @term @@ -2512,6 +2543,13 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. unresolved bindings into existential variables, if any, instead of failing. It has the same variants as :tacn:`rewrite` has. + .. flag:: Keyed Unification + + Makes higher-order unification used by :tacn:`rewrite` rely on a set of keys to drive + unification. The subterms, considered as rewriting candidates, must start with + the same key as the left- or right-hand side of the lemma given to rewrite, and the arguments + are then unified up to full reduction. + .. tacn:: replace @term with @term’ :name: replace @@ -2522,6 +2560,7 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. :n:`cut @term = @term’; [intro H`:sub:`n` :n:`; rewrite <- H`:sub:`n` :n:`; clear H`:sub:`n`:n:`|| assumption || symmetry; try assumption]`. .. exn:: Terms do not have convertible types. + :undocumented: .. tacv:: replace @term with @term’ by @tactic @@ -2544,8 +2583,8 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. the form :n:`@term’ = @term` .. tacv:: replace @term {? with @term} in clause {? by @tactic} - .. tacv:: replace -> @term in clause - .. tacv:: replace <- @term in clause + replace -> @term in clause + replace <- @term in clause Acts as before but the replacements take place in the specified clause (see :ref:`performingcomputations`) and not only in the conclusion of the goal. The @@ -2658,6 +2697,7 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. convertible. .. exn:: Not convertible. + :undocumented: .. tacv:: change @term with @term’ @@ -2670,6 +2710,7 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. in the current goal. The terms :n:`@term` and :n:`@term’` must be convertible. .. exn:: Too few occurrences. + :undocumented: .. tacv:: change @term {? {? at {+ @num}} with @term} in @ident @@ -2712,12 +2753,9 @@ following: For backward compatibility, the notation :n:`in {+ @ident}` performs the conversion in hypotheses :n:`{+ @ident}`. -.. tacn:: cbv {* flag} - :name: cbv -.. tacn:: lazy {* flag} - :name: lazy -.. tacn:: compute - :name: compute +.. tacn:: cbv {* @flag} + lazy {* @flag} + :name: cbv; lazy These parameterized reduction tactics apply to any goal and perform the normalization of the goal according to the specified flags. In @@ -2765,7 +2803,8 @@ the conversion in hypotheses :n:`{+ @ident}`. evaluating purely computational expressions (i.e. with little dead code). .. tacv:: compute -.. tacv:: cbv + cbv + :name: compute; _ These are synonyms for ``cbv beta delta iota zeta``. @@ -2774,17 +2813,17 @@ the conversion in hypotheses :n:`{+ @ident}`. This is a synonym for ``lazy beta delta iota zeta``. .. tacv:: compute {+ @qualid} -.. tacv:: cbv {+ @qualid} + cbv {+ @qualid} These are synonyms of :n:`cbv beta delta {+ @qualid} iota zeta`. .. tacv:: compute -{+ @qualid} -.. tacv:: cbv -{+ @qualid} + cbv -{+ @qualid} These are synonyms of :n:`cbv beta delta -{+ @qualid} iota zeta`. .. tacv:: lazy {+ @qualid} -.. tacv:: lazy -{+ @qualid} + lazy -{+ @qualid} These are respectively synonyms of :n:`lazy beta delta {+ @qualid} iota zeta` and :n:`lazy beta delta -{+ @qualid} iota zeta`. @@ -2864,9 +2903,8 @@ the conversion in hypotheses :n:`{+ @ident}`. on transparency and opacity). .. tacn:: cbn - :name: cbn -.. tacn:: simpl - :name: simpl + simpl + :name: cbn; simpl These tactics apply to any goal. They try to reduce a term to something still readable instead of fully normalizing it. They perform @@ -2962,7 +3000,7 @@ the conversion in hypotheses :n:`{+ @ident}`. :g:`succ t` is reduced to :g:`S t`. .. tacv:: cbn {+ @qualid} -.. tacv:: cbn -{+ @qualid} + cbn -{+ @qualid} These are respectively synonyms of :n:`cbn beta delta {+ @qualid} iota zeta` and :n:`cbn beta delta -{+ @qualid} iota zeta` (see :tacn:`cbn`). @@ -2978,16 +3016,17 @@ the conversion in hypotheses :n:`{+ @ident}`. matching :n:`@pattern` in the current goal. .. exn:: Too few occurrences. + :undocumented: .. tacv:: simpl @qualid -.. tacv:: simpl @string + simpl @string - This applies ``simpl`` only to the applicative subterms whose head occurrence + This applies :tacn:`simpl` only to the applicative subterms whose head occurrence is the unfoldable constant :n:`@qualid` (the constant can be referred to by its notation using :n:`@string` if such a notation exists). .. tacv:: simpl @qualid at {+ @num} -.. tacv:: simpl @string at {+ @num} + simpl @string at {+ @num} This applies ``simpl`` only to the :n:`{+ @num}` applicative subterms whose head occurrence is :n:`@qualid` (or :n:`@string`). @@ -3008,6 +3047,7 @@ the conversion in hypotheses :n:`{+ @ident}`. :math:`\beta`:math:`\iota`-normal form. .. exn:: @qualid does not denote an evaluable constant. + :undocumented: .. tacv:: unfold @qualid in @ident @@ -3025,8 +3065,10 @@ the conversion in hypotheses :n:`{+ @ident}`. unfolded. Occurrences are located from left to right. .. exn:: Bad occurrence number of @qualid. + :undocumented: .. exn:: @qualid does not occur. + :undocumented: .. tacv:: unfold @string @@ -3117,6 +3159,7 @@ Conversion tactics applied to hypotheses Example: :n:`unfold not in (type of H1) (type of H3)`. .. exn:: No such hypothesis: @ident. + :undocumented: .. _automation: @@ -3127,38 +3170,41 @@ Automation .. tacn:: auto :name: auto -This tactic implements a Prolog-like resolution procedure to solve the -current goal. It first tries to solve the goal using the assumption -tactic, then it reduces the goal to an atomic one using intros and -introduces the newly generated hypotheses as hints. Then it looks at -the list of tactics associated to the head symbol of the goal and -tries to apply one of them (starting from the tactics with lower -cost). This process is recursively applied to the generated subgoals. + This tactic implements a Prolog-like resolution procedure to solve the + current goal. It first tries to solve the goal using the assumption + tactic, then it reduces the goal to an atomic one using intros and + introduces the newly generated hypotheses as hints. Then it looks at + the list of tactics associated to the head symbol of the goal and + tries to apply one of them (starting from the tactics with lower + cost). This process is recursively applied to the generated subgoals. -By default, auto only uses the hypotheses of the current goal and the -hints of the database named core. + By default, auto only uses the hypotheses of the current goal and the + hints of the database named core. .. tacv:: auto @num - Forces the search depth to be :n:`@num`. The maximal search depth - is `5` by default. + Forces the search depth to be :token:`num`. The maximal search depth + is 5 by default. .. tacv:: auto with {+ @ident} - Uses the hint databases :n:`{+ @ident}` in addition to the database core. See - :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` for the list of - pre-defined databases and the way to create or extend a database. + Uses the hint databases :n:`{+ @ident}` in addition to the database core. + + .. seealso:: + :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` for the list of + pre-defined databases and the way to create or extend a database. .. tacv:: auto with * - Uses all existing hint databases. See - :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` + Uses all existing hint databases. -.. tacv:: auto using {+ @lemma} + .. seealso:: :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` - Uses :n:`{+ @lemma}` in addition to hints (can be combined with the with - :n:`@ident` option). If :n:`@lemma` is an inductive type, it is the - collection of its constructors which is added as hints. +.. tacv:: auto using {+ @ident__i} {? with {+ @ident } } + + Uses lemmas :n:`@ident__i` in addition to hints. If :n:`@ident` is an + inductive type, it is the collection of its constructors which are added + as hints. .. tacv:: info_auto @@ -3184,13 +3230,24 @@ hints of the database named core. equalities like :g:`X=X`. .. tacv:: trivial with {+ @ident} + :undocumented: + .. tacv:: trivial with * + :undocumented: + .. tacv:: trivial using {+ @lemma} + :undocumented: + .. tacv:: debug trivial :name: debug trivial + :undocumented: + .. tacv:: info_trivial :name: info_trivial + :undocumented: + .. tacv:: {? info_}trivial {? using {+ @lemma}} {? with {+ @ident}} + :undocumented: .. note:: :tacn:`auto` either solves completely the goal or else leaves it @@ -3210,26 +3267,26 @@ the :tacn:`auto` and :tacn:`trivial` tactics: .. tacn:: eauto :name: eauto -This tactic generalizes :tacn:`auto`. While :tacn:`auto` does not try -resolution hints which would leave existential variables in the goal, -:tacn:`eauto` does try them (informally speaking, it usessimple :tacn:`eapply` -where :tacn:`auto` uses simple :tacn:`apply`). As a consequence, :tacn:`eauto` -can solve such a goal: + This tactic generalizes :tacn:`auto`. While :tacn:`auto` does not try + resolution hints which would leave existential variables in the goal, + :tacn:`eauto` does try them (informally speaking, it usessimple :tacn:`eapply` + where :tacn:`auto` uses simple :tacn:`apply`). As a consequence, :tacn:`eauto` + can solve such a goal: -.. example:: + .. example:: - .. coqtop:: all + .. coqtop:: all - Hint Resolve ex_intro. - Goal forall P:nat -> Prop, P 0 -> exists n, P n. - eauto. + Hint Resolve ex_intro. + Goal forall P:nat -> Prop, P 0 -> exists n, P n. + eauto. -Note that ``ex_intro`` should be declared as a hint. + Note that ``ex_intro`` should be declared as a hint. .. tacv:: {? info_}eauto {? @num} {? using {+ @lemma}} {? with {+ @ident}} - The various options for eauto are the same as for auto. + The various options for :tacn:`eauto` are the same as for :tacn:`auto`. :tacn:`eauto` also obeys the following options: @@ -3243,13 +3300,12 @@ Note that ``ex_intro`` should be declared as a hint. .. tacn:: autounfold with {+ @ident} :name: autounfold - -This tactic unfolds constants that were declared through a ``Hint Unfold`` -in the given databases. + This tactic unfolds constants that were declared through a :cmd:`Hint Unfold` + in the given databases. .. tacv:: autounfold with {+ @ident} in clause - Performs the unfolding in the given clause. + Performs the unfolding in the given clause. .. tacv:: autounfold with * @@ -3258,18 +3314,18 @@ in the given databases. .. tacn:: autorewrite with {+ @ident} :name: autorewrite -This tactic [4]_ carries out rewritings according to the rewriting rule -bases :n:`{+ @ident}`. + This tactic [4]_ carries out rewritings according to the rewriting rule + bases :n:`{+ @ident}`. -Each rewriting rule from the base :n:`@ident` is applied to the main subgoal until -it fails. Once all the rules have been processed, if the main subgoal has -progressed (e.g., if it is distinct from the initial main goal) then the rules -of this base are processed again. If the main subgoal has not progressed then -the next base is processed. For the bases, the behavior is exactly similar to -the processing of the rewriting rules. + Each rewriting rule from the base :n:`@ident` is applied to the main subgoal until + it fails. Once all the rules have been processed, if the main subgoal has + progressed (e.g., if it is distinct from the initial main goal) then the rules + of this base are processed again. If the main subgoal has not progressed then + the next base is processed. For the bases, the behavior is exactly similar to + the processing of the rewriting rules. -The rewriting rule bases are built with the ``Hint Rewrite vernacular`` -command. + The rewriting rule bases are built with the :cmd:`Hint Rewrite` + command. .. warning:: @@ -3435,6 +3491,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is itself. .. exn:: @term cannot be used as a hint + :undocumented: .. cmdv:: Immediate {+ @term} @@ -3448,6 +3505,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is :n:`(@ident ...)`, :tacn:`auto` will try to apply each constructor. .. exn:: @ident is not an inductive type + :undocumented: .. cmdv:: Hint Constructors {+ @ident} @@ -3616,16 +3674,16 @@ use one or several databases specific to your development. .. cmd:: Remove Hints {+ @term} : {+ @ident} -This command removes the hints associated to terms :n:`{+ @term}` in databases -:n:`{+ @ident}`. + This command removes the hints associated to terms :n:`{+ @term}` in databases + :n:`{+ @ident}`. .. _printhint: .. cmd:: Print Hint -This command displays all hints that apply to the current goal. It -fails if no proof is being edited, while the two variants can be used -at every moment. + This command displays all hints that apply to the current goal. It + fails if no proof is being edited, while the two variants can be used + at every moment. **Variants:** @@ -3753,17 +3811,17 @@ Decision procedures .. tacn:: tauto :name: tauto -This tactic implements a decision procedure for intuitionistic propositional -calculus based on the contraction-free sequent calculi LJT* of Roy Dyckhoff -:cite:`Dyc92`. Note that :tacn:`tauto` succeeds on any instance of an -intuitionistic tautological proposition. :tacn:`tauto` unfolds negations and -logical equivalence but does not unfold any other definition. - -The following goal can be proved by :tacn:`tauto` whereas :tacn:`auto` would -fail: + This tactic implements a decision procedure for intuitionistic propositional + calculus based on the contraction-free sequent calculi LJT* of Roy Dyckhoff + :cite:`Dyc92`. Note that :tacn:`tauto` succeeds on any instance of an + intuitionistic tautological proposition. :tacn:`tauto` unfolds negations and + logical equivalence but does not unfold any other definition. .. example:: + The following goal can be proved by :tacn:`tauto` whereas :tacn:`auto` would + fail: + .. coqtop:: reset all Goal forall (x:nat) (P:nat -> Prop), x = 0 \/ P x -> x <> 0 -> P x. @@ -3799,27 +3857,24 @@ Therefore, the use of :tacn:`intros` in the previous proof is unnecessary. .. tacn:: intuition @tactic :name: intuition -The tactic :tacn:`intuition` takes advantage of the search-tree built by the -decision procedure involved in the tactic :tacn:`tauto`. It uses this -information to generate a set of subgoals equivalent to the original one (but -simpler than it) and applies the tactic :n:`@tactic` to them :cite:`Mun94`. If -this tactic fails on some goals then :tacn:`intuition` fails. In fact, -:tacn:`tauto` is simply :g:`intuition fail`. + The tactic :tacn:`intuition` takes advantage of the search-tree built by the + decision procedure involved in the tactic :tacn:`tauto`. It uses this + information to generate a set of subgoals equivalent to the original one (but + simpler than it) and applies the tactic :n:`@tactic` to them :cite:`Mun94`. If + this tactic fails on some goals then :tacn:`intuition` fails. In fact, + :tacn:`tauto` is simply :g:`intuition fail`. -For instance, the tactic :g:`intuition auto` applied to the goal - -:: - - (forall (x:nat), P x) /\ B -> (forall (y:nat), P y) /\ P O \/ B /\ P O + .. example:: + For instance, the tactic :g:`intuition auto` applied to the goal:: -internally replaces it by the equivalent one: -:: + (forall (x:nat), P x) /\ B -> (forall (y:nat), P y) /\ P O \/ B /\ P O - (forall (x:nat), P x), B |- P O + internally replaces it by the equivalent one:: + (forall (x:nat), P x), B |- P O -and then uses :tacn:`auto` which completes the proof. + and then uses :tacn:`auto` which completes the proof. Originally due to César Muñoz, these tactics (:tacn:`tauto` and :tacn:`intuition`) have been completely re-engineered by David Delahaye using @@ -3849,25 +3904,25 @@ some incompatibilities. .. tacn:: rtauto :name: rtauto -The :tacn:`rtauto` tactic solves propositional tautologies similarly to what -:tacn:`tauto` does. The main difference is that the proof term is built using a -reflection scheme applied to a sequent calculus proof of the goal. The search -procedure is also implemented using a different technique. + The :tacn:`rtauto` tactic solves propositional tautologies similarly to what + :tacn:`tauto` does. The main difference is that the proof term is built using a + reflection scheme applied to a sequent calculus proof of the goal. The search + procedure is also implemented using a different technique. -Users should be aware that this difference may result in faster proof-search -but slower proof-checking, and :tacn:`rtauto` might not solve goals that -:tacn:`tauto` would be able to solve (e.g. goals involving universal -quantifiers). + Users should be aware that this difference may result in faster proof-search + but slower proof-checking, and :tacn:`rtauto` might not solve goals that + :tacn:`tauto` would be able to solve (e.g. goals involving universal + quantifiers). -Note that this tactic is only available after a ``Require Import Rtauto``. + Note that this tactic is only available after a ``Require Import Rtauto``. .. tacn:: firstorder :name: firstorder -The tactic :tacn:`firstorder` is an experimental extension of :tacn:`tauto` to -first- order reasoning, written by Pierre Corbineau. It is not restricted to -usual logical connectives but instead may reason about any first-order class -inductive definition. + The tactic :tacn:`firstorder` is an experimental extension of :tacn:`tauto` to + first- order reasoning, written by Pierre Corbineau. It is not restricted to + usual logical connectives but instead may reason about any first-order class + inductive definition. .. opt:: Firstorder Solver @tactic :name: Firstorder Solver @@ -3906,20 +3961,20 @@ inductive definition. .. tacn:: congruence :name: congruence -The tactic :tacn:`congruence`, by Pierre Corbineau, implements the standard -Nelson and Oppen congruence closure algorithm, which is a decision procedure -for ground equalities with uninterpreted symbols. It also includes -constructor theory (see :tacn:`injection` and :tacn:`discriminate`). If the goal -is a non-quantified equality, congruence tries to prove it with non-quantified -equalities in the context. Otherwise it tries to infer a discriminable equality -from those in the context. Alternatively, congruence tries to prove that a -hypothesis is equal to the goal or to the negation of another hypothesis. - -:tacn:`congruence` is also able to take advantage of hypotheses stating -quantified equalities, but you have to provide a bound for the number of extra -equalities generated that way. Please note that one of the sides of the -equality must contain all the quantified variables in order for congruence to -match against it. + The tactic :tacn:`congruence`, by Pierre Corbineau, implements the standard + Nelson and Oppen congruence closure algorithm, which is a decision procedure + for ground equalities with uninterpreted symbols. It also includes + constructor theory (see :tacn:`injection` and :tacn:`discriminate`). If the goal + is a non-quantified equality, congruence tries to prove it with non-quantified + equalities in the context. Otherwise it tries to infer a discriminable equality + from those in the context. Alternatively, congruence tries to prove that a + hypothesis is equal to the goal or to the negation of another hypothesis. + + :tacn:`congruence` is also able to take advantage of hypotheses stating + quantified equalities, but you have to provide a bound for the number of extra + equalities generated that way. Please note that one of the sides of the + equality must contain all the quantified variables in order for congruence to + match against it. .. example:: @@ -3980,7 +4035,10 @@ succeeds, and results in an error otherwise. conversion, casts and universe constraints. It may unify universes. .. exn:: Not equal. + :undocumented: + .. exn:: Not equal (due to universes). + :undocumented: .. tacn:: constr_eq_strict @term @term :name: constr_eq_strict @@ -3990,7 +4048,10 @@ succeeds, and results in an error otherwise. constraints. .. exn:: Not equal. + :undocumented: + .. exn:: Not equal (due to universes). + :undocumented: .. tacn:: unify @term @term :name: unify @@ -3999,6 +4060,7 @@ succeeds, and results in an error otherwise. instantiating existential variables. .. exn:: Unable to unify @term with @term. + :undocumented: .. tacv:: unify @term @term with @ident @@ -4013,6 +4075,7 @@ succeeds, and results in an error otherwise. by :tacn:`eapply` and some other tactics. .. exn:: Not an evar. + :undocumented: .. tacn:: has_evar @term :name: has_evar @@ -4022,6 +4085,7 @@ succeeds, and results in an error otherwise. scans all subterms, including those under binders. .. exn:: No evars. + :undocumented: .. tacn:: is_var @term :name: is_var @@ -4030,6 +4094,7 @@ succeeds, and results in an error otherwise. the current goal context or in the opened sections. .. exn:: Not a variable or hypothesis. + :undocumented: .. _equality: @@ -4041,45 +4106,46 @@ Equality .. tacn:: f_equal :name: f_equal -This tactic applies to a goal of the form :g:`f a`:sub:`1` :g:`... a`:sub:`n` -:g:`= f′a′`:sub:`1` :g:`... a′`:sub:`n`. Using :tacn:`f_equal` on such a goal -leads to subgoals :g:`f=f′` and :g:`a`:sub:`1` = :g:`a′`:sub:`1` and so on up -to :g:`a`:sub:`n` :g:`= a′`:sub:`n`. Amongst these subgoals, the simple ones -(e.g. provable by :tacn:`reflexivity` or :tacn:`congruence`) are automatically -solved by :tacn:`f_equal`. + This tactic applies to a goal of the form :g:`f a`:sub:`1` :g:`... a`:sub:`n` + :g:`= f′a′`:sub:`1` :g:`... a′`:sub:`n`. Using :tacn:`f_equal` on such a goal + leads to subgoals :g:`f=f′` and :g:`a`:sub:`1` = :g:`a′`:sub:`1` and so on up + to :g:`a`:sub:`n` :g:`= a′`:sub:`n`. Amongst these subgoals, the simple ones + (e.g. provable by :tacn:`reflexivity` or :tacn:`congruence`) are automatically + solved by :tacn:`f_equal`. .. tacn:: reflexivity :name: reflexivity -This tactic applies to a goal that has the form :g:`t=u`. It checks that `t` -and `u` are convertible and then solves the goal. It is equivalent to -``apply refl_equal``. + This tactic applies to a goal that has the form :g:`t=u`. It checks that `t` + and `u` are convertible and then solves the goal. It is equivalent to + ``apply refl_equal``. -.. exn:: The conclusion is not a substitutive equation. + .. exn:: The conclusion is not a substitutive equation. + :undocumented: -.. exn:: Unable to unify ... with ... + .. exn:: Unable to unify ... with ... + :undocumented: .. tacn:: symmetry :name: symmetry -This tactic applies to a goal that has the form :g:`t=u` and changes it into -:g:`u=t`. + This tactic applies to a goal that has the form :g:`t=u` and changes it into + :g:`u=t`. .. tacv:: symmetry in @ident - If the statement of the hypothesis ident has the form :g:`t=u`, the tactic - changes it to :g:`u=t`. - + If the statement of the hypothesis ident has the form :g:`t=u`, the tactic + changes it to :g:`u=t`. .. tacn:: transitivity @term :name: transitivity -This tactic applies to a goal that has the form :g:`t=u` and transforms it -into the two subgoals :n:`t=@term` and :n:`@term=u`. + This tactic applies to a goal that has the form :g:`t=u` and transforms it + into the two subgoals :n:`t=@term` and :n:`@term=u`. Equality and inductive sets @@ -4133,10 +4199,10 @@ symbol :g:`=`. instantiate parameters or hypotheses of :n:`@term`. .. tacv:: esimplify_eq @num -.. tacv:: esimplify_eq @term {? with @bindings_list} - :name: esimplify_eq + esimplify_eq @term {? with @bindings_list} + :name: esimplify_eq; _ - This works the same as ``simplify_eq`` but if the type of :n:`@term`, or the + This works the same as :tacn:`simplify_eq` but if the type of :n:`@term`, or the type of the hypothesis referred to by :n:`@num`, has uninstantiated parameters, these parameters are left as existential variables. @@ -4168,35 +4234,35 @@ Inversion .. tacn:: functional inversion @ident :name: functional inversion -:tacn:`functional inversion` is a tactic that performs inversion on hypothesis -:n:`@ident` of the form :n:`@qualid {+ @term} = @term` or :n:`@term = @qualid -{+ @term}` where :n:`@qualid` must have been defined using Function (see -:ref:`advanced-recursive-functions`). Note that this tactic is only -available after a ``Require Import FunInd``. + :tacn:`functional inversion` is a tactic that performs inversion on hypothesis + :n:`@ident` of the form :n:`@qualid {+ @term} = @term` or :n:`@term = @qualid + {+ @term}` where :n:`@qualid` must have been defined using Function (see + :ref:`advanced-recursive-functions`). Note that this tactic is only + available after a ``Require Import FunInd``. + .. exn:: Hypothesis @ident must contain at least one Function. + :undocumented: -.. exn:: Hypothesis @ident must contain at least one Function. -.. exn:: Cannot find inversion information for hypothesis @ident. + .. exn:: Cannot find inversion information for hypothesis @ident. - This error may be raised when some inversion lemma failed to be generated by - Function. + This error may be raised when some inversion lemma failed to be generated by + Function. -.. tacv:: functional inversion @num + .. tacv:: functional inversion @num - This does the same thing as :n:`intros until @num` folowed by - :n:`functional inversion @ident` where :token:`ident` is the - identifier for the last introduced hypothesis. + This does the same thing as :n:`intros until @num` folowed by + :n:`functional inversion @ident` where :token:`ident` is the + identifier for the last introduced hypothesis. -.. tacv:: functional inversion ident qualid -.. tacv:: functional inversion num qualid + .. tacv:: functional inversion @ident @qualid + functional inversion @num @qualid - If the hypothesis :n:`@ident` (or :n:`@num`) has a type of the form - :n:`@qualid`:sub:`1` :n:`@term`:sub:`1` ... :n:`@term`:sub:`n` :n:`= - @qualid`:sub:`2` :n:`@term`:sub:`n+1` ... :n:`@term`:sub:`n+m` where - :n:`@qualid`:sub:`1` and :n:`@qualid`:sub:`2` are valid candidates to - functional inversion, this variant allows choosing which :n:`@qualid` is - inverted. + If the hypothesis :token:`ident` (or :token:`num`) has a type of the form + :n:`@qualid__1 {+ @term__i } = @qualid__2 {+ @term__j }` where + :n:`@qualid__1` and :n:`@qualid__2` are valid candidates to + functional inversion, this variant allows choosing which :token:`qualid` + is inverted. Classical tactics ----------------- @@ -4206,15 +4272,14 @@ loaded. A few more tactics are available. Make sure to load the module using the ``Require Import`` command. .. tacn:: classical_left - :name: classical_left -.. tacv:: classical_right - :name: classical_right + classical_right + :name: classical_left; classical_right - The tactics ``classical_left`` and ``classical_right`` are the analog of the - left and right but using classical logic. They can only be used for - disjunctions. Use ``classical_left`` to prove the left part of the + These tactics are the analog of :tacn:`left` and :tacn:`right` + but using classical logic. They can only be used for + disjunctions. Use :tacn:`classical_left` to prove the left part of the disjunction with the assumption that the negation of right part holds. - Use ``classical_right`` to prove the right part of the disjunction with + Use :tacn:`classical_right` to prove the right part of the disjunction with the assumption that the negation of left part holds. .. _tactics-automating: @@ -4226,93 +4291,92 @@ Automating .. tacn:: btauto :name: btauto -The tactic :tacn:`btauto` implements a reflexive solver for boolean -tautologies. It solves goals of the form :g:`t = u` where `t` and `u` are -constructed over the following grammar: + The tactic :tacn:`btauto` implements a reflexive solver for boolean + tautologies. It solves goals of the form :g:`t = u` where `t` and `u` are + constructed over the following grammar: -.. _btauto_grammar: + .. _btauto_grammar: - .. productionlist:: `sentence` - t : x - :∣ true - :∣ false - :∣ orb t1 t2 - :∣ andb t1 t2 - :∣ xorb t1 t2 - :∣ negb t - :∣ if t1 then t2 else t3 + .. productionlist:: `sentence` + t : x + :∣ true + :∣ false + :∣ orb t1 t2 + :∣ andb t1 t2 + :∣ xorb t1 t2 + :∣ negb t + :∣ if t1 then t2 else t3 - Whenever the formula supplied is not a tautology, it also provides a - counter-example. + Whenever the formula supplied is not a tautology, it also provides a + counter-example. - Internally, it uses a system very similar to the one of the ring - tactic. + Internally, it uses a system very similar to the one of the ring + tactic. - Note that this tactic is only available after a ``Require Import Btauto``. + Note that this tactic is only available after a ``Require Import Btauto``. -.. exn:: Cannot recognize a boolean equality. + .. exn:: Cannot recognize a boolean equality. - The goal is not of the form :g:`t = u`. Especially note that :tacn:`btauto` - doesn't introduce variables into the context on its own. + The goal is not of the form :g:`t = u`. Especially note that :tacn:`btauto` + doesn't introduce variables into the context on its own. .. tacn:: omega :name: omega -The tactic :tacn:`omega`, due to Pierre Crégut, is an automatic decision -procedure for Presburger arithmetic. It solves quantifier-free -formulas built with `~`, `\/`, `/\`, `->` on top of equalities, -inequalities and disequalities on both the type :g:`nat` of natural numbers -and :g:`Z` of binary integers. This tactic must be loaded by the command -``Require Import Omega``. See the additional documentation about omega -(see Chapter :ref:`omega`). + The tactic :tacn:`omega`, due to Pierre Crégut, is an automatic decision + procedure for Presburger arithmetic. It solves quantifier-free + formulas built with `~`, `\/`, `/\`, `->` on top of equalities, + inequalities and disequalities on both the type :g:`nat` of natural numbers + and :g:`Z` of binary integers. This tactic must be loaded by the command + ``Require Import Omega``. See the additional documentation about omega + (see Chapter :ref:`omega`). .. tacn:: ring :name: ring + + This tactic solves equations upon polynomial expressions of a ring + (or semiring) structure. It proceeds by normalizing both hand sides + of the equation (w.r.t. associativity, commutativity and + distributivity, constant propagation) and comparing syntactically the + results. + .. tacn:: ring_simplify {+ @term} :name: ring_simplify -The :n:`ring` tactic solves equations upon polynomial expressions of a ring -(or semiring) structure. It proceeds by normalizing both hand sides -of the equation (w.r.t. associativity, commutativity and -distributivity, constant propagation) and comparing syntactically the -results. - -:n:`ring_simplify` applies the normalization procedure described above to -the given terms. The tactic then replaces all occurrences of the terms -given in the conclusion of the goal by their normal forms. If no term -is given, then the conclusion should be an equation and both hand -sides are normalized. + This tactic applies the normalization procedure described above to + the given terms. The tactic then replaces all occurrences of the terms + given in the conclusion of the goal by their normal forms. If no term + is given, then the conclusion should be an equation and both hand + sides are normalized. See :ref:`Theringandfieldtacticfamilies` for more information on the tactic and how to declare new ring structures. All declared field structures can be printed with the ``Print Rings`` command. .. tacn:: field - :name: field -.. tacn:: field_simplify {+ @term} - :name: field_simplify -.. tacn:: field_simplify_eq - :name: field_simplify_eq - -The field tactic is built on the same ideas as ring: this is a -reflexive tactic that solves or simplifies equations in a field -structure. The main idea is to reduce a field expression (which is an -extension of ring expressions with the inverse and division -operations) to a fraction made of two polynomial expressions. - -Tactic :n:`field` is used to solve subgoals, whereas :n:`field_simplify {+ @term}` -replaces the provided terms by their reduced fraction. -:n:`field_simplify_eq` applies when the conclusion is an equation: it -simplifies both hand sides and multiplies so as to cancel -denominators. So it produces an equation without division nor inverse. - -All of these 3 tactics may generate a subgoal in order to prove that -denominators are different from zero. - -See :ref:`Theringandfieldtacticfamilies` for more information on the tactic and how to -declare new field structures. All declared field structures can be -printed with the Print Fields command. + field_simplify {+ @term} + field_simplify_eq + :name: field; field_simplify; field_simplify_eq + + The field tactic is built on the same ideas as ring: this is a + reflexive tactic that solves or simplifies equations in a field + structure. The main idea is to reduce a field expression (which is an + extension of ring expressions with the inverse and division + operations) to a fraction made of two polynomial expressions. + + Tactic :n:`field` is used to solve subgoals, whereas :n:`field_simplify {+ @term}` + replaces the provided terms by their reduced fraction. + :n:`field_simplify_eq` applies when the conclusion is an equation: it + simplifies both hand sides and multiplies so as to cancel + denominators. So it produces an equation without division nor inverse. + + All of these 3 tactics may generate a subgoal in order to prove that + denominators are different from zero. + + See :ref:`Theringandfieldtacticfamilies` for more information on the tactic and how to + declare new field structures. All declared field structures can be + printed with the Print Fields command. .. example:: @@ -4373,16 +4437,16 @@ Non-logical tactics .. tacn:: revgoals :name: revgoals -This tactics reverses the list of the focused goals. + This tactics reverses the list of the focused goals. -.. example:: + .. example:: - .. coqtop:: all reset + .. coqtop:: all reset - Parameter P : nat -> Prop. - Goal P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5. - repeat split. - all: revgoals. + Parameter P : nat -> Prop. + Goal P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5. + repeat split. + all: revgoals. .. tacn:: shelve :name: shelve @@ -4455,3 +4519,42 @@ user-defined tactics. significant changes in your theories to obtain the same result. As a drawback of the re-engineering of the code, this tactic has also been completely revised to get a very compact and readable version. + +Delaying solving unification constraints +---------------------------------------- + +.. tacn:: solve_constraints + :name: solve_constraints + :undocumented: + +.. flag:: Solve Unification Constraints + + By default, after each tactic application, postponed typechecking unification + problems are resolved using heuristics. Unsetting this flag disables this + behavior, allowing tactics to leave unification constraints unsolved. Use the + :tacn:`solve_constraints` tactic at any point to solve the constraints. + +Proof maintenance +----------------- + +*Experimental.* Many tactics, such as :tacn:`intros`, can automatically generate names, such +as "H0" or "H1" for a new hypothesis introduced from a goal. Subsequent proof steps +may explicitly refer to these names. However, future versions of Coq may not assign +names exactly the same way, which could cause the proof to fail because the +new names don't match the explicit references in the proof. + +The following "Mangle Names" settings let users find all the +places where proofs rely on automatically generated names, which can +then be named explicitly to avoid any incompatibility. These +settings cause Coq to generate different names, producing errors for +references to automatically generated names. + +.. flag:: Mangle Names + + When set, generated names use the prefix specified in the following + option instead of the default prefix. + +.. opt:: Mangle Names Prefix @string + :name: Mangle Names Prefix + + Specifies the prefix to use when generating names. diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index a69cf209c7..a98a46ba21 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -20,10 +20,13 @@ Displaying Error messages: .. exn:: @qualid not a defined object. + :undocumented: .. exn:: Universe instance should have length @num. + :undocumented: .. exn:: This object does not support universe names. + :undocumented: .. cmdv:: Print Term @qualid @@ -81,9 +84,9 @@ and tables: * A :production:`flag` has a boolean value, such as :flag:`Asymmetric Patterns`. * An :production:`option` generally has a numeric or string value, such as :opt:`Firstorder Depth`. * A :production:`table` contains a set of strings or qualids. -* In addition, some commands provide settings, such as :cmd:`Extraction Language OCaml`. +* In addition, some commands provide settings, such as :cmd:`Extraction Language`. -.. FIXME Convert `Extraction Language OCaml` to an option. +.. FIXME Convert "Extraction Language" to an option. Flags, options and tables are identified by a series of identifiers, each with an initial capital letter. @@ -271,8 +274,8 @@ Requests to the environment This searches for all statements or types of definition that contains a subterm that matches the pattern - `term_pattern` (holes of the pattern are either denoted by `_` or by - `?ident` when non linear patterns are expected). + :token:`term_pattern` (holes of the pattern are either denoted by `_` or by + :n:`?@ident` when non linear patterns are expected). .. cmdv:: Search { + [-]@term_pattern_string } @@ -538,8 +541,7 @@ toplevel. This kind of file is called a *script* for |Coq|. The standard will use the default extension ``.v``. .. cmdv:: Load Verbose @ident - - .. cmdv:: Load Verbose @string + Load Verbose @string Display, while loading, the answers of |Coq| to each command (including tactics) contained in @@ -548,10 +550,13 @@ toplevel. This kind of file is called a *script* for |Coq|. The standard .. seealso:: Section :ref:`controlling-display`. .. exn:: Can’t find file @ident on loadpath. + :undocumented: .. exn:: Load is not supported inside proofs. + :undocumented: .. exn:: Files processed by Load cannot leave open proofs. + :undocumented: .. _compiled-files: @@ -575,7 +580,7 @@ file is a particular case of module called *library file*. replayed nor rechecked. To locate the file in the file system, :n:`@qualid` is decomposed under the - form `dirpath.ident` and the file `ident.vo` is searched in the physical + form :n:`dirpath.@ident` and the file :n:`@ident.vo` is searched in the physical directory of the file system that is mapped in |Coq| loadpath to the logical path dirpath (see Section :ref:`libraries-and-filesystem`). The mapping between physical directories and logical names at the time of requiring the @@ -606,7 +611,7 @@ file is a particular case of module called *library file*. .. cmdv:: Require [Import | Export] {+ @qualid } This loads the - modules named by the :n:`qualid` sequence and their recursive + modules named by the :token:`qualid` sequence and their recursive dependencies. If ``Import`` or ``Export`` is given, it also imports these modules and all the recursive dependencies that were marked or transitively marked @@ -615,11 +620,12 @@ file is a particular case of module called *library file*. .. cmdv:: From @dirpath Require @qualid This command acts as :cmd:`Require`, but picks - any library whose absolute name is of the form dirpath.dirpath’.qualid - for some `dirpath’`. This is useful to ensure that the :n:`@qualid` library + any library whose absolute name is of the form :n:`@dirpath.@dirpath’.@qualid` + for some :n:`@dirpath’`. This is useful to ensure that the :token:`qualid` library comes from a given package by making explicit its absolute root. .. exn:: Cannot load qualid: no physical path bound to dirpath. + :undocumented: .. exn:: Cannot find library foo in loadpath. @@ -631,21 +637,21 @@ file is a particular case of module called *library file*. The command tried to load library file :n:`@ident`.vo that depends on some specific version of library :n:`@qualid` which is not the - one already loaded in the current |Coq| session. Probably `ident.v` was + one already loaded in the current |Coq| session. Probably :n:`@ident.v` was not properly recompiled with the last version of the file containing - module :n:`@qualid`. + module :token:`qualid`. .. exn:: Bad magic number. - The file `ident.vo` was found but either it is not a + The file :n:`@ident.vo` was found but either it is not a |Coq| compiled module, or it was compiled with an incompatible version of |Coq|. - .. exn:: The file `ident.vo` contains library dirpath and not library dirpath’. + .. exn:: The file :n:`@ident.vo` contains library dirpath and not library dirpath’. - The library file `dirpath’` is indirectly required by the + The library file :n:`@dirpath’` is indirectly required by the ``Require`` command but it is bound in the current loadpath to the - file `ident.vo` which was bound to a different library name `dirpath` at + file :n:`@ident.vo` which was bound to a different library name :token:`dirpath` at the time it was compiled. @@ -669,10 +675,10 @@ file is a particular case of module called *library file*. .. cmd:: Declare ML Module {+ @string } This commands loads the OCaml compiled files - with names given by the :n:`@string` sequence + with names given by the :token:`string` sequence (dynamic link). It is mainly used to load tactics dynamically. The files are searched into the current OCaml loadpath (see the - command ``Add ML Path`` in Section :ref:`libraries-and-filesystem`). + command :cmd:`Add ML Path`). Loading of OCaml files is only possible under the bytecode version of ``coqtop`` (i.e. ``coqtop`` called with option ``-byte``, see chapter :ref:`thecoqcommands`), or when |Coq| has been compiled with a @@ -684,15 +690,17 @@ file is a particular case of module called *library file*. where they occur, even if outside a section. .. exn:: File not found on loadpath: @string. + :undocumented: .. exn:: Loading of ML object file forbidden in a native Coq. + :undocumented: .. cmd:: Print ML Modules - This prints the name of all OCaml modules loaded with ``Declare - ML Module``. To know from where these module were loaded, the user - should use the command ``Locate File`` (see :ref:`here <locate-file>`) + This prints the name of all OCaml modules loaded with :cmd:`Declare ML Module`. + To know from where these module were loaded, the user + should use the command :cmd:`Locate File`. .. _loadpath: @@ -713,7 +721,7 @@ the toplevel, and using them in source files is discouraged. .. cmd:: Cd @string - This command changes the current directory according to :n:`@string` which + This command changes the current directory according to :token:`string` which can be any valid path. .. cmdv:: Cd @@ -724,24 +732,24 @@ the toplevel, and using them in source files is discouraged. .. cmd:: Add LoadPath @string as @dirpath This command is equivalent to the command line option - ``-Q`` :n:`@string` :n:`@dirpath`. It adds the physical directory string to the current + :n:`-Q @string @dirpath`. It adds the physical directory string to the current |Coq| loadpath and maps it to the logical directory dirpath. .. cmdv:: Add LoadPath @string - Performs as Add LoadPath :n:`@string` as :n:`@dirpath` but + Performs as :n:`Add LoadPath @string @dirpath` but for the empty directory path. .. cmd:: Add Rec LoadPath @string as @dirpath This command is equivalent to the command line option - ``-R`` :n:`@string` :n:`@dirpath`. It adds the physical directory string and all its + :n:`-R @string @dirpath`. It adds the physical directory string and all its subdirectories to the current |Coq| loadpath. .. cmdv:: Add Rec LoadPath @string - Works as :cmd:`Add Rec LoadPath` :n:`@string` as :n:`@dirpath` but for the empty + Works as :n:`Add Rec LoadPath @string as @dirpath` but for the empty logical directory path. @@ -784,7 +792,7 @@ the toplevel, and using them in source files is discouraged. .. cmd:: Locate File @string This command displays the location of file string in the current - loadpath. Typically, string is a .cmo or .vo or .v file. + loadpath. Typically, string is a ``.cmo`` or ``.vo`` or ``.v`` file. .. cmd:: Locate Library @dirpath @@ -812,6 +820,7 @@ interactively, they cannot be part of a vernacular file loaded via over the name of a module or of an object inside a module. .. exn:: @ident: no such entry. + :undocumented: .. cmdv:: Reset Initial @@ -849,7 +858,7 @@ interactively, they cannot be part of a vernacular file loaded via state label is an integer which grows after each successful command. It is displayed in the prompt when in -emacs mode. Just as :cmd:`Back` (see above), the :cmd:`BackTo` command now handles proof states. For that, it may - have to undo some extra commands and end on a state `num′ ≤ num` if + have to undo some extra commands and end on a state :n:`@num′ ≤ @num` if necessary. .. cmdv:: Backtrack @num @num @num @@ -953,6 +962,7 @@ Quitting and debugging it prints a message indicating that the failure did not occur. .. exn:: The command has not failed! + :undocumented: .. _controlling-display: @@ -1136,6 +1146,7 @@ described first. variable nor a constant. .. exn:: The reference is not unfoldable. + :undocumented: .. cmdv:: Print Strategies @@ -1146,7 +1157,7 @@ described first. This command allows giving a short name to a reduction expression, for instance lazy beta delta [foo bar]. This short name can then be used - in ``Eval`` :n:`@ident` ``in`` ... or ``eval`` directives. This command + in :n:`Eval @ident in` or ``eval`` directives. This command accepts the Local modifier, for discarding this reduction name at the end of the file or module. For the moment the name cannot be qualified. In @@ -1154,7 +1165,7 @@ described first. functor applications will be refused if these declarations are not local. The name :n:`@ident` cannot be used directly as an Ltac tactic, but nothing prevents the user to also perform a - ``Ltac`` `ident` ``:=`` `convtactic`. + :n:`Ltac @ident := @convtactic`. .. seealso:: :ref:`performingcomputations` @@ -1166,41 +1177,41 @@ Controlling the locality of commands .. cmd:: Local @command -.. cmd:: Global @command - -Some commands support a Local or Global prefix modifier to control the -scope of their effect. There are four kinds of commands: - - -+ Commands whose default is to extend their effect both outside the - section and the module or library file they occur in. For these - commands, the Local modifier limits the effect of the command to the - current section or module it occurs in. As an example, the :cmd:`Coercion` - and :cmd:`Strategy` commands belong to this category. -+ Commands whose default behavior is to stop their effect at the end - of the section they occur in but to extend their effect outside the module or - library file they occur in. For these commands, the Local modifier limits the - effect of the command to the current module if the command does not occur in a - section and the Global modifier extends the effect outside the current - sections and current module if the command occurs in a section. As an example, - the :cmd:`Arguments`, :cmd:`Ltac` or :cmd:`Notation` commands belong - to this category. Notice that a subclass of these commands do not support - extension of their scope outside sections at all and the Global modifier is not - applicable to them. -+ Commands whose default behavior is to stop their effect at the end - of the section or module they occur in. For these commands, the ``Global`` - modifier extends their effect outside the sections and modules they - occur in. The :cmd:`Transparent` and :cmd:`Opaque` - (see Section :ref:`vernac-controlling-the-reduction-strategies`) commands - belong to this category. -+ Commands whose default behavior is to extend their effect outside - sections but not outside modules when they occur in a section and to - extend their effect outside the module or library file they occur in - when no section contains them.For these commands, the Local modifier - limits the effect to the current section or module while the Global - modifier extends the effect outside the module even when the command - occurs in a section. The :cmd:`Set` and :cmd:`Unset` commands belong to this - category. + Global @command + + Some commands support a Local or Global prefix modifier to control the + scope of their effect. There are four kinds of commands: + + + + Commands whose default is to extend their effect both outside the + section and the module or library file they occur in. For these + commands, the Local modifier limits the effect of the command to the + current section or module it occurs in. As an example, the :cmd:`Coercion` + and :cmd:`Strategy` commands belong to this category. + + Commands whose default behavior is to stop their effect at the end + of the section they occur in but to extend their effect outside the module or + library file they occur in. For these commands, the Local modifier limits the + effect of the command to the current module if the command does not occur in a + section and the Global modifier extends the effect outside the current + sections and current module if the command occurs in a section. As an example, + the :cmd:`Arguments`, :cmd:`Ltac` or :cmd:`Notation` commands belong + to this category. Notice that a subclass of these commands do not support + extension of their scope outside sections at all and the Global modifier is not + applicable to them. + + Commands whose default behavior is to stop their effect at the end + of the section or module they occur in. For these commands, the ``Global`` + modifier extends their effect outside the sections and modules they + occur in. The :cmd:`Transparent` and :cmd:`Opaque` + (see Section :ref:`vernac-controlling-the-reduction-strategies`) commands + belong to this category. + + Commands whose default behavior is to extend their effect outside + sections but not outside modules when they occur in a section and to + extend their effect outside the module or library file they occur in + when no section contains them.For these commands, the Local modifier + limits the effect to the current section or module while the Global + modifier extends the effect outside the module even when the command + occurs in a section. The :cmd:`Set` and :cmd:`Unset` commands belong to this + category. .. _exposing-constants-to-ocaml-libraries: diff --git a/doc/sphinx/user-extensions/proof-schemes.rst b/doc/sphinx/user-extensions/proof-schemes.rst index 8f76085d88..418922e9b3 100644 --- a/doc/sphinx/user-extensions/proof-schemes.rst +++ b/doc/sphinx/user-extensions/proof-schemes.rst @@ -12,7 +12,7 @@ The ``Scheme`` command is a high-level tool for generating automatically (possibly mutual) induction principles for given types and sorts. Its syntax follows the schema: -.. cmd:: Scheme @ident__1 := Induction for @ident__2 Sort sort {* with @ident__i := Induction for @ident__j Sort sort} +.. cmd:: Scheme @ident__1 := Induction for @ident__2 Sort @sort {* with @ident__i := Induction for @ident__j Sort @sort} This command is a high-level tool for generating automatically (possibly mutual) induction principles for given types and sorts. @@ -22,10 +22,10 @@ syntax follows the schema: definitions. Each term :n:`@ident__i` proves a general principle of mutual induction for objects in type :n:`@ident__j`. -.. cmdv:: Scheme @ident := Minimality for @ident Sort sort {* with @ident := Minimality for @ident' Sort sort} +.. cmdv:: Scheme @ident := Minimality for @ident Sort @sort {* with @ident := Minimality for @ident' Sort @sort} - Same as before but defines a non-dependent elimination principle more - natural in case of inductively defined relations. + Same as before but defines a non-dependent elimination principle more + natural in case of inductively defined relations. .. cmdv:: Scheme Equality for @ident :name: Scheme Equality @@ -33,7 +33,7 @@ syntax follows the schema: Tries to generate a Boolean equality and a proof of the decidability of the usual equality. If `ident` involves some other inductive types, their equality has to be defined first. -.. cmdv:: Scheme Induction for @ident Sort sort {* with Induction for @ident Sort sort} +.. cmdv:: Scheme Induction for @ident Sort @sort {* with Induction for @ident Sort @sort} If you do not provide the name of the schemes, they will be automatically computed from the sorts involved (works also with Minimality). @@ -195,19 +195,18 @@ Combined Scheme Generation of induction principles with ``Functional`` ``Scheme`` ----------------------------------------------------------------- -The ``Functional Scheme`` command is a high-level experimental tool for -generating automatically induction principles corresponding to -(possibly mutually recursive) functions. First, it must be made -available via ``Require Import FunInd``. Its syntax then follows the -schema: -.. cmd:: Functional Scheme @ident := Induction for ident' Sort sort {* with @ident := Induction for @ident Sort sort} +.. cmd:: Functional Scheme @ident__0 := Induction for @ident' Sort @sort {* with @ident__i := Induction for @ident__i' Sort @sort} -where each `ident'ᵢ` is a different mutually defined function -name (the names must be in the same order as when they were defined). This -command generates the induction principle for each `identᵢ`, following -the recursive structure and case analyses of the corresponding function -identᵢ’. + This command is a high-level experimental tool for + generating automatically induction principles corresponding to + (possibly mutually recursive) functions. First, it must be made + available via ``Require Import FunInd``. + Each :n:`@ident__i` is a different mutually defined function + name (the names must be in the same order as when they were defined). This + command generates the induction principle for each :n:`@ident__i`, following + the recursive structure and case analyses of the corresponding function + :n:`@ident__i'`. .. warning:: @@ -349,17 +348,17 @@ Generation of inversion principles with ``Derive`` ``Inversion`` :g:`inversion`. -.. cmdv:: Derive Inversion_clear @ident with forall (x:T), I t Sort sort +.. cmdv:: Derive Inversion_clear @ident with forall (x:T), I t Sort @sort When applied, it is equivalent to having inverted the instance with the tactic inversion replaced by the tactic `inversion_clear`. -.. cmdv:: Derive Dependent Inversion @ident with forall (x:T), I t Sort sort +.. cmdv:: Derive Dependent Inversion @ident with forall (x:T), I t Sort @sort When applied, it is equivalent to having inverted the instance with the tactic `dependent inversion`. -.. cmdv:: Derive Dependent Inversion_clear @ident with forall(x:T), I t Sort sort +.. cmdv:: Derive Dependent Inversion_clear @ident with forall(x:T), I t Sort @sort When applied, it is equivalent to having inverted the instance with the tactic `dependent inversion_clear`. @@ -377,8 +376,8 @@ Generation of inversion principles with ``Derive`` ``Inversion`` Parameter P : nat -> nat -> Prop. - To generate the inversion lemma for the instance `(Le (S n) m)` and the - sort `Prop`, we do: + To generate the inversion lemma for the instance :g:`(Le (S n) m)` and the + sort :g:`Prop`, we do: .. coqtop:: all diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 2214cbfb34..a5869055fa 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -31,8 +31,8 @@ Basic notations .. cmd:: Notation -A *notation* is a symbolic expression denoting some term or term -pattern. + A *notation* is a symbolic expression denoting some term or term + pattern. A typical notation is the use of the infix symbol ``/\`` to denote the logical conjunction (and). Such a notation is declared by @@ -1040,6 +1040,8 @@ interpreted in the scope stack extended with the scope bound tokey. To remove a delimiting key of a scope, use the command :n:`Undelimit Scope @scope` +.. _ArgumentScopes: + Binding arguments of a constant to an interpretation scope +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -1307,6 +1309,65 @@ Displaying information about scopes It also displays the delimiting key if any and the class to which the scope is bound, if any. +Impact of scopes on printing +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When several notations are available for printing the same expression, +Coq will use the following rules for printing priorities: + +- If two notations are available in different scopes which are open, + the notation in the more recently opened scope takes precedence. + +- If two notations are available in the same scope, the more recently + defined (or imported) notation takes precedence. + +- Abbreviations and lonely notations, both of which have no scope, + take precedence over a notation in an open scope if and only if the + abbreviation or lonely notation was defined (or imported) more + recently than when the corresponding scope was open. They take + precedence over any notation not in an open scope, whether this scope + has a delimiter or not. + +- A scope is *active* for printing a term either because it was opened + with :cmd:`Open Scope`, or the term is the immediate argument of a + constant which temporarily opens a scope for this argument (see + :ref:`Arguments <ArgumentScopes>`) in which case this temporary + scope is the most recent open one. + +- In case no abbreviation, nor lonely notation, nor notation in an + explicitly open scope, nor notation in a temporarily open scope of + arguments, has been found, notations in those closed scopes which + have a delimiter are considered, giving priority to the most + recently defined (or imported) ones. The corresponding delimiter is + inserted, making the corresponding scope the most recent explicitly + open scope for all subterms of the current term. As an exception to + the insertion of the corresponding delimiter, when an expression is + statically known to be in a position expecting a type and the + notation is from scope ``type_scope``, and the latter is closed, the + delimiter is not inserted. This is because expressions statically + known to be in a position expecting a type are by default + interpreted with `type_scope` temporarily activated. Expressions + statically known to be in a position expecting a type typically + include being on the right-hand side of `:`, `<:`, `<<:` and after + the comma in a `forall` expression. + +- As a refinement of the previous rule, in the case of applied global + references, notations in a non-opened scope with delimiter + specifically defined for this applied global reference take priority + over notations in a non-opened scope with delimiter for generic + applications. For instance, in the presence of ``Notation "f ( x + )" := (f x) (at level 10, format "f ( x )") : app_scope`` and + ``Notation "x '.+1'" := (S x) (at level 10, format "x '.+1'") : + mynat_scope.`` and both of ``app_scope`` and ``mynat_scope`` being + bound to a delimiter *and* both not opened, the latter, more + specific notation will always take precedence over the first, more + generic one. + +- A scope can be closed by using :cmd:`Close Scope` and its delimiter + removed by using :cmd:`Undelimit Scope`. To remove automatic + temporary opening of scopes for arguments of a constant, use + :ref:`Arguments <ArgumentScopes>`. + .. _Abbreviations: Abbreviations @@ -1380,147 +1441,147 @@ Numeral notations .. cmd:: Numeral Notation @ident__1 @ident__2 @ident__3 : @scope. :name: Numeral Notation - This command allows the user to customize the way numeral literals - are parsed and printed. + This command allows the user to customize the way numeral literals + are parsed and printed. - The token :n:`@ident__1` should be the name of an inductive type, - while :n:`@ident__2` and :n:`@ident__3` should be the names of the - parsing and printing functions, respectively. The parsing function - :n:`@ident__2` should have one of the following types: + The token :n:`@ident__1` should be the name of an inductive type, + while :n:`@ident__2` and :n:`@ident__3` should be the names of the + parsing and printing functions, respectively. The parsing function + :n:`@ident__2` should have one of the following types: - * :n:`Decimal.int -> @ident__1` - * :n:`Decimal.int -> option @ident__1` - * :n:`Decimal.uint -> @ident__1` - * :n:`Decimal.uint -> option @ident__1` - * :n:`Z -> @ident__1` - * :n:`Z -> option @ident__1` + * :n:`Decimal.int -> @ident__1` + * :n:`Decimal.int -> option @ident__1` + * :n:`Decimal.uint -> @ident__1` + * :n:`Decimal.uint -> option @ident__1` + * :n:`Z -> @ident__1` + * :n:`Z -> option @ident__1` - And the printing function :n:`@ident__3` should have one of the - following types: + And the printing function :n:`@ident__3` should have one of the + following types: - * :n:`@ident__1 -> Decimal.int` - * :n:`@ident__1 -> option Decimal.int` - * :n:`@ident__1 -> Decimal.uint` - * :n:`@ident__1 -> option Decimal.uint` - * :n:`@ident__1 -> Z` - * :n:`@ident__1 -> option Z` + * :n:`@ident__1 -> Decimal.int` + * :n:`@ident__1 -> option Decimal.int` + * :n:`@ident__1 -> Decimal.uint` + * :n:`@ident__1 -> option Decimal.uint` + * :n:`@ident__1 -> Z` + * :n:`@ident__1 -> option Z` - When parsing, the application of the parsing function - :n:`@ident__2` to the number will be fully reduced, and universes - of the resulting term will be refreshed. + When parsing, the application of the parsing function + :n:`@ident__2` to the number will be fully reduced, and universes + of the resulting term will be refreshed. - .. cmdv:: Numeral Notation @ident__1 @ident__2 @ident__3 : @scope (warning after @num). + .. cmdv:: Numeral Notation @ident__1 @ident__2 @ident__3 : @scope (warning after @num). - When a literal larger than :token:`num` is parsed, a warning - message about possible stack overflow, resulting from evaluating - :n:`@ident__2`, will be displayed. + When a literal larger than :token:`num` is parsed, a warning + message about possible stack overflow, resulting from evaluating + :n:`@ident__2`, will be displayed. - .. cmdv:: Numeral Notation @ident__1 @ident__2 @ident__3 : @scope (abstract after @num). + .. cmdv:: Numeral Notation @ident__1 @ident__2 @ident__3 : @scope (abstract after @num). - When a literal :g:`m` larger than :token:`num` is parsed, the - result will be :n:`(@ident__2 m)`, without reduction of this - application to a normal form. Here :g:`m` will be a - :g:`Decimal.int` or :g:`Decimal.uint` or :g:`Z`, depending on the - type of the parsing function :n:`@ident__2`. This allows for a - more compact representation of literals in types such as :g:`nat`, - and limits parse failures due to stack overflow. Note that a - warning will be emitted when an integer larger than :token:`num` - is parsed. Note that :n:`(abstract after @num)` has no effect - when :n:`@ident__2` lands in an :g:`option` type. + When a literal :g:`m` larger than :token:`num` is parsed, the + result will be :n:`(@ident__2 m)`, without reduction of this + application to a normal form. Here :g:`m` will be a + :g:`Decimal.int` or :g:`Decimal.uint` or :g:`Z`, depending on the + type of the parsing function :n:`@ident__2`. This allows for a + more compact representation of literals in types such as :g:`nat`, + and limits parse failures due to stack overflow. Note that a + warning will be emitted when an integer larger than :token:`num` + is parsed. Note that :n:`(abstract after @num)` has no effect + when :n:`@ident__2` lands in an :g:`option` type. - .. exn:: Cannot interpret this number as a value of type @type + .. exn:: Cannot interpret this number as a value of type @type - The numeral notation registered for :token:`type` does not support - the given numeral. This error is given when the interpretation - function returns :g:`None`, or if the interpretation is registered - for only non-negative integers, and the given numeral is negative. + The numeral notation registered for :token:`type` does not support + the given numeral. This error is given when the interpretation + function returns :g:`None`, or if the interpretation is registered + for only non-negative integers, and the given numeral is negative. - .. exn:: @ident should go from Decimal.int to @type or (option @type). Instead of Decimal.int, the types Decimal.uint or Z could be used{? (require BinNums first)}. + .. exn:: @ident should go from Decimal.int to @type or (option @type). Instead of Decimal.int, the types Decimal.uint or Z could be used{? (require BinNums first)}. - The parsing function given to the :cmd:`Numeral Notation` - vernacular is not of the right type. + The parsing function given to the :cmd:`Numeral Notation` + vernacular is not of the right type. - .. exn:: @ident should go from @type to Decimal.int or (option Decimal.int). Instead of Decimal.int, the types Decimal.uint or Z could be used{? (require BinNums first)}. + .. exn:: @ident should go from @type to Decimal.int or (option Decimal.int). Instead of Decimal.int, the types Decimal.uint or Z could be used{? (require BinNums first)}. - The printing function given to the :cmd:`Numeral Notation` - vernacular is not of the right type. + The printing function given to the :cmd:`Numeral Notation` + vernacular is not of the right type. - .. exn:: @type is not an inductive type. + .. exn:: @type is not an inductive type. - Numeral notations can only be declared for inductive types with no - arguments. + Numeral notations can only be declared for inductive types with no + arguments. - .. exn:: Unexpected term @term while parsing a numeral notation. + .. exn:: Unexpected term @term while parsing a numeral notation. - Parsing functions must always return ground terms, made up of - applications of constructors and inductive types. Parsing - functions may not return terms containing axioms, bare - (co)fixpoints, lambdas, etc. + Parsing functions must always return ground terms, made up of + applications of constructors and inductive types. Parsing + functions may not return terms containing axioms, bare + (co)fixpoints, lambdas, etc. - .. exn:: Unexpected non-option term @term while parsing a numeral notation. + .. exn:: Unexpected non-option term @term while parsing a numeral notation. - Parsing functions expected to return an :g:`option` must always - return a concrete :g:`Some` or :g:`None` when applied to a - concrete numeral expressed as a decimal. They may not return - opaque constants. + Parsing functions expected to return an :g:`option` must always + return a concrete :g:`Some` or :g:`None` when applied to a + concrete numeral expressed as a decimal. They may not return + opaque constants. - .. exn:: Cannot interpret in @scope because @ident could not be found in the current environment. + .. exn:: Cannot interpret in @scope because @ident could not be found in the current environment. - The inductive type used to register the numeral notation is no - longer available in the environment. Most likely, this is because - the numeral notation was declared inside a functor for an - inductive type inside the functor. This use case is not currently - supported. + The inductive type used to register the numeral notation is no + longer available in the environment. Most likely, this is because + the numeral notation was declared inside a functor for an + inductive type inside the functor. This use case is not currently + supported. - Alternatively, you might be trying to use a primitive token - notation from a plugin which forgot to specify which module you - must :g:`Require` for access to that notation. + Alternatively, you might be trying to use a primitive token + notation from a plugin which forgot to specify which module you + must :g:`Require` for access to that notation. - .. exn:: Syntax error: [prim:reference] expected after 'Notation' (in [vernac:command]). + .. exn:: Syntax error: [prim:reference] expected after 'Notation' (in [vernac:command]). - The type passed to :cmd:`Numeral Notation` must be a single - identifier. + The type passed to :cmd:`Numeral Notation` must be a single + identifier. - .. exn:: Syntax error: [prim:reference] expected after [prim:reference] (in [vernac:command]). + .. exn:: Syntax error: [prim:reference] expected after [prim:reference] (in [vernac:command]). - Both functions passed to :cmd:`Numeral Notation` must be single - identifiers. + Both functions passed to :cmd:`Numeral Notation` must be single + identifiers. - .. exn:: The reference @ident was not found in the current environment. + .. exn:: The reference @ident was not found in the current environment. - Identifiers passed to :cmd:`Numeral Notation` must exist in the - global environment. + Identifiers passed to :cmd:`Numeral Notation` must exist in the + global environment. - .. exn:: @ident is bound to a notation that does not denote a reference. + .. exn:: @ident is bound to a notation that does not denote a reference. - Identifiers passed to :cmd:`Numeral Notation` must be global - references, or notations which denote to single identifiers. + Identifiers passed to :cmd:`Numeral Notation` must be global + references, or notations which denote to single identifiers. - .. warn:: Stack overflow or segmentation fault happens when working with large numbers in @type (threshold may vary depending on your system limits and on the command executed). + .. warn:: Stack overflow or segmentation fault happens when working with large numbers in @type (threshold may vary depending on your system limits and on the command executed). - When a :cmd:`Numeral Notation` is registered in the current scope - with :n:`(warning after @num)`, this warning is emitted when - parsing a numeral greater than or equal to :token:`num`. + When a :cmd:`Numeral Notation` is registered in the current scope + with :n:`(warning after @num)`, this warning is emitted when + parsing a numeral greater than or equal to :token:`num`. - .. warn:: To avoid stack overflow, large numbers in @type are interpreted as applications of @ident__2. + .. warn:: To avoid stack overflow, large numbers in @type are interpreted as applications of @ident__2. - When a :cmd:`Numeral Notation` is registered in the current scope - with :n:`(abstract after @num)`, this warning is emitted when - parsing a numeral greater than or equal to :token:`num`. - Typically, this indicates that the fully computed representation - of numerals can be so large that non-tail-recursive OCaml - functions run out of stack space when trying to walk them. + When a :cmd:`Numeral Notation` is registered in the current scope + with :n:`(abstract after @num)`, this warning is emitted when + parsing a numeral greater than or equal to :token:`num`. + Typically, this indicates that the fully computed representation + of numerals can be so large that non-tail-recursive OCaml + functions run out of stack space when trying to walk them. - For example + For example - .. coqtop:: all + .. coqtop:: all - Check 90000. + Check 90000. - .. warn:: The 'abstract after' directive has no effect when the parsing function (@ident__2) targets an option type. + .. warn:: The 'abstract after' directive has no effect when the parsing function (@ident__2) targets an option type. - As noted above, the :n:`(abstract after @num)` directive has no - effect when :n:`@ident__2` lands in an :g:`option` type. + As noted above, the :n:`(abstract after @num)` directive has no + effect when :n:`@ident__2` lands in an :g:`option` type. .. _TacticNotation: diff --git a/engine/eConstr.ml b/engine/eConstr.ml index cfc4bea85f..96f1ce5e60 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -296,6 +296,8 @@ let decompose_prod_n_assum sigma n c = let existential_type = Evd.existential_type +let lift n c = of_constr (Vars.lift n (unsafe_to_constr c)) + let map_under_context f n c = let f c = unsafe_to_constr (f (of_constr c)) in of_constr (Constr.map_under_context f n (unsafe_to_constr c)) @@ -306,137 +308,21 @@ let map_return_predicate f ci p = let f c = unsafe_to_constr (f (of_constr c)) in of_constr (Constr.map_return_predicate f ci (unsafe_to_constr p)) -let map_gen userview sigma f c = match kind sigma c with - | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> c - | Cast (b,k,t) -> - let b' = f b in - let t' = f t in - if b'==b && t' == t then c - else mkCast (b', k, t') - | Prod (na,t,b) -> - let b' = f b in - let t' = f t in - if b'==b && t' == t then c - else mkProd (na, t', b') - | Lambda (na,t,b) -> - let b' = f b in - let t' = f t in - if b'==b && t' == t then c - else mkLambda (na, t', b') - | LetIn (na,b,t,k) -> - let b' = f b in - let t' = f t in - let k' = f k in - if b'==b && t' == t && k'==k then c - else mkLetIn (na, b', t', k') - | App (b,l) -> - let b' = f b in - let l' = Array.Smart.map f l in - if b'==b && l'==l then c - else mkApp (b', l') - | Proj (p,t) -> - let t' = f t in - if t' == t then c - else mkProj (p, t') - | Evar (e,l) -> - let l' = Array.Smart.map f l in - if l'==l then c - else mkEvar (e, l') - | Case (ci,p,b,bl) when userview -> - let b' = f b in - let p' = map_return_predicate f ci p in - let bl' = map_branches f ci bl in - if b'==b && p'==p && bl'==bl then c - else mkCase (ci, p', b', bl') - | Case (ci,p,b,bl) -> - let b' = f b in - let p' = f p in - let bl' = Array.Smart.map f bl in - if b'==b && p'==p && bl'==bl then c - else mkCase (ci, p', b', bl') - | Fix (ln,(lna,tl,bl)) -> - let tl' = Array.Smart.map f tl in - let bl' = Array.Smart.map f bl in - if tl'==tl && bl'==bl then c - else mkFix (ln,(lna,tl',bl')) - | CoFix(ln,(lna,tl,bl)) -> - let tl' = Array.Smart.map f tl in - let bl' = Array.Smart.map f bl in - if tl'==tl && bl'==bl then c - else mkCoFix (ln,(lna,tl',bl')) - -let map_user_view = map_gen true -let map = map_gen false - -let map_with_binders sigma g f l c0 = match kind sigma c0 with - | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> c0 - | Cast (c, k, t) -> - let c' = f l c in - let t' = f l t in - if c' == c && t' == t then c0 - else mkCast (c', k, t') - | Prod (na, t, c) -> - let t' = f l t in - let c' = f (g l) c in - if t' == t && c' == c then c0 - else mkProd (na, t', c') - | Lambda (na, t, c) -> - let t' = f l t in - let c' = f (g l) c in - if t' == t && c' == c then c0 - else mkLambda (na, t', c') - | LetIn (na, b, t, c) -> - let b' = f l b in - let t' = f l t in - let c' = f (g l) c in - if b' == b && t' == t && c' == c then c0 - else mkLetIn (na, b', t', c') - | App (c, al) -> - let c' = f l c in - let al' = Array.Fun1.Smart.map f l al in - if c' == c && al' == al then c0 - else mkApp (c', al') - | Proj (p, t) -> - let t' = f l t in - if t' == t then c0 - else mkProj (p, t') - | Evar (e, al) -> - let al' = Array.Fun1.Smart.map f l al in - if al' == al then c0 - else mkEvar (e, al') - | Case (ci, p, c, bl) -> - let p' = f l p in - let c' = f l c in - let bl' = Array.Fun1.Smart.map f l bl in - if p' == p && c' == c && bl' == bl then c0 - else mkCase (ci, p', c', bl') - | Fix (ln, (lna, tl, bl)) -> - let tl' = Array.Fun1.Smart.map f l tl in - let l' = iterate g (Array.length tl) l in - let bl' = Array.Fun1.Smart.map f l' bl in - if tl' == tl && bl' == bl then c0 - else mkFix (ln,(lna,tl',bl')) - | CoFix(ln,(lna,tl,bl)) -> - let tl' = Array.Fun1.Smart.map f l tl in - let l' = iterate g (Array.length tl) l in - let bl' = Array.Fun1.Smart.map f l' bl in - mkCoFix (ln,(lna,tl',bl')) - -let iter sigma f c = match kind sigma c with - | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> () - | Cast (c,_,t) -> f c; f t - | Prod (_,t,c) -> f t; f c - | Lambda (_,t,c) -> f t; f c - | LetIn (_,b,t,c) -> f b; f t; f c - | App (c,l) -> f c; Array.iter f l - | Proj (p,c) -> f c - | Evar (_,l) -> Array.iter f l - | Case (_,p,c,bl) -> f p; f c; Array.iter f bl - | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl - | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl +let map_user_view sigma f c = + let f c = unsafe_to_constr (f (of_constr c)) in + of_constr (Constr.map_user_view f (unsafe_to_constr (whd_evar sigma c))) + +let map sigma f c = + let f c = unsafe_to_constr (f (of_constr c)) in + of_constr (Constr.map f (unsafe_to_constr (whd_evar sigma c))) + +let map_with_binders sigma g f l c = + let f l c = unsafe_to_constr (f l (of_constr c)) in + of_constr (Constr.map_with_binders g f l (unsafe_to_constr (whd_evar sigma c))) + +let iter sigma f c = + let f c = f (of_constr c) in + Constr.iter f (unsafe_to_constr (whd_evar sigma c)) let iter_with_full_binders sigma g f n c = let open Context.Rel.Declaration in @@ -453,31 +339,20 @@ let iter_with_full_binders sigma g f n c = | Proj (p,c) -> f n c | Fix (_,(lna,tl,bl)) -> Array.iter (f n) tl; - let n' = Array.fold_left2 (fun n na t -> g (LocalAssum (na,t)) n) n lna tl in + let n' = Array.fold_left2_i (fun i n na t -> g (LocalAssum (na, lift i t)) n) n lna tl in Array.iter (f n') bl | CoFix (_,(lna,tl,bl)) -> Array.iter (f n) tl; - let n' = Array.fold_left2 (fun n na t -> g (LocalAssum (na,t)) n) n lna tl in + let n' = Array.fold_left2_i (fun i n na t -> g (LocalAssum (na,lift i t)) n) n lna tl in Array.iter (f n') bl let iter_with_binders sigma g f n c = - iter_with_full_binders sigma (fun _ acc -> g acc) f n c + let f l c = f l (of_constr c) in + Constr.iter_with_binders g f n (unsafe_to_constr (whd_evar sigma c)) -let fold sigma f acc c = match kind sigma c with - | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> acc - | Cast (c,_,t) -> f (f acc c) t - | Prod (_,t,c) -> f (f acc t) c - | Lambda (_,t,c) -> f (f acc t) c - | LetIn (_,b,t,c) -> f (f (f acc b) t) c - | App (c,l) -> Array.fold_left f (f acc c) l - | Proj (p,c) -> f acc c - | Evar (_,l) -> Array.fold_left f acc l - | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl - | Fix (_,(lna,tl,bl)) -> - Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl - | CoFix (_,(lna,tl,bl)) -> - Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl +let fold sigma f acc c = + let f acc c = f acc (of_constr c) in + Constr.fold f acc (unsafe_to_constr (whd_evar sigma c)) let compare_gen k eq_inst eq_sort eq_constr nargs c1 c2 = (c1 == c2) || Constr.compare_head_gen_with k k eq_inst eq_sort eq_constr nargs c1 c2 @@ -712,7 +587,7 @@ let to_rel_decl = unsafe_to_rel_decl type substl = t list (** Operations that commute with evar-normalization *) -let lift n c = of_constr (Vars.lift n (to_constr c)) +let lift = lift let liftn n m c = of_constr (Vars.liftn n m (to_constr c)) let substnl subst n c = of_constr (Vars.substnl (cast_list unsafe_eq subst) n (to_constr c)) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 4e1636e321..69ee5223c4 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -50,6 +50,18 @@ let new_global evd x = (* Expanding/testing/exposing existential variables *) (****************************************************) +let finalize ?abort_on_undefined_evars sigma f = + let sigma = minimize_universes sigma in + let uvars = ref Univ.LSet.empty in + let v = f (fun c -> + let varsc = EConstr.universes_of_constr sigma c in + let c = EConstr.to_constr ?abort_on_undefined_evars sigma c in + uvars := Univ.LSet.union !uvars varsc; + c) + in + let sigma = restrict_universe_context sigma !uvars in + sigma, v + (* flush_and_check_evars fails if an existential is undefined *) exception Uninstantiated_evar of Evar.t diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 0c8d8c9b8a..0e67475778 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -181,6 +181,19 @@ val nf_evars_universes : evar_map -> Constr.constr -> Constr.constr exception Uninstantiated_evar of Evar.t val flush_and_check_evars : evar_map -> constr -> Constr.constr +(** [finalize env sigma f] combines universe minimisation, + evar-and-universe normalisation and universe restriction. + + It minimizes universes in [sigma], calls [f] a normalisation + function with respect to the updated [sigma] and restricts the + local universes of [sigma] to those encountered while running [f]. + + Note that the normalizer passed to [f] holds some imperative state + in its closure. *) +val finalize : ?abort_on_undefined_evars:bool -> evar_map -> + ((EConstr.t -> Constr.t) -> 'a) -> + evar_map * 'a + (** {6 Term manipulation up to instantiation} *) (** Like {!Constr.kind} except that [kind_of_term sigma t] exposes [t] diff --git a/engine/namegen.ml b/engine/namegen.ml index db72dc8ec3..a67ff6965b 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -208,25 +208,18 @@ let it_mkLambda_or_LetIn_name env sigma b hyps = (* Introduce a mode where auto-generated names are mangled to test dependence of scripts on auto-generated names *) -let mangle_names = ref false - -let _ = Goptions.( - declare_bool_option - { optdepr = false; - optname = "mangle auto-generated names"; - optkey = ["Mangle";"Names"]; - optread = (fun () -> !mangle_names); - optwrite = (:=) mangle_names; }) +let get_mangle_names = + Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"mangle auto-generated names" + ~key:["Mangle";"Names"] + ~value:false let mangle_names_prefix = ref (Id.of_string "_0") -let set_prefix x = mangle_names_prefix := forget_subscript x -let set_mangle_names_mode x = begin - set_prefix x; - mangle_names := true - end +let set_prefix x = mangle_names_prefix := forget_subscript x -let _ = Goptions.( +let () = Goptions.( declare_string_option { optdepr = false; optname = "mangled names prefix"; @@ -238,7 +231,7 @@ let _ = Goptions.( with CErrors.UserError _ -> CErrors.user_err Pp.(str ("Not a valid identifier: \"" ^ x ^ "\"."))) end }) -let mangle_id id = if !mangle_names then !mangle_names_prefix else id +let mangle_id id = if get_mangle_names () then !mangle_names_prefix else id (* Looks for next "good" name by lifting subscript *) diff --git a/engine/namegen.mli b/engine/namegen.mli index a53c3a0d1f..3722cbed24 100644 --- a/engine/namegen.mli +++ b/engine/namegen.mli @@ -125,7 +125,3 @@ val rename_bound_vars_as_displayed : val compute_displayed_name_in_gen : (evar_map -> int -> 'a -> bool) -> evar_map -> Id.Set.t -> Name.t -> 'a -> Name.t * Id.Set.t - -val set_mangle_names_mode : Id.t -> unit -(** Turn on mangled names mode and with the given prefix. - @raise UserError if the argument is invalid as an identifier. *) diff --git a/engine/termops.ml b/engine/termops.ml index ada6311067..98300764df 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -721,18 +721,16 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = let bl' = Array.map (f l) bl in if p==p' && c==c' && Array.for_all2 (==) bl bl' then cstr else mkCase (ci, p', c', bl') - | Fix (ln,(lna,tl,bl)) -> + | Fix (ln,(lna,tl,bl as fx)) -> let tl' = Array.map (f l) tl in - let l' = - Array.fold_left2 (fun l na t -> g (RelDecl.LocalAssum (na, t)) l) l lna tl in + let l' = fold_rec_types g fx l in let bl' = Array.map (f l') bl in if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then cstr else mkFix (ln,(lna,tl',bl')) - | CoFix(ln,(lna,tl,bl)) -> + | CoFix(ln,(lna,tl,bl as fx)) -> let tl' = Array.map (f l) tl in - let l' = - Array.fold_left2 (fun l na t -> g (RelDecl.LocalAssum (na, t)) l) l lna tl in + let l' = fold_rec_types g fx l in let bl' = Array.map (f l') bl in if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then cstr @@ -759,34 +757,17 @@ let fold_constr_with_full_binders sigma g f n acc c = Constr.fold_with_full_binders g f n acc c let fold_constr_with_binders sigma g f n acc c = - fold_constr_with_full_binders sigma (fun _ x -> g x) f n acc c + let open EConstr in + let f l acc c = f l acc (of_constr c) in + let c = Unsafe.to_constr (whd_evar sigma c) in + Constr.fold_constr_with_binders g f n acc c (* [iter_constr_with_full_binders g f acc c] iters [f acc] on the immediate subterms of [c]; it carries an extra data [acc] which is processed by [g] at each binder traversal; it is not recursive and the order with which subterms are processed is not specified *) -let iter_constr_with_full_binders sigma g f l c = - let open RelDecl in - match EConstr.kind sigma c with - | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> () - | Cast (c,_, t) -> f l c; f l t - | Prod (na,t,c) -> f l t; f (g (LocalAssum (na,t)) l) c - | Lambda (na,t,c) -> f l t; f (g (LocalAssum (na,t)) l) c - | LetIn (na,b,t,c) -> f l b; f l t; f (g (LocalDef (na,b,t)) l) c - | App (c,args) -> f l c; Array.iter (f l) args - | Proj (p,c) -> f l c - | Evar (_,args) -> Array.iter (f l) args - | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl - | Fix (_,(lna,tl,bl)) -> - let l' = Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in - Array.iter (f l) tl; - Array.iter (f l') bl - | CoFix (_,(lna,tl,bl)) -> - let l' = Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in - Array.iter (f l) tl; - Array.iter (f l') bl +let iter_constr_with_full_binders = EConstr.iter_with_full_binders (***************************) (* occurs check functions *) diff --git a/engine/termops.mli b/engine/termops.mli index 6c3d4fa612..eef8452e64 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -88,6 +88,7 @@ val iter_constr_with_full_binders : Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit +[@@ocaml.deprecated "Use [EConstr.iter_with_full_binders]."] (**********************************************************************) diff --git a/engine/uState.ml b/engine/uState.ml index 5747ae2ad4..6aecc368e6 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -441,11 +441,13 @@ let restrict_universe_context (univs, csts) keep = if LSet.is_empty removed then univs, csts else let allunivs = Constraint.fold (fun (u,_,v) all -> LSet.add u (LSet.add v all)) csts univs in - let g = UGraph.empty_universes in - let g = LSet.fold UGraph.add_universe_unconstrained allunivs g in + let g = UGraph.initial_universes in + let g = LSet.fold (fun v g -> if Level.is_small v then g else UGraph.add_universe v false g) allunivs g in let g = UGraph.merge_constraints csts g in - let allkept = LSet.diff allunivs removed in + let allkept = LSet.union (UGraph.domain UGraph.initial_universes) (LSet.diff allunivs removed) in let csts = UGraph.constraints_for ~kept:allkept g in + let csts = Constraint.filter (fun (l,d,r) -> + not ((Level.is_set l && d == Le) || (Level.is_prop l && d == Lt && Level.is_set r))) csts in (LSet.inter univs keep, csts) let restrict ctx vars = @@ -575,25 +577,33 @@ let add_global_univ uctx u = uctx_universes = univs } let make_flexible_variable ctx ~algebraic u = - let {uctx_local = cstrs; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} = ctx in - let uvars' = Univ.LMap.add u None uvars in - let avars' = - if algebraic then - let uu = Univ.Universe.make u in - let substu_not_alg u' v = - Option.cata (fun vu -> Univ.Universe.equal uu vu && not (Univ.LSet.mem u' avars)) false v - in - let has_upper_constraint () = - Univ.Constraint.exists - (fun (l,d,r) -> d == Univ.Lt && Univ.Level.equal l u) - (Univ.ContextSet.constraints cstrs) - in - if not (Univ.LMap.exists substu_not_alg uvars || has_upper_constraint ()) - then Univ.LSet.add u avars else avars - else avars - in - {ctx with uctx_univ_variables = uvars'; - uctx_univ_algebraic = avars'} + let open Univ in + let {uctx_local = cstrs; uctx_univ_variables = uvars; + uctx_univ_algebraic = avars; uctx_universes=g; } = ctx in + assert (try LMap.find u uvars == None with Not_found -> true); + match UGraph.choose (fun v -> not (Level.equal u v) && (algebraic || not (LSet.mem v avars))) g u with + | Some v -> + let uvars' = LMap.add u (Some (Universe.make v)) uvars in + { ctx with uctx_univ_variables = uvars'; } + | None -> + let uvars' = LMap.add u None uvars in + let avars' = + if algebraic then + let uu = Universe.make u in + let substu_not_alg u' v = + Option.cata (fun vu -> Universe.equal uu vu && not (LSet.mem u' avars)) false v + in + let has_upper_constraint () = + Constraint.exists + (fun (l,d,r) -> d == Lt && Level.equal l u) + (ContextSet.constraints cstrs) + in + if not (LMap.exists substu_not_alg uvars || has_upper_constraint ()) + then LSet.add u avars else avars + else avars + in + {ctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = avars'} let make_nonalgebraic_variable ctx u = { ctx with uctx_univ_algebraic = Univ.LSet.remove u ctx.uctx_univ_algebraic } diff --git a/engine/univMinim.ml b/engine/univMinim.ml index f10e6d2ec1..e20055b133 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -12,17 +12,12 @@ open Univ open UnivSubst (* To disallow minimization to Set *) -let set_minimization = ref true -let is_set_minimization () = !set_minimization - -let _ = - Goptions.(declare_bool_option - { optdepr = false; - optname = "minimization to Set"; - optkey = ["Universe";"Minimization";"ToSet"]; - optread = is_set_minimization; - optwrite = (:=) set_minimization }) - +let get_set_minimization = + Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"minimization to Set" + ~key:["Universe";"Minimization";"ToSet"] + ~value:true (** Simplification *) @@ -278,7 +273,7 @@ let normalize_context_set g ctx us algs weak = let smallles, csts = Constraint.partition (fun (l,d,r) -> d == Le && Level.is_small l) csts in - let smallles = if is_set_minimization () + let smallles = if get_set_minimization () then Constraint.filter (fun (l,d,r) -> LSet.mem r ctx) smallles else Constraint.empty in diff --git a/gramlib/dune b/gramlib/dune index 6a9e622b4c..8ca6aff25a 100644 --- a/gramlib/dune +++ b/gramlib/dune @@ -1,3 +1,4 @@ (library (name gramlib) - (public_name coq.gramlib)) + (public_name coq.gramlib) + (libraries coq.lib)) diff --git a/gramlib/gramext.ml b/gramlib/gramext.ml index 72468b540e..46c2688f05 100644 --- a/gramlib/gramext.ml +++ b/gramlib/gramext.ml @@ -8,7 +8,7 @@ type 'a parser_t = 'a Stream.t -> Obj.t type 'te grammar = { gtokens : (Plexing.pattern, int ref) Hashtbl.t; - mutable glexer : 'te Plexing.lexer } + glexer : 'te Plexing.lexer } type 'te g_entry = { egram : 'te grammar; @@ -52,11 +52,8 @@ type position = | Last | Before of string | After of string - | Like of string | Level of string -let warning_verbose = ref true - let rec derive_eps = function Slist0 _ -> true @@ -96,7 +93,7 @@ let is_before s1 s2 = | Stoken _, _ -> true | _ -> false -let insert_tree entry_name gsymbols action tree = +let insert_tree ~warning entry_name gsymbols action tree = let rec insert symbols tree = match symbols with s :: sl -> insert_in_tree s sl tree @@ -105,14 +102,16 @@ let insert_tree entry_name gsymbols action tree = Node {node = s; son = son; brother = bro} -> Node {node = s; son = son; brother = insert [] bro} | LocAct (old_action, action_list) -> - if !warning_verbose then - begin - eprintf "<W> Grammar extension: "; - if entry_name <> "" then eprintf "in [%s], " entry_name; - eprintf "some rule has been masked\n"; - flush stderr - end; - LocAct (action, old_action :: action_list) + begin match warning with + | None -> () + | Some warn_fn -> + let msg = + "<W> Grammar extension: " ^ + (if entry_name <> "" then "" else "in ["^entry_name^"%s], ") ^ + "some rule has been masked" in + warn_fn msg + end; + LocAct (action, old_action :: action_list) | DeadEnd -> LocAct (action, []) and insert_in_tree s sl tree = match try_insert s sl tree with @@ -141,51 +140,28 @@ let insert_tree entry_name gsymbols action tree = in insert gsymbols tree -let srules rl = +let srules ~warning rl = let t = List.fold_left - (fun tree (symbols, action) -> insert_tree "" symbols action tree) + (fun tree (symbols, action) -> insert_tree ~warning "" symbols action tree) DeadEnd rl in Stree t -external action : 'a -> g_action = "%identity" - let is_level_labelled n lev = match lev.lname with Some n1 -> n = n1 | None -> false -let rec token_exists_in_level f lev = - token_exists_in_tree f lev.lprefix || token_exists_in_tree f lev.lsuffix -and token_exists_in_tree f = - function - Node n -> - token_exists_in_symbol f n.node || token_exists_in_tree f n.brother || - token_exists_in_tree f n.son - | LocAct (_, _) | DeadEnd -> false -and token_exists_in_symbol f = - function - | Slist0 sy -> token_exists_in_symbol f sy - | Slist0sep (sy, sep, _) -> - token_exists_in_symbol f sy || token_exists_in_symbol f sep - | Slist1 sy -> token_exists_in_symbol f sy - | Slist1sep (sy, sep, _) -> - token_exists_in_symbol f sy || token_exists_in_symbol f sep - | Sopt sy -> token_exists_in_symbol f sy - | Stoken tok -> f tok - | Stree t -> token_exists_in_tree f t - | Snterm _ | Snterml (_, _) | Snext | Sself -> false - -let insert_level entry_name e1 symbols action slev = +let insert_level ~warning entry_name e1 symbols action slev = match e1 with true -> {assoc = slev.assoc; lname = slev.lname; - lsuffix = insert_tree entry_name symbols action slev.lsuffix; + lsuffix = insert_tree ~warning entry_name symbols action slev.lsuffix; lprefix = slev.lprefix} | false -> {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; - lprefix = insert_tree entry_name symbols action slev.lprefix} + lprefix = insert_tree ~warning entry_name symbols action slev.lprefix} let empty_lev lname assoc = let assoc = @@ -195,27 +171,33 @@ let empty_lev lname assoc = in {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} -let change_lev lev n lname assoc = +let change_lev ~warning lev n lname assoc = let a = match assoc with None -> lev.assoc | Some a -> - if a <> lev.assoc && !warning_verbose then - begin - eprintf "<W> Changing associativity of level \"%s\"\n" n; - flush stderr - end; + if a <> lev.assoc then + begin + match warning with + | None -> () + | Some warn_fn -> + warn_fn ("<W> Changing associativity of level \""^n^"\"") + end; a in begin match lname with Some n -> - if lname <> lev.lname && !warning_verbose then - begin eprintf "<W> Level label \"%s\" ignored\n" n; flush stderr end + if lname <> lev.lname then + begin match warning with + | None -> () + | Some warn_fn -> + warn_fn ("<W> Level label \""^n^"\" ignored") + end; | None -> () end; {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix} -let get_level entry position levs = +let get_level ~warning entry position levs = match position with Some First -> [], empty_lev, levs | Some Last -> levs, empty_lev, [] @@ -228,7 +210,7 @@ let get_level entry position levs = flush stderr; failwith "Grammar.extend" | lev :: levs -> - if is_level_labelled n lev then [], change_lev lev n, levs + if is_level_labelled n lev then [], change_lev ~warning lev n, levs else let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 in @@ -261,58 +243,11 @@ let get_level entry position levs = let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 in get levs - | Some (Like n) -> - let f (tok, prm) = n = tok || n = prm in - let rec get = - function - [] -> - eprintf "No level with \"%s\" in entry \"%s\"\n" n entry.ename; - flush stderr; - failwith "Grammar.extend" - | lev :: levs -> - if token_exists_in_level f lev then [], change_lev lev n, levs - else - let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 - in - get levs | None -> match levs with - lev :: levs -> [], change_lev lev "<top>", levs + lev :: levs -> [], change_lev ~warning lev "<top>", levs | [] -> [], empty_lev, [] -let rec check_gram entry = - function - Snterm e -> - if e.egram != entry.egram then - begin - eprintf "\ -Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush stderr; - failwith "Grammar.extend error" - end - | Snterml (e, _) -> - if e.egram != entry.egram then - begin - eprintf "\ -Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush stderr; - failwith "Grammar.extend error" - end - | Slist0sep (s, t, _) -> check_gram entry t; check_gram entry s - | Slist1sep (s, t, _) -> check_gram entry t; check_gram entry s - | Slist0 s -> check_gram entry s - | Slist1 s -> check_gram entry s - | Sopt s -> check_gram entry s - | Stree t -> tree_check_gram entry t - | Snext | Sself | Stoken _ -> () -and tree_check_gram entry = - function - Node {node = n; brother = bro; son = son} -> - check_gram entry n; tree_check_gram entry bro; tree_check_gram entry son - | LocAct (_, _) | DeadEnd -> () - let change_to_self entry = function Snterm e when e == entry -> Sself @@ -349,7 +284,7 @@ let insert_tokens gram symbols = in List.iter insert symbols -let levels_of_rules entry position rules = +let levels_of_rules ~warning entry position rules = let elev = match entry.edesc with Dlevels elev -> elev @@ -360,7 +295,7 @@ let levels_of_rules entry position rules = in if rules = [] then elev else - let (levs1, make_lev, levs2) = get_level entry position elev in + let (levs1, make_lev, levs2) = get_level ~warning entry position elev in let (levs, _) = List.fold_left (fun (levs, make_lev) (lname, assoc, level) -> @@ -369,10 +304,9 @@ let levels_of_rules entry position rules = List.fold_left (fun lev (symbols, action) -> let symbols = List.map (change_to_self entry) symbols in - List.iter (check_gram entry) symbols; let (e1, symbols) = get_initial entry symbols in insert_tokens entry.egram symbols; - insert_level entry.ename e1 symbols action lev) + insert_level ~warning entry.ename e1 symbols action lev) lev level in lev :: levs, empty_lev) diff --git a/gramlib/gramext.mli b/gramlib/gramext.mli index e888508277..f1e294fb4c 100644 --- a/gramlib/gramext.mli +++ b/gramlib/gramext.mli @@ -6,7 +6,7 @@ type 'a parser_t = 'a Stream.t -> Obj.t type 'te grammar = { gtokens : (Plexing.pattern, int ref) Hashtbl.t; - mutable glexer : 'te Plexing.lexer } + glexer : 'te Plexing.lexer } type 'te g_entry = { egram : 'te grammar; @@ -50,19 +50,16 @@ type position = | Last | Before of string | After of string - | Like of string | Level of string -val levels_of_rules : +val levels_of_rules : warning:(string -> unit) option -> 'te g_entry -> position option -> (string option * g_assoc option * ('te g_symbol list * g_action) list) list -> 'te g_level list -val srules : ('te g_symbol list * g_action) list -> 'te g_symbol -external action : 'a -> g_action = "%identity" + +val srules : warning:(string -> unit) option -> ('te g_symbol list * g_action) list -> 'te g_symbol val eq_symbol : 'a g_symbol -> 'a g_symbol -> bool val delete_rule_in_level_list : 'te g_entry -> 'te g_symbol list -> 'te g_level list -> 'te g_level list - -val warning_verbose : bool ref diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index 1ce0136c1d..0ad11d075f 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -5,6 +5,8 @@ open Gramext open Format +external gramext_action : 'a -> g_action = "%identity" + let rec flatten_tree = function DeadEnd -> [] @@ -128,7 +130,7 @@ let loc_of_token_interval bp ep = if bp == ep then if bp == 0 then Ploc.dummy else Ploc.after (!floc (bp - 1)) 0 1 else - let loc1 = !floc bp in let loc2 = !floc (pred ep) in Ploc.encl loc1 loc2 + let loc1 = !floc bp in let loc2 = !floc (pred ep) in Loc.merge loc1 loc2 let name_of_symbol entry = function @@ -184,84 +186,6 @@ and name_of_tree_failed entry = end | DeadEnd | LocAct (_, _) -> "???" -let search_tree_in_entry prev_symb tree = - function - Dlevels levels -> - let rec search_levels = - function - [] -> tree - | level :: levels -> - match search_level level with - Some tree -> tree - | None -> search_levels levels - and search_level level = - match search_tree level.lsuffix with - Some t -> Some (Node {node = Sself; son = t; brother = DeadEnd}) - | None -> search_tree level.lprefix - and search_tree t = - if tree <> DeadEnd && t == tree then Some t - else - match t with - Node n -> - begin match search_symbol n.node with - Some symb -> - Some (Node {node = symb; son = n.son; brother = DeadEnd}) - | None -> - match search_tree n.son with - Some t -> - Some (Node {node = n.node; son = t; brother = DeadEnd}) - | None -> search_tree n.brother - end - | LocAct (_, _) | DeadEnd -> None - and search_symbol symb = - match symb with - Snterm _ | Snterml (_, _) | Slist0 _ | Slist0sep (_, _, _) | - Slist1 _ | Slist1sep (_, _, _) | Sopt _ | Stoken _ | Stree _ - when symb == prev_symb -> - Some symb - | Slist0 symb -> - begin match search_symbol symb with - Some symb -> Some (Slist0 symb) - | None -> None - end - | Slist0sep (symb, sep, b) -> - begin match search_symbol symb with - Some symb -> Some (Slist0sep (symb, sep, b)) - | None -> - match search_symbol sep with - Some sep -> Some (Slist0sep (symb, sep, b)) - | None -> None - end - | Slist1 symb -> - begin match search_symbol symb with - Some symb -> Some (Slist1 symb) - | None -> None - end - | Slist1sep (symb, sep, b) -> - begin match search_symbol symb with - Some symb -> Some (Slist1sep (symb, sep, b)) - | None -> - match search_symbol sep with - Some sep -> Some (Slist1sep (symb, sep, b)) - | None -> None - end - | Sopt symb -> - begin match search_symbol symb with - Some symb -> Some (Sopt symb) - | None -> None - end - | Stree t -> - begin match search_tree t with - Some t -> Some (Stree t) - | None -> None - end - | _ -> None - in - search_levels levels - | Dparser _ -> tree - -let error_verbose = ref false - let tree_failed entry prev_symb_result prev_symb tree = let txt = name_of_tree_failed entry tree in let txt = @@ -293,18 +217,6 @@ let tree_failed entry prev_symb_result prev_symb tree = | Sopt _ | Stree _ -> txt ^ " expected" | _ -> txt ^ " expected after " ^ name_of_symbol_failed entry prev_symb in - if !error_verbose then - begin let tree = search_tree_in_entry prev_symb tree entry.edesc in - let ppf = err_formatter in - fprintf ppf "@[<v 0>@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename; - fprintf ppf "@["; - print_level ppf pp_force_newline (flatten_tree tree); - fprintf ppf "@]@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "@]@." - end; txt ^ " (in [" ^ entry.ename ^ "])" let symb_failed entry prev_symb_result prev_symb symb = @@ -350,7 +262,7 @@ let top_tree entry = | LocAct (_, _) | DeadEnd -> raise Stream.Failure let skip_if_empty bp p strm = - if Stream.count strm == bp then Gramext.action (fun a -> p strm) + if Stream.count strm == bp then gramext_action (fun a -> p strm) else raise Stream.Failure let continue entry bp a s son p1 (strm__ : _ Stream.t) = @@ -359,7 +271,7 @@ let continue entry bp a s son p1 (strm__ : _ Stream.t) = try p1 strm__ with Stream.Failure -> raise (Stream.Error (tree_failed entry a s son)) in - Gramext.action (fun _ -> app act a) + gramext_action (fun _ -> app act a) let do_recover parser_of_tree entry nlevn alevn bp a s son (strm__ : _ Stream.t) = @@ -372,11 +284,8 @@ let do_recover parser_of_tree entry nlevn alevn bp a s son continue entry bp a s son (parser_of_tree entry nlevn alevn son) strm__ -let strict_parsing = ref false - let recover parser_of_tree entry nlevn alevn bp a s son strm = - if !strict_parsing then raise (Stream.Error (tree_failed entry a s son)) - else do_recover parser_of_tree entry nlevn alevn bp a s son strm + do_recover parser_of_tree entry nlevn alevn bp a s son strm let token_count = ref 0 @@ -753,9 +662,9 @@ let init_entry_functions entry = let f = continue_parser_of_entry entry in entry.econtinue <- f; f lev bp a strm) -let extend_entry entry position rules = +let extend_entry ~warning entry position rules = try - let elev = Gramext.levels_of_rules entry position rules in + let elev = Gramext.levels_of_rules ~warning entry position rules in entry.edesc <- Dlevels elev; init_entry_functions entry with Plexing.Error s -> Printf.eprintf "Lexer initialization error:\n- %s\n" s; @@ -792,8 +701,6 @@ let tokens g con = g.gtokens; !list -let glexer g = g.glexer - type 'te gen_parsable = { pa_chr_strm : char Stream.t; pa_tok_strm : 'te Stream.t; @@ -814,7 +721,7 @@ let parse_parsable entry p = let cnt = Stream.count ts in let loc = fun_loc cnt in if !token_count - 1 <= cnt then loc - else Ploc.encl loc (fun_loc (!token_count - 1)) + else Loc.merge loc (fun_loc (!token_count - 1)) with Failure _ -> Ploc.make_unlined (Stream.count cs, Stream.count cs + 1) in floc := fun_loc; @@ -839,8 +746,6 @@ let clear_entry e = Dlevels _ -> e.edesc <- Dlevels [] | Dparser _ -> () -let gram_reinit g glexer = Hashtbl.clear g.gtokens; g.glexer <- glexer - (* Functorial interface *) module type GLexerType = sig type te val lexer : te Plexing.lexer end @@ -851,7 +756,6 @@ module type S = type parsable val parsable : char Stream.t -> parsable val tokens : string -> (string * int) list - val glexer : te Plexing.lexer module Entry : sig type 'a e @@ -861,7 +765,6 @@ module type S = val of_parser : string -> (te Stream.t -> 'a) -> 'a e val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit - external obj : 'a e -> te Gramext.g_entry = "%identity" end type ('self, 'a) ty_symbol type ('self, 'f, 'r) ty_rule @@ -880,29 +783,21 @@ module type S = val s_self : ('self, 'self) ty_symbol val s_next : ('self, 'self) ty_symbol val s_token : Plexing.pattern -> ('self, string) ty_symbol - val s_rules : 'a ty_production list -> ('self, 'a) ty_symbol + val s_rules : warning:(string -> unit) option -> 'a ty_production list -> ('self, 'a) ty_symbol val r_stop : ('self, 'r, 'r) ty_rule val r_next : ('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol -> ('self, 'b -> 'a, 'r) ty_rule - val production : ('a, 'f, Ploc.t -> 'a) ty_rule * 'f -> 'a ty_production + val production : ('a, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_production module Unsafe : sig - val gram_reinit : te Plexing.lexer -> unit val clear_entry : 'a Entry.e -> unit end - val extend : - 'a Entry.e -> Gramext.position option -> - (string option * Gramext.g_assoc option * - (te Gramext.g_symbol list * Gramext.g_action) list) - list -> - unit - val safe_extend : + val safe_extend : warning:(string -> unit) option -> 'a Entry.e -> Gramext.position option -> (string option * Gramext.g_assoc option * 'a ty_production list) list -> unit - val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit val safe_delete_rule : 'a Entry.e -> ('a, 'r, 'f) ty_rule -> unit end @@ -915,7 +810,6 @@ module GMake (L : GLexerType) = let (ts, lf) = L.lexer.Plexing.tok_func cs in {pa_chr_strm = cs; pa_tok_strm = ts; pa_loc_func = lf} let tokens = tokens gram - let glexer = glexer gram module Entry = struct type 'a e = te g_entry @@ -951,23 +845,20 @@ module GMake (L : GLexerType) = let s_self = Sself let s_next = Snext let s_token tok = Stoken tok - let s_rules (t : Obj.t ty_production list) = Gramext.srules (Obj.magic t) + let s_rules ~warning (t : Obj.t ty_production list) = Gramext.srules ~warning (Obj.magic t) let r_stop = [] let r_next r s = r @ [s] let production - (p : ('a, 'f, Ploc.t -> 'a) ty_rule * 'f) : 'a ty_production = + (p : ('a, 'f, Loc.t -> 'a) ty_rule * 'f) : 'a ty_production = Obj.magic p module Unsafe = struct - let gram_reinit = gram_reinit gram let clear_entry = clear_entry end - let extend = extend_entry - let safe_extend e pos + let safe_extend ~warning e pos (r : (string option * Gramext.g_assoc option * Obj.t ty_production list) list) = - extend e pos (Obj.magic r) - let delete_rule e r = delete_rule (Entry.obj e) r - let safe_delete_rule = delete_rule + extend_entry ~warning e pos (Obj.magic r) + let safe_delete_rule e r = delete_rule (Entry.obj e) r end diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli index 1c5fcb7bbf..bde07ddc48 100644 --- a/gramlib/grammar.mli +++ b/gramlib/grammar.mli @@ -25,7 +25,6 @@ module type S = type parsable val parsable : char Stream.t -> parsable val tokens : string -> (string * int) list - val glexer : te Plexing.lexer module Entry : sig type 'a e @@ -35,7 +34,6 @@ module type S = val of_parser : string -> (te Stream.t -> 'a) -> 'a e val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit - external obj : 'a e -> te Gramext.g_entry = "%identity" end type ('self, 'a) ty_symbol type ('self, 'f, 'r) ty_rule @@ -54,30 +52,22 @@ module type S = val s_self : ('self, 'self) ty_symbol val s_next : ('self, 'self) ty_symbol val s_token : Plexing.pattern -> ('self, string) ty_symbol - val s_rules : 'a ty_production list -> ('self, 'a) ty_symbol + val s_rules : warning:(string -> unit) option -> 'a ty_production list -> ('self, 'a) ty_symbol val r_stop : ('self, 'r, 'r) ty_rule val r_next : ('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol -> ('self, 'b -> 'a, 'r) ty_rule - val production : ('a, 'f, Ploc.t -> 'a) ty_rule * 'f -> 'a ty_production + val production : ('a, 'f, Loc.t -> 'a) ty_rule * 'f -> 'a ty_production module Unsafe : sig - val gram_reinit : te Plexing.lexer -> unit val clear_entry : 'a Entry.e -> unit end - val extend : - 'a Entry.e -> Gramext.position option -> - (string option * Gramext.g_assoc option * - (te Gramext.g_symbol list * Gramext.g_action) list) - list -> - unit - val safe_extend : + val safe_extend : warning:(string -> unit) option -> 'a Entry.e -> Gramext.position option -> (string option * Gramext.g_assoc option * 'a ty_production list) list -> unit - val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit val safe_delete_rule : 'a Entry.e -> ('a, 'f, 'r) ty_rule -> unit end (** Signature type of the functor [Grammar.GMake]. The types and diff --git a/gramlib/plexing.ml b/gramlib/plexing.ml index 986363ec1f..f99a3c2480 100644 --- a/gramlib/plexing.ml +++ b/gramlib/plexing.ml @@ -6,14 +6,13 @@ type pattern = string * string exception Error of string -type location = Ploc.t -type location_function = int -> location +type location_function = int -> Loc.t type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function type 'te lexer = { tok_func : 'te lexer_func; tok_using : pattern -> unit; tok_removing : pattern -> unit; - mutable tok_match : pattern -> 'te -> string; + tok_match : pattern -> 'te -> string; tok_text : pattern -> string; - mutable tok_comm : location list option } + } diff --git a/gramlib/plexing.mli b/gramlib/plexing.mli index 96b432a8ad..eed4082e00 100644 --- a/gramlib/plexing.mli +++ b/gramlib/plexing.mli @@ -28,10 +28,10 @@ type 'te lexer = { tok_func : 'te lexer_func; tok_using : pattern -> unit; tok_removing : pattern -> unit; - mutable tok_match : pattern -> 'te -> string; + tok_match : pattern -> 'te -> string; tok_text : pattern -> string; - mutable tok_comm : Ploc.t list option } + } and 'te lexer_func = char Stream.t -> 'te Stream.t * location_function -and location_function = int -> Ploc.t +and location_function = int -> Loc.t (** The type of a function giving the location of a token in the source from the token number in the stream (starting from zero). *) diff --git a/gramlib/ploc.ml b/gramlib/ploc.ml index 082686db01..9342fc6c1d 100644 --- a/gramlib/ploc.ml +++ b/gramlib/ploc.ml @@ -2,60 +2,23 @@ (* ploc.ml,v *) (* Copyright (c) INRIA 2007-2017 *) -type t = - { fname : string; - line_nb : int; - bol_pos : int; - line_nb_last : int; - bol_pos_last : int; - bp : int; - ep : int; - comm : string; - ecomm : string } - -let make_loc fname line_nb bol_pos (bp, ep) comm = - {fname = fname; line_nb = line_nb; bol_pos = bol_pos; - line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep; - comm = comm; ecomm = ""} +open Loc let make_unlined (bp, ep) = - {fname = ""; line_nb = 1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; + {fname = InFile ""; line_nb = 1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; bp = bp; ep = ep; comm = ""; ecomm = ""} let dummy = - {fname = ""; line_nb = 1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; + {fname = InFile ""; line_nb = 1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; bp = 0; ep = 0; comm = ""; ecomm = ""} -let file_name loc = loc.fname -let first_pos loc = loc.bp -let last_pos loc = loc.ep -let line_nb loc = loc.line_nb -let bol_pos loc = loc.bol_pos -let line_nb_last loc = loc.line_nb_last -let bol_pos_last loc = loc.bol_pos_last -let comment loc = loc.comm -let comment_last loc = loc.ecomm - (* *) -let encl loc1 loc2 = - if loc1.bp < loc2.bp then - if loc1.ep < loc2.ep then - {fname = loc1.fname; line_nb = loc1.line_nb; bol_pos = loc1.bol_pos; - line_nb_last = loc2.line_nb_last; bol_pos_last = loc2.bol_pos_last; - bp = loc1.bp; ep = loc2.ep; comm = loc1.comm; ecomm = loc2.comm} - else loc1 - else if loc2.ep < loc1.ep then - {fname = loc2.fname; line_nb = loc2.line_nb; bol_pos = loc2.bol_pos; - line_nb_last = loc1.line_nb_last; bol_pos_last = loc1.bol_pos_last; - bp = loc2.bp; ep = loc1.ep; comm = loc2.comm; ecomm = loc1.comm} - else loc2 -let shift sh loc = {loc with bp = sh + loc.bp; ep = sh + loc.ep} let sub loc sh len = {loc with bp = loc.bp + sh; ep = loc.bp + sh + len} let after loc sh len = {loc with bp = loc.ep + sh; ep = loc.ep + sh + len} let with_comment loc comm = {loc with comm = comm} -exception Exc of t * exn +exception Exc of Loc.t * exn let raise loc exc = match exc with diff --git a/gramlib/ploc.mli b/gramlib/ploc.mli index 2ce6382183..766e96fdfc 100644 --- a/gramlib/ploc.mli +++ b/gramlib/ploc.mli @@ -2,85 +2,36 @@ (* ploc.mli,v *) (* Copyright (c) INRIA 2007-2017 *) -(** Locations and some pervasive type and value. *) - -type t - (* located exceptions *) -exception Exc of t * exn +exception Exc of Loc.t * exn (** [Ploc.Exc loc e] is an encapsulation of the exception [e] with the input location [loc]. To be used to specify a location for an error. This exception must not be raised by [raise] but rather by [Ploc.raise] (see below), to prevent the risk of several encapsulations of [Ploc.Exc]. *) -val raise : t -> exn -> 'a +val raise : Loc.t -> exn -> 'a (** [Ploc.raise loc e], if [e] is already the exception [Ploc.Exc], re-raise it (ignoring the new location [loc]), else raise the exception [Ploc.Exc loc e]. *) -(* making locations *) - -val make_loc : string -> int -> int -> int * int -> string -> t - (** [Ploc.make_loc fname line_nb bol_pos (bp, ep) comm] creates a location - starting at line number [line_nb], where the position of the beginning - of the line is [bol_pos] and between the positions [bp] (included) and - [ep] excluded. And [comm] is the comment before the location. The - positions are in number of characters since the begin of the stream. *) -val make_unlined : int * int -> t +val make_unlined : int * int -> Loc.t (** [Ploc.make_unlined] is like [Ploc.make] except that the line number is not provided (to be used e.g. when the line number is unknown. *) -val dummy : t +val dummy : Loc.t (** [Ploc.dummy] is a dummy location, used in situations when location has no meaning. *) -(* getting location info *) - -val file_name : t -> string - (** [Ploc.file_name loc] returns the file name of the location. *) -val first_pos : t -> int - (** [Ploc.first_pos loc] returns the position of the begin of the location - in number of characters since the beginning of the stream. *) -val last_pos : t -> int - (** [Ploc.last_pos loc] returns the position of the first character not - in the location in number of characters since the beginning of the - stream. *) -val line_nb : t -> int - (** [Ploc.line_nb loc] returns the line number of the location or [-1] if - the location does not contain a line number (i.e. built with - [Ploc.make_unlined]. *) -val bol_pos : t -> int - (** [Ploc.bol_pos loc] returns the position of the beginning of the line - of the location in number of characters since the beginning of - the stream, or [0] if the location does not contain a line number - (i.e. built with [Ploc.make_unlined]. *) -val line_nb_last : t -> int -val bol_pos_last : t -> int - (** Return the line number and the position of the beginning of the line - of the last position. *) -val comment : t -> string - (** [Ploc.comment loc] returns the comment before the location. *) -val comment_last : t -> string - (** [Ploc.comment loc] returns the last comment of the location. *) - (* combining locations *) -val encl : t -> t -> t - (** [Ploc.encl loc1 loc2] returns the location starting at the - smallest start of [loc1] and [loc2] and ending at the greatest end - of them. In other words, it is the location enclosing [loc1] and - [loc2]. *) -val shift : int -> t -> t - (** [Ploc.shift sh loc] returns the location [loc] shifted with [sh] - characters. The line number is not recomputed. *) -val sub : t -> int -> int -> t +val sub : Loc.t -> int -> int -> Loc.t (** [Ploc.sub loc sh len] is the location [loc] shifted with [sh] characters and with length [len]. The previous ending position of the location is lost. *) -val after : t -> int -> int -> t +val after : Loc.t -> int -> int -> Loc.t (** [Ploc.after loc sh len] is the location just after loc (starting at the end position of [loc]) shifted with [sh] characters and of length [len]. *) -val with_comment : t -> string -> t +val with_comment : Loc.t -> string -> Loc.t (** Change the comment part of the given location *) diff --git a/ide/coqide_WIN32.ml.in b/ide/coqide_WIN32.ml.in index 8c4649fc39..0793a1cc1c 100644 --- a/ide/coqide_WIN32.ml.in +++ b/ide/coqide_WIN32.ml.in @@ -37,9 +37,8 @@ let reroute_stdout_stderr () = Unix.dup2 out_descr Unix.stdout; Unix.dup2 out_descr Unix.stderr -(* We also provide specific kill and interrupt functions. *) +(* We also provide a specific interrupt function. *) -external win32_kill : int -> unit = "win32_kill" external win32_interrupt : int -> unit = "win32_interrupt" let () = Coq.gio_channel_of_descr_socket := Glib.Io.channel_of_descr_socket; diff --git a/ide/ide_win32_stubs.c b/ide/ide_win32_stubs.c index c09bf37dee..f430c9f2b6 100644 --- a/ide/ide_win32_stubs.c +++ b/ide/ide_win32_stubs.c @@ -4,22 +4,6 @@ #include <caml/memory.h> #include <windows.h> -/* Win32 emulation of kill -9 */ - -/* The pid returned by Unix.create_process is actually a pseudo-pid, - made via a cast of the obtained HANDLE, (cf. win32unix/createprocess.c - in the sources of ocaml). Since we're still in the caller process, - we simply cast back to get an handle... - The 0 is the exit code we want for the terminated process. -*/ - -CAMLprim value win32_kill(value pseudopid) { - CAMLparam1(pseudopid); - TerminateProcess((HANDLE)(Long_val(pseudopid)), 0); - CAMLreturn(Val_unit); -} - - /* Win32 emulation of a kill -2 (SIGINT) */ /* This code rely of the fact that coqide is now without initial console. diff --git a/ide/idetop.ml b/ide/idetop.ml index 8cb02190e6..a2b85041e8 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -537,5 +537,5 @@ let islave_init ~opts extra_args = let () = let open Coqtop in - let custom = { init = islave_init; run = loop; } in + let custom = { init = islave_init; run = loop; opts = Coqargs.default_opts } in start_coq custom diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index d5f0b7bff6..3a4969a3ee 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -604,15 +604,6 @@ let rec coerce_to_cases_pattern_expr c = CAst.map_with_loc (fun ?loc -> function CErrors.user_err ?loc ~hdr:"coerce_to_cases_pattern_expr" (str "This expression should be coercible to a pattern.")) c -let asymmetric_patterns = ref (false) -let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; - Goptions.optname = "no parameters in constructors"; - Goptions.optkey = ["Asymmetric";"Patterns"]; - Goptions.optread = (fun () -> !asymmetric_patterns); - Goptions.optwrite = (fun a -> asymmetric_patterns:=a); -} - (** Local universe and constraint declarations. *) let interp_univ_constraints env evd cstrs = diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index 9e83bde8b2..7f14eb4583 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -127,9 +127,6 @@ val patntn_loc : ?loc:Loc.t -> cases_pattern_notation_substitution -> notation - (** For cases pattern parsing errors *) val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a -(** Placeholder for global option, should be moved to a parameter *) -val asymmetric_patterns : bool ref - (** Local universe and constraint declarations. *) val interp_univ_decl : Environ.env -> universe_decl_expr -> Evd.evar_map * UState.universe_decl diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 838ef40545..fba03b9de9 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -110,13 +110,13 @@ let deactivate_notation nr = (* shouldn't we check wether it is well defined? *) inactive_notations_table := IRuleSet.add nr !inactive_notations_table | NotationRule (scopt, ntn) -> - match availability_of_notation (scopt, ntn) (scopt, []) with - | None -> user_err ~hdr:"Notation" + if not (exists_notation_interpretation_in_scope scopt ntn) then + user_err ~hdr:"Notation" (pr_notation ntn ++ spc () ++ str "does not exist" ++ (match scopt with | None -> spc () ++ str "in the empty scope." | Some _ -> show_scope scopt ++ str ".")) - | Some _ -> + else if IRuleSet.mem nr !inactive_notations_table then Feedback.msg_warning (str "Notation" ++ spc () ++ pr_notation ntn ++ spc () @@ -193,17 +193,12 @@ let without_specific_symbols l = (* Control printing of records *) (* Set Record Printing flag *) -let record_print = ref true - -let _ = - let open Goptions in - declare_bool_option - { optdepr = false; - optname = "record printing"; - optkey = ["Printing";"Records"]; - optread = (fun () -> !record_print); - optwrite = (fun b -> record_print := b) } - +let get_record_print = + Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"record printing" + ~key:["Printing";"Records"] + ~value:true let is_record indsp = try @@ -268,6 +263,11 @@ let rec insert_pat_coercion ?loc l c = match l with | [] -> c | ntn::l -> CAst.make ?loc @@ CPatNotation (ntn,([insert_pat_coercion ?loc l c],[]),[]) +let add_lonely keyrule seen = + match keyrule with + | NotationRule (None,ntn) -> ntn::seen + | SynDefRule _ | NotationRule (Some _,_) -> seen + (**********************************************************************) (* conversion of references *) @@ -392,8 +392,8 @@ let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = with No_match -> try if !Flags.in_debugger || !Flags.raw_print || !print_no_symbol then raise No_match; - extern_notation_pattern allscopes vars pat - (uninterp_cases_pattern_notations pat) + extern_notation_pattern allscopes [] vars pat + (uninterp_cases_pattern_notations scopes pat) with No_match -> let loc = pat.CAst.loc in match DAst.get pat with @@ -431,7 +431,7 @@ let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = with Not_found | No_match | Exit -> let c = extern_reference Id.Set.empty (ConstructRef cstrsp) in - if !asymmetric_patterns then + if Constrintern.get_asymmetric_patterns () then if pattern_printable_in_both_syntax cstrsp then CPatCstr (c, None, args) else CPatCstr (c, Some (add_patt_for_params (fst cstrsp) args), []) @@ -446,18 +446,15 @@ let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = insert_pat_coercion coercion pat and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) - (custom, (tmp_scope, scopes) as allscopes) vars = + (custom, (tmp_scope, scopes) as allscopes) lonely_seen vars = function - | NotationRule (sc,ntn) -> + | NotationRule (sc,ntn),key,need_delim -> begin match availability_of_entry_coercion custom (fst ntn) with | None -> raise No_match | Some coercion -> - match availability_of_notation (sc,ntn) (tmp_scope,scopes) with - (* Uninterpretation is not allowed in current context *) - | None -> raise No_match - (* Uninterpretation is allowed in current context *) - | Some (scopt,key) -> + let key = if need_delim || List.mem ntn lonely_seen then key else None in + let scopt = match key with Some _ -> sc | _ -> None in let scopes' = Option.List.cons scopt scopes in let l = List.map (fun (c,(subentry,(scopt,scl))) -> @@ -469,7 +466,7 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) List.map (extern_cases_pattern_in_scope subscope vars) c) substlist in let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in - let l2' = if !asymmetric_patterns || not (List.is_empty ll) then l2 + let l2' = if Constrintern.get_asymmetric_patterns () || not (List.is_empty ll) then l2 else match drop_implicits_in_patt gr nb_to_drop l2 with |Some true_args -> true_args @@ -479,7 +476,8 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) (insert_pat_delimiters ?loc (make_pat_notation ?loc ntn (l,ll) l2') key) end - | SynDefRule kn -> + | SynDefRule kn,key,need_delim -> + assert (key = None && need_delim = false); match availability_of_entry_coercion custom InConstrEntrySomeLevel with | None -> raise No_match | Some coercion -> @@ -489,7 +487,7 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) extern_cases_pattern_in_scope (subentry,(scopt,scl@scopes)) vars c) subst in let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in - let l2' = if !asymmetric_patterns then l2 + let l2' = if Constrintern.get_asymmetric_patterns () then l2 else match drop_implicits_in_patt gr (nb_to_drop + List.length l1) l2 with |Some true_args -> true_args @@ -497,9 +495,9 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) in assert (List.is_empty substlist); insert_pat_coercion ?loc coercion (mkPat ?loc qid (List.rev_append l1 l2')) -and extern_notation_pattern allscopes vars t = function +and extern_notation_pattern allscopes lonely_seen vars t = function | [] -> raise No_match - | (keyrule,pat,n as _rule)::rules -> + | (keyrule,pat,n as _rule,key,need_delim)::rules -> try if is_inactive_rule keyrule then raise No_match; let loc = t.loc in @@ -507,22 +505,27 @@ and extern_notation_pattern allscopes vars t = function | PatCstr (cstr,args,na) -> let t = if na = Anonymous then t else DAst.make ?loc (PatCstr (cstr,args,Anonymous)) in let p = apply_notation_to_pattern ?loc (ConstructRef cstr) - (match_notation_constr_cases_pattern t pat) allscopes vars keyrule in + (match_notation_constr_cases_pattern t pat) allscopes lonely_seen vars + (keyrule,key,need_delim) in insert_pat_alias ?loc p na | PatVar Anonymous -> CAst.make ?loc @@ CPatAtom None | PatVar (Name id) -> CAst.make ?loc @@ CPatAtom (Some (qualid_of_ident ?loc id)) with - No_match -> extern_notation_pattern allscopes vars t rules + No_match -> + let lonely_seen = add_lonely keyrule lonely_seen in + extern_notation_pattern allscopes lonely_seen vars t rules -let rec extern_notation_ind_pattern allscopes vars ind args = function +let rec extern_notation_ind_pattern allscopes lonely_seen vars ind args = function | [] -> raise No_match - | (keyrule,pat,n as _rule)::rules -> + | (keyrule,pat,n as _rule,key,need_delim)::rules -> try if is_inactive_rule keyrule then raise No_match; apply_notation_to_pattern (IndRef ind) - (match_notation_constr_ind_pattern ind args pat) allscopes vars keyrule + (match_notation_constr_ind_pattern ind args pat) allscopes lonely_seen vars (keyrule,key,need_delim) with - No_match -> extern_notation_ind_pattern allscopes vars ind args rules + No_match -> + let lonely_seen = add_lonely keyrule lonely_seen in + extern_notation_ind_pattern allscopes lonely_seen vars ind args rules let extern_ind_pattern_in_scope (custom,scopes as allscopes) vars ind args = (* pboutill: There are letins in pat which is incompatible with notations and @@ -534,8 +537,8 @@ let extern_ind_pattern_in_scope (custom,scopes as allscopes) vars ind args = else try if !Flags.raw_print || !print_no_symbol then raise No_match; - extern_notation_ind_pattern allscopes vars ind args - (uninterp_ind_pattern_notations ind) + extern_notation_ind_pattern allscopes [] vars ind args + (uninterp_ind_pattern_notations scopes ind) with No_match -> let c = extern_reference vars (IndRef ind) in let args = List.map (extern_cases_pattern_in_scope allscopes vars) args in @@ -716,20 +719,20 @@ let rec flatten_application c = match DAst.get c with (* one with no delimiter if possible) *) let extern_possible_prim_token (custom,scopes) r = - try - let (sc,n) = uninterp_prim_token r in - match availability_of_entry_coercion custom InConstrEntrySomeLevel with - | None -> raise No_match - | Some coercion -> - match availability_of_prim_token n sc scopes with - | None -> None - | Some key -> Some (insert_coercion coercion (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key)) - with No_match -> - None - -let extern_optimal_prim_token scopes r r' = - let c = extern_possible_prim_token scopes r in - let c' = if r==r' then None else extern_possible_prim_token scopes r' in + let (sc,n) = uninterp_prim_token r in + match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> + match availability_of_prim_token n sc scopes with + | None -> raise No_match + | Some key -> insert_coercion coercion (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key) + +let extern_possible extern r = + try Some (extern r) with No_match -> None + +let extern_optimal extern r r' = + let c = extern_possible extern r in + let c' = if r==r' then None else extern_possible extern r' in match c,c' with | Some n, (Some ({ CAst.v = CDelimiters _}) | None) | _, Some n -> n | _ -> raise No_match @@ -765,30 +768,32 @@ let extern_ref vars ref us = let extern_var ?loc id = CRef (qualid_of_ident ?loc id,None) -let rec extern inctx scopes vars r = +let rec extern inctx (custom,scopes as allscopes) vars r = let r' = remove_coercions inctx r in try if !Flags.raw_print || !print_no_symbol then raise No_match; - extern_optimal_prim_token scopes r r' + extern_optimal (extern_possible_prim_token allscopes) r r' with No_match -> try let r'' = flatten_application r' in if !Flags.raw_print || !print_no_symbol then raise No_match; - extern_notation scopes vars r'' (uninterp_notations r'') + extern_optimal + (fun r -> extern_notation allscopes [] vars r (uninterp_notations scopes r)) + r r'' with No_match -> let loc = r'.CAst.loc in match DAst.get r' with - | GRef (ref,us) when entry_has_global (fst scopes) -> CAst.make ?loc (extern_ref vars ref us) + | GRef (ref,us) when entry_has_global custom -> CAst.make ?loc (extern_ref vars ref us) - | GVar id when entry_has_ident (fst scopes) -> CAst.make ?loc (extern_var ?loc id) + | GVar id when entry_has_ident custom -> CAst.make ?loc (extern_var ?loc id) | c -> - match availability_of_entry_coercion (fst scopes) InConstrEntrySomeLevel with + match availability_of_entry_coercion custom InConstrEntrySomeLevel with | None -> raise No_match | Some coercion -> - let scopes = (InConstrEntrySomeLevel, snd scopes) in + let scopes = (InConstrEntrySomeLevel, scopes) in let c = match c with (* The remaining cases are only for the constr entry *) @@ -800,7 +805,7 @@ let rec extern inctx scopes vars r = | GEvar (n,[]) when !print_meta_as_hole -> CHole (None, IntroAnonymous, None) | GEvar (n,l) -> - extern_evar n (List.map (on_snd (extern false scopes vars)) l) + extern_evar n (List.map (on_snd (extern false allscopes vars)) l) | GPatVar kind -> if !print_meta_as_hole then CHole (None, IntroAnonymous, None) else @@ -822,7 +827,7 @@ let rec extern inctx scopes vars r = () else if PrintingConstructor.active (fst cstrsp) then raise Exit - else if not !record_print then + else if not (get_record_print ()) then raise Exit; let projs = struc.Recordops.s_PROJ in let locals = struc.Recordops.s_PROJKIND in @@ -1059,9 +1064,9 @@ and extern_eqn inctx scopes vars {CAst.loc;v=(ids,pll,c)} = let pll = List.map (List.map (extern_cases_pattern_in_scope scopes vars)) pll in make ?loc (pll,extern inctx scopes vars c) -and extern_notation (custom,scopes as allscopes) vars t = function +and extern_notation (custom,scopes as allscopes) lonely_seen vars t = function | [] -> raise No_match - | (keyrule,pat,n as _rule)::rules -> + | (keyrule,pat,n as _rule,key,need_delim)::rules -> let loc = Glob_ops.loc_of_glob_constr t in try if is_inactive_rule keyrule then raise No_match; @@ -1109,11 +1114,8 @@ and extern_notation (custom,scopes as allscopes) vars t = function (match availability_of_entry_coercion custom (fst ntn) with | None -> raise No_match | Some coercion -> - match availability_of_notation (sc,ntn) scopes with - (* Uninterpretation is not allowed in current context *) - | None -> raise No_match - (* Uninterpretation is allowed in current context *) - | Some (scopt,key) -> + let key = if need_delim || List.mem ntn lonely_seen then key else None in + let scopt = match key with Some _ -> sc | None -> None in let scopes' = Option.List.cons scopt (snd scopes) in let l = List.map (fun (c,(subentry,(scopt,scl))) -> @@ -1149,7 +1151,9 @@ and extern_notation (custom,scopes as allscopes) vars t = function let args = extern_args (extern true) vars args in CAst.make ?loc @@ explicitize false argsimpls (None,e) args with - No_match -> extern_notation allscopes vars t rules + No_match -> + let lonely_seen = add_lonely keyrule lonely_seen in + extern_notation allscopes lonely_seen vars t rules and extern_recursion_order scopes vars = function GStructRec -> CStructRec diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 02db8f6aab..6313f2d7ba 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1488,6 +1488,12 @@ let is_non_zero_pat c = match c with | { CAst.v = CPatPrim (Numeral (p, true)) } -> not (is_zero p) | _ -> false +let get_asymmetric_patterns = Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"no parameters in constructors" + ~key:["Asymmetric";"Patterns"] + ~value:false + let drop_notations_pattern looked_for genv = (* At toplevel, Constructors and Inductives are accepted, in recursive calls only constructor are allowed *) @@ -1562,7 +1568,7 @@ let drop_notations_pattern looked_for genv = | None -> DAst.make ?loc @@ RCPatAtom None | Some (n, head, pl) -> let pl = - if !asymmetric_patterns then pl else + if get_asymmetric_patterns () then pl else let pars = List.make n (CAst.make ?loc @@ CPatAtom None) in List.rev_append pars pl in match drop_syndef top scopes head pl with @@ -1684,7 +1690,7 @@ let rec intern_pat genv ntnvars aliases pat = let aliases' = merge_aliases aliases id in intern_pat genv ntnvars aliases' p | RCPatCstr (head, expl_pl, pl) -> - if !asymmetric_patterns then + if get_asymmetric_patterns () then let len = if List.is_empty expl_pl then Some (List.length pl) else None in let c,idslpl1 = find_constructor loc len head in let with_letin = diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 147a903fe2..035e4bc644 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -197,3 +197,6 @@ val parsing_explicit : bool ref (** Globalization leak for Grammar *) val for_grammar : ('a -> 'b) -> 'a -> 'b + +(** Placeholder for global option, should be moved to a parameter *) +val get_asymmetric_patterns : unit -> bool diff --git a/interp/impargs.ml b/interp/impargs.ml index d8582d856e..d024a9e808 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -19,7 +19,6 @@ open Decl_kinds open Lib open Libobject open EConstr -open Termops open Reductionops open Constrexpr open Namegen @@ -200,16 +199,16 @@ let add_free_rels_until strict strongly_strict revpat bound env sigma m pos acc acc.(i) <- update pos rig acc.(i) | App (f,_) when rig && is_flexible_reference env sigma bound depth f -> if strict then () else - iter_constr_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders sigma push_lift (frec false) ed c | Proj (p,c) when rig -> if strict then () else - iter_constr_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders sigma push_lift (frec false) ed c | Case _ when rig -> if strict then () else - iter_constr_with_full_binders sigma push_lift (frec false) ed c + iter_with_full_binders sigma push_lift (frec false) ed c | Evar _ -> () | _ -> - iter_constr_with_full_binders sigma push_lift (frec rig) ed c + iter_with_full_binders sigma push_lift (frec rig) ed c in let () = if not (Vars.noccur_between sigma 1 bound m) then frec true (env,1) m in acc diff --git a/interp/notation.ml b/interp/notation.ml index db8ee5bc18..0af75b5bfa 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -21,6 +21,7 @@ open Notation_term open Glob_term open Glob_ops open Context.Named.Declaration +open Classops (*i*) @@ -156,6 +157,8 @@ let scope_eq s1 s2 = match s1, s2 with | Scope _, SingleNotation _ | SingleNotation _, Scope _ -> false +(* Scopes for interpretation *) + let scope_stack = ref [] let current_scopes () = !scope_stack @@ -165,14 +168,91 @@ let scope_is_open_in_scopes sc l = let scope_is_open sc = scope_is_open_in_scopes sc (!scope_stack) +(* Uninterpretation tables *) + +type interp_rule = + | NotationRule of scope_name option * notation + | SynDefRule of KerName.t + +type scoped_notation_rule_core = scope_name * notation * interpretation * int option +type notation_rule_core = interp_rule * interpretation * int option +type notation_rule = notation_rule_core * delimiters option * bool + +(* Scopes for uninterpretation: includes abbreviations (i.e. syntactic definitions) and *) + +type uninterp_scope_elem = + | UninterpScope of scope_name + | UninterpSingle of notation_rule_core + +let uninterp_scope_eq_weak s1 s2 = match s1, s2 with +| UninterpScope s1, UninterpScope s2 -> String.equal s1 s2 +| UninterpSingle s1, UninterpSingle s2 -> false +| (UninterpSingle _ | UninterpScope _), _ -> false + +module ScopeOrd = + struct + type t = scope_name option + let compare = Pervasives.compare + end + +module ScopeMap = CMap.Make(ScopeOrd) + +let uninterp_scope_stack = ref [] + +let push_uninterp_scope sc scopes = UninterpScope sc :: scopes + +let push_uninterp_scopes = List.fold_right push_uninterp_scope + +(**********************************************************************) +(* Mapping classes to scopes *) + +type scope_class = cl_typ + +let scope_class_compare : scope_class -> scope_class -> int = + cl_typ_ord + +let compute_scope_class sigma t = + let (cl,_,_) = find_class_type sigma t in + cl + +module ScopeClassOrd = +struct + type t = scope_class + let compare = scope_class_compare +end + +module ScopeClassMap = Map.Make(ScopeClassOrd) + +let initial_scope_class_map : scope_name ScopeClassMap.t = + ScopeClassMap.empty + +let scope_class_map = ref initial_scope_class_map + +let declare_scope_class sc cl = + scope_class_map := ScopeClassMap.add cl sc !scope_class_map + +let find_scope_class cl = + ScopeClassMap.find cl !scope_class_map + +let find_scope_class_opt = function + | None -> None + | Some cl -> try Some (find_scope_class cl) with Not_found -> None + +let current_type_scope_name () = + find_scope_class_opt (Some CL_SORT) + (* TODO: push nat_scope, z_scope, ... in scopes summary *) (* Exportation of scopes *) let open_scope i (_,(local,op,sc)) = - if Int.equal i 1 then + if Int.equal i 1 then begin scope_stack := - if op then sc :: !scope_stack - else List.except scope_eq sc !scope_stack + if op then Scope sc :: !scope_stack + else List.except scope_eq (Scope sc) !scope_stack; + uninterp_scope_stack := + if op then UninterpScope sc :: !uninterp_scope_stack + else List.except uninterp_scope_eq_weak (UninterpScope sc) !uninterp_scope_stack + end let cache_scope o = open_scope 1 o @@ -187,7 +267,7 @@ let discharge_scope (_,(local,_,_ as o)) = let classify_scope (local,_,_ as o) = if local then Dispose else Substitute o -let inScope : bool * bool * scope_elem -> obj = +let inScope : bool * bool * scope_name -> obj = declare_object {(default_object "SCOPE") with cache_function = cache_scope; open_function = open_scope; @@ -196,7 +276,7 @@ let inScope : bool * bool * scope_elem -> obj = classify_function = classify_scope } let open_close_scope (local,opening,sc) = - Lib.add_anonymous_leaf (inScope (local,opening,Scope (normalize_scope sc))) + Lib.add_anonymous_leaf (inScope (local,opening,normalize_scope sc)) let empty_scope_stack = [] @@ -204,9 +284,20 @@ let push_scope sc scopes = Scope sc :: scopes let push_scopes = List.fold_right push_scope +let make_type_scope_soft tmp_scope = + if Option.equal String.equal tmp_scope (current_type_scope_name ()) then + true, None + else + false, tmp_scope + let make_current_scopes (tmp_scope,scopes) = Option.fold_right push_scope tmp_scope (push_scopes scopes !scope_stack) +let make_current_uninterp_scopes (tmp_scope,scopes) = + let istyp,tmp_scope = make_type_scope_soft tmp_scope in + istyp,Option.fold_right push_uninterp_scope tmp_scope + (push_uninterp_scopes scopes !uninterp_scope_stack) + (**********************************************************************) (* Delimiters *) @@ -250,40 +341,80 @@ let find_delimiters_scope ?loc key = user_err ?loc ~hdr:"find_delimiters" (str "Unknown scope delimiting key " ++ str key ++ str ".") -(* Uninterpretation tables *) - -type interp_rule = - | NotationRule of scope_name option * notation - | SynDefRule of KerName.t - (* We define keys for glob_constr and aconstr to split the syntax entries according to the key of the pattern (adapted from Chet Murthy by HH) *) type key = | RefKey of GlobRef.t + | LambdaKey + | ProdKey | Oth let key_compare k1 k2 = match k1, k2 with | RefKey gr1, RefKey gr2 -> GlobRef.Ordered.compare gr1 gr2 -| RefKey _, Oth -> -1 -| Oth, RefKey _ -> 1 -| Oth, Oth -> 0 +| RefKey _, _ -> -1 +| _, RefKey _ -> 1 +| k1, k2 -> Pervasives.compare k1 k2 module KeyOrd = struct type t = key let compare = key_compare end module KeyMap = Map.Make(KeyOrd) -type notation_rule = interp_rule * interpretation * int option - -let keymap_add key interp map = - let old = try KeyMap.find key map with Not_found -> [] in - KeyMap.add key (interp :: old) map +let keymap_add key sc interp (scope_map,global_map) = + (* Adding to scope keymap for printing based on open scopes *) + let oldkeymap = try ScopeMap.find sc scope_map with Not_found -> KeyMap.empty in + let oldscmap = try KeyMap.find key oldkeymap with Not_found -> [] in + let newscmap = KeyMap.add key (interp :: oldscmap) oldkeymap in + let scope_map = ScopeMap.add sc newscmap scope_map in + (* Adding to global keymap of scoped notations in case the scope is not open *) + let global_map = match interp with + | NotationRule (Some sc,ntn), interp, c -> + let oldglobalkeymap = try KeyMap.find key global_map with Not_found -> [] in + KeyMap.add key ((sc,ntn,interp,c) :: oldglobalkeymap) global_map + | (NotationRule (None,_) | SynDefRule _), _, _ -> global_map in + (scope_map, global_map) + +let keymap_extract istype keys sc map = + let keymap = + try ScopeMap.find (Some sc) map + with Not_found -> KeyMap.empty in + let delim = + if istype && Option.equal String.equal (Some sc) (current_type_scope_name ()) then + (* A type is re-interpreted with type_scope on top, so never need a delimiter *) + None + else + (* Pass the delimiter so that it can be used if ever the notation is masked *) + (String.Map.find sc !scope_map).delimiters in + let add_scope rule = (rule,delim,false) in + List.map_append (fun key -> try List.map add_scope (KeyMap.find key keymap) with Not_found -> []) keys + +let find_with_delimiters istype = function + | None -> + None + | Some _ as scope when istype && Option.equal String.equal scope (current_type_scope_name ()) -> + (* This is in case type_scope (which by default is open in the + initial state) has been explicitly closed *) + Some None + | Some scope -> + match (String.Map.find scope !scope_map).delimiters with + | Some key -> Some (Some key) + | None -> None -let keymap_find key map = - try KeyMap.find key map - with Not_found -> [] +let rec keymap_extract_remainder istype scope_seen = function + | [] -> [] + | (sc,ntn,interp,c) :: l -> + if String.Set.mem sc scope_seen then keymap_extract_remainder istype scope_seen l + else + match find_with_delimiters istype (Some sc) with + | None -> keymap_extract_remainder istype scope_seen l + | Some delim -> + let rule = (NotationRule (Some sc, ntn), interp, c) in + (rule,delim,true) :: keymap_extract_remainder istype scope_seen l (* Scopes table : interpretation -> scope_name *) -let notations_key_table = ref (KeyMap.empty : notation_rule list KeyMap.t) +let notations_key_table = + ref ((ScopeMap.empty, KeyMap.empty) : + notation_rule_core list KeyMap.t ScopeMap.t * + scoped_notation_rule_core list KeyMap.t) let glob_prim_constr_key c = match DAst.get c with | GRef (ref, _) -> Some (canonical_gr ref) @@ -295,12 +426,14 @@ let glob_prim_constr_key c = match DAst.get c with | _ -> None let glob_constr_keys c = match DAst.get c with + | GRef (ref,_) -> [RefKey (canonical_gr ref)] | GApp (c, _) -> begin match DAst.get c with | GRef (ref, _) -> [RefKey (canonical_gr ref); Oth] | _ -> [Oth] end - | GRef (ref,_) -> [RefKey (canonical_gr ref)] + | GLambda _ -> [LambdaKey] + | GProd _ -> [ProdKey] | _ -> [Oth] let cases_pattern_key c = match DAst.get c with @@ -314,6 +447,8 @@ let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) RefKey (canonical_gr ref), Some (List.length args) | NRef ref -> RefKey(canonical_gr ref), None | NApp (_,args) -> Oth, Some (List.length args) + | NLambda _ | NBinderList (_,_,NLambda _,_,_) | NList (_,_,NLambda _,_,_) -> LambdaKey, None + | NProd _ | NBinderList (_,_,NProd _,_,_) | NList (_,_,NProd _,_,_) -> ProdKey, None | _ -> Oth, None (**********************************************************************) @@ -839,37 +974,31 @@ let check_required_module ?loc sc (sp,d) = (* Look if some notation or numeral printer in [scope] can be used in the scope stack [scopes], and if yes, using delimiters or not *) -let find_with_delimiters = function - | None -> None - | Some scope -> - match (String.Map.find scope !scope_map).delimiters with - | Some key -> Some (Some scope, Some key) - | None -> None - -let rec find_without_delimiters find (ntn_scope,ntn) = function - | Scope scope :: scopes -> +let rec find_without_delimiters find (istype,ntn_scope,ntn as ntndata) = function + | UninterpScope scope :: scopes -> (* Is the expected ntn/numpr attached to the most recently open scope? *) begin match ntn_scope with | Some scope' when String.equal scope scope' -> - Some (None,None) + Some None | _ -> (* If the most recently open scope has a notation/numeral printer but not the expected one then we need delimiters *) if find scope then - find_with_delimiters ntn_scope + find_with_delimiters istype ntn_scope else - find_without_delimiters find (ntn_scope,ntn) scopes + find_without_delimiters find ntndata scopes end - | SingleNotation ntn' :: scopes -> + | UninterpSingle (NotationRule (_,ntn'),_,_) :: scopes -> begin match ntn_scope, ntn with | None, Some ntn when notation_eq ntn ntn' -> - Some (None, None) + Some None | _ -> - find_without_delimiters find (ntn_scope,ntn) scopes + find_without_delimiters find ntndata scopes end + | UninterpSingle (SynDefRule _,_,_) :: scopes -> find_without_delimiters find ntndata scopes | [] -> (* Can we switch to [scope]? Yes if it has defined delimiters *) - find_with_delimiters ntn_scope + find_with_delimiters istype ntn_scope (* The mapping between notations and their interpretation *) @@ -902,9 +1031,19 @@ let declare_notation_interpretation ntn scopt pat df ~onlyprint = | Some _ -> () end +let scope_of_rule = function + | NotationRule (None,_) | SynDefRule _ -> None + | NotationRule (Some sc as sco,_) -> sco + +let uninterp_scope_to_add pat n = function + | NotationRule (None,_) | SynDefRule _ as rule -> Some (UninterpSingle (rule,pat,n)) + | NotationRule (Some sc,_) -> None + let declare_uninterpretation rule (metas,c as pat) = let (key,n) = notation_constr_key c in - notations_key_table := keymap_add key (rule,pat,n) !notations_key_table + let sc = scope_of_rule rule in + notations_key_table := keymap_add key sc (rule,pat,n) !notations_key_table; + uninterp_scope_stack := Option.List.cons (uninterp_scope_to_add pat n rule) !uninterp_scope_stack let rec find_interpretation ntn find = function | [] -> raise Not_found @@ -982,20 +1121,29 @@ let interp_notation ?loc ntn local_scopes = user_err ?loc (str "Unknown interpretation for notation " ++ pr_notation ntn ++ str ".") -let uninterp_notations c = - List.map_append (fun key -> keymap_find key !notations_key_table) - (glob_constr_keys c) +let extract_notations (istype,scopes) keys = + if keys == [] then [] (* shortcut *) else + let scope_map, global_map = !notations_key_table in + let rec aux scopes seen = + match scopes with + | UninterpScope sc :: scopes -> keymap_extract istype keys sc scope_map @ aux scopes (String.Set.add sc seen) + | UninterpSingle rule :: scopes -> (rule,None,false) :: aux scopes seen + | [] -> + let find key = try KeyMap.find key global_map with Not_found -> [] in + keymap_extract_remainder istype seen (List.flatten (List.map find keys)) + in aux scopes String.Set.empty -let uninterp_cases_pattern_notations c = - keymap_find (cases_pattern_key c) !notations_key_table +let uninterp_notations scopes c = + let scopes = make_current_uninterp_scopes scopes in + extract_notations scopes (glob_constr_keys c) -let uninterp_ind_pattern_notations ind = - keymap_find (RefKey (canonical_gr (IndRef ind))) !notations_key_table +let uninterp_cases_pattern_notations scopes c = + let scopes = make_current_uninterp_scopes scopes in + extract_notations scopes [cases_pattern_key c] -let availability_of_notation (ntn_scope,ntn) scopes = - let f scope = - NotationMap.mem ntn (String.Map.find scope !scope_map).notations in - find_without_delimiters f (ntn_scope,Some ntn) (make_current_scopes scopes) +let uninterp_ind_pattern_notations scopes ind = + let scopes = make_current_uninterp_scopes scopes in + extract_notations scopes [RefKey (canonical_gr (IndRef ind))] (* We support coercions from a custom entry at some level to an entry at some level (possibly the same), and from and to the constr entry. E.g.: @@ -1149,13 +1297,11 @@ let availability_of_prim_token n printer_scope local_scopes = | _ -> false with Not_found -> false in - let scopes = make_current_scopes local_scopes in - Option.map snd (find_without_delimiters f (Some printer_scope,None) scopes) + let istype,scopes = make_current_uninterp_scopes local_scopes in + find_without_delimiters f (istype,Some printer_scope,None) scopes (* Miscellaneous *) -let pair_eq f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 - let notation_binder_source_eq s1 s2 = match s1, s2 with | NtnParsedAsIdent, NtnParsedAsIdent -> true | NtnParsedAsPattern b1, NtnParsedAsPattern b2 -> b1 = b2 @@ -1169,9 +1315,10 @@ let ntpe_eq t1 t2 = match t1, t2 with | NtnTypeBinderList, NtnTypeBinderList -> true | (NtnTypeConstr | NtnTypeBinder _ | NtnTypeConstrList | NtnTypeBinderList), _ -> false -let var_attributes_eq (_, ((entry1, sc1), tp1)) (_, ((entry2, sc2), tp2)) = +let var_attributes_eq (_, ((entry1, (tmpsc1, scl1)), tp1)) (_, ((entry2, (tmpsc2, scl2)), tp2)) = notation_entry_level_eq entry1 entry2 && - pair_eq (Option.equal String.equal) (List.equal String.equal) sc1 sc2 && + Option.equal String.equal tmpsc1 tmpsc2 && + List.equal String.equal scl1 scl2 && ntpe_eq tp1 tp2 let interpretation_eq (vars1, t1) (vars2, t2) = @@ -1186,44 +1333,15 @@ let exists_notation_in_scope scopt ntn onlyprint r = interpretation_eq n.not_interp r with Not_found -> false -let isNVar_or_NHole = function NVar _ | NHole _ -> true | _ -> false - -(**********************************************************************) -(* Mapping classes to scopes *) - -open Classops - -type scope_class = cl_typ - -let scope_class_compare : scope_class -> scope_class -> int = - cl_typ_ord - -let compute_scope_class sigma t = - let (cl,_,_) = find_class_type sigma t in - cl - -module ScopeClassOrd = -struct - type t = scope_class - let compare = scope_class_compare -end - -module ScopeClassMap = Map.Make(ScopeClassOrd) - -let initial_scope_class_map : scope_name ScopeClassMap.t = - ScopeClassMap.empty - -let scope_class_map = ref initial_scope_class_map - -let declare_scope_class sc cl = - scope_class_map := ScopeClassMap.add cl sc !scope_class_map - -let find_scope_class cl = - ScopeClassMap.find cl !scope_class_map +let exists_notation_interpretation_in_scope scopt ntn = + let scope = match scopt with Some s -> s | None -> default_scope in + try + let sc = String.Map.find scope !scope_map in + let _ = NotationMap.find ntn sc.notations in + true + with Not_found -> false -let find_scope_class_opt = function - | None -> None - | Some cl -> try Some (find_scope_class cl) with Not_found -> None +let isNVar_or_NHole = function NVar _ | NHole _ -> true | _ -> false (**********************************************************************) (* Special scopes associated to arguments of a global reference *) @@ -1245,9 +1363,6 @@ let compute_arguments_scope sigma t = fst (compute_arguments_scope_full sigma t) let compute_type_scope sigma t = find_scope_class_opt (try Some (compute_scope_class sigma t) with Not_found -> None) -let current_type_scope_name () = - find_scope_class_opt (Some CL_SORT) - let scope_class_of_class (x : cl_typ) : scope_class = x @@ -1604,7 +1719,7 @@ let locate_notation prglob ntn scope = str "Notation" ++ fnl () ++ prlist_with_sep fnl (fun (ntn,l) -> let scope = find_default ntn scopes in - prlist + prlist_with_sep fnl (fun (sc,r,(_,df)) -> hov 0 ( pr_notation_info prglob df r ++ @@ -1667,17 +1782,18 @@ let pr_visibility prglob = function (* Synchronisation with reset *) let freeze _ = - (!scope_map, !scope_stack, !arguments_scope, + (!scope_map, !scope_stack, !uninterp_scope_stack, !arguments_scope, !delimiters_map, !notations_key_table, !scope_class_map, !prim_token_interp_infos, !prim_token_uninterp_infos, !entry_coercion_map, !entry_has_global_map, !entry_has_ident_map) -let unfreeze (scm,scs,asc,dlm,fkm,clsc,ptii,ptui,coe,globs,ids) = +let unfreeze (scm,scs,uscs,asc,dlm,fkm,clsc,ptii,ptui,coe,globs,ids) = scope_map := scm; scope_stack := scs; - delimiters_map := dlm; + uninterp_scope_stack := uscs; arguments_scope := asc; + delimiters_map := dlm; notations_key_table := fkm; scope_class_map := clsc; prim_token_interp_infos := ptii; @@ -1688,8 +1804,9 @@ let unfreeze (scm,scs,asc,dlm,fkm,clsc,ptii,ptui,coe,globs,ids) = let init () = init_scope_map (); + uninterp_scope_stack := []; delimiters_map := String.Map.empty; - notations_key_table := KeyMap.empty; + notations_key_table := (ScopeMap.empty,KeyMap.empty); scope_class_map := initial_scope_class_map; prim_token_interp_infos := String.Map.empty; prim_token_uninterp_infos := GlobRef.Map.empty diff --git a/interp/notation.mli b/interp/notation.mli index 734198bbf6..3480d1c8f2 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -211,18 +211,28 @@ val declare_uninterpretation : interp_rule -> interpretation -> unit val interp_notation : ?loc:Loc.t -> notation -> subscopes -> interpretation * (notation_location * scope_name option) -type notation_rule = interp_rule * interpretation * int option +type notation_rule_core = + interp_rule (* kind of notation *) + * interpretation (* pattern associated to the notation *) + * int option (* number of expected arguments *) + +type notation_rule = + notation_rule_core + * delimiters option (* delimiter to possibly add *) + * bool (* true if the delimiter is mandatory *) (** Return the possible notations for a given term *) -val uninterp_notations : 'a glob_constr_g -> notation_rule list -val uninterp_cases_pattern_notations : 'a cases_pattern_g -> notation_rule list -val uninterp_ind_pattern_notations : inductive -> notation_rule list +val uninterp_notations : subscopes -> 'a glob_constr_g -> notation_rule list +val uninterp_cases_pattern_notations : subscopes -> 'a cases_pattern_g -> notation_rule list +val uninterp_ind_pattern_notations : subscopes -> inductive -> notation_rule list +(* (** Test if a notation is available in the scopes context [scopes]; if available, the result is not None; the first argument is itself not None if a delimiters is needed *) val availability_of_notation : scope_name option * notation -> subscopes -> (scope_name option * delimiters option) option + *) (** {6 Miscellaneous} *) @@ -233,6 +243,9 @@ val interp_notation_as_global_reference : ?loc:Loc.t -> (GlobRef.t -> bool) -> val exists_notation_in_scope : scope_name option -> notation -> bool -> interpretation -> bool +(** Checks for already existing notations *) +val exists_notation_interpretation_in_scope : scope_name option -> notation -> bool + (** Declares and looks for scopes associated to arguments of a global ref *) val declare_arguments_scope : bool (** true=local *) -> GlobRef.t -> scope_name option list -> unit diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 7e73609996..1f61bcae2e 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -300,7 +300,7 @@ and fterm = | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (Name.t * constr) list * constr * fconstr subs - | FProd of Name.t * fconstr * fconstr + | FProd of Name.t * fconstr * constr * fconstr subs | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FLIFT of int * fconstr @@ -584,9 +584,12 @@ let rec to_constr lfts v = let tys = List.mapi (fun i (na, c) -> na, subst_constr (subs_liftn i subs) c) tys in let f = subst_constr (subs_liftn len subs) f in Term.compose_lam (List.rev tys) f - | FProd (n,t,c) -> - mkProd (n, to_constr lfts t, - to_constr (el_lift lfts) c) + | FProd (n, t, c, e) -> + if is_subs_id e && is_lift_id lfts then + mkProd (n, to_constr lfts t, c) + else + let subs' = comp_subs lfts e in + mkProd (n, to_constr lfts t, subst_constr (subs_lift subs') c) | FLetIn (n,b,t,f,e) -> let subs = comp_subs (el_lift lfts) (subs_lift e) in mkLetIn (n, to_constr lfts b, @@ -869,7 +872,7 @@ and knht info e t stk = | CoFix cfx -> { norm = Cstr; term = FCoFix (cfx,e) }, stk | Lambda _ -> { norm = Cstr; term = mk_lambda e t }, stk | Prod (n, t, c) -> - { norm = Whnf; term = FProd (n, mk_clos e t, mk_clos (subs_lift e) c) }, stk + { norm = Whnf; term = FProd (n, mk_clos e t, c, e) }, stk | LetIn (n,b,t,c) -> { norm = Red; term = FLetIn (n, mk_clos e b, mk_clos e t, c, e) }, stk | Evar ev -> { norm = Red; term = FEvar (ev, e) }, stk @@ -992,8 +995,8 @@ and norm_head info tab m = | FLetIn(na,a,b,f,e) -> let c = mk_clos (subs_lift e) f in mkLetIn(na, kl info tab a, kl info tab b, kl info tab c) - | FProd(na,dom,rng) -> - mkProd(na, kl info tab dom, kl info tab rng) + | FProd(na,dom,rng,e) -> + mkProd(na, kl info tab dom, kl info tab (mk_clos (subs_lift e) rng)) | FCoFix((n,(na,tys,bds)),e) -> let ftys = Array.Fun1.map mk_clos e tys in let fbds = diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index b6c87b3732..c2d53eed47 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -114,7 +114,7 @@ type fterm = | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) | FLambda of int * (Name.t * constr) list * constr * fconstr subs - | FProd of Name.t * fconstr * fconstr + | FProd of Name.t * fconstr * constr * fconstr subs | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FLIFT of int * fconstr diff --git a/kernel/constr.ml b/kernel/constr.ml index 704e6de6b8..8e5d15dd2d 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -452,27 +452,6 @@ let fold f acc c = match kind c with | CoFix (_,(_lna,tl,bl)) -> Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl -let fold_with_full_binders g f n acc c = - let open Context.Rel.Declaration in - match kind c with - | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ -> acc - | Cast (c,_, t) -> f n (f n acc c) t - | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c - | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c - | LetIn (na,b,t,c) -> f (g (LocalDef (na,b,t)) n) (f n (f n acc b) t) c - | App (c,l) -> Array.fold_left (f n) (f n acc c) l - | Proj (_,c) -> f n acc c - | Evar (_,l) -> Array.fold_left (f n) acc l - | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl - | Fix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n,t)) c) n lna tl in - let fd = Array.map2 (fun t b -> (t,b)) tl bl in - Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd - | CoFix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n,t)) c) n lna tl in - let fd = Array.map2 (fun t b -> (t,b)) tl bl in - Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd - (* [iter f c] iters [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) @@ -534,12 +513,12 @@ let fold_constr_with_binders g f n acc c = | Proj (_p,c) -> f n acc c | Evar (_,l) -> Array.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl - | Fix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c _n _t -> g c) n lna tl in + | Fix (_,(_,tl,bl)) -> + let n' = iterate g (Array.length tl) n in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd - | CoFix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c _n _t -> g c) n lna tl in + | CoFix (_,(_,tl,bl)) -> + let n' = iterate g (Array.length tl) n in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd @@ -799,6 +778,49 @@ let map_with_binders g f l c0 = match kind c0 with let bl' = Array.Fun1.Smart.map f l' bl in mkCoFix (ln,(lna,tl',bl')) +(*********************) +(* Lifting *) +(*********************) + +(* The generic lifting function *) +let rec exliftn el c = + let open Esubst in + match kind c with + | Rel i -> mkRel(reloc_rel i el) + | _ -> map_with_binders el_lift exliftn el c + +(* Lifting the binding depth across k bindings *) + +let liftn n k c = + let open Esubst in + match el_liftn (pred k) (el_shft n el_id) with + | ELID -> c + | el -> exliftn el c + +let lift n = liftn n 1 + +let fold_with_full_binders g f n acc c = + let open Context.Rel.Declaration in + match kind c with + | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ -> acc + | Cast (c,_, t) -> f n (f n acc c) t + | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c + | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c + | LetIn (na,b,t,c) -> f (g (LocalDef (na,b,t)) n) (f n (f n acc b) t) c + | App (c,l) -> Array.fold_left (f n) (f n acc c) l + | Proj (_,c) -> f n acc c + | Evar (_,l) -> Array.fold_left (f n) acc l + | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl + | Fix (_,(lna,tl,bl)) -> + let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in + let fd = Array.map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd + | CoFix (_,(lna,tl,bl)) -> + let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in + let fd = Array.map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd + + type 'univs instance_compare_fn = GlobRef.t -> int -> 'univs -> 'univs -> bool diff --git a/kernel/constr.mli b/kernel/constr.mli index 1be1f63ff7..f2cedcdabb 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -383,6 +383,17 @@ type rel_context = rel_declaration list type named_context = named_declaration list type compacted_context = compacted_declaration list +(** {6 Relocation and substitution } *) + +(** [exliftn el c] lifts [c] with lifting [el] *) +val exliftn : Esubst.lift -> constr -> constr + +(** [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *) +val liftn : int -> int -> constr -> constr + +(** [lift n c] lifts by [n] the positive indexes in [c] *) +val lift : int -> constr -> constr + (** {6 Functionals working on expressions canonically abstracted over a local context (possibly with let-ins)} *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index b39aed01e8..f4b4834d98 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -158,6 +158,7 @@ type result = { cook_body : constant_def; cook_type : types; cook_universes : constant_universes; + cook_private_univs : Univ.ContextSet.t option; cook_inline : inline; cook_context : Constr.named_context option; } @@ -204,7 +205,8 @@ let lift_univs cb subst auctx0 = else let ainst = Univ.make_abstract_instance auctx in let subst = Instance.append subst ainst in - let auctx' = Univ.subst_univs_level_abstract_universe_context (Univ.make_instance_subst subst) auctx in + let substf = Univ.make_instance_subst subst in + let auctx' = Univ.subst_univs_level_abstract_universe_context substf auctx in subst, (Polymorphic_const (AUContext.union auctx0 auctx')) let cook_constant ~hcons { from = cb; info } = @@ -229,10 +231,15 @@ let cook_constant ~hcons { from = cb; info } = hyps) hyps0 ~init:cb.const_hyps in let typ = abstract_constant_type (expmod cb.const_type) hyps in + let private_univs = Option.map (on_snd (Univ.subst_univs_level_constraints + (Univ.make_instance_subst usubst))) + cb.const_private_poly_univs + in { cook_body = body; cook_type = typ; cook_universes = univs; + cook_private_univs = private_univs; cook_inline = cb.const_inline_code; cook_context = Some const_hyps; } diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 6ebe691b83..7ff4b657d3 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -21,6 +21,7 @@ type result = { cook_body : constant_def; cook_type : types; cook_universes : constant_universes; + cook_private_univs : Univ.ContextSet.t option; cook_inline : inline; cook_context : Constr.named_context option; } diff --git a/kernel/declarations.ml b/kernel/declarations.ml index c1b38b4156..016b63be09 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -61,13 +61,27 @@ type constant_universes = of a constant are tracked in their {!constant_body} so that they can be displayed to the user. *) type typing_flags = { - check_guarded : bool; (** If [false] then fixed points and co-fixed - points are assumed to be total. *) - check_universes : bool; (** If [false] universe constraints are not checked *) - conv_oracle : Conv_oracle.oracle; (** Unfolding strategies for conversion *) - share_reduction : bool; (** Use by-need reduction algorithm *) - enable_VM : bool; (** If [false], all VM conversions fall back to interpreted ones *) - enable_native_compiler : bool; (** If [false], all native conversions fall back to VM ones *) + check_guarded : bool; + (** If [false] then fixed points and co-fixed points are assumed to + be total. *) + + check_universes : bool; + (** If [false] universe constraints are not checked *) + + conv_oracle : Conv_oracle.oracle; + (** Unfolding strategies for conversion *) + + share_reduction : bool; + (** Use by-need reduction algorithm *) + + enable_VM : bool; + (** If [false], all VM conversions fall back to interpreted ones *) + + enable_native_compiler : bool; + (** If [false], all native conversions fall back to VM ones *) + + indices_matter: bool; + (** The universe of an inductive type must be above that of its indices. *) } (* some contraints are in constant_constraints, some other may be in @@ -78,6 +92,7 @@ type constant_body = { const_type : types; const_body_code : Cemitcodes.to_patch_substituted option; const_universes : constant_universes; + const_private_poly_univs : Univ.ContextSet.t option; const_inline_code : bool; const_typing_flags : typing_flags; (** The typing options which were used for diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 3ed599c538..707c46048b 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -24,6 +24,7 @@ let safe_flags oracle = { share_reduction = true; enable_VM = true; enable_native_compiler = true; + indices_matter = true; } (** {6 Arities } *) @@ -101,6 +102,7 @@ let subst_const_body sub cb = const_body_code = Option.map (Cemitcodes.subst_to_patch_subst sub) cb.const_body_code; const_universes = cb.const_universes; + const_private_poly_univs = cb.const_private_poly_univs; const_inline_code = cb.const_inline_code; const_typing_flags = cb.const_typing_flags } @@ -126,14 +128,20 @@ let hcons_const_universes cbu = match cbu with | Monomorphic_const ctx -> Monomorphic_const (Univ.hcons_universe_context_set ctx) - | Polymorphic_const ctx -> + | Polymorphic_const ctx -> Polymorphic_const (Univ.hcons_abstract_universe_context ctx) +let hcons_const_private_univs = function + | None -> None + | Some univs -> Some (Univ.hcons_universe_context_set univs) + let hcons_const_body cb = { cb with const_body = hcons_const_def cb.const_body; const_type = Constr.hcons cb.const_type; - const_universes = hcons_const_universes cb.const_universes } + const_universes = hcons_const_universes cb.const_universes; + const_private_poly_univs = hcons_const_private_univs cb.const_private_poly_univs; + } (** {6 Inductive types } *) diff --git a/kernel/dune b/kernel/dune index a503238907..4f2e0e4e28 100644 --- a/kernel/dune +++ b/kernel/dune @@ -4,7 +4,7 @@ (public_name coq.kernel) (wrapped false) (modules_without_implementation cinstr nativeinstr) - (libraries clib config lib byterun)) + (libraries lib byterun)) (rule (targets copcodes.ml) diff --git a/kernel/environ.ml b/kernel/environ.ml index 019c0a6819..38a428d9a1 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -241,6 +241,8 @@ let is_impredicative_set env = let type_in_type env = not (typing_flags env).check_universes let deactivated_guard env = not (typing_flags env).check_guarded +let indices_matter env = env.env_typing_flags.indices_matter + let universes env = env.env_stratification.env_universes let named_context env = env.env_named_context.env_named_ctx let named_context_val env = env.env_named_context @@ -380,6 +382,18 @@ let add_universes_set strict ctx g = let push_context_set ?(strict=false) ctx env = map_universes (add_universes_set strict ctx) env +let push_subgraph (levels,csts) env = + let add_subgraph g = + let newg = Univ.LSet.fold (fun v g -> UGraph.add_universe v false g) levels g in + let newg = UGraph.merge_constraints csts newg in + (if not (Univ.Constraint.is_empty csts) then + let restricted = UGraph.constraints_for ~kept:(UGraph.domain g) newg in + (if not (UGraph.check_constraints restricted g) then + CErrors.anomaly Pp.(str "Local constraints imply new transitive constraints."))); + newg + in + map_universes add_subgraph env + let set_engagement c env = (* Unsafe *) { env with env_stratification = { env.env_stratification with env_engagement = c } } @@ -389,6 +403,7 @@ let same_flags { check_guarded; check_universes; conv_oracle; + indices_matter; share_reduction; enable_VM; enable_native_compiler; @@ -396,6 +411,7 @@ let same_flags { check_guarded == alt.check_guarded && check_universes == alt.check_universes && conv_oracle == alt.conv_oracle && + indices_matter == alt.indices_matter && share_reduction == alt.share_reduction && enable_VM == alt.enable_VM && enable_native_compiler == alt.enable_native_compiler diff --git a/kernel/environ.mli b/kernel/environ.mli index c285f907fc..8a2efb2477 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -96,6 +96,7 @@ val typing_flags : env -> typing_flags val is_impredicative_set : env -> bool val type_in_type : env -> bool val deactivated_guard : env -> bool +val indices_matter : env -> bool (** is the local context empty *) val empty_context : env -> bool @@ -268,6 +269,12 @@ val push_context : ?strict:bool -> Univ.UContext.t -> env -> env val push_context_set : ?strict:bool -> Univ.ContextSet.t -> env -> env val push_constraints_to_env : 'a Univ.constrained -> env -> env +val push_subgraph : Univ.ContextSet.t -> env -> env +(** [push_subgraph univs env] adds the universes and constraints in + [univs] to [env] as [push_context_set ~strict:false univs env], and + also checks that they do not imply new transitive constraints + between pre-existing universes in [env]. *) + val set_engagement : engagement -> env -> env val set_typing_flags : typing_flags -> env -> env diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 20c90bc05a..a4a02791b4 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -35,14 +35,6 @@ env_ar_par = env_ar + declaration of parameters nmr = ongoing computation of recursive parameters *) -(* Tell if indices (aka real arguments) contribute to size of inductive type *) -(* If yes, this is compatible with the univalent model *) - -let indices_matter = ref false - -let enforce_indices_matter () = indices_matter := true -let is_indices_matter () = !indices_matter - (* [weaker_noccur_between env n nvars t] (defined above), checks that no de Bruijn indices between [n] and [n+nvars] occur in [t]. If some such occurrences are found, then reduction is performed @@ -303,7 +295,7 @@ let typecheck_inductive env mie = let inflev = (* The level of the inductive includes levels of indices if in indices_matter mode *) - if !indices_matter + if indices_matter env then Some (cumulate_arity_large_levels env_params sign) else None in diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index a827c17683..840e23ed69 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -50,8 +50,3 @@ val check_positivity : chkpos:bool -> (** The following function does checks on inductive declarations. *) val check_inductive : env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body - -(** The following enforces a system compatible with the univalent model *) - -val enforce_indices_matter : unit -> unit -val is_indices_matter : unit -> bool diff --git a/kernel/modops.ml b/kernel/modops.ml index 0dde1c7e75..f43dbd88f9 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -338,7 +338,8 @@ let strengthen_const mp_from l cb resolver = | Polymorphic_const ctx -> Univ.make_abstract_instance ctx in { cb with - const_body = Def (Mod_subst.from_val (mkConstU (con,u))); + const_body = Def (Mod_subst.from_val (mkConstU (con,u))); + const_private_poly_univs = None; const_body_code = Some (Cemitcodes.from_val (Cbytegen.compile_alias con)) } let rec strengthen_mod mp_from mp_to mb = diff --git a/kernel/reduction.ml b/kernel/reduction.ml index fbb481424f..97cd4c00d7 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -438,14 +438,14 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv - | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> + | (FProd (_, c1, c2, e), FProd (_, c'1, c'2, e')) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (FProd)."); (* Luo's system *) let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in - ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 cuniv + ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) (mk_clos (subs_lift e) c2) (mk_clos (subs_lift e') c'2) cuniv (* Eta-expansion on the fly *) | (FLambda _, _) -> diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 2464df799e..df9e253135 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -196,6 +196,9 @@ let set_typing_flags c senv = if env == senv.env then senv else { senv with env } +let set_indices_matter indices_matter senv = + set_typing_flags { (Environ.typing_flags senv.env) with indices_matter } senv + let set_share_reduction b senv = let flags = Environ.typing_flags senv.env in set_typing_flags { flags with share_reduction = b } senv @@ -498,7 +501,7 @@ type generic_name = | M (** name already known, cf the mod_mp field *) | MT (** name already known, cf the mod_mp field *) -let add_field ((l,sfb) as field) gn senv = +let add_field ?(is_include=false) ((l,sfb) as field) gn senv = let mlabs,olabs = match sfb with | SFBmind mib -> let l = labels_of_mib mib in @@ -508,8 +511,18 @@ let add_field ((l,sfb) as field) gn senv = | SFBmodule _ | SFBmodtype _ -> check_modlabel l senv; (Label.Set.singleton l, Label.Set.empty) in - let cst = constraints_of_sfb senv.env sfb in - let senv = add_constraints_list cst senv in + let senv = + if is_include then + (* Universes and constraints were added when the included module + was defined eg in [Include F X.] (one of the trickier + versions of Include) the constraints on the fields are + exactly those of the fields of F which was defined + separately. *) + senv + else + let cst = constraints_of_sfb senv.env sfb in + add_constraints_list cst senv + in let env' = match sfb, gn with | SFBconst cb, C con -> Environ.add_constant con cb senv.env | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env @@ -599,7 +612,7 @@ let inline_side_effects env body side_eff = let subst = Cmap_env.add c (Inr var) subst in let ctx = Univ.ContextSet.union ctx univs in (subst, var + 1, ctx, (cname c, b, ty, opaque) :: args) - | Polymorphic_const _auctx -> + | Polymorphic_const _ -> (** Inline the term to emulate universe polymorphism *) let subst = Cmap_env.add c (Inl b) subst in (subst, var, ctx, args) @@ -1049,7 +1062,7 @@ let add_include me is_module inl senv = | SFBmodule _ -> M | SFBmodtype _ -> MT in - add_field field new_name senv + add_field ~is_include:true field new_name senv in resolver, List.fold_left add senv str diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 7af773e3bc..57b01f15e3 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -136,6 +136,7 @@ val add_constraints : (** Setting the type theory flavor *) val set_engagement : Declarations.engagement -> safe_transformer0 +val set_indices_matter : bool -> safe_transformer0 val set_typing_flags : Declarations.typing_flags -> safe_transformer0 val set_share_reduction : bool -> safe_transformer0 val set_VM : bool -> safe_transformer0 diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 35fa871b4e..f9fdbdd68e 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -88,6 +88,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = Cooking.cook_body = Undef nl; cook_type = t; cook_universes = univs; + cook_private_univs = None; cook_inline = false; cook_context = ctx; } @@ -130,6 +131,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = Cooking.cook_body = def; cook_type = typ; cook_universes = Monomorphic_const univs; + cook_private_univs = None; cook_inline = c.const_entry_inline_code; cook_context = c.const_entry_secctx; } @@ -145,24 +147,25 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = let body, ctx', _ = handle env body side_eff in body, Univ.ContextSet.union ctx ctx' in - let env, usubst, univs = match c.const_entry_universes with + let env, usubst, univs, private_univs = match c.const_entry_universes with | Monomorphic_const_entry univs -> let ctx = Univ.ContextSet.union univs ctx in let env = push_context_set ~strict:true ctx env in - env, Univ.empty_level_subst, Monomorphic_const ctx + env, Univ.empty_level_subst, Monomorphic_const ctx, None | Polymorphic_const_entry (nas, uctx) -> - (** Ensure not to generate internal constraints in polymorphic mode. - The only way for this to happen would be that either the body - contained deferred universes, or that it contains monomorphic - side-effects. The first property is ruled out by upper layers, - and the second one is ensured by the fact we currently - unconditionally export side-effects from polymorphic definitions, - i.e. [trust] is always [Pure]. *) - let () = assert (Univ.ContextSet.is_empty ctx) in + (** [ctx] must contain local universes, such that it has no impact + on the rest of the graph (up to transitivity). *) let env = push_context ~strict:false uctx env in let sbst, auctx = Univ.abstract_universes nas uctx in let sbst = Univ.make_instance_subst sbst in - env, sbst, Polymorphic_const auctx + let env, local = + if opaque then + push_subgraph ctx env, Some (on_snd (Univ.subst_univs_level_constraints sbst) ctx) + else + if Univ.ContextSet.is_empty ctx then env, None + else CErrors.anomaly Pp.(str "Local universes in non-opaque polymorphic definition.") + in + env, sbst, Polymorphic_const auctx, local in let j = infer env body in let typ = match typ with @@ -183,6 +186,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = Cooking.cook_body = def; cook_type = typ; cook_universes = univs; + cook_private_univs = private_univs; cook_inline = c.const_entry_inline_code; cook_context = c.const_entry_secctx; } @@ -277,6 +281,7 @@ let build_constant_declaration _kn env result = const_type = typ; const_body_code = tps; const_universes = univs; + const_private_poly_univs = result.cook_private_univs; const_inline_code = result.cook_inline; const_typing_flags = Environ.typing_flags env } diff --git a/kernel/typeops.ml b/kernel/typeops.ml index c8fd83c8a9..c9acd168e8 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -151,28 +151,41 @@ let type_of_abstraction _env name var ty = let make_judgev c t = Array.map2 make_judge c t +let rec check_empty_stack = function +| [] -> true +| CClosure.Zupdate _ :: s -> check_empty_stack s +| _ -> false + let type_of_apply env func funt argsv argstv = + let open CClosure in let len = Array.length argsv in - let rec apply_rec i typ = - if Int.equal i len then typ - else - (match kind (whd_all env typ) with - | Prod (_,c1,c2) -> - let arg = argsv.(i) and argt = argstv.(i) in - (try - let () = conv_leq false env argt c1 in - apply_rec (i+1) (subst1 arg c2) - with NotConvertible -> - error_cant_apply_bad_type env - (i+1,c1,argt) - (make_judge func funt) - (make_judgev argsv argstv)) - + let infos = create_clos_infos all env in + let tab = create_tab () in + let rec apply_rec i typ = + if Int.equal i len then term_of_fconstr typ + else + let typ, stk = whd_stack infos tab typ [] in + (** The return stack is known to be empty *) + let () = assert (check_empty_stack stk) in + match fterm_of typ with + | FProd (_, c1, c2, e) -> + let arg = argsv.(i) in + let argt = argstv.(i) in + let c1 = term_of_fconstr c1 in + begin match conv_leq false env argt c1 with + | () -> apply_rec (i+1) (mk_clos (Esubst.subs_cons ([| inject arg |], e)) c2) + | exception NotConvertible -> + error_cant_apply_bad_type env + (i+1,c1,argt) + (make_judge func funt) + (make_judgev argsv argstv) + end | _ -> - error_cant_apply_not_functional env - (make_judge func funt) - (make_judgev argsv argstv)) - in apply_rec 0 funt + error_cant_apply_not_functional env + (make_judge func funt) + (make_judgev argsv argstv) + in + apply_rec 0 (inject funt) (* Type of product *) diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 9083156745..afdc8f1511 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -866,6 +866,23 @@ let constraints_for ~kept g = arc.ltle csts) kept csts +let domain g = LMap.domain g.entries + +let choose p g u = + let exception Found of Level.t in + let ru = (repr g u).univ in + if p ru then Some ru + else + try LMap.iter (fun v -> function + | Canonical _ -> () (* we already tried [p ru] *) + | Equiv v' -> + let rv = (repr g v').univ in + if rv == ru && p v then raise (Found v) + (* NB: we could also try [p v'] but it will come up in the + rest of the iteration regardless. *) + ) g.entries; None + with Found v -> Some v + (** [sort_universes g] builds a totally ordered universe graph. The output graph should imply the input graph (and the implication will be strict most of the time), but is not necessarily minimal. diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index a2cc5b3116..4dbfac5c73 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -73,12 +73,19 @@ val sort_universes : t -> t of the universes into equivalence classes. *) val constraints_of_universes : t -> Constraint.t * LSet.t list +val choose : (Level.t -> bool) -> t -> Level.t -> Level.t option +(** [choose p g u] picks a universe verifying [p] and equal + to [u] in [g]. *) + (** [constraints_for ~kept g] returns the constraints about the universes [kept] in [g] up to transitivity. eg if [g] is [a <= b <= c] then [constraints_for ~kept:{a, c} g] is [a <= c]. *) val constraints_for : kept:LSet.t -> t -> Constraint.t +val domain : t -> LSet.t +(** Known universes *) + val check_subtype : AUContext.t check_function (** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of [ctx1]. *) diff --git a/kernel/vars.ml b/kernel/vars.ml index 7380a860dd..f9c576ca4a 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Esubst module RelDecl = Context.Rel.Declaration @@ -80,19 +79,9 @@ let noccur_with_meta n m term = (* Lifting *) (*********************) -(* The generic lifting function *) -let rec exliftn el c = match Constr.kind c with - | Constr.Rel i -> Constr.mkRel(reloc_rel i el) - | _ -> Constr.map_with_binders el_lift exliftn el c - -(* Lifting the binding depth across k bindings *) - -let liftn n k c = - match el_liftn (pred k) (el_shft n el_id) with - | ELID -> c - | el -> exliftn el c - -let lift n = liftn n 1 +let exliftn = Constr.exliftn +let liftn = Constr.liftn +let lift = Constr.lift (*********************) (* Substituting *) diff --git a/lib/coqProject_file.ml b/lib/coqProject_file.ml index 868042303d..d908baa1e8 100644 --- a/lib/coqProject_file.ml +++ b/lib/coqProject_file.ml @@ -24,7 +24,6 @@ type project = { v_files : string sourced list; mli_files : string sourced list; - ml4_files : string sourced list; mlg_files : string sourced list; ml_files : string sourced list; mllib_files : string sourced list; @@ -62,7 +61,6 @@ let mk_project project_file makefile install_kind use_ocamlopt = { v_files = []; mli_files = []; - ml4_files = []; mlg_files = []; ml_files = []; mllib_files = []; @@ -220,7 +218,9 @@ let process_cmd_line ~warning_fn orig_dir proj args = | ".v" -> { proj with v_files = proj.v_files @ [sourced f] } | ".ml" -> { proj with ml_files = proj.ml_files @ [sourced f] } - | ".ml4" -> { proj with ml4_files = proj.ml4_files @ [sourced f] } + | ".ml4" -> + let msg = Printf.sprintf "camlp5 macro files not supported anymore, please port %s to coqpp" f in + raise (Parsing_error msg) | ".mlg" -> { proj with mlg_files = proj.mlg_files @ [sourced f] } | ".mli" -> { proj with mli_files = proj.mli_files @ [sourced f] } | ".mllib" -> { proj with mllib_files = proj.mllib_files @ [sourced f] } @@ -248,9 +248,9 @@ let rec find_project_file ~from ~projfile_name = else find_project_file ~from:newdir ~projfile_name ;; -let all_files { v_files; ml_files; mli_files; ml4_files; mlg_files; +let all_files { v_files; ml_files; mli_files; mlg_files; mllib_files; mlpack_files } = - v_files @ mli_files @ ml4_files @ mlg_files @ ml_files @ mllib_files @ mlpack_files + v_files @ mli_files @ mlg_files @ ml_files @ mllib_files @ mlpack_files let map_sourced_list f l = List.map (fun x -> f x.thing) l ;; diff --git a/lib/coqProject_file.mli b/lib/coqProject_file.mli index 20b276ce8c..39c5d019d0 100644 --- a/lib/coqProject_file.mli +++ b/lib/coqProject_file.mli @@ -22,7 +22,6 @@ type project = { v_files : string sourced list; mli_files : string sourced list; - ml4_files : string sourced list; mlg_files : string sourced list; ml_files : string sourced list; mllib_files : string sourced list; @@ -4,4 +4,4 @@ (public_name coq.lib) (wrapped false) (modules_without_implementation xml_datatype) - (libraries threads coq.clib coq.config)) + (libraries dynlink coq.clib coq.config)) diff --git a/lib/flags.ml b/lib/flags.ml index 3aef5a7b2c..ae4d337ded 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -123,8 +123,5 @@ let get_inline_level () = !inline_level (* Native code compilation for conversion and normalization *) let output_native_objects = ref false -(* Print the mod uid associated to a vo file by the native compiler *) -let print_mod_uid = ref false - let profile_ltac = ref false let profile_ltac_cutoff = ref 2.0 diff --git a/lib/flags.mli b/lib/flags.mli index e282d4ca8c..d883cf1e30 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -119,8 +119,6 @@ val default_inline_level : int (** When producing vo objects, also compile the native-code version *) val output_native_objects : bool ref -(** Print the mod uid associated to a vo file by the native compiler *) -val print_mod_uid : bool ref - +(** Global profile_ltac flag *) val profile_ltac : bool ref val profile_ltac_cutoff : float ref diff --git a/lib/loc.ml b/lib/loc.ml index 1a09091bff..c08648911b 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -22,15 +22,19 @@ type t = { bol_pos_last : int; (** position of the beginning of end line *) bp : int; (** start position *) ep : int; (** end position *) + comm : string; (** start comment *) + ecomm : string (** end comment *) } let create fname line_nb bol_pos bp ep = { fname = fname; line_nb = line_nb; bol_pos = bol_pos; - line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep; } + line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep; + comm = ""; ecomm = "" } let make_loc (bp, ep) = { fname = ToplevelInput; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; - bp = bp; ep = ep; } + bp = bp; ep = ep; + comm = ""; ecomm = "" } let mergeable loc1 loc2 = loc1.fname = loc2.fname @@ -45,7 +49,8 @@ let merge loc1 loc2 = bol_pos = loc1.bol_pos; line_nb_last = loc2.line_nb_last; bol_pos_last = loc2.bol_pos_last; - bp = loc1.bp; ep = loc2.ep; } + bp = loc1.bp; ep = loc2.ep; + comm = loc1.comm; ecomm = loc2.comm } else loc1 else if loc2.ep < loc1.ep then { fname = loc2.fname; @@ -53,7 +58,9 @@ let merge loc1 loc2 = bol_pos = loc2.bol_pos; line_nb_last = loc1.line_nb_last; bol_pos_last = loc1.bol_pos_last; - bp = loc2.bp; ep = loc1.ep; } + bp = loc2.bp; ep = loc1.ep; + comm = loc2.comm; ecomm = loc1.comm + } else loc2 let merge_opt l1 l2 = match l1, l2 with diff --git a/lib/loc.mli b/lib/loc.mli index 23df1ebd9a..c46311b639 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -22,6 +22,8 @@ type t = { bol_pos_last : int; (** position of the beginning of end line *) bp : int; (** start position *) ep : int; (** end position *) + comm : string; (** start comment *) + ecomm : string (** end comment *) } (** {5 Location manipulation} *) diff --git a/library/global.ml b/library/global.ml index 4ea5969a6f..67b00cf411 100644 --- a/library/global.ml +++ b/library/global.ml @@ -88,6 +88,7 @@ let add_constraints c = globalize0 (Safe_typing.add_constraints c) let push_context_set b c = globalize0 (Safe_typing.push_context_set b c) let set_engagement c = globalize0 (Safe_typing.set_engagement c) +let set_indices_matter b = globalize0 (Safe_typing.set_indices_matter b) let set_typing_flags c = globalize0 (Safe_typing.set_typing_flags c) let typing_flags () = Environ.typing_flags (env ()) let export_private_constants ~in_section cd = globalize (Safe_typing.export_private_constants ~in_section cd) diff --git a/library/global.mli b/library/global.mli index 01ee695c49..40962e21af 100644 --- a/library/global.mli +++ b/library/global.mli @@ -29,6 +29,7 @@ val named_context : unit -> Constr.named_context (** Changing the (im)predicativity of the system *) val set_engagement : Declarations.engagement -> unit +val set_indices_matter : bool -> unit val set_typing_flags : Declarations.typing_flags -> unit val typing_flags : unit -> Declarations.typing_flags diff --git a/library/goptions.ml b/library/goptions.ml index 154b863fa1..98efb512ab 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -276,10 +276,7 @@ let declare_option cast uncast append ?(preprocess = fun x -> x) let cread () = cast (read ()) in let cwrite l v = warn (); change l OptSet (uncast v) in let cappend l v = warn (); change l OptAppend (uncast v) in - value_tab := OptionMap.add key (name, depr, (cread,cwrite,cappend)) !value_tab; - write - -type 'a write_function = 'a -> unit + value_tab := OptionMap.add key (name, depr, (cread,cwrite,cappend)) !value_tab let declare_int_option = declare_option @@ -302,6 +299,18 @@ let declare_stringopt_option = (function StringOptValue v -> v | _ -> anomaly (Pp.str "async_option.")) (fun _ _ -> anomaly (Pp.str "async_option.")) +let declare_bool_option_and_ref ~depr ~name ~key ~(value:bool) = + let r_opt = ref value in + let optwrite v = r_opt := v in + let optread () = !r_opt in + let _ = declare_bool_option { + optdepr = depr; + optname = name; + optkey = key; + optread; optwrite + } in + optread + (* 3- User accessible commands *) (* Setting values of options *) @@ -425,6 +434,3 @@ let print_tables () = (fun (nickkey,_) p -> p ++ str " " ++ str nickkey ++ fnl ()) !ref_table (mt ()) ++ fnl () - - - diff --git a/library/goptions.mli b/library/goptions.mli index 3d7df18fed..b91553bf3c 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -122,17 +122,18 @@ type 'a option_sig = { (** The [preprocess] function is triggered before setting the option. It can be used to emit a warning on certain values, and clean-up the final value. *) -type 'a write_function = 'a -> unit - val declare_int_option : ?preprocess:(int option -> int option) -> - int option option_sig -> int option write_function + int option option_sig -> unit val declare_bool_option : ?preprocess:(bool -> bool) -> - bool option_sig -> bool write_function + bool option_sig -> unit val declare_string_option: ?preprocess:(string -> string) -> - string option_sig -> string write_function + string option_sig -> unit val declare_stringopt_option: ?preprocess:(string option -> string option) -> - string option option_sig -> string option write_function + string option option_sig -> unit +(** Helper to declare a reference controlled by an option. Read-only + as to avoid races. *) +val declare_bool_option_and_ref : depr:bool -> name:string -> key:option_name -> value:bool -> (unit -> bool) (** {6 Special functions supposed to be used only in vernacentries.ml } *) diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index d81ee475b5..c2b7fa117d 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -13,28 +13,6 @@ open Util open Tok open Gramlib -(** Location utilities *) -let ploc_file_of_coq_file = function -| Loc.ToplevelInput -> "" -| Loc.InFile f -> f - -let coq_file_of_ploc_file s = - if s = "" then Loc.ToplevelInput else Loc.InFile s - -let from_coqloc fname line_nb bol_pos bp ep = - Ploc.make_loc (ploc_file_of_coq_file fname) line_nb bol_pos (bp, ep) "" - -let to_coqloc loc = - { Loc.fname = coq_file_of_ploc_file (Ploc.file_name loc); - Loc.line_nb = Ploc.line_nb loc; - Loc.bol_pos = Ploc.bol_pos loc; - Loc.bp = Ploc.first_pos loc; - Loc.ep = Ploc.last_pos loc; - Loc.line_nb_last = Ploc.line_nb_last loc; - Loc.bol_pos_last = Ploc.bol_pos_last loc; } - -let (!@) = to_coqloc - (* Dictionaries: trees annotated with string options, each node being a map from chars to dictionaries (the subtrees). A trie, in other words. *) @@ -128,18 +106,22 @@ module Error = struct end open Error -let err loc str = Loc.raise ~loc:(to_coqloc loc) (Error.E str) +let err loc str = Loc.raise ~loc (Error.E str) let bad_token str = raise (Error.E (Bad_token str)) (* Update a loc without allocating an intermediate pair *) let set_loc_pos loc bp ep = - Ploc.sub loc (bp - Ploc.first_pos loc) (ep - bp) + Ploc.sub loc (bp - loc.Loc.bp) (ep - bp) (* Increase line number by 1 and update position of beginning of line *) let bump_loc_line loc bol_pos = - Ploc.make_loc (Ploc.file_name loc) (Ploc.line_nb loc + 1) bol_pos - (Ploc.first_pos loc, Ploc.last_pos loc) (Ploc.comment loc) + Loc.{ loc with + line_nb = loc.line_nb + 1; + line_nb_last = loc.line_nb + 1; + bol_pos; + bol_pos_last = bol_pos; + } (* Same as [bump_loc_line], but for the last line in location *) (* For an obscure reason, camlp5 does not give an easy way to set line_nb_stop, @@ -147,19 +129,25 @@ let bump_loc_line loc bol_pos = (* Warning: [bump_loc_line_last] changes the end position. You may need to call [set_loc_pos] to fix it. *) let bump_loc_line_last loc bol_pos = - let loc' = - Ploc.make_loc (Ploc.file_name loc) (Ploc.line_nb_last loc + 1) bol_pos - (Ploc.first_pos loc + 1, Ploc.last_pos loc + 1) (Ploc.comment loc) - in - Ploc.encl loc loc' + let open Loc in + let loc' = { loc with + line_nb = loc.line_nb_last + 1; + line_nb_last = loc.line_nb_last + 1; + bol_pos; + bol_pos_last = bol_pos; + bp = loc.bp + 1; + ep = loc.ep + 1; + } in + Loc.merge loc loc' (* For some reason, the [Ploc.after] function of Camlp5 does not update line numbers, so we define our own function that does it. *) let after loc = - let line_nb = Ploc.line_nb_last loc in - let bol_pos = Ploc.bol_pos_last loc in - Ploc.make_loc (Ploc.file_name loc) line_nb bol_pos - (Ploc.last_pos loc, Ploc.last_pos loc) (Ploc.comment loc) + Loc.{ loc with + line_nb = loc.line_nb_last; + bol_pos = loc.bol_pos_last; + bp = loc.ep; + } (** Lexer conventions on tokens *) @@ -324,7 +312,7 @@ let rec ident_tail loc len s = match Stream.peek s with | Utf8Token (st, n) when Unicode.is_unknown st -> let id = get_buff len in let u = String.concat "" (List.map (String.make 1) (Stream.npeek n s)) in - warn_unrecognized_unicode ~loc:!@loc (u,id); len + warn_unrecognized_unicode ~loc (u,id); len | _ -> len let rec number len s = match Stream.peek s with @@ -368,7 +356,7 @@ let rec string loc ~comm_level bp len s = match Stream.peek s with Stream.junk s; let () = match comm_level with | Some 0 -> - warn_comment_terminator_in_string ~loc:!@loc () + warn_comment_terminator_in_string ~loc () | _ -> () in let comm_level = Option.map pred comm_level in @@ -757,7 +745,7 @@ let token_text = function let func cs = let loct = loct_create () in - let cur_loc = ref (from_coqloc !current_file 1 0 0 0) in + let cur_loc = ref (Loc.create !current_file 1 0 0 0) in let ts = Stream.from (fun i -> @@ -775,7 +763,6 @@ let lexer = { | _ -> ()); Plexing.tok_removing = (fun _ -> ()); Plexing.tok_match = Tok.match_pattern; - Plexing.tok_comm = None; Plexing.tok_text = token_text } (** Terminal symbols interpretation *) diff --git a/parsing/extend.ml b/parsing/extend.ml index 5caeab535a..050ed49622 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -14,17 +14,8 @@ type 'a entry = 'a Gramlib.Grammar.GMake(CLexer).Entry.e type side = Left | Right -type gram_assoc = NonA | RightA | LeftA - -type gram_position = - | First - | Last - | Before of string - | After of string - | Level of string - type production_position = - | BorderProd of side * gram_assoc option + | BorderProd of side * Gramlib.Gramext.g_assoc option | InternalProd type production_level = @@ -116,11 +107,11 @@ type 'a production_rule = type 'a single_extend_statement = string option * (** Level *) - gram_assoc option * + Gramlib.Gramext.g_assoc option * (** Associativity *) 'a production_rule list (** Symbol list with the interpretation function *) type 'a extend_statement = - gram_position option * + Gramlib.Gramext.position option * 'a single_extend_statement list diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index e25f7aa54f..b3ae24e941 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -81,7 +81,7 @@ let err () = raise Stream.Failure (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) (* admissible notation "(x t)" *) let lpar_id_coloneq = - Gram.Entry.of_parser "test_lpar_id_coloneq" + Pcoq.Entry.of_parser "test_lpar_id_coloneq" (fun strm -> match stream_nth 0 strm with | KEYWORD "(" -> @@ -96,7 +96,7 @@ let lpar_id_coloneq = | _ -> err ()) let impl_ident_head = - Gram.Entry.of_parser "impl_ident_head" + Pcoq.Entry.of_parser "impl_ident_head" (fun strm -> match stream_nth 0 strm with | KEYWORD "{" -> @@ -109,7 +109,7 @@ let impl_ident_head = | _ -> err ()) let name_colon = - Gram.Entry.of_parser "name_colon" + Pcoq.Entry.of_parser "name_colon" (fun strm -> match stream_nth 0 strm with | IDENT s -> diff --git a/parsing/g_prim.mlg b/parsing/g_prim.mlg index dfb788907e..6247a12640 100644 --- a/parsing/g_prim.mlg +++ b/parsing/g_prim.mlg @@ -13,7 +13,6 @@ open Names open Libnames -open Pcoq open Pcoq.Prim let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "'"] diff --git a/parsing/notation_gram.ml b/parsing/notation_gram.ml index d8c08803b6..fc5feba58b 100644 --- a/parsing/notation_gram.ml +++ b/parsing/notation_gram.ml @@ -32,7 +32,7 @@ type grammar_constr_prod_item = type one_notation_grammar = { notgram_level : level; - notgram_assoc : Extend.gram_assoc option; + notgram_assoc : Gramlib.Gramext.g_assoc option; notgram_notation : Constrexpr.notation; notgram_prods : grammar_constr_prod_item list list; } diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 445338b786..923147ba2e 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -14,32 +14,6 @@ open Extend open Genarg open Gramlib -let curry f x y = f (x, y) -let uncurry f (x,y) = f x y - -(** Location Utils *) -let ploc_file_of_coq_file = function -| Loc.ToplevelInput -> "" -| Loc.InFile f -> f - -let coq_file_of_ploc_file s = - if s = "" then Loc.ToplevelInput else Loc.InFile s - -let of_coqloc loc = - let open Loc in - Ploc.make_loc (ploc_file_of_coq_file loc.fname) loc.line_nb loc.bol_pos (loc.bp, loc.ep) "" - -let to_coqloc loc = - { Loc.fname = coq_file_of_ploc_file (Ploc.file_name loc); - Loc.line_nb = Ploc.line_nb loc; - Loc.bol_pos = Ploc.bol_pos loc; - Loc.bp = Ploc.first_pos loc; - Loc.ep = Ploc.last_pos loc; - Loc.line_nb_last = Ploc.line_nb_last loc; - Loc.bol_pos_last = Ploc.bol_pos_last loc; } - -let (!@) = to_coqloc - (** The parser of Coq *) module G : sig @@ -83,28 +57,18 @@ module type S = end *) - type 'a entry = 'a Entry.e - type internal_entry = Tok.t Gramext.g_entry - type symbol = Tok.t Gramext.g_symbol - type action = Gramext.g_action type coq_parsable val coq_parsable : ?file:Loc.source -> char Stream.t -> coq_parsable - val action : 'a -> action val entry_create : string -> 'a entry val entry_parse : 'a entry -> coq_parsable -> 'a val comment_state : coq_parsable -> ((int * int) * string) list -end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e = struct +end with type 'a Entry.e = 'a Extend.entry = struct include Grammar.GMake(CLexer) - type 'a entry = 'a Entry.e - type internal_entry = Tok.t Gramext.g_entry - type symbol = Tok.t Gramext.g_symbol - type action = Gramext.g_action - type coq_parsable = parsable * CLexer.lexer_state ref let coq_parsable ?(file=Loc.ToplevelInput) c = @@ -114,7 +78,6 @@ end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e = struct state := CLexer.get_lexer_state (); (a,state) - let action = Gramext.action let entry_create = Entry.create let entry_parse e (p,state) = @@ -126,7 +89,7 @@ end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e = struct with Ploc.Exc (loc,e) -> CLexer.drop_lexer_state (); let loc' = Loc.get_loc (Exninfo.info e) in - let loc = match loc' with None -> to_coqloc loc | Some loc -> loc in + let loc = match loc' with None -> loc | Some loc -> loc in Loc.raise ~loc e let comment_state (p,state) = @@ -149,34 +112,16 @@ struct let create = G.Entry.create let parse = G.entry_parse let print = G.Entry.print + let of_parser = G.Entry.of_parser + let name = G.Entry.name + let parse_token_stream = G.Entry.parse_token_stream end -let warning_verbose = Gramext.warning_verbose - -let of_coq_assoc = function -| Extend.RightA -> Gramext.RightA -| Extend.LeftA -> Gramext.LeftA -| Extend.NonA -> Gramext.NonA - -let of_coq_position = function -| Extend.First -> Gramext.First -| Extend.Last -> Gramext.Last -| Extend.Before s -> Gramext.Before s -| Extend.After s -> Gramext.After s -| Extend.Level s -> Gramext.Level s - module Symbols : sig - val stoken : Tok.t -> G.symbol - val sself : G.symbol - val snext : G.symbol - val slist0 : G.symbol -> G.symbol - val slist0sep : G.symbol * G.symbol -> G.symbol - val slist1 : G.symbol -> G.symbol - val slist1sep : G.symbol * G.symbol -> G.symbol - val sopt : G.symbol -> G.symbol - val snterml : G.internal_entry * string -> G.symbol - val snterm : G.internal_entry -> G.symbol + val stoken : Tok.t -> ('s, string) G.ty_symbol + val slist0sep : ('s, 'a) G.ty_symbol -> ('s, 'b) G.ty_symbol -> ('s, 'a list) G.ty_symbol + val slist1sep : ('s, 'a) G.ty_symbol -> ('s, 'b) G.ty_symbol -> ('s, 'a list) G.ty_symbol end = struct let stoken tok = @@ -191,27 +136,12 @@ end = struct | Tok.BULLET s -> "BULLET", s | Tok.EOI -> "EOI", "" in - Gramext.Stoken pattern - - let slist0sep (x, y) = Gramext.Slist0sep (x, y, false) - let slist1sep (x, y) = Gramext.Slist1sep (x, y, false) - - let snterml (x, y) = Gramext.Snterml (x, y) - let snterm x = Gramext.Snterm x - let sself = Gramext.Sself - let snext = Gramext.Snext - let slist0 x = Gramext.Slist0 x - let slist1 x = Gramext.Slist1 x - let sopt x = Gramext.Sopt x + G.s_token pattern + let slist0sep x y = G.s_list0sep x y false + let slist1sep x y = G.s_list1sep x y false end -let camlp5_verbosity silent f x = - let a = !warning_verbose in - warning_verbose := silent; - f x; - warning_verbose := a - (** Grammar extensions *) (** NB: [extend_statement = @@ -225,61 +155,71 @@ let camlp5_verbosity silent f x = (** Binding general entry keys to symbol *) -let rec of_coq_action : type a r. (r, a, Loc.t -> r) Extend.rule -> a -> G.action = function -| Stop -> fun f -> G.action (fun loc -> f (!@ loc)) -| Next (r, _) -> fun f -> G.action (fun x -> of_coq_action r (f x)) - -let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> _ = function - | Atoken t -> Symbols.stoken t - | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) - | Alist1sep (s,sep) -> - Symbols.slist1sep (symbol_of_prod_entry_key s, symbol_of_prod_entry_key sep) - | Alist0 s -> Symbols.slist0 (symbol_of_prod_entry_key s) - | Alist0sep (s,sep) -> - Symbols.slist0sep (symbol_of_prod_entry_key s, symbol_of_prod_entry_key sep) - | Aopt s -> Symbols.sopt (symbol_of_prod_entry_key s) - | Aself -> Symbols.sself - | Anext -> Symbols.snext - | Aentry e -> - Symbols.snterm (G.Entry.obj e) - | Aentryl (e, n) -> - Symbols.snterml (G.Entry.obj e, n) - | Arules rs -> - Gramext.srules (List.map symbol_of_rules rs) - -and symbol_of_rule : type s a r. (s, a, r) Extend.rule -> _ = function -| Stop -> fun accu -> accu -| Next (r, s) -> fun accu -> symbol_of_rule r (symbol_of_prod_entry_key s :: accu) - -and symbol_of_rules : type a. a Extend.rules -> _ = function +type ('s, 'a, 'r) casted_rule = Casted : ('s, 'b, 'r) G.ty_rule * ('a -> 'b) -> ('s, 'a, 'r) casted_rule + +let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> (s, a) G.ty_symbol = function +| Atoken t -> Symbols.stoken t +| Alist1 s -> G.s_list1 (symbol_of_prod_entry_key s) +| Alist1sep (s,sep) -> + Symbols.slist1sep (symbol_of_prod_entry_key s) (symbol_of_prod_entry_key sep) +| Alist0 s -> G.s_list0 (symbol_of_prod_entry_key s) +| Alist0sep (s,sep) -> + Symbols.slist0sep (symbol_of_prod_entry_key s) (symbol_of_prod_entry_key sep) +| Aopt s -> G.s_opt (symbol_of_prod_entry_key s) +| Aself -> G.s_self +| Anext -> G.s_next +| Aentry e -> G.s_nterm e +| Aentryl (e, n) -> G.s_nterml e n +| Arules rs -> + let warning msg = Feedback.msg_warning Pp.(str msg) in + G.s_rules ~warning:(Some warning) (List.map symbol_of_rules rs) + +and symbol_of_rule : type s a r. (s, a, Loc.t -> r) Extend.rule -> (s, a, Loc.t -> r) casted_rule = function +| Stop -> Casted (G.r_stop, fun act loc -> act loc) +| Next (r, s) -> + let Casted (r, cast) = symbol_of_rule r in + Casted (G.r_next r (symbol_of_prod_entry_key s), (fun act x -> cast (act x))) + +and symbol_of_rules : type a. a Extend.rules -> a G.ty_production = function | Rules (r, act) -> - let symb = symbol_of_rule r.norec_rule [] in - let act = of_coq_action r.norec_rule act in - (symb, act) + let Casted (symb, cast) = symbol_of_rule r.norec_rule in + G.production (symb, cast act) + +(** FIXME: This is a hack around a deficient camlp5 API *) +type 'a any_production = AnyProduction : ('a, 'f, Loc.t -> 'a) G.ty_rule * 'f -> 'a any_production -let of_coq_production_rule : type a. a Extend.production_rule -> _ = function -| Rule (toks, act) -> (symbol_of_rule toks [], of_coq_action toks act) +let of_coq_production_rule : type a. a Extend.production_rule -> a any_production = function +| Rule (toks, act) -> + let Casted (symb, cast) = symbol_of_rule toks in + AnyProduction (symb, cast act) let of_coq_single_extend_statement (lvl, assoc, rule) = - (lvl, Option.map of_coq_assoc assoc, List.map of_coq_production_rule rule) + (lvl, assoc, List.map of_coq_production_rule rule) let of_coq_extend_statement (pos, st) = - (Option.map of_coq_position pos, List.map of_coq_single_extend_statement st) + (pos, List.map of_coq_single_extend_statement st) + +let fix_extend_statement (pos, st) = + let fix_single_extend_statement (lvl, assoc, rules) = + let fix_production_rule (AnyProduction (s, act)) = G.production (s, act) in + (lvl, assoc, List.map fix_production_rule rules) + in + (pos, List.map fix_single_extend_statement st) (** Type of reinitialization data *) -type gram_reinit = gram_assoc * gram_position +type gram_reinit = Gramlib.Gramext.g_assoc * Gramlib.Gramext.position type extend_rule = -| ExtendRule : 'a G.entry * gram_reinit option * 'a extend_statement -> extend_rule +| ExtendRule : 'a G.Entry.e * gram_reinit option * 'a extend_statement -> extend_rule module EntryCommand = Dyn.Make () -module EntryData = struct type _ t = Ex : 'b G.entry String.Map.t -> ('a * 'b) t end +module EntryData = struct type _ t = Ex : 'b G.Entry.e String.Map.t -> ('a * 'b) t end module EntryDataMap = EntryCommand.Map(EntryData) type ext_kind = | ByGrammar of extend_rule | ByEXTEND of (unit -> unit) * (unit -> unit) - | ByEntry : ('a * 'b) EntryCommand.tag * string * 'b G.entry -> ext_kind + | ByEntry : ('a * 'b) EntryCommand.tag * string * 'b G.Entry.e -> ext_kind (** The list of extensions *) @@ -292,17 +232,16 @@ let camlp5_entries = ref EntryDataMap.empty let grammar_delete e reinit (pos,rls) = List.iter (fun (n,ass,lev) -> - List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev)) + List.iter (fun (AnyProduction (pil,_)) -> G.safe_delete_rule e pil) (List.rev lev)) (List.rev rls); match reinit with | Some (a,ext) -> - let a = of_coq_assoc a in - let ext = of_coq_position ext in let lev = match pos with | Some (Gramext.Level n) -> n | _ -> assert false in - (G.extend e) (Some ext) [Some lev,Some a,[]] + let warning msg = Feedback.msg_warning Pp.(str msg) in + (G.safe_extend ~warning:(Some warning) e) (Some ext) [Some lev,Some a,[]] | None -> () (** Extension *) @@ -310,13 +249,15 @@ let grammar_delete e reinit (pos,rls) = let grammar_extend e reinit ext = let ext = of_coq_extend_statement ext in let undo () = grammar_delete e reinit ext in - let redo () = camlp5_verbosity false (uncurry (G.extend e)) ext in + let pos, ext = fix_extend_statement ext in + let redo () = G.safe_extend ~warning:None e pos ext in camlp5_state := ByEXTEND (undo, redo) :: !camlp5_state; redo () let grammar_extend_sync e reinit ext = camlp5_state := ByGrammar (ExtendRule (e, reinit, ext)) :: !camlp5_state; - camlp5_verbosity false (uncurry (G.extend e)) (of_coq_extend_statement ext) + let pos, ext = fix_extend_statement (of_coq_extend_statement ext) in + G.safe_extend ~warning:None e pos ext (** The apparent parser of Coq; encapsulate G to keep track of the extensions. *) @@ -324,25 +265,6 @@ let grammar_extend_sync e reinit ext = module Gram = struct include G - let extend e = - curry - (fun ext -> - camlp5_state := - (ByEXTEND ((fun () -> grammar_delete e None ext), - (fun () -> uncurry (G.extend e) ext))) - :: !camlp5_state; - uncurry (G.extend e) ext) - let delete_rule e pil = - (* spiwack: if you use load an ML module which contains GDELETE_RULE - in a section, God kills a kitty. As it would corrupt remove_grammars. - There does not seem to be a good way to undo a delete rule. As deleting - takes fewer arguments than extending. The production rule isn't returned - by delete_rule. If we could retrieve the necessary information, then - ByEXTEND provides just the framework we need to allow this in section. - I'm not entirely sure it makes sense, but at least it would be more correct. - *) - G.delete_rule e pil - let gram_extend e ext = grammar_extend e None ext end (** Remove extensions @@ -381,16 +303,18 @@ let make_rule r = [None, None, r] let eoi_entry en = let e = Entry.create ((Gram.Entry.name en) ^ "_eoi") in - let symbs = [Symbols.snterm (Gram.Entry.obj en); Symbols.stoken Tok.EOI] in - let act = Gram.action (fun _ x loc -> x) in - uncurry (Gram.extend e) (None, make_rule [symbs, act]); + let symbs = G.r_next (G.r_next G.r_stop (G.s_nterm en)) (Symbols.stoken Tok.EOI) in + let act = fun _ x loc -> x in + let warning msg = Feedback.msg_warning Pp.(str msg) in + Gram.safe_extend ~warning:(Some warning) e None (make_rule [G.production (symbs, act)]); e let map_entry f en = let e = Entry.create ((Gram.Entry.name en) ^ "_map") in - let symbs = [Symbols.snterm (Gram.Entry.obj en)] in - let act = Gram.action (fun x loc -> f x) in - uncurry (Gram.extend e) (None, make_rule [symbs, act]); + let symbs = G.r_next G.r_stop (G.s_nterm en) in + let act = fun x loc -> f x in + let warning msg = Feedback.msg_warning Pp.(str msg) in + Gram.safe_extend ~warning:(Some warning) e None (make_rule [G.production (symbs, act)]); e (* Parse a string, does NOT check if the entire string was read @@ -517,10 +441,11 @@ module Module = end let epsilon_value f e = - let r = Rule (Next (Stop, e), fun x _ -> f x) in - let ext = of_coq_extend_statement (None, [None, None, [r]]) in + let r = G.production (G.r_next G.r_stop (symbol_of_prod_entry_key e), (fun x _ -> f x)) in + let ext = [None, None, [r]] in let entry = Gram.entry_create "epsilon" in - let () = uncurry (G.extend entry) ext in + let warning msg = Feedback.msg_warning Pp.(str msg) in + let () = G.safe_extend ~warning:(Some warning) entry None ext in try Some (parse_string entry "") with _ -> None (** Synchronized grammar extensions *) @@ -573,7 +498,7 @@ let extend_grammar_command tag g = let nb = List.length rules in grammar_stack := (GramExt (nb, GrammarCommand.Dyn (tag, g)), st) :: !grammar_stack -let extend_entry_command (type a) (type b) (tag : (a, b) entry_command) (g : a) : b Gram.entry list = +let extend_entry_command (type a) (type b) (tag : (a, b) entry_command) (g : a) : b Gram.Entry.e list = let EntryInterp.Ex modify = EntryInterpMap.find tag !entry_interp in let grammar_state = match !grammar_stack with | [] -> GramState.empty @@ -605,7 +530,7 @@ let extend_dyn_grammar (e, _) = match e with (** Registering extra grammar *) -type any_entry = AnyEntry : 'a Gram.entry -> any_entry +type any_entry = AnyEntry : 'a Gram.Entry.e -> any_entry let grammar_names : any_entry list String.Map.t ref = ref String.Map.empty diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 593cf59341..352857d4cd 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -13,21 +13,9 @@ open Extend open Genarg open Constrexpr open Libnames -open Gramlib (** The parser of Coq *) -(** DO NOT USE EXTENSION FUNCTIONS IN THIS MODULE. - We only have it here to work with Camlp5. Handwritten grammar extensions - should use the safe [Pcoq.grammar_extend] function below. *) -module Gram : sig - - include Grammar.S with type te = Tok.t - - val gram_extend : 'a Entry.e -> 'a Extend.extend_statement -> unit - -end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e - module Parsable : sig type t @@ -37,10 +25,13 @@ sig end module Entry : sig - type 'a t = 'a Grammar.GMake(CLexer).Entry.e + type 'a t = 'a Extend.entry val create : string -> 'a t val parse : 'a t -> Parsable.t -> 'a val print : Format.formatter -> 'a t -> unit + val of_parser : string -> (Tok.t Stream.t -> 'a) -> 'a t + val parse_token_stream : 'a t -> Tok.t Stream.t -> 'a + val name : 'a t -> string end (** The parser of Coq is built from three kinds of rule declarations: @@ -118,10 +109,6 @@ end *) -(** Temporarily activate camlp5 verbosity *) - -val camlp5_verbosity : bool -> ('a -> unit) -> 'a -> unit - (** Parse a string *) val parse_string : 'a Entry.t -> string -> 'a @@ -210,7 +197,7 @@ val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option (** {5 Extending the parser without synchronization} *) -type gram_reinit = gram_assoc * gram_position +type gram_reinit = Gramlib.Gramext.g_assoc * Gramlib.Gramext.position (** Type of reinitialization data *) val grammar_extend : 'a Entry.t -> gram_reinit option -> @@ -273,11 +260,6 @@ val find_custom_entry : ('a, 'b) entry_command -> string -> 'b Entry.t val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b -(** Location Utils *) -val of_coqloc : Loc.t -> Ploc.t -val to_coqloc : Ploc.t -> Loc.t -val (!@) : Ploc.t -> Loc.t - type frozen_t val parser_summary_tag : frozen_t Summary.Dyn.tag diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index a6f432b5bd..575d964158 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -33,7 +33,7 @@ let print_constr t = let debug x = if !cc_verbose then Feedback.msg_debug (x ()) -let _= +let () = let gdopt= { optdepr=false; optname="Congruence Verbose"; @@ -61,7 +61,7 @@ module ST=struct type t = {toterm: int IntPairTable.t; tosign: (int * int) IntTable.t} - let empty ()= + let empty () = {toterm=IntPairTable.create init_size; tosign=IntTable.create init_size} @@ -321,7 +321,7 @@ let compress_path uf i j = uf.map.(j).cpath<-i let rec find_aux uf visited i= let j = uf.map.(i).cpath in - if j<0 then let _ = List.iter (compress_path uf i) visited in i else + if j<0 then let () = List.iter (compress_path uf i) visited in i else find_aux uf (i::visited) j let find uf i= find_aux uf [] i diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index f6eea3c5c4..16890ea260 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -500,7 +500,7 @@ let info_file f = let my_bool_option name initval = let flag = ref initval in let access = fun () -> !flag in - let _ = declare_bool_option + let () = declare_bool_option {optdepr = false; optname = "Extraction "^name; optkey = ["Extraction"; name]; @@ -572,14 +572,14 @@ let chg_flag n = int_flag_ref := n; opt_flag_ref := flag_of_int n let optims () = !opt_flag_ref -let _ = declare_bool_option +let () = declare_bool_option {optdepr = false; optname = "Extraction Optimize"; optkey = ["Extraction"; "Optimize"]; optread = (fun () -> not (Int.equal !int_flag_ref 0)); optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))} -let _ = declare_int_option +let () = declare_int_option { optdepr = false; optname = "Extraction Flag"; optkey = ["Extraction";"Flag"]; @@ -593,7 +593,7 @@ let _ = declare_int_option let conservative_types_ref = ref false let conservative_types () = !conservative_types_ref -let _ = declare_bool_option +let () = declare_bool_option {optdepr = false; optname = "Extraction Conservative Types"; optkey = ["Extraction"; "Conservative"; "Types"]; @@ -605,7 +605,7 @@ let _ = declare_bool_option let file_comment_ref = ref "" let file_comment () = !file_comment_ref -let _ = declare_string_option +let () = declare_string_option {optdepr = false; optname = "Extraction File Comment"; optkey = ["Extraction"; "File"; "Comment"]; diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index a212d13453..37fc81ee38 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -33,7 +33,7 @@ DECLARE PLUGIN "ground_plugin" let ground_depth=ref 3 -let _= +let ()= let gdopt= { optdepr=false; optname="Firstorder Depth"; @@ -47,7 +47,7 @@ let _= declare_int_option gdopt -let _= +let ()= let congruence_depth=ref 100 in let gdopt= { optdepr=true; (* noop *) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index ef1d1af199..3b95423067 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1005,8 +1005,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num (mk_equation_id f_id) (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem)) evd - lemma_type - (Lemmas.mk_hook (fun _ _ -> ())); + lemma_type; ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None))); evd diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 1cf952576d..4cdfc6fac5 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -310,7 +310,6 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) !evd (EConstr.of_constr new_principle_type) - hook ; (* let _tim1 = System.get_time () in *) let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in @@ -322,11 +321,11 @@ 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 ~keep_body_ucst_separate:false (fun x -> x) in + let { id; entries; persistence } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) in match entries with | [entry] -> discard_current (); - (id,(entry,persistence)), CEphemeron.create hook + (id,(entry,persistence)), hook | _ -> CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") end @@ -386,7 +385,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) (* Pr 1278 : Don't forget to close the goal if an error is raised !!!! *) - save false new_princ_name entry g_kind hook + save false new_princ_name entry g_kind ~hook with e when CErrors.noncritical e -> begin begin diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 7e707b423a..8f0440a2a4 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -145,7 +145,6 @@ END { -module Gram = Pcoq.Gram module Vernac = Pvernac.Vernac_ module Tactic = Pltac diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 35acbea488..3a04c753ea 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -415,7 +415,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp ~program_mode:false fname (Decl_kinds.Global,false,Decl_kinds.Definition) pl - bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ())); + bl None body (Some ret_type); let evd,rev_pconstants = List.fold_left (fun (evd,l) ((({CAst.v=fname},_),_,_,_,_),_) -> diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index b68b34ca35..19f954c10d 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -129,7 +129,7 @@ let get_locality = function | Local -> true | Global -> false -let save with_clean id const (locality,_,kind) hook = +let save with_clean id const ?hook (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 () -> @@ -144,7 +144,7 @@ let save with_clean id const (locality,_,kind) hook = (locality, ConstRef kn) in if with_clean then Proof_global.discard_current (); - CEphemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r); + Lemmas.call_hook ?hook ~fix_exn l r; definition_message id let with_full_print f a = @@ -375,7 +375,7 @@ let functional_induction_rewrite_dependent_proofs_sig = optread = (fun () -> !functional_induction_rewrite_dependent_proofs); optwrite = (fun b -> functional_induction_rewrite_dependent_proofs := b) } -let _ = declare_bool_option functional_induction_rewrite_dependent_proofs_sig +let () = declare_bool_option functional_induction_rewrite_dependent_proofs_sig let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = true @@ -388,7 +388,7 @@ let function_debug_sig = optwrite = (fun b -> function_debug := b) } -let _ = declare_bool_option function_debug_sig +let () = declare_bool_option function_debug_sig let do_observe () = !function_debug @@ -406,7 +406,7 @@ let strict_tcc_sig = optwrite = (fun b -> strict_tcc := b) } -let _ = declare_bool_option strict_tcc_sig +let () = declare_bool_option strict_tcc_sig exception Building_graph of exn diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index c9d153d89f..9584649cff 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -42,8 +42,7 @@ val const_of_id: Id.t -> GlobRef.t(* constantyes *) val jmeq : unit -> EConstr.constr val jmeq_refl : unit -> EConstr.constr -val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> Decl_kinds.goal_kind -> - Lemmas.declaration_hook CEphemeron.key -> unit +val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> ?hook:Lemmas.declaration_hook -> Decl_kinds.goal_kind -> unit (* [with_full_print f a] applies [f] to [a] in full printing environment. diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index d1a227d517..95e2e9f6e5 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -806,8 +806,7 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list lem_id (Decl_kinds.Global,false,((Decl_kinds.Proof Decl_kinds.Theorem))) !evd - typ - (Lemmas.mk_hook (fun _ _ -> ())); + typ; ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") (proving_tac i)))); @@ -867,8 +866,7 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list let lem_id = mk_complete_id f_id in Lemmas.start_proof lem_id (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) sigma - (fst lemmas_types_infos.(i)) - (Lemmas.mk_hook (fun _ _ -> ())); + (fst lemmas_types_infos.(i)); ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") (proving_tac i)))) ; diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 6e5e3f9353..38f27f760b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1372,7 +1372,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp na (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma) sigma gls_type - (Lemmas.mk_hook hook); + ~hook:(Lemmas.mk_hook hook); if Indfun_common.is_strict_tcc () then ignore (by (Proofview.V82.tactic (tclIDTAC))) @@ -1418,7 +1418,7 @@ let com_terminate let evd, env = Pfedit.get_current_context () in Lemmas.start_proof thm_name (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) - ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) hook; + ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) ~hook; ignore (by (Proofview.V82.tactic (observe_tac (str "starting_tac") tac_start))); ignore (by (Proofview.V82.tactic (observe_tac (str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref @@ -1474,8 +1474,7 @@ let (com_eqn : int -> Id.t -> (Lemmas.start_proof eq_name (Global, false, Proof Lemma) ~sign:(Environ.named_context_val env) evd - (EConstr.of_constr equation_lemma_type) - (Lemmas.mk_hook (fun _ _ -> ())); + (EConstr.of_constr equation_lemma_type); ignore (by (Proofview.V82.tactic (start_equation f_ref terminate_ref (fun x -> diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index c4c4e51ecc..156ee94a66 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -332,7 +332,7 @@ END let local_test_lpar_id_colon = let err () = raise Stream.Failure in - Pcoq.Gram.Entry.of_parser "lpar_id_colon" + Pcoq.Entry.of_parser "lpar_id_colon" (fun strm -> match Util.stream_nth 0 strm with | Tok.KEYWORD "(" -> diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli index fa70235975..0509d6ae71 100644 --- a/plugins/ltac/extraargs.mli +++ b/plugins/ltac/extraargs.mli @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Genintern open Tacexpr open Names open Constrexpr @@ -28,22 +29,22 @@ val wit_natural : int Genarg.uniform_genarg_type val wit_glob : (constr_expr, - Tacexpr.glob_constr_and_expr, + glob_constr_and_expr, Tacinterp.interp_sign * glob_constr) Genarg.genarg_type val wit_lglob : (constr_expr, - Tacexpr.glob_constr_and_expr, + glob_constr_and_expr, Tacinterp.interp_sign * glob_constr) Genarg.genarg_type val wit_lconstr : (constr_expr, - Tacexpr.glob_constr_and_expr, + glob_constr_and_expr, EConstr.t) Genarg.genarg_type val wit_casted_constr : (constr_expr, - Tacexpr.glob_constr_and_expr, + glob_constr_and_expr, EConstr.t) Genarg.genarg_type val glob : constr_expr Pcoq.Entry.t diff --git a/plugins/ltac/extratactics.mli b/plugins/ltac/extratactics.mli index 7fb9a19a0c..4576562634 100644 --- a/plugins/ltac/extratactics.mli +++ b/plugins/ltac/extratactics.mli @@ -14,4 +14,4 @@ val injHyp : Names.Id.t -> unit Proofview.tactic (* val refine_tac : Evd.open_constr -> unit Proofview.tactic *) -val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tacexpr.delayed_open option -> unit Proofview.tactic +val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tactypes.delayed_open option -> unit Proofview.tactic diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index bd8a097154..d9b19c1ae6 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -70,7 +70,7 @@ let _ = (* Hack to parse "[ id" without dropping [ *) let test_bracket_ident = - Gram.Entry.of_parser "test_bracket_ident" + Pcoq.Entry.of_parser "test_bracket_ident" (fun strm -> match stream_nth 0 strm with | KEYWORD "[" -> @@ -373,7 +373,7 @@ open Libnames let print_info_trace = ref None -let _ = declare_int_option { +let () = declare_int_option { optdepr = false; optname = "print info trace"; optkey = ["Info" ; "Level"]; diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index e29f78af5b..ef18dd6cdc 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -45,7 +45,6 @@ let with_tac f tac = * Subtac. These entries are named Subtac.<foo> *) -module Gram = Pcoq.Gram module Tactic = Pltac open Pcoq diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 2596bc22f2..31fb1c9abf 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -16,6 +16,7 @@ open Names open Locus open Constrexpr open Glob_term +open Genintern open Geninterp open Extraargs open Tacmach @@ -37,8 +38,8 @@ DECLARE PLUGIN "ltac_plugin" { type constr_expr_with_bindings = constr_expr with_bindings -type glob_constr_with_bindings = Tacexpr.glob_constr_and_expr with_bindings -type glob_constr_with_bindings_sign = interp_sign * Tacexpr.glob_constr_and_expr with_bindings +type glob_constr_with_bindings = glob_constr_and_expr with_bindings +type glob_constr_with_bindings_sign = interp_sign * glob_constr_and_expr with_bindings let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = let _, env = Pfedit.get_current_context () in @@ -70,7 +71,7 @@ END { type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast -type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast +type glob_strategy = (glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast let interp_strategy ist gl s = let sigma = project gl in @@ -226,8 +227,6 @@ let () = let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in Pptactic.declare_extra_vernac_genarg_pprule wit_binders raw_printer -open Pcoq - } GRAMMAR EXTEND Gram diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 0ce0fbd0cd..46ea3819ac 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -39,7 +39,7 @@ let err () = raise Stream.Failure (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) (* admissible notation "(x t)" *) let test_lpar_id_coloneq = - Gram.Entry.of_parser "lpar_id_coloneq" + Pcoq.Entry.of_parser "lpar_id_coloneq" (fun strm -> match stream_nth 0 strm with | KEYWORD "(" -> @@ -53,7 +53,7 @@ let test_lpar_id_coloneq = (* Hack to recognize "(x)" *) let test_lpar_id_rpar = - Gram.Entry.of_parser "lpar_id_coloneq" + Pcoq.Entry.of_parser "lpar_id_coloneq" (fun strm -> match stream_nth 0 strm with | KEYWORD "(" -> @@ -67,7 +67,7 @@ let test_lpar_id_rpar = (* idem for (x:=t) and (1:=t) *) let test_lpar_idnum_coloneq = - Gram.Entry.of_parser "test_lpar_idnum_coloneq" + Pcoq.Entry.of_parser "test_lpar_idnum_coloneq" (fun strm -> match stream_nth 0 strm with | KEYWORD "(" -> @@ -84,7 +84,7 @@ open Extraargs (* idem for (x1..xn:t) [n^2 complexity but exceptional use] *) let check_for_coloneq = - Gram.Entry.of_parser "lpar_id_colon" + Pcoq.Entry.of_parser "lpar_id_colon" (fun strm -> let rec skip_to_rpar p n = match List.last (Stream.npeek n strm) with @@ -108,7 +108,7 @@ let check_for_coloneq = | _ -> err ()) let lookup_at_as_comma = - Gram.Entry.of_parser "lookup_at_as_comma" + Pcoq.Entry.of_parser "lookup_at_as_comma" (fun strm -> match stream_nth 0 strm with | KEYWORD (","|"at"|"as") -> () diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 50cfb6d004..55e58187b0 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -26,6 +26,7 @@ open Pputils open Ppconstr open Printer +open Genintern open Tacexpr open Tacarg open Tactics diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 6c09e447a5..0ab9e501bc 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -17,6 +17,7 @@ open Names open Environ open Constrexpr open Notation_gram +open Genintern open Tacexpr open Tactypes diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 3eb049dbab..ae4b53325f 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -446,7 +446,7 @@ let do_print_results_at_close () = let _ = Declaremods.append_end_library_hook do_print_results_at_close -let _ = +let () = let open Goptions in declare_bool_option { optdepr = false; diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index fee469032c..06783de614 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1998,7 +1998,7 @@ let add_morphism_infer atts m n = let hook = Lemmas.mk_hook hook in Flags.silently (fun () -> - Lemmas.start_proof instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) hook; + Lemmas.start_proof ~hook instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance); ignore (Pfedit.by (Tacinterp.interp tac))) () let add_morphism atts binders m s n = diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 4f46e78c71..2457b265f0 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -13,6 +13,7 @@ open Environ open EConstr open Constrexpr open Evd +open Genintern open Tactypes open Tacexpr open Tacinterp diff --git a/plugins/ltac/tacarg.mli b/plugins/ltac/tacarg.mli index bdb0be03cf..0c7096a4de 100644 --- a/plugins/ltac/tacarg.mli +++ b/plugins/ltac/tacarg.mli @@ -11,6 +11,7 @@ open Genarg open EConstr open Constrexpr +open Genintern open Tactypes open Tacexpr diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index d2ae92f6ce..b04c3b9f4e 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -53,7 +53,7 @@ val coerce_var_to_ident : bool -> Environ.env -> Evd.evar_map -> Value.t -> Id.t val coerce_to_ident_not_fresh : Evd.evar_map -> Value.t -> Id.t -val coerce_to_intro_pattern : Evd.evar_map -> Value.t -> Tacexpr.delayed_open_constr intro_pattern_expr +val coerce_to_intro_pattern : Evd.evar_map -> Value.t -> delayed_open_constr intro_pattern_expr val coerce_to_intro_pattern_naming : Evd.evar_map -> Value.t -> Namegen.intro_pattern_naming_expr diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index ac2d88dec2..2aee809eb6 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -119,7 +119,7 @@ let get_tactic_entry n = else if Int.equal n 5 then Pltac.binder_tactic, None else if 1<=n && n<5 then - Pltac.tactic_expr, Some (Extend.Level (string_of_int n)) + Pltac.tactic_expr, Some (Gramlib.Gramext.Level (string_of_int n)) else user_err Pp.(str ("Invalid Tactic Notation level: "^(string_of_int n)^".")) diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 9435d0b911..2bd21f9d7a 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -93,19 +93,8 @@ type ml_tactic_entry = { (** Composite types *) -type glob_constr_and_expr = Genintern.glob_constr_and_expr - type open_constr_expr = unit * constr_expr -type open_glob_constr = unit * glob_constr_and_expr - -type binding_bound_vars = Constr_matching.binding_bound_vars -type glob_constr_pattern_and_expr = binding_bound_vars * glob_constr_and_expr * constr_pattern - -type 'a delayed_open = Environ.env -> Evd.evar_map -> Evd.evar_map * 'a - -type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_open - -type delayed_open_constr = EConstr.constr delayed_open +type open_glob_constr = unit * Genintern.glob_constr_and_expr type intro_pattern = delayed_open_constr intro_pattern_expr CAst.t type intro_patterns = delayed_open_constr intro_pattern_expr CAst.t list @@ -279,8 +268,8 @@ constraint 'a = < (** Globalized tactics *) -type g_trm = glob_constr_and_expr -type g_pat = glob_constr_pattern_and_expr +type g_trm = Genintern.glob_constr_and_expr +type g_pat = Genintern.glob_constr_pattern_and_expr type g_cst = evaluable_global_reference Stdarg.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 1527724420..0c27f3bfe2 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -92,20 +92,8 @@ type ml_tactic_entry = { } (** Composite types *) - -type glob_constr_and_expr = Genintern.glob_constr_and_expr - type open_constr_expr = unit * constr_expr -type open_glob_constr = unit * glob_constr_and_expr - -type binding_bound_vars = Constr_matching.binding_bound_vars -type glob_constr_pattern_and_expr = binding_bound_vars * glob_constr_and_expr * constr_pattern - -type 'a delayed_open = Environ.env -> Evd.evar_map -> Evd.evar_map * 'a - -type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_open - -type delayed_open_constr = EConstr.constr delayed_open +type open_glob_constr = unit * Genintern.glob_constr_and_expr type intro_pattern = delayed_open_constr intro_pattern_expr CAst.t type intro_patterns = delayed_open_constr intro_pattern_expr CAst.t list @@ -279,8 +267,8 @@ constraint 'a = < (** Globalized tactics *) -type g_trm = glob_constr_and_expr -type g_pat = glob_constr_pattern_and_expr +type g_trm = Genintern.glob_constr_and_expr +type g_pat = Genintern.glob_constr_pattern_and_expr type g_cst = evaluable_global_reference Stdarg.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli index 178f6af71d..978ad4dd24 100644 --- a/plugins/ltac/tacintern.mli +++ b/plugins/ltac/tacintern.mli @@ -12,6 +12,7 @@ open Names open Tacexpr open Genarg open Constrexpr +open Genintern open Tactypes (** Globalization of tactic expressions : diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index cb3a0aaed9..cf5eb442be 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -2039,7 +2039,7 @@ let _ = let vernac_debug b = set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) -let _ = +let () = let open Goptions in declare_bool_option { optdepr = false; @@ -2048,13 +2048,4 @@ let _ = optread = (fun () -> get_debug () != Tactic_debug.DebugOff); optwrite = vernac_debug } -let _ = - let open Goptions in - declare_bool_option - { optdepr = false; - optname = "Ltac debug"; - optkey = ["Debug";"Ltac"]; - optread = (fun () -> get_debug () != Tactic_debug.DebugOff); - optwrite = vernac_debug } - let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index f9883e4441..d9c80bb835 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -43,6 +43,8 @@ type interp_sign = Geninterp.interp_sign = { lfun : value Id.Map.t; extra : TacStore.t } +open Genintern + val f_avoid_ids : Id.Set.t TacStore.field val f_debug : debug_info TacStore.field diff --git a/plugins/ltac/tacsubst.mli b/plugins/ltac/tacsubst.mli index d406686c56..4487604dca 100644 --- a/plugins/ltac/tacsubst.mli +++ b/plugins/ltac/tacsubst.mli @@ -11,6 +11,7 @@ open Tacexpr open Mod_subst open Genarg +open Genintern open Tactypes (** Substitution of tactics at module closing time *) diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 877d4ee758..99b9e881f6 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -89,7 +89,7 @@ let batch = ref false open Goptions -let _ = +let () = declare_bool_option { optdepr = false; optname = "Ltac batch debug"; diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli index 175341df09..91e8510b92 100644 --- a/plugins/ltac/tactic_debug.mli +++ b/plugins/ltac/tactic_debug.mli @@ -40,7 +40,7 @@ val db_constr : debug_info -> env -> evar_map -> constr -> unit Proofview.NonLog (** Prints the pattern rule *) val db_pattern_rule : - debug_info -> int -> (Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t + debug_info -> int -> (Genintern.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t (** Prints a matched hypothesis *) val db_matched_hyp : diff --git a/plugins/ltac/tactic_matching.mli b/plugins/ltac/tactic_matching.mli index 0722c68783..457c4e0b9a 100644 --- a/plugins/ltac/tactic_matching.mli +++ b/plugins/ltac/tactic_matching.mli @@ -35,7 +35,7 @@ val match_term : Environ.env -> Evd.evar_map -> EConstr.constr -> - (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> + (Constr_matching.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> Tacexpr.glob_tactic_expr t Proofview.tactic (** [match_goal env sigma hyps concl rules] matches the goal @@ -48,5 +48,5 @@ val match_goal: Evd.evar_map -> EConstr.named_context -> EConstr.constr -> - (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> + (Constr_matching.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> Tacexpr.glob_tactic_expr t Proofview.tactic diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 561bfc5d7c..19256e054d 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -65,7 +65,7 @@ let assoc_flags ist : tauto_flags = let negation_unfolding = ref true open Goptions -let _ = +let () = declare_bool_option { optdepr = false; optname = "unfolding of not in intuition"; diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 402e8b91e6..d4bafe773f 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -51,7 +51,7 @@ let get_lra_option () = -let _ = +let () = let int_opt l vref = { @@ -89,11 +89,11 @@ let _ = optwrite = (fun x -> Certificate.dump_file := x) } in - let _ = declare_bool_option solver_opt in - let _ = declare_stringopt_option dump_file_opt in - let _ = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in - let _ = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in - let _ = declare_bool_option lia_enum_opt in + let () = declare_bool_option solver_opt in + let () = declare_stringopt_option dump_file_opt in + let () = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in + let () = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in + let () = declare_bool_option lia_enum_opt in () diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index d8adb17710..dff25b3a42 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -64,7 +64,7 @@ let write f x = f:=x open Goptions -let _ = +let () = declare_bool_option { optdepr = false; optname = "Omega system time displaying flag"; @@ -72,7 +72,7 @@ let _ = optread = read display_system_flag; optwrite = write display_system_flag } -let _ = +let () = declare_bool_option { optdepr = false; optname = "Omega action display flag"; @@ -80,7 +80,7 @@ let _ = optread = read display_action_flag; optwrite = write display_action_flag } -let _ = +let () = declare_bool_option { optdepr = false; optname = "Omega old style flag"; @@ -88,7 +88,7 @@ let _ = optread = read old_style_flag; optwrite = write old_style_flag } -let _ = +let () = declare_bool_option { optdepr = true; optname = "Omega automatic reset of generated names"; @@ -96,7 +96,7 @@ let _ = optread = read reset_flag; optwrite = write reset_flag } -let _ = +let () = declare_bool_option { optdepr = false; optname = "Omega takes advantage of context variables with body"; diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 3de5923968..aab1e47555 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -54,7 +54,7 @@ let opt_pruning= optread=(fun () -> !pruning); optwrite=(fun b -> pruning:=b)} -let _ = declare_bool_option opt_pruning +let () = declare_bool_option opt_pruning type form= Atom of int diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 840a05e02b..e66fa10d5b 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -236,7 +236,7 @@ let opt_verbose= optread=(fun () -> !verbose); optwrite=(fun b -> verbose:=b)} -let _ = declare_bool_option opt_verbose +let () = declare_bool_option opt_verbose let check = ref false @@ -247,7 +247,7 @@ let opt_check= optread=(fun () -> !check); optwrite=(fun b -> check:=b)} -let _ = declare_bool_option opt_check +let () = declare_bool_option opt_check open Pp @@ -255,7 +255,7 @@ let rtauto_tac gls= Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"]; let gamma={next=1;env=[]} in let gl=pf_concl gls in - let _= + let () = if Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) gl != InProp then user_err ~hdr:"rtauto" (Pp.str "goal should be in Prop") in @@ -267,7 +267,7 @@ let rtauto_tac gls= | Tactic_debug.DebugOn 0 -> Search.debug_depth_first | _ -> Search.depth_first in - let _ = + let () = begin reset_info (); if !verbose then @@ -279,7 +279,7 @@ let rtauto_tac gls= with Not_found -> user_err ~hdr:"rtauto" (Pp.str "rtauto couldn't find any proof") in let search_end_time = System.get_time () in - let _ = if !verbose then + let () = if !verbose then begin Feedback.msg_info (str "Proof tree found in " ++ System.fmt_time_difference search_start_time search_end_time); @@ -287,7 +287,7 @@ let rtauto_tac gls= Feedback.msg_info (str "Building proof term ... ") end in let build_start_time=System.get_time () in - let _ = step_count := 0; node_count := 0 in + let () = step_count := 0; node_count := 0 in let main = mkApp (force node_count l_Reflect, [|build_env gamma; build_form formula; @@ -295,7 +295,7 @@ let rtauto_tac gls= let term= applistc main (List.rev_map (fun (id,_) -> mkVar id) hyps) in let build_end_time=System.get_time () in - let _ = if !verbose then + let () = if !verbose then begin Feedback.msg_info (str "Proof term built in " ++ System.fmt_time_difference build_start_time build_end_time ++ @@ -314,7 +314,7 @@ let rtauto_tac gls= else Proofview.V82.of_tactic (Tactics.exact_no_check term) gls in let tac_end_time = System.get_time () in - let _ = + let () = if !check then Feedback.msg_info (str "Proof term type-checking is on"); if !verbose then Feedback.msg_info (str "Internal tactic executed in " ++ diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index a786b9953d..bb8a0faf2e 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -47,7 +47,7 @@ type ssrdocc = ssrclear option * ssrocc (* OLD ssr terms *) type ssrtermkind = char (* FIXME, make algebraic *) -type ssrterm = ssrtermkind * Tacexpr.glob_constr_and_expr +type ssrterm = ssrtermkind * Genintern.glob_constr_and_expr (* NEW ssr term *) diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index e25c93bf0a..824827e90c 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -146,7 +146,7 @@ val interp_refine : val interp_open_constr : Tacinterp.interp_sign -> Goal.goal Evd.sigma -> - Tacexpr.glob_constr_and_expr -> evar_map * (evar_map * EConstr.t) + Genintern.glob_constr_and_expr -> evar_map * (evar_map * EConstr.t) val pf_e_type_of : Goal.goal Evd.sigma -> diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 22475fef34..490e8fbdbc 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -32,13 +32,13 @@ open Tacticals open Tacmach let ssroldreworder = Summary.ref ~name:"SSR:oldreworder" false -let _ = - Goptions.declare_bool_option - { Goptions.optname = "ssreflect 1.3 compatibility flag"; - Goptions.optkey = ["SsrOldRewriteGoalsOrder"]; - Goptions.optread = (fun _ -> !ssroldreworder); - Goptions.optdepr = false; - Goptions.optwrite = (fun b -> ssroldreworder := b) } +let () = + Goptions.(declare_bool_option + { optname = "ssreflect 1.3 compatibility flag"; + optkey = ["SsrOldRewriteGoalsOrder"]; + optread = (fun _ -> !ssroldreworder); + optdepr = false; + optwrite = (fun b -> ssroldreworder := b) }) (** The "simpl" tactic *) diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index f67cf20e49..8cebe62e16 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -66,14 +66,14 @@ open Ssripats let ssrhaveNOtcresolution = Summary.ref ~name:"SSR:havenotcresolution" false -let _ = - Goptions.declare_bool_option - { Goptions.optname = "have type classes"; - Goptions.optkey = ["SsrHave";"NoTCResolution"]; - Goptions.optread = (fun _ -> !ssrhaveNOtcresolution); - Goptions.optdepr = false; - Goptions.optwrite = (fun b -> ssrhaveNOtcresolution := b); - } +let () = + Goptions.(declare_bool_option + { optname = "have type classes"; + optkey = ["SsrHave";"NoTCResolution"]; + optread = (fun _ -> !ssrhaveNOtcresolution); + optdepr = false; + optwrite = (fun b -> ssrhaveNOtcresolution := b); + }) open Constrexpr diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 7c91860228..c9221ef758 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -268,16 +268,16 @@ let negate_parser f x = | Some _ -> raise Stream.Failure let test_not_ssrslashnum = - Pcoq.Gram.Entry.of_parser + Pcoq.Entry.of_parser "test_not_ssrslashnum" (negate_parser test_ssrslashnum10) let test_ssrslashnum00 = - Pcoq.Gram.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum00 + Pcoq.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum00 let test_ssrslashnum10 = - Pcoq.Gram.Entry.of_parser "test_ssrslashnum10" test_ssrslashnum10 + Pcoq.Entry.of_parser "test_ssrslashnum10" test_ssrslashnum10 let test_ssrslashnum11 = - Pcoq.Gram.Entry.of_parser "test_ssrslashnum11" test_ssrslashnum11 + Pcoq.Entry.of_parser "test_ssrslashnum11" test_ssrslashnum11 let test_ssrslashnum01 = - Pcoq.Gram.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum01 + Pcoq.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum01 } @@ -470,7 +470,7 @@ let input_ssrtermkind strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "@" -> xWithAt | _ -> xNoFlag -let ssrtermkind = Pcoq.Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind +let ssrtermkind = Pcoq.Entry.of_parser "ssrtermkind" input_ssrtermkind (* New kinds of terms *) @@ -481,7 +481,7 @@ let input_term_annotation strm = | Tok.KEYWORD "@" :: _ -> `At | _ -> `None let term_annotation = - Gram.Entry.of_parser "term_annotation" input_term_annotation + Pcoq.Entry.of_parser "term_annotation" input_term_annotation (* terms *) @@ -576,6 +576,8 @@ END { +type ssrfwdview = ast_closure_term list + let pr_ssrfwdview _ _ _ = pr_view2 } @@ -637,6 +639,7 @@ let rec map_ipat map_id map_ssrhyp map_ast_closure_term = function | IPatView (clr,v) -> IPatView (clr,List.map map_ast_closure_term v) | IPatTac _ -> assert false (*internal usage only *) +type ssripatrep = ssripat let wit_ssripatrep = add_genarg "ssripatrep" pr_ipat let pr_ssripat _ _ _ = pr_ipat @@ -800,7 +803,7 @@ let reject_ssrhid strm = | _ -> ()) | _ -> () -let test_nohidden = Pcoq.Gram.Entry.of_parser "test_ssrhid" reject_ssrhid +let test_nohidden = Pcoq.Entry.of_parser "test_ssrhid" reject_ssrhid } @@ -961,7 +964,7 @@ let accept_ssrfwdid strm = | Tok.IDENT id -> accept_before_syms_or_any_id [":"; ":="; "("] strm | _ -> raise Stream.Failure -let test_ssrfwdid = Gram.Entry.of_parser "test_ssrfwdid" accept_ssrfwdid +let test_ssrfwdid = Pcoq.Entry.of_parser "test_ssrfwdid" accept_ssrfwdid } @@ -1540,7 +1543,7 @@ let accept_ssrseqvar strm = accept_before_syms_or_ids ["["] ["first";"last"] strm | _ -> raise Stream.Failure -let test_ssrseqvar = Gram.Entry.of_parser "test_ssrseqvar" accept_ssrseqvar +let test_ssrseqvar = Pcoq.Entry.of_parser "test_ssrseqvar" accept_ssrseqvar let swaptacarg (loc, b) = (b, []), Some (TacId []) @@ -1605,14 +1608,14 @@ let old_tac = V82.tactic let ssr_reserved_ids = Summary.ref ~name:"SSR:idents" true -let _ = - Goptions.declare_bool_option - { Goptions.optname = "ssreflect identifiers"; - Goptions.optkey = ["SsrIdents"]; - Goptions.optdepr = false; - Goptions.optread = (fun _ -> !ssr_reserved_ids); - Goptions.optwrite = (fun b -> ssr_reserved_ids := b) - } +let () = + Goptions.(declare_bool_option + { optname = "ssreflect identifiers"; + optkey = ["SsrIdents"]; + optdepr = false; + optread = (fun _ -> !ssr_reserved_ids); + optwrite = (fun b -> ssr_reserved_ids := b) + }) let is_ssr_reserved s = let n = String.length s in n > 2 && s.[0] = '_' && s.[n - 1] = '_' @@ -1628,7 +1631,7 @@ let ssr_id_of_string loc s = ^ "Scripts with explicit references to anonymous variables are fragile.")) end; Id.of_string s -let ssr_null_entry = Gram.Entry.of_parser "ssr_null" (fun _ -> ()) +let ssr_null_entry = Pcoq.Entry.of_parser "ssr_null" (fun _ -> ()) } @@ -1933,6 +1936,7 @@ END (* argument *) { +type ssreqid = ssripatrep option let pr_eqid = function Some pat -> str " " ++ pr_ipat pat | None -> mt () let pr_ssreqid _ _ _ = pr_eqid @@ -1955,7 +1959,7 @@ let accept_ssreqid strm = accept_before_syms [":"] strm | _ -> raise Stream.Failure -let test_ssreqid = Gram.Entry.of_parser "test_ssreqid" accept_ssreqid +let test_ssreqid = Pcoq.Entry.of_parser "test_ssreqid" accept_ssreqid } @@ -1987,10 +1991,12 @@ END (* the entry point parses only non-empty arguments to avoid conflicts *) (* with the basic Coq tactics. *) -(* type ssrarg = ssrbwdview * (ssreqid * (ssrdgens * ssripats)) *) - { +type ssrarg = ssrfwdview * (ssreqid * (cpattern ssragens * ssripats)) + +(* type ssrarg = ssrbwdview * (ssreqid * (ssrdgens * ssripats)) *) + let pr_ssrarg _ _ _ (view, (eqid, (dgens, ipats))) = let pri = pr_intros (gens_sep dgens) in pr_view2 view ++ pr_eqid eqid ++ pr_dgens pr_gen dgens ++ pri ipats @@ -2355,13 +2361,13 @@ END let ssr_rw_syntax = Summary.ref ~name:"SSR:rewrite" true -let _ = - Goptions.declare_bool_option - { Goptions.optname = "ssreflect rewrite"; - Goptions.optkey = ["SsrRewrite"]; - Goptions.optread = (fun _ -> !ssr_rw_syntax); - Goptions.optdepr = false; - Goptions.optwrite = (fun b -> ssr_rw_syntax := b) } +let () = + Goptions.(declare_bool_option + { optname = "ssreflect rewrite"; + optkey = ["SsrRewrite"]; + optread = (fun _ -> !ssr_rw_syntax); + optdepr = false; + optwrite = (fun b -> ssr_rw_syntax := b) }) let lbrace = Char.chr 123 (** Workaround to a limitation of coqpp *) @@ -2373,7 +2379,7 @@ let test_ssr_rw_syntax = match Util.stream_nth 0 strm with | Tok.KEYWORD key when List.mem key.[0] [lbrace; '['; '/'] -> () | _ -> raise Stream.Failure in - Gram.Entry.of_parser "test_ssr_rw_syntax" test + Pcoq.Entry.of_parser "test_ssr_rw_syntax" test } @@ -2583,7 +2589,7 @@ let accept_idcomma strm = | Tok.IDENT _ | Tok.KEYWORD "_" -> accept_before_syms [","] strm | _ -> raise Stream.Failure -let test_idcomma = Gram.Entry.of_parser "test_idcomma" accept_idcomma +let test_idcomma = Pcoq.Entry.of_parser "test_idcomma" accept_idcomma } diff --git a/plugins/ssr/ssrparser.mli b/plugins/ssr/ssrparser.mli index 862a93765d..a2cbd3c9c8 100644 --- a/plugins/ssr/ssrparser.mli +++ b/plugins/ssr/ssrparser.mli @@ -28,10 +28,22 @@ open Ssrmatching open Ssrast open Ssrequality +type ssrfwdview = ast_closure_term list +type ssreqid = ssripat option +type ssrarg = ssrfwdview * (ssreqid * (cpattern ssragens * ssripats)) + +val wit_ssripatrep : ssripat Genarg.uniform_genarg_type +val wit_ssrarg : ssrarg Genarg.uniform_genarg_type val wit_ssrrwargs : ssrrwarg list Genarg.uniform_genarg_type val wit_ssrclauses : clauses Genarg.uniform_genarg_type val wit_ssrcasearg : (cpattern ssragens) ssrmovearg Genarg.uniform_genarg_type val wit_ssrmovearg : (cpattern ssragens) ssrmovearg Genarg.uniform_genarg_type val wit_ssrapplyarg : ssrapplyarg Genarg.uniform_genarg_type val wit_ssrhavefwdwbinders : - (Tacexpr.raw_tactic_expr fwdbinders, Tacexpr.glob_tactic_expr fwdbinders, Tacinterp.Value.t fwdbinders) Genarg.genarg_type + (Tacexpr.raw_tactic_expr fwdbinders, + Tacexpr.glob_tactic_expr fwdbinders, + Tacinterp.Value.t fwdbinders) Genarg.genarg_type +val wit_ssrhintarg : + (Tacexpr.raw_tactic_expr ssrhint, + Tacexpr.glob_tactic_expr ssrhint, + Tacinterp.Value.t ssrhint) Genarg.genarg_type diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index 824666ba9c..8bf4816e99 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -119,13 +119,13 @@ and pr_iorpat iorpat = pr_list pr_bar pr_ipats iorpat (* 0 cost pp function. Active only if Debug Ssreflect is Set *) let ppdebug_ref = ref (fun _ -> ()) let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s) -let _ = - Goptions.declare_bool_option - { Goptions.optname = "ssreflect debugging"; - Goptions.optkey = ["Debug";"Ssreflect"]; - Goptions.optdepr = false; - Goptions.optread = (fun _ -> !ppdebug_ref == ssr_pp); - Goptions.optwrite = (fun b -> +let () = + Goptions.(declare_bool_option + { optname = "ssreflect debugging"; + optkey = ["Debug";"Ssreflect"]; + optdepr = false; + optread = (fun _ -> !ppdebug_ref == ssr_pp); + optwrite = (fun b -> Ssrmatching.debug b; - if b then ppdebug_ref := ssr_pp else ppdebug_ref := fun _ -> ()) } + if b then ppdebug_ref := ssr_pp else ppdebug_ref := fun _ -> ()) }) let ppdebug s = !ppdebug_ref s diff --git a/plugins/ssrmatching/g_ssrmatching.mlg b/plugins/ssrmatching/g_ssrmatching.mlg index 3f0794fdd4..4ddaeb49fd 100644 --- a/plugins/ssrmatching/g_ssrmatching.mlg +++ b/plugins/ssrmatching/g_ssrmatching.mlg @@ -11,7 +11,6 @@ { open Ltac_plugin -open Pcoq open Pcoq.Constr open Ssrmatching open Ssrmatching.Internal @@ -69,7 +68,7 @@ let input_ssrtermkind strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "(" -> '(' | Tok.KEYWORD "@" -> '@' | _ -> ' ' -let ssrtermkind = Pcoq.Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind +let ssrtermkind = Pcoq.Entry.of_parser "ssrtermkind" input_ssrtermkind } diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 8cb0a8b463..6497b6ff98 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -896,7 +896,7 @@ let interp_rpattern s = function let interp_rpattern0 ist gl t = Tacmach.project gl, interp_rpattern ist t -type cpattern = char * glob_constr_and_expr * Geninterp.interp_sign option +type cpattern = char * Genintern.glob_constr_and_expr * Geninterp.interp_sign option let tag_of_cpattern = pi1 let loc_of_cpattern = loc_ofCG let cpattern_of_term (c, t) ist = c, t, Some ist diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 93a8c48435..8672c55767 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -5,9 +5,7 @@ open Goal open Environ open Evd open Constr - -open Ltac_plugin -open Tacexpr +open Genintern (** ******** Small Scale Reflection pattern matching facilities ************* *) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index e02fb33276..fe67f5767b 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -995,7 +995,7 @@ let expand_arg tms (p,ccl) ((_,t),_,na) = let use_unit_judge env evd = let j, ctx = coq_unit_judge !!env in - let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd ctx in + let evd' = Evd.merge_context_set Evd.univ_flexible evd ctx in evd', j let add_assert_false_case pb tomatch = @@ -2037,7 +2037,7 @@ let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = | None -> (* No type constraint: we first create a generic evar type constraint *) let src = (loc, Evar_kinds.CasesType false) in - let sigma, (t, _) = Evarutil.new_type_evar !!env sigma univ_flexible_alg ~src in + let sigma, (t, _) = Evarutil.new_type_evar !!env sigma univ_flexible ~src in sigma, t in (* First strategy: we build an "inversion" predicate, also replacing the *) (* dependencies with existential variables *) @@ -2061,7 +2061,7 @@ let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = | Some rtntyp -> (* We extract the signature of the arity *) let building_arsign,envar = List.fold_right_map (push_rel_context sigma) arsign env in - let sigma, newt = new_sort_variable univ_flexible_alg sigma in + let sigma, newt = new_sort_variable univ_flexible sigma in let sigma, predcclj = typing_fun (mk_tycon (mkSort newt)) envar sigma rtntyp in let predccl = nf_evar sigma predcclj.uj_val in [sigma, predccl, building_arsign] diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 5061aeff88..f8289f558c 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -183,14 +183,11 @@ let cofixp_reducible flgs _ stk = else false -let debug_cbv = ref false -let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; - Goptions.optname = "cbv visited constants display"; - Goptions.optkey = ["Debug";"Cbv"]; - Goptions.optread = (fun () -> !debug_cbv); - Goptions.optwrite = (fun a -> debug_cbv:=a); -} +let get_debug_cbv = Goptions.declare_bool_option_and_ref + ~depr:false + ~value:false + ~name:"cbv visited constants display" + ~key:["Debug";"Cbv"] let debug_pr_key = function | ConstKey (sp,_) -> Names.Constant.print sp @@ -325,14 +322,14 @@ and norm_head_ref k info env stack normt = if red_set_ref info.reds normt then match cbv_value_cache info normt with | Some body -> - if !debug_cbv then Feedback.msg_debug Pp.(str "Unfolding " ++ debug_pr_key normt); + if get_debug_cbv () then Feedback.msg_debug Pp.(str "Unfolding " ++ debug_pr_key normt); strip_appl (shift_value k body) stack | None -> - if !debug_cbv then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); + if get_debug_cbv () then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); (VAL(0,make_constr_ref k normt),stack) else begin - if !debug_cbv then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); + if get_debug_cbv () then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); (VAL(0,make_constr_ref k normt),stack) end diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 2c2a8fe49e..f18040accb 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -398,16 +398,12 @@ let class_params = function let add_class cl = add_new_class cl { cl_param = class_params cl } -let automatically_import_coercions = ref false - -open Goptions -let _ = - declare_bool_option - { optdepr = true; (* remove in 8.8 *) - optname = "automatic import of coercions"; - optkey = ["Automatic";"Coercions";"Import"]; - optread = (fun () -> !automatically_import_coercions); - optwrite = (:=) automatically_import_coercions } +let get_automatically_import_coercions = + Goptions.declare_bool_option_and_ref + ~depr:true (* Remove in 8.8 *) + ~name:"automatic import of coercions" + ~key:["Automatic";"Coercions";"Import"] + ~value:false let cache_coercion (_, c) = let () = add_class c.coercion_source in @@ -425,7 +421,7 @@ let cache_coercion (_, c) = add_coercion_in_graph (xf,is,it) let load_coercion _ o = - if !automatically_import_coercions then + if get_automatically_import_coercions () then cache_coercion o let set_coercion_in_scope (_, c) = @@ -435,7 +431,7 @@ let set_coercion_in_scope (_, c) = let open_coercion i o = if Int.equal i 1 then begin set_coercion_in_scope o; - if not !automatically_import_coercions then + if not (get_automatically_import_coercions ()) then cache_coercion o end diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index e21c2fda85..4d1d405bd7 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -33,16 +33,12 @@ open Evd open Termops open Globnames -let use_typeclasses_for_conversion = ref true - -let _ = - Goptions.(declare_bool_option - { optdepr = false; - optname = "use typeclass resolution during conversion"; - optkey = ["Typeclass"; "Resolution"; "For"; "Conversion"]; - optread = (fun () -> !use_typeclasses_for_conversion); - optwrite = (fun b -> use_typeclasses_for_conversion := b) } - ) +let get_use_typeclasses_for_conversion = + Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"use typeclass resolution during conversion" + ~key:["Typeclass"; "Resolution"; "For"; "Conversion"] + ~value:true (* Typing operations dealing with coercions *) exception NoCoercion @@ -183,7 +179,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) with UnableToUnify _ -> let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in - let _ = + let () = try evdref := the_conv_x_leq env eqT eqT' !evdref with UnableToUnify _ -> raise NoSubtacCoercion in @@ -424,7 +420,7 @@ let inh_app_fun resolve_tc env evd j = try inh_app_fun_core env evd j with | NoCoercion when not resolve_tc - || not !use_typeclasses_for_conversion -> (evd, j) + || not (get_use_typeclasses_for_conversion ()) -> (evd, j) | NoCoercion -> try inh_app_fun_core env (saturate_evd env evd) j with NoCoercion -> (evd, j) @@ -534,7 +530,7 @@ let inh_conv_coerce_to_gen ?loc resolve_tc rigidonly env evd cj t = coerce_itf ?loc env evd (Some cj.uj_val) cj.uj_type t else raise NoSubtacCoercion with - | NoSubtacCoercion when not resolve_tc || not !use_typeclasses_for_conversion -> + | NoSubtacCoercion when not resolve_tc || not (get_use_typeclasses_for_conversion ()) -> error_actual_type ?loc env best_failed_evd cj t e | NoSubtacCoercion -> let evd' = saturate_evd env evd in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 072ac9deed..33ced6d6e0 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -138,7 +138,7 @@ open Goptions let wildcard_value = ref true let force_wildcard () = !wildcard_value -let _ = declare_bool_option +let () = declare_bool_option { optdepr = false; optname = "forced wildcard"; optkey = ["Printing";"Wildcard"]; @@ -148,7 +148,7 @@ let _ = declare_bool_option let synth_type_value = ref true let synthetize_type () = !synth_type_value -let _ = declare_bool_option +let () = declare_bool_option { optdepr = false; optname = "pattern matching return type synthesizability"; optkey = ["Printing";"Synth"]; @@ -158,7 +158,7 @@ let _ = declare_bool_option let reverse_matching_value = ref true let reverse_matching () = !reverse_matching_value -let _ = declare_bool_option +let () = declare_bool_option { optdepr = false; optname = "pattern-matching reversibility"; optkey = ["Printing";"Matching"]; @@ -168,7 +168,7 @@ let _ = declare_bool_option let print_primproj_params_value = ref false let print_primproj_params () = !print_primproj_params_value -let _ = declare_bool_option +let () = declare_bool_option { optdepr = false; optname = "printing of primitive projection parameters"; optkey = ["Printing";"Primitive";"Projection";"Parameters"]; @@ -178,7 +178,7 @@ let _ = declare_bool_option let print_primproj_compatibility_value = ref false let print_primproj_compatibility () = !print_primproj_compatibility_value -let _ = declare_bool_option +let () = declare_bool_option { optdepr = false; optname = "backwards-compatible printing of primitive projections"; optkey = ["Printing";"Primitive";"Projection";"Compatibility"]; @@ -257,8 +257,7 @@ let lookup_index_as_renamed env sigma t n = let print_factorize_match_patterns = ref true -let _ = - let open Goptions in +let () = declare_bool_option { optdepr = false; optname = "factorization of \"match\" patterns in printing"; @@ -268,8 +267,7 @@ let _ = let print_allow_match_default_clause = ref true -let _ = - let open Goptions in +let () = declare_bool_option { optdepr = false; optname = "possible use of \"match\" default pattern in printing"; diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index f370ad7ae2..6c268de3b3 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -33,14 +33,14 @@ type unify_fun = TransparentState.t -> env -> evar_map -> conv_pb -> EConstr.constr -> EConstr.constr -> Evarsolve.unification_result let debug_unification = ref (false) -let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; - Goptions.optname = +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = "Print states sent to Evarconv unification"; - Goptions.optkey = ["Debug";"Unification"]; - Goptions.optread = (fun () -> !debug_unification); - Goptions.optwrite = (fun a -> debug_unification:=a); -} + optkey = ["Debug";"Unification"]; + optread = (fun () -> !debug_unification); + optwrite = (fun a -> debug_unification:=a); +}) (*******************************************) (* Functions to deal with impossible cases *) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 14358dd02a..10d8451947 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -759,6 +759,6 @@ let control_only_guard env sigma c = in let rec iter env c = check_fix_cofix env c; - iter_constr_with_full_binders sigma EConstr.push_rel iter env c + EConstr.iter_with_full_binders sigma EConstr.push_rel iter env c in iter env c diff --git a/pretyping/inferCumulativity.ml b/pretyping/inferCumulativity.ml index 9762d0f1d9..e46d03b743 100644 --- a/pretyping/inferCumulativity.ml +++ b/pretyping/inferCumulativity.ml @@ -110,9 +110,9 @@ let rec infer_fterm cv_pb infos variances hd stk = let (_,ty,bd) = destFLambda mk_clos hd in let variances = infer_fterm CONV infos variances ty [] in infer_fterm CONV infos variances bd [] - | FProd (_,dom,codom) -> + | FProd (_,dom,codom,e) -> let variances = infer_fterm CONV infos variances dom [] in - infer_fterm cv_pb infos variances codom [] + infer_fterm cv_pb infos variances (mk_clos (Esubst.subs_lift e) codom) [] | FInd (ind, u) -> let variances = if Instance.is_empty u then variances diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 8c57fc2375..f5e48bcd39 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -105,16 +105,12 @@ let search_guard ?loc env possible_indexes fixdefs = (* To force universe name declaration before use *) -let strict_universe_declarations = ref true -let is_strict_universe_declarations () = !strict_universe_declarations - -let _ = - Goptions.(declare_bool_option - { optdepr = false; - optname = "strict universe declaration"; - optkey = ["Strict";"Universe";"Declaration"]; - optread = is_strict_universe_declarations; - optwrite = (:=) strict_universe_declarations }) +let is_strict_universe_declarations = + Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"strict universe declaration" + ~key:["Strict";"Universe";"Declaration"] + ~value:true (** Miscellaneous interpretation functions *) @@ -215,7 +211,7 @@ type frozen = (** Proper partition of the evar map as described above. *) let frozen_and_pending_holes (sigma, sigma') = - let undefined0 = Evd.undefined_map sigma in + let undefined0 = Option.cata Evd.undefined_map Evar.Map.empty sigma in (** Fast path when the undefined evars where not modified *) if undefined0 == Evd.undefined_map sigma' then FrozenId undefined0 @@ -306,8 +302,8 @@ let check_evars_are_solved env sigma frozen = (* Try typeclasses, hooks, unification heuristics ... *) -let solve_remaining_evars ?hook flags env sigma init_sigma = - let frozen = frozen_and_pending_holes (init_sigma, sigma) in +let solve_remaining_evars ?hook flags env ?initial sigma = + let frozen = frozen_and_pending_holes (initial, sigma) in let sigma = if flags.use_typeclasses then apply_typeclasses env sigma frozen false @@ -324,12 +320,12 @@ let solve_remaining_evars ?hook flags env sigma init_sigma = if flags.fail_evar then check_evars_are_solved env sigma frozen; sigma -let check_evars_are_solved env current_sigma init_sigma = - let frozen = frozen_and_pending_holes (init_sigma, current_sigma) in +let check_evars_are_solved env ?initial current_sigma = + let frozen = frozen_and_pending_holes (initial, current_sigma) in check_evars_are_solved env current_sigma frozen -let process_inference_flags flags env initial_sigma (sigma,c,cty) = - let sigma = solve_remaining_evars flags env sigma initial_sigma in +let process_inference_flags flags env initial (sigma,c,cty) = + let sigma = solve_remaining_evars flags env ~initial sigma in let c = if flags.expand_evars then nf_evar sigma c else c in sigma,c,cty diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 2eaa77b822..59e6c00037 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -95,13 +95,13 @@ val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> [pending], however, it can contain more evars than the pending ones. *) val solve_remaining_evars : ?hook:inference_hook -> inference_flags -> - env -> (* current map *) evar_map -> (* initial map *) evar_map -> evar_map + env -> ?initial:evar_map -> (* current map *) evar_map -> evar_map (** Checking evars and pending conversion problems are all solved, reporting an appropriate error message *) val check_evars_are_solved : - env -> (* current map: *) evar_map -> (* initial map: *) evar_map -> unit + env -> ?initial:evar_map -> (* current map: *) evar_map -> unit (** [check_evars env initial_sigma extended_sigma c] fails if some new unresolved evar remains in [c] *) diff --git a/pretyping/program.ml b/pretyping/program.ml index bbabbefdc3..7e38c09189 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -75,7 +75,7 @@ let is_program_cases () = !program_cases open Goptions -let _ = +let () = declare_bool_option { optdepr = false; optname = "preferred transparency of Program obligations"; @@ -83,7 +83,7 @@ let _ = optread = get_proofs_transparency; optwrite = set_proofs_transparency; } -let _ = +let () = declare_bool_option { optdepr = false; optname = "program cases"; @@ -91,7 +91,7 @@ let _ = optread = (fun () -> !program_cases); optwrite = (:=) program_cases } -let _ = +let () = declare_bool_option { optdepr = false; optname = "program generalized coercion"; diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index e632976ae5..a57ee6e292 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -29,14 +29,14 @@ exception Elimconst their parameters in its stack. *) -let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; - Goptions.optname = +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = "Generate weak constraints between Irrelevant universes"; - Goptions.optkey = ["Cumulativity";"Weak";"Constraints"]; - Goptions.optread = (fun () -> not !UState.drop_weak_constraints); - Goptions.optwrite = (fun a -> UState.drop_weak_constraints:=not a); -} + optkey = ["Cumulativity";"Weak";"Constraints"]; + optread = (fun () -> not !UState.drop_weak_constraints); + optwrite = (fun a -> UState.drop_weak_constraints:=not a); +}) (** Support for reduction effects *) @@ -830,14 +830,14 @@ let fix_recarg ((recindices,bodynum),_) stack = *) let debug_RAKAM = ref (false) -let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; - Goptions.optname = +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = "Print states of the Reductionops abstract machine"; - Goptions.optkey = ["Debug";"RAKAM"]; - Goptions.optread = (fun () -> !debug_RAKAM); - Goptions.optwrite = (fun a -> debug_RAKAM:=a); -} + optkey = ["Debug";"RAKAM"]; + optread = (fun () -> !debug_RAKAM); + optwrite = (fun a -> debug_RAKAM:=a); +}) let equal_stacks sigma (x, l) (y, l') = let f_equal x y = eq_constr sigma x y in diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 4aea2c3db9..d732544c5c 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -31,19 +31,12 @@ type 'a hint_info_gen = type hint_info = (Pattern.patvar list * Pattern.constr_pattern) hint_info_gen -let typeclasses_unique_solutions = ref false -let set_typeclasses_unique_solutions d = (:=) typeclasses_unique_solutions d -let get_typeclasses_unique_solutions () = !typeclasses_unique_solutions - -open Goptions - -let _ = - declare_bool_option - { optdepr = false; - optname = "check that typeclasses proof search returns unique solutions"; - optkey = ["Typeclasses";"Unique";"Solutions"]; - optread = get_typeclasses_unique_solutions; - optwrite = set_typeclasses_unique_solutions; } +let get_typeclasses_unique_solutions = + Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"check that typeclasses proof search returns unique solutions" + ~key:["Typeclasses";"Unique";"Solutions"] + ~value:false let (add_instance_hint, add_instance_hint_hook) = Hook.make () let add_instance_hint id = Hook.get add_instance_hint id @@ -434,28 +427,40 @@ let remove_instance i = Lib.add_anonymous_leaf (instance_input (RemoveInstance, i)); remove_instance_hint i.is_impl -let declare_instance info local glob = +let warning_not_a_class = + let name = "not-a-class" in + let category = "typeclasses" in + CWarnings.create ~name ~category (fun (n, ty) -> + let env = Global.env () in + let evd = Evd.from_env env in + Pp.(str "Ignored instance declaration for “" + ++ Nametab.pr_global_env Id.Set.empty n + ++ str "”: “" + ++ Termops.Internal.print_constr_env env evd (EConstr.of_constr ty) + ++ str "” is not a class") + ) + +let declare_instance ?(warn = false) info local glob = let ty, _ = Typeops.type_of_global_in_context (Global.env ()) glob in let info = Option.default {hint_priority = None; hint_pattern = None} info in match class_of_constr Evd.empty (EConstr.of_constr ty) with | Some (rels, ((tc,_), args) as _cl) -> assert (not (isVarRef glob) || local); add_instance (new_instance tc info (not local) glob) - | None -> () + | None -> if warn then warning_not_a_class (glob, ty) let add_class cl = add_class cl; List.iter (fun (n, inst, body) -> - match inst with - | Some (Backward, info) -> - (match body with - | None -> CErrors.user_err Pp.(str "Non-definable projection can not be declared as a subinstance") - | Some b -> declare_instance (Some info) false (ConstRef b)) - | _ -> ()) - cl.cl_projs + match inst with + | Some (Backward, info) -> + (match body with + | None -> CErrors.user_err Pp.(str "Non-definable projection can not be declared as a subinstance") + | Some b -> declare_instance ~warn:true (Some info) false (ConstRef b)) + | _ -> ()) + cl.cl_projs - (* * interface functions *) diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index 8bdac0a575..d00195678b 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -133,7 +133,10 @@ val remove_instance_hint : GlobRef.t -> unit val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t val solve_one_instance_hook : (env -> evar_map -> EConstr.types -> bool -> evar_map * EConstr.constr) Hook.t -val declare_instance : hint_info option -> bool -> GlobRef.t -> unit +(** Declares the given global reference as an instance of its type. + Does nothing — or emit a “not-a-class” warning if the [warn] argument is set — + when said type is not a registered type class. *) +val declare_instance : ?warn:bool -> hint_info option -> bool -> GlobRef.t -> unit (** Build the subinstances hints for a given typeclass object. diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 490d58fa52..094fcd923e 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -43,25 +43,25 @@ module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration let keyed_unification = ref (false) -let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; - Goptions.optname = "Unification is keyed"; - Goptions.optkey = ["Keyed";"Unification"]; - Goptions.optread = (fun () -> !keyed_unification); - Goptions.optwrite = (fun a -> keyed_unification:=a); -} +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = "Unification is keyed"; + optkey = ["Keyed";"Unification"]; + optread = (fun () -> !keyed_unification); + optwrite = (fun a -> keyed_unification:=a); +}) let is_keyed_unification () = !keyed_unification let debug_unification = ref (false) -let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; - Goptions.optname = +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = "Print states sent to tactic unification"; - Goptions.optkey = ["Debug";"Tactic";"Unification"]; - Goptions.optread = (fun () -> !debug_unification); - Goptions.optwrite = (fun a -> debug_unification:=a); -} + optkey = ["Debug";"Tactic";"Unification"]; + optread = (fun () -> !debug_unification); + optwrite = (fun a -> debug_unification:=a); +}) (** Making this unification algorithm correct w.r.t. the evar-map abstraction breaks too much stuff. So we redefine incorrect functions here. *) @@ -1530,7 +1530,7 @@ let indirectly_dependent sigma c d decls = List.exists (fun d' -> exists (fun c -> Termops.local_occur_var sigma (NamedDecl.get_id d') c) d) decls let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) = - let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in + let sigma = Pretyping.solve_remaining_evars flags env current_sigma ~initial:pending in (sigma, nf_evar sigma c) let default_matching_core_flags sigma = diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 712eb21ee6..f9f4d7f7f8 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -96,8 +96,9 @@ let print_ref reduce ref udecl = then Printer.pr_universe_instance sigma inst else mt () in + let priv = None in (* We deliberately don't print private univs in About. *) hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_letype_env env sigma typ ++ - Printer.pr_abstract_universe_ctx sigma ?variance univs) + Printer.pr_abstract_universe_ctx sigma ?variance univs ~priv) (********************************) (** Printing implicit arguments *) @@ -580,11 +581,11 @@ let print_constant with_values sep sp udecl = str"*** [ " ++ print_basename sp ++ print_instance sigma cb ++ str " : " ++ cut () ++ pr_ltype typ ++ str" ]" ++ - Printer.pr_constant_universes sigma univs + Printer.pr_constant_universes sigma univs ~priv:cb.const_private_poly_univs | Some (c, ctx) -> print_basename sp ++ print_instance sigma cb ++ str sep ++ cut () ++ (if with_values then print_typed_body env sigma (Some c,typ) else pr_ltype typ)++ - Printer.pr_constant_universes sigma univs) + Printer.pr_constant_universes sigma univs ~priv:cb.const_private_poly_univs) let gallina_print_constant_with_infos sp udecl = print_constant true " = " sp udecl ++ diff --git a/printing/printer.ml b/printing/printer.ml index 4840577cbf..2bbda279bd 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -34,7 +34,7 @@ let should_unfoc() = !enable_unfocused_goal_printing let should_gname() = !enable_goal_names_printing -let _ = +let () = let open Goptions in declare_bool_option { optdepr = false; @@ -45,7 +45,7 @@ let _ = (* This is set on by proofgeneral proof-tree mode. But may be used for other purposes *) -let _ = +let () = let open Goptions in declare_bool_option { optdepr = false; @@ -55,7 +55,7 @@ let _ = optwrite = (fun b -> enable_goal_tags_printing:=b) } -let _ = +let () = let open Goptions in declare_bool_option { optdepr = false; @@ -140,10 +140,10 @@ let pr_cases_pattern t = let pr_sort sigma s = pr_glob_sort (extern_sort sigma s) -let _ = Termops.Internal.set_print_constr +let () = Termops.Internal.set_print_constr (fun env sigma t -> pr_lconstr_expr (extern_constr ~lax:true false env sigma t)) -let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)" +let pr_in_comment x = str "(* " ++ x ++ str " *)" (** Term printers resilient to [Nametab] errors *) @@ -199,42 +199,43 @@ let safe_pr_constr_env = safe_gen pr_constr_env let pr_universe_ctx_set sigma c = if !Detyping.print_universes && not (Univ.ContextSet.is_empty c) then - fnl()++pr_in_comment (fun c -> v 0 - (Univ.pr_universe_context_set (Termops.pr_evd_level sigma) c)) c + fnl()++pr_in_comment (v 0 (Univ.pr_universe_context_set (Termops.pr_evd_level sigma) c)) else mt() let pr_universe_ctx sigma ?variance c = if !Detyping.print_universes && not (Univ.UContext.is_empty c) then - fnl()++pr_in_comment (fun c -> v 0 - (Univ.pr_universe_context (Termops.pr_evd_level sigma) ?variance c)) c + fnl()++pr_in_comment (v 0 (Univ.pr_universe_context (Termops.pr_evd_level sigma) ?variance c)) else mt() -let pr_abstract_universe_ctx sigma ?variance c = - if !Detyping.print_universes && not (Univ.AUContext.is_empty c) then - fnl()++pr_in_comment (fun c -> v 0 - (Univ.pr_abstract_universe_context (Termops.pr_evd_level sigma) ?variance c)) c +let pr_abstract_universe_ctx sigma ?variance c ~priv = + let open Univ in + let priv = Option.default Univ.ContextSet.empty priv in + let has_priv = not (ContextSet.is_empty priv) in + if !Detyping.print_universes && (not (Univ.AUContext.is_empty c) || has_priv) then + let prlev u = Termops.pr_evd_level sigma u in + let pub = (if has_priv then str "Public universes:" ++ fnl() else mt()) ++ v 0 (Univ.pr_abstract_universe_context prlev ?variance c) in + let priv = if has_priv then fnl() ++ str "Private universes:" ++ fnl() ++ v 0 (Univ.pr_universe_context_set prlev priv) else mt() in + fnl()++pr_in_comment (pub ++ priv) else mt() -let pr_constant_universes sigma = function +let pr_constant_universes sigma ~priv = function | Declarations.Monomorphic_const ctx -> pr_universe_ctx_set sigma ctx - | Declarations.Polymorphic_const ctx -> pr_abstract_universe_ctx sigma ctx + | Declarations.Polymorphic_const ctx -> pr_abstract_universe_ctx sigma ctx ~priv let pr_cumulativity_info sigma cumi = if !Detyping.print_universes && not (Univ.UContext.is_empty (Univ.CumulativityInfo.univ_context cumi)) then - fnl()++pr_in_comment (fun uii -> v 0 - (Univ.pr_cumulativity_info (Termops.pr_evd_level sigma) uii)) cumi + fnl()++pr_in_comment (v 0 (Univ.pr_cumulativity_info (Termops.pr_evd_level sigma) cumi)) else mt() let pr_abstract_cumulativity_info sigma cumi = if !Detyping.print_universes && not (Univ.AUContext.is_empty (Univ.ACumulativityInfo.univ_context cumi)) then - fnl()++pr_in_comment (fun uii -> v 0 - (Univ.pr_abstract_cumulativity_info (Termops.pr_evd_level sigma) uii)) cumi + fnl()++pr_in_comment (v 0 (Univ.pr_abstract_cumulativity_info (Termops.pr_evd_level sigma) cumi)) else mt() @@ -430,7 +431,7 @@ let pr_context_limit_compact ?n env sigma = (* If [None], no limit *) let print_hyps_limit = ref (None : int option) -let _ = +let () = let open Goptions in declare_int_option { optdepr = false; @@ -638,7 +639,7 @@ let print_evar_constraints gl sigma = let should_print_dependent_evars = ref false -let _ = +let () = let open Goptions in declare_bool_option { optdepr = false; diff --git a/printing/printer.mli b/printing/printer.mli index cefc005c74..b0232ec4ac 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -87,10 +87,10 @@ val pr_universe_instance : evar_map -> Univ.Instance.t -> Pp.t val pr_universe_instance_constraints : evar_map -> Univ.Instance.t -> Univ.Constraint.t -> Pp.t val pr_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> Univ.UContext.t -> Pp.t -val pr_abstract_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> - Univ.AUContext.t -> Pp.t +val pr_abstract_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> + Univ.AUContext.t -> priv:Univ.ContextSet.t option -> Pp.t val pr_universe_ctx_set : evar_map -> Univ.ContextSet.t -> Pp.t -val pr_constant_universes : evar_map -> Declarations.constant_universes -> Pp.t +val pr_constant_universes : evar_map -> priv:Univ.ContextSet.t option -> Declarations.constant_universes -> Pp.t val pr_cumulativity_info : evar_map -> Univ.CumulativityInfo.t -> Pp.t val pr_abstract_cumulativity_info : evar_map -> Univ.ACumulativityInfo.t -> Pp.t diff --git a/printing/printmod.ml b/printing/printmod.ml index 2c3ab46670..a8d7b0c1a8 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -41,7 +41,7 @@ type short = OnlyNames | WithContents let short = ref false -let _ = +let () = declare_bool_option { optdepr = false; optname = "short module printing"; @@ -310,7 +310,7 @@ let print_body is_impl extent env mp (l,body) = hov 2 (str ":= " ++ Printer.pr_lconstr_env env sigma (Mod_subst.force_constr l)) | _ -> mt ()) ++ str "." ++ - Printer.pr_abstract_universe_ctx sigma ctx) + Printer.pr_abstract_universe_ctx sigma ctx ~priv:cb.const_private_poly_univs) | SFBmind mib -> match extent with | WithContents -> diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index cc1bcc66ae..3e2093db4a 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -52,7 +52,7 @@ let write_diffs_option = function | "removed" -> diff_option := `REMOVED | _ -> CErrors.user_err Pp.(str "Diffs option only accepts the following values: \"off\", \"on\", \"removed\".") -let _ = +let () = Goptions.(declare_string_option { optdepr = false; optname = "show diffs in proofs"; diff --git a/proofs/goal_select.ml b/proofs/goal_select.ml index 65a94a2c60..cef3fd3f5e 100644 --- a/proofs/goal_select.ml +++ b/proofs/goal_select.ml @@ -53,7 +53,7 @@ let parse_goal_selector = function with Failure _ -> CErrors.user_err Pp.(str err_msg) end -let _ = let open Goptions in +let () = let open Goptions in declare_string_option { optdepr = false; optname = "default goal selector" ; diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 81122e6858..886a62cb89 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -16,18 +16,18 @@ open Environ open Evd let use_unification_heuristics_ref = ref true -let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; - Goptions.optname = "Solve unification constraints at every \".\""; - Goptions.optkey = ["Solve";"Unification";"Constraints"]; - Goptions.optread = (fun () -> !use_unification_heuristics_ref); - Goptions.optwrite = (fun a -> use_unification_heuristics_ref:=a); -} +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = "Solve unification constraints at every \".\""; + optkey = ["Solve";"Unification";"Constraints"]; + optread = (fun () -> !use_unification_heuristics_ref); + optwrite = (fun a -> use_unification_heuristics_ref:=a); +}) let use_unification_heuristics () = !use_unification_heuristics_ref exception NoSuchGoal -let _ = CErrors.register_handler begin function +let () = CErrors.register_handler begin function | NoSuchGoal -> CErrors.user_err Pp.(str "No such goal.") | _ -> raise CErrors.Unhandled end @@ -138,7 +138,7 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo try let status = by tac in let open Proof_global in - let { entries; universes } = fst @@ close_proof ~keep_body_ucst_separate:false (fun x -> x) in + let { entries; universes } = fst @@ close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) in match entries with | [entry] -> discard_current (); diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index ed8df29d7b..2ca4f0afb4 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -176,7 +176,7 @@ end (* Current bullet behavior, controlled by the option *) let current_behavior = ref Strict.strict -let _ = +let () = Goptions.(declare_string_option { optdepr = false; optname = "bullet behavior"; diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index cb4b5759dc..67e19df0e7 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -53,7 +53,7 @@ let default_proof_mode = ref (find_proof_mode "No") let get_default_proof_mode_name () = (CEphemeron.default !default_proof_mode standard).name -let _ = +let () = Goptions.(declare_string_option { optdepr = false; optname = "default proof mode" ; @@ -128,13 +128,13 @@ let push a l = l := a::!l; update_proof_mode () exception NoSuchProof -let _ = CErrors.register_handler begin function +let () = CErrors.register_handler begin function | NoSuchProof -> CErrors.user_err Pp.(str "No such proof.") | _ -> raise CErrors.Unhandled end exception NoCurrentProof -let _ = CErrors.register_handler begin function +let () = CErrors.register_handler begin function | NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof (No proof-editing in progress).") | _ -> raise CErrors.Unhandled end @@ -271,14 +271,6 @@ let start_dependent_proof id ?(pl=UState.default_univ_decl) str goals terminator let get_used_variables () = (cur_pstate ()).section_vars let get_universe_decl () = (cur_pstate ()).universe_decl -let proof_using_auto_clear = ref false -let _ = Goptions.declare_bool_option - { Goptions.optdepr = false; - Goptions.optname = "Proof using Clear Unused"; - Goptions.optkey = ["Proof";"Using";"Clear";"Unused"]; - Goptions.optread = (fun () -> !proof_using_auto_clear); - Goptions.optwrite = (fun b -> proof_using_auto_clear := b) } - let set_used_variables l = let open Context.Named.Declaration in let env = Global.env () in @@ -287,27 +279,26 @@ let set_used_variables l = let ctx_set = List.fold_right Id.Set.add (List.map NamedDecl.get_id ctx) Id.Set.empty in let vars_of = Environ.global_vars_set in - let aux env entry (ctx, all_safe, to_clear as orig) = + let aux env entry (ctx, all_safe as orig) = match entry with | LocalAssum (x,_) -> if Id.Set.mem x all_safe then orig - else (ctx, all_safe, (CAst.make x)::to_clear) + else (ctx, all_safe) | LocalDef (x,bo, ty) as decl -> if Id.Set.mem x all_safe then orig else let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in if Id.Set.subset vars all_safe - then (decl :: ctx, Id.Set.add x all_safe, to_clear) - else (ctx, all_safe, (CAst.make x) :: to_clear) in - let ctx, _, to_clear = - Environ.fold_named_context aux env ~init:(ctx,ctx_set,[]) in - let to_clear = if !proof_using_auto_clear then to_clear else [] in + then (decl :: ctx, Id.Set.add x all_safe) + else (ctx, all_safe) in + let ctx, _ = + Environ.fold_named_context aux env ~init:(ctx,ctx_set) in match !pstates with | [] -> raise NoCurrentProof | p :: rest -> if not (Option.is_empty p.section_vars) then CErrors.user_err Pp.(str "Used section variables can be declared only once"); pstates := { p with section_vars = Some ctx} :: rest; - ctx, to_clear + ctx, [] let get_open_goals () = let gl, gll, shelf , _ , _ = Proof.proof (cur_pstate ()).proof in @@ -318,10 +309,23 @@ let get_open_goals () = type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * UState.t -let close_proof ~keep_body_ucst_separate ?feedback_id ~now +let private_poly_univs = + let b = ref true in + let _ = Goptions.(declare_bool_option { + optdepr = false; + optname = "use private polymorphic universes for Qed constants"; + optkey = ["Private";"Polymorphic";"Universes"]; + optread = (fun () -> !b); + optwrite = ((:=) b); + }) + in + fun () -> !b + +let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now (fpl : closed_proof_output Future.computation) = let { pid; section_vars; strength; proof; terminator; universe_decl } = cur_pstate () in + let opaque = match opaque with Opaque -> true | Transparent -> false in let poly = pi2 strength (* Polymorphic *) in let initial_goals = Proof.initial_goals proof in let initial_euctx = Proof.initial_euctx proof in @@ -358,6 +362,16 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now let ctx_body = UState.restrict ctx used_univs in let univs = UState.check_mono_univ_decl ctx_body universe_decl in (initunivs, typ), ((body, univs), eff) + else if poly && opaque && private_poly_univs () then + let used_univs = Univ.LSet.union used_univs_body used_univs_typ in + let universes = UState.restrict universes used_univs in + let typus = UState.restrict universes used_univs_typ in + let udecl = UState.check_univ_decl ~poly typus universe_decl in + let ubody = Univ.ContextSet.diff + (UState.context_set universes) + (UState.context_set typus) + in + (udecl, typ), ((body, ubody), eff) else (* Since the proof is computed now, we can simply have 1 set of constraints in which we merge the ones for the body and the ones @@ -394,7 +408,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now const_entry_feedback = feedback_id; const_entry_type = Some typ; const_entry_inline_code = false; - const_entry_opaque = true; + const_entry_opaque = opaque; const_entry_universes = univs; } in let entries = Future.map2 entry_fn fpl initial_goals in @@ -425,10 +439,10 @@ let return_proof ?(allow_partial=false) () = List.map (fun (c, _) -> (EConstr.to_constr evd c, eff)) initial_goals in proofs, Evd.evar_universe_context evd -let close_future_proof ~feedback_id proof = - close_proof ~keep_body_ucst_separate:true ~feedback_id ~now:false proof -let close_proof ~keep_body_ucst_separate fix_exn = - close_proof ~keep_body_ucst_separate ~now:true +let close_future_proof ~opaque ~feedback_id proof = + close_proof ~opaque ~keep_body_ucst_separate:true ~feedback_id ~now:false proof +let close_proof ~opaque ~keep_body_ucst_separate fix_exn = + close_proof ~opaque ~keep_body_ucst_separate ~now:true (Future.from_val ~fix_exn (return_proof ())) (** Gets the current terminator without checking that the proof has @@ -467,7 +481,7 @@ let update_global_env () = (p, ()))) (* XXX: Bullet hook, should be really moved elsewhere *) -let _ = +let () = let hook n = try let prf = give_me_the_proof () in diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index e3808bc36d..d9c32cf9d5 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -86,7 +86,7 @@ val update_global_env : unit -> unit (* Takes a function to add to the exceptions data relative to the state in which the proof was built *) -val close_proof : keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof +val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof (* Intermediate step necessary to delegate the future. * Both access the current proof state. The former is supposed to be @@ -97,7 +97,7 @@ type closed_proof_output = (Constr.t * Safe_typing.private_constants) list * USt (* 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 -> unit -> closed_proof_output -val close_future_proof : feedback_id:Stateid.t -> +val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> closed_proof_output Future.computation -> closed_proof (** Gets the current terminator without checking that the proof has diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 0981584bb5..6658c37f41 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -54,14 +54,14 @@ let strong_cbn flags = strong_with_flags whd_cbn flags let simplIsCbn = ref (false) -let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; - Goptions.optname = +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = "Plug the simpl tactic to the new cbn mechanism"; - Goptions.optkey = ["SimplIsCbn"]; - Goptions.optread = (fun () -> !simplIsCbn); - Goptions.optwrite = (fun a -> simplIsCbn:=a); -} + optkey = ["SimplIsCbn"]; + optread = (fun () -> !simplIsCbn); + optwrite = (fun a -> simplIsCbn:=a); +}) let set_strategy_one ref l = let k = diff --git a/stm/stm.ml b/stm/stm.ml index 9359ab15e2..3444229735 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -27,6 +27,9 @@ open Feedback open Vernacexpr open Vernacextend +let is_vtkeep = function VtKeep _ -> true | _ -> false +let get_vtkeep = function VtKeep x -> x | _ -> assert false + module AsyncOpts = struct type cache = Force @@ -41,7 +44,6 @@ module AsyncOpts = struct async_proofs_mode : async_proofs; async_proofs_private_flags : string option; - async_proofs_full : bool; async_proofs_never_reopen_branch : bool; async_proofs_tac_error_resilience : tac_error_filter; @@ -58,7 +60,6 @@ module AsyncOpts = struct async_proofs_mode = APoff; async_proofs_private_flags = None; - async_proofs_full = false; async_proofs_never_reopen_branch = false; async_proofs_tac_error_resilience = `Only [ "curly" ]; @@ -1439,11 +1440,14 @@ end = struct (* {{{ *) let perspective = ref [] let set_perspective l = perspective := l + let is_inside_perspective st = true + (* This code is now disabled. If an IDE needs this feature, make it accessible again. + List.exists (fun x -> CList.mem_f Stateid.equal x !perspective) st + *) + let task_match age t = match age, t with - | Fresh, BuildProof { t_states } -> - not !cur_opt.async_proofs_full || - List.exists (fun x -> CList.mem_f Stateid.equal x !perspective) t_states + | Fresh, BuildProof { t_states } -> is_inside_perspective t_states | Old my_states, States l -> List.for_all (fun x -> CList.mem_f Stateid.equal x my_states) l | _ -> false @@ -1479,8 +1483,7 @@ end = struct (* {{{ *) feedback (InProgress ~-1); t_assign (`Val pl); record_pb_time ?loc:t_loc t_name time; - if !cur_opt.async_proofs_full || t_drop - then `Stay(t_states,[States t_states]) + if t_drop then `Stay(t_states,[States t_states]) else `End | Fresh, BuildProof { t_assign; t_loc; t_name; t_states }, RespError { e_error_at; e_safe_id = valid; e_msg; e_safe_states } -> @@ -1532,20 +1535,21 @@ end = struct (* {{{ *) let st = Vernacstate.freeze_interp_state `No in if not drop then begin let checked_proof = Future.chain future_proof (fun p -> + let opaque = Proof_global.Opaque in (* Unfortunately close_future_proof and friends are not pure so we need to set the state manually here *) Vernacstate.unfreeze_interp_state st; let pobject, _ = - Proof_global.close_future_proof ~feedback_id:stop (Future.from_val ~fix_exn p) in + Proof_global.close_future_proof ~opaque ~feedback_id:stop (Future.from_val ~fix_exn p) in let terminator = (* The one sent by master is an InvalidKey *) - Lemmas.(standard_proof_terminator [] (mk_hook (fun _ _ -> ()))) in + Lemmas.(standard_proof_terminator []) in let st = Vernacstate.freeze_interp_state `No in stm_vernac_interp stop ~proof:(pobject, terminator) st { verbose = false; loc; indentation = 0; strlen = 0; - expr = VernacExpr ([], VernacEndProof (Proved (Proof_global.Opaque,None))) }) in + expr = VernacExpr ([], VernacEndProof (Proved (opaque,None))) }) in ignore(Future.join checked_proof); end; (* STATE: Restore the state XXX: handle exn *) @@ -1678,11 +1682,11 @@ end = struct (* {{{ *) `OK_ADMITTED else begin (* The original terminator, a hook, has not been saved in the .vio*) - Proof_global.set_terminator - (Lemmas.standard_proof_terminator [] - (Lemmas.mk_hook (fun _ _ -> ()))); + Proof_global.set_terminator (Lemmas.standard_proof_terminator []); + + let opaque = Proof_global.Opaque in let proof = - Proof_global.close_proof ~keep_body_ucst_separate:true (fun x -> x) in + Proof_global.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:`No start; @@ -1695,7 +1699,7 @@ end = struct (* {{{ *) let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp stop ~proof st { verbose = false; loc; indentation = 0; strlen = 0; - expr = VernacExpr ([], VernacEndProof (Proved (Proof_global.Opaque,None))) }); + expr = VernacExpr ([], VernacEndProof (Proved (opaque,None))) }); `OK proof end with e -> @@ -2121,8 +2125,7 @@ end = struct (* {{{ *) TaskQueue.enqueue_task (Option.get !queue) QueryTask.({ t_where = prev; t_for = id; t_what = q }) ~cancel_switch - let init () = queue := Some (TaskQueue.create - (if !cur_opt.async_proofs_full then 1 else 0)) + let init () = queue := Some (TaskQueue.create 0) end (* }}} *) @@ -2145,7 +2148,6 @@ let async_policy () = let delegate name = get_hint_bp_time name >= !cur_opt.async_proofs_delegation_threshold || VCS.is_vio_doc () - || !cur_opt.async_proofs_full let collect_proof keep cur hd brkind id = stm_prerr_endline (fun () -> "Collecting proof ending at "^Stateid.to_string id); @@ -2252,8 +2254,7 @@ let collect_proof keep cur hd brkind id = else let rc = collect (Some cur) [] id in if is_empty rc then make_sync `AlreadyEvaluated rc - else if (keep == VtKeep || keep == VtKeepAsAxiom) && - (not(State.is_cached_and_valid id) || !cur_opt.async_proofs_full) + else if (is_vtkeep keep) && (not(State.is_cached_and_valid id)) then check_policy rc else make_sync `AlreadyEvaluated rc @@ -2440,9 +2441,9 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = ), `Yes, true | `Qed ({ qast = x; keep; brinfo; brname } as qed, eop) -> let rec aux = function - | `ASync (block_start, nodes, name, delegate) -> (fun () -> - assert(keep == VtKeep || keep == VtKeepAsAxiom); - let drop_pt = keep == VtKeepAsAxiom in + | `ASync (block_start, nodes, name, delegate) -> (fun () -> + let keep' = get_vtkeep keep in + let drop_pt = keep' == VtKeepAxiom in let block_stop, exn_info, loc = eop, (id, eop), x.loc in log_processing_async id name; VCS.create_proof_task_box nodes ~qed:id ~block_start; @@ -2450,11 +2451,11 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | { VCS.kind = `Edit _ }, None -> assert false | { VCS.kind = `Edit (_,_,_, okeep, _) }, Some (ofp, cancel) -> assert(redefine_qed = true); - if okeep != keep then + if okeep <> keep then msg_warning(strbrk("The command closing the proof changed. " ^"The kernel cannot take this into account and will " - ^(if keep == VtKeep then "not check " else "reject ") - ^"the "^(if keep == VtKeep then "new" else "incomplete") + ^(if not drop_pt then "not check " else "reject ") + ^"the "^(if not drop_pt then "new" else "incomplete") ^" proof. Reprocess the command declaring " ^"the proof's statement to avoid that.")); let fp, cancel = @@ -2477,8 +2478,13 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = ~drop_pt exn_info block_stop, ref false in qed.fproof <- Some (fp, cancel); + let opaque = match keep' with + | VtKeepAxiom | VtKeepOpaque -> + Proof_global.Opaque (* Admitted -> Opaque should be OK. *) + | VtKeepDefined -> Proof_global.Transparent + in let proof = - Proof_global.close_future_proof ~feedback_id:id fp in + Proof_global.close_future_proof ~opaque ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; let st = Vernacstate.freeze_interp_state `No in @@ -2502,15 +2508,19 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = let proof = match keep with | VtDrop -> None - | VtKeepAsAxiom -> + | VtKeep VtKeepAxiom -> let ctx = UState.empty in let fp = Future.from_val ([],ctx) in qed.fproof <- Some (fp, ref false); None - | VtKeep -> - Some(Proof_global.close_proof + | VtKeep opaque -> + let opaque = let open Proof_global in match opaque with + | VtKeepOpaque -> Opaque | VtKeepDefined -> Transparent + | VtKeepAxiom -> assert false + in + Some(Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (State.exn_on id ~valid:eop)) in - if keep != VtKeepAsAxiom then + if keep <> VtKeep VtKeepAxiom then reach view.next; let wall_clock2 = Unix.gettimeofday () in let st = Vernacstate.freeze_interp_state `No in @@ -2632,13 +2642,14 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = name by looking at the load path! *) List.iter Mltop.add_coq_path iload_path; + Safe_typing.allow_delayed_constants := !cur_opt.async_proofs_mode <> APoff; + begin match doc_type with | Interactive ln -> let dp = match ln with | TopLogical dp -> dp | TopPhysical f -> dirpath_of_file f in - Safe_typing.allow_delayed_constants := true; Declaremods.start_library dp | VoDoc f -> @@ -2649,7 +2660,6 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = set_compilation_hints f | VioDoc f -> - Safe_typing.allow_delayed_constants := true; let ldir = dirpath_of_file f in check_coq_overwriting ldir; let () = Flags.verbosely Declaremods.start_library ldir in @@ -2714,7 +2724,7 @@ let rec join_admitted_proofs id = if Stateid.equal id Stateid.initial then () else let view = VCS.visit id in match view.step with - | `Qed ({ keep = VtKeepAsAxiom; fproof = Some (fp,_) },_) -> + | `Qed ({ keep = VtKeep VtKeepAxiom; fproof = Some (fp,_) },_) -> ignore(Future.force fp); join_admitted_proofs view.next | _ -> join_admitted_proofs view.next @@ -2827,13 +2837,12 @@ let process_back_meta_command ~newtip ~head oid aast w = VCS.commit id (Alias (oid,aast)); Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok -let allow_nested_proofs = ref false -let _ = Goptions.declare_bool_option - { Goptions.optdepr = false; - Goptions.optname = "Nested Proofs Allowed"; - Goptions.optkey = Vernac_classifier.stm_allow_nested_proofs_option_name; - Goptions.optread = (fun () -> !allow_nested_proofs); - Goptions.optwrite = (fun b -> allow_nested_proofs := b) } +let get_allow_nested_proofs = + Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"Nested Proofs Allowed" + ~key:Vernac_classifier.stm_allow_nested_proofs_option_name + ~value:false let process_transaction ~doc ?(newtip=Stateid.fresh ()) ({ verbose; loc; expr } as x) c = @@ -2855,11 +2864,10 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) | VtQuery, w -> let id = VCS.new_node ~id:newtip () in let queue = - if !cur_opt.async_proofs_full then `QueryQueue (ref false) - else if VCS.is_vio_doc () && - VCS.((get_branch head).kind = `Master) && - may_pierce_opaque (Vernacprop.under_control x.expr) - then `SkipQueue + if VCS.is_vio_doc () && + VCS.((get_branch head).kind = `Master) && + may_pierce_opaque (Vernacprop.under_control x.expr) + then `SkipQueue else `MainQueue in VCS.commit id (mkTransCmd x [] false queue); Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok @@ -2867,7 +2875,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) (* Proof *) | VtStartProof (mode, guarantee, names), w -> - if not !allow_nested_proofs && VCS.proof_nesting () > 0 then + if not (get_allow_nested_proofs ()) && VCS.proof_nesting () > 0 then "Nested proofs are not allowed unless you turn option Nested Proofs Allowed on." |> Pp.str |> (fun s -> (UserError (None, s), Exninfo.null)) @@ -3192,8 +3200,7 @@ let edit_at ~doc id = VCS.delete_boxes_of id; VCS.gc (); VCS.print (); - if not !cur_opt.async_proofs_full then - Reach.known_state ~doc ~cache:(VCS.is_interactive ()) id; + Reach.known_state ~doc ~cache:(VCS.is_interactive ()) id; VCS.checkout_shallowest_proof_branch (); `NewTip in try diff --git a/stm/stm.mli b/stm/stm.mli index 0c0e19ce5c..b6071fa56b 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -16,7 +16,9 @@ open Names module AsyncOpts : sig type cache = Force - type async_proofs = APoff | APonLazy | APon + type async_proofs = APoff + | APonLazy (* Delays proof checking, but does it in master *) + | APon type tac_error_filter = [ `None | `Only of string list | `All ] type stm_opt = { @@ -27,7 +29,6 @@ module AsyncOpts : sig async_proofs_mode : async_proofs; async_proofs_private_flags : string option; - async_proofs_full : bool; async_proofs_never_reopen_branch : bool; async_proofs_tac_error_resilience : tac_error_filter; diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 526858bd73..44d07279fc 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -26,8 +26,8 @@ let string_of_vernac_type = function | VtUnknown -> "Unknown" | VtStartProof _ -> "StartProof" | VtSideff _ -> "Sideff" - | VtQed VtKeep -> "Qed(keep)" - | VtQed VtKeepAsAxiom -> "Qed(admitted)" + | VtQed (VtKeep VtKeepAxiom) -> "Qed(admitted)" + | VtQed (VtKeep (VtKeepOpaque | VtKeepDefined)) -> "Qed(keep)" | VtQed VtDrop -> "Qed(drop)" | VtProofStep { parallel; proof_block_detection } -> "ProofStep " ^ string_of_parallel parallel ^ @@ -43,6 +43,10 @@ let string_of_vernac_when = function let string_of_vernac_classification (t,w) = string_of_vernac_type t ^ " " ^ string_of_vernac_when w +let vtkeep_of_opaque = let open Proof_global in function + | Opaque -> VtKeepOpaque + | Transparent -> VtKeepDefined + let idents_of_name : Names.Name.t -> Names.Id.t list = function | Names.Anonymous -> [] @@ -65,8 +69,9 @@ let classify_vernac e = VtSideff [], VtNow (* Qed *) | VernacAbort _ -> VtQed VtDrop, VtLater - | VernacEndProof Admitted -> VtQed VtKeepAsAxiom, VtLater - | VernacEndProof _ | VernacExactProof _ -> VtQed VtKeep, VtLater + | VernacEndProof Admitted -> VtQed (VtKeep VtKeepAxiom), VtLater + | VernacEndProof (Proved (opaque,_)) -> VtQed (VtKeep (vtkeep_of_opaque opaque)), VtLater + | VernacExactProof _ -> VtQed (VtKeep VtKeepOpaque), VtLater (* Query *) | VernacShow _ | VernacPrint _ | VernacSearch _ | VernacLocate _ | VernacCheckMayEval _ -> VtQuery, VtLater diff --git a/tactics/auto.ml b/tactics/auto.ml index 81e487b77d..441fb68acc 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -172,15 +172,14 @@ let global_info_trivial = ref false let global_info_auto = ref false let add_option ls refe = - let _ = Goptions.declare_bool_option - { Goptions.optdepr = false; - Goptions.optname = String.concat " " ls; - Goptions.optkey = ls; - Goptions.optread = (fun () -> !refe); - Goptions.optwrite = (:=) refe } - in () - -let _ = + Goptions.(declare_bool_option + { optdepr = false; + optname = String.concat " " ls; + optkey = ls; + optread = (fun () -> !refe); + optwrite = (:=) refe }) + +let () = add_option ["Debug";"Trivial"] global_debug_trivial; add_option ["Debug";"Auto"] global_debug_auto; add_option ["Info";"Trivial"] global_info_trivial; diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 5959dd54b1..fd2a163f80 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -80,7 +80,7 @@ let get_typeclasses_depth () = !typeclasses_depth open Goptions -let _ = +let () = declare_bool_option { optdepr = false; optname = "do typeclass search avoiding eta-expansions " ^ @@ -89,7 +89,7 @@ let _ = optread = get_typeclasses_limit_intros; optwrite = set_typeclasses_limit_intros; } -let _ = +let () = declare_bool_option { optdepr = false; optname = "during typeclass resolution, solve instances according to their dependency order"; @@ -97,7 +97,7 @@ let _ = optread = get_typeclasses_dependency_order; optwrite = set_typeclasses_dependency_order; } -let _ = +let () = declare_bool_option { optdepr = false; optname = "use iterative deepening strategy"; @@ -105,7 +105,7 @@ let _ = optread = get_typeclasses_iterative_deepening; optwrite = set_typeclasses_iterative_deepening; } -let _ = +let () = declare_bool_option { optdepr = false; optname = "compat"; @@ -113,7 +113,7 @@ let _ = optread = get_typeclasses_filtered_unification; optwrite = set_typeclasses_filtered_unification; } -let set_typeclasses_debug = +let () = declare_bool_option { optdepr = false; optname = "debug output for typeclasses proof search"; @@ -122,14 +122,6 @@ let set_typeclasses_debug = optwrite = set_typeclasses_debug; } let _ = - declare_bool_option - { optdepr = false; - optname = "debug output for typeclasses proof search"; - optkey = ["Debug";"Typeclasses"]; - optread = get_typeclasses_debug; - optwrite = set_typeclasses_debug; } - -let _ = declare_int_option { optdepr = false; optname = "verbosity of debug output for typeclasses proof search"; @@ -137,7 +129,7 @@ let _ = optread = get_typeclasses_verbose; optwrite = set_typeclasses_verbose; } -let set_typeclasses_depth = +let () = declare_int_option { optdepr = false; optname = "depth for typeclasses proof search"; @@ -1126,7 +1118,7 @@ let solve_inst env evd filter unique split fail = end in sigma -let _ = +let () = Hook.set Typeclasses.solve_all_instances_hook solve_inst let resolve_one_typeclass env ?(sigma=Evd.from_env env) gl unique = @@ -1151,7 +1143,7 @@ let resolve_one_typeclass env ?(sigma=Evd.from_env env) gl unique = end in (sigma, term) -let _ = +let () = Hook.set Typeclasses.solve_one_instance_hook (fun x y z w -> resolve_one_typeclass x ~sigma:y z w) diff --git a/tactics/eauto.ml b/tactics/eauto.ml index b8adb792e8..3019fc0231 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -329,21 +329,21 @@ module Search = Explore.Make(SearchProblem) let global_debug_eauto = ref false let global_info_eauto = ref false -let _ = - Goptions.declare_bool_option - { Goptions.optdepr = false; - Goptions.optname = "Debug Eauto"; - Goptions.optkey = ["Debug";"Eauto"]; - Goptions.optread = (fun () -> !global_debug_eauto); - Goptions.optwrite = (:=) global_debug_eauto } - -let _ = - Goptions.declare_bool_option - { Goptions.optdepr = false; - Goptions.optname = "Info Eauto"; - Goptions.optkey = ["Info";"Eauto"]; - Goptions.optread = (fun () -> !global_info_eauto); - Goptions.optwrite = (:=) global_info_eauto } +let () = + Goptions.(declare_bool_option + { optdepr = false; + optname = "Debug Eauto"; + optkey = ["Debug";"Eauto"]; + optread = (fun () -> !global_debug_eauto); + optwrite = (:=) global_debug_eauto }) + +let () = + Goptions.(declare_bool_option + { optdepr = false; + optname = "Info Eauto"; + optkey = ["Info";"Eauto"]; + optread = (fun () -> !global_info_eauto); + optwrite = (:=) global_info_eauto }) let mk_eauto_dbg d = if d == Debug || !global_debug_eauto then Debug diff --git a/tactics/equality.ml b/tactics/equality.ml index b8967775bf..bdc95941b2 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -69,7 +69,7 @@ let use_injection_in_context = function | None -> !injection_in_context | Some flags -> flags.injection_in_context -let _ = +let () = declare_bool_option { optdepr = false; optname = "injection in context"; @@ -714,7 +714,7 @@ exception DiscrFound of let keep_proof_equalities_for_injection = ref false -let _ = +let () = declare_bool_option { optdepr = false; optname = "injection on prop arguments"; @@ -1501,7 +1501,7 @@ let intro_decomp_eq tac data (c, t) = decompEqThen !keep_proof_equalities_for_injection (fun _ -> tac) data cl end -let _ = declare_intro_decomp_eq intro_decomp_eq +let () = declare_intro_decomp_eq intro_decomp_eq (* [subst_tuple_term dep_pair B] @@ -1666,7 +1666,7 @@ user = raise user error specific to rewrite let regular_subst_tactic = ref true -let _ = +let () = declare_bool_option { optdepr = false; optname = "more regular behavior of tactic subst"; @@ -1911,8 +1911,8 @@ let replace_term dir_opt c = (* Declare rewriting tactic for intro patterns "<-" and "->" *) -let _ = +let () = let gmr l2r with_evars tac c = general_rewrite_clause l2r with_evars tac c in Hook.set Tactics.general_rewrite_clause gmr -let _ = Hook.set Tactics.subst_one subst_one +let () = Hook.set Tactics.subst_one subst_one diff --git a/tactics/hints.ml b/tactics/hints.ml index e64e08dbde..77479f9efa 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -194,14 +194,14 @@ let write_warn_hint = function | "Strict" -> warn_hint := `STRICT | _ -> user_err Pp.(str "Only the following flags are accepted: Lax, Warn, Strict.") -let _ = - Goptions.declare_string_option - { Goptions.optdepr = false; - Goptions.optname = "behavior of non-imported hints"; - Goptions.optkey = ["Loose"; "Hint"; "Behavior"]; - Goptions.optread = read_warn_hint; - Goptions.optwrite = write_warn_hint; - } +let () = + Goptions.(declare_string_option + { optdepr = false; + optname = "behavior of non-imported hints"; + optkey = ["Loose"; "Hint"; "Behavior"]; + optread = read_warn_hint; + optwrite = write_warn_hint; + }) let fresh_key = let id = Summary.ref ~name:"HINT-COUNTER" 0 in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 0beafb7e31..b3ea13cf4f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -61,7 +61,7 @@ let clear_hyp_by_default = ref false let use_clear_hyp_by_default () = !clear_hyp_by_default -let _ = +let () = declare_bool_option { optdepr = false; optname = "default clearing of hypotheses after use"; @@ -77,7 +77,7 @@ let universal_lemma_under_conjunctions = ref false let accept_universal_lemma_under_conjunctions () = !universal_lemma_under_conjunctions -let _ = +let () = declare_bool_option { optdepr = false; optname = "trivial unification in tactics applying under conjunctions"; @@ -96,7 +96,7 @@ let bracketing_last_or_and_intro_pattern = ref true let use_bracketing_last_or_and_intro_pattern () = !bracketing_last_or_and_intro_pattern -let _ = +let () = declare_bool_option { optdepr = false; optname = "bracketing last or-and introduction pattern"; @@ -4548,7 +4548,7 @@ let induction_gen_l isrec with_evars elim names lc = match EConstr.kind sigma c with | Var id when not (mem_named_context_val id (Global.named_context_val ())) && not with_evars -> - let _ = newlc:= id::!newlc in + let () = newlc:= id::!newlc in atomize_list l' | _ -> @@ -4561,7 +4561,7 @@ let induction_gen_l isrec with_evars elim names lc = let id = new_fresh_id Id.Set.empty x gl in let newl' = List.map (fun r -> replace_term sigma c (mkVar id) r) l' in - let _ = newlc:=id::!newlc in + let () = newlc:=id::!newlc in Tacticals.New.tclTHEN (letin_tac None (Name id) c None allHypsAndConcl) (atomize_list newl') diff --git a/test-suite/bugs/closed/bug_8364.v b/test-suite/bugs/closed/bug_8364.v new file mode 100644 index 0000000000..10f955b41f --- /dev/null +++ b/test-suite/bugs/closed/bug_8364.v @@ -0,0 +1,17 @@ +Unset Primitive Projections. + +Record Box (A:Type) := box { unbox : A }. +Arguments box {_} _. Arguments unbox {_} _. + +Definition map {A B} (f:A -> B) x := + match x with box x => box (f x) end. + +Definition tuple (l : Box Type) : Type := + match l with + | box x => x + end. + +Fail Inductive stack : Type -> Type := +| Stack T foos : + tuple (map stack foos) -> + stack T. diff --git a/test-suite/bugs/closed/bug_9014.v b/test-suite/bugs/closed/bug_9014.v new file mode 100644 index 0000000000..c1fdd04a65 --- /dev/null +++ b/test-suite/bugs/closed/bug_9014.v @@ -0,0 +1,19 @@ +(* A type, not a class *) +Variant T := mkT. + +(* In records, :> declares a coercion *) +Record R := { t_of_r :> T }. +Check forall r : R, r = r :> T. + +(* A class *) +Class A := { p : Prop }. +(* A sub-class *) +Class B := { a_of_b :> A ; t_of_b :> T }. +(* The sub-instance is automatically inferred due to :> for a_of_b *) +Check forall b : B, p. +(* No coercion is introduced by :> in t_of_b *) +Fail Check forall b : B, b = b :> T. + +(* Using :> when the RHS is not a class produces a “not-a-class” warning. *) +Set Warnings "+not-a-class". +Fail Class B' := { a_of_b' :> A ; t_of_b' :> T }. diff --git a/test-suite/coqchk/bug_8937.v b/test-suite/coqchk/bug_8937.v new file mode 100644 index 0000000000..5b326e389b --- /dev/null +++ b/test-suite/coqchk/bug_8937.v @@ -0,0 +1,21 @@ +(* -*- coq-prog-args: ("-noinit"); -*- *) + +Unset Elimination Schemes. +Module Type S. + +Inductive foo : Prop :=. +Definition bar (x:foo) : Prop := match x with end. + +End S. + +Module M. + +Inductive foo : Prop :=. +Definition bar (x:foo) : Prop := match x with end. + +End M. + +Module MS : S := M. + +Module F (Z:S) := Z. +Module MS' : S := F M. diff --git a/test-suite/misc/quick-include.sh b/test-suite/misc/quick-include.sh new file mode 100755 index 0000000000..96bdee2fc2 --- /dev/null +++ b/test-suite/misc/quick-include.sh @@ -0,0 +1,5 @@ +#!/bin/sh +set -e + +$coqc -R misc/quick-include/ QuickInclude -quick misc/quick-include/file1.v +$coqc -R misc/quick-include/ QuickInclude -quick misc/quick-include/file2.v diff --git a/test-suite/misc/quick-include/file1.v b/test-suite/misc/quick-include/file1.v new file mode 100644 index 0000000000..fa48e240cb --- /dev/null +++ b/test-suite/misc/quick-include/file1.v @@ -0,0 +1,18 @@ + +Module Type E. End E. + +Module M. + Lemma x : True. + Proof. trivial. Qed. +End M. + + +Module Type T. + Lemma x : True. + Proof. trivial. Qed. +End T. + +Module F(A:E). + Lemma x : True. + Proof. trivial. Qed. +End F. diff --git a/test-suite/misc/quick-include/file2.v b/test-suite/misc/quick-include/file2.v new file mode 100644 index 0000000000..ab10dfd8de --- /dev/null +++ b/test-suite/misc/quick-include/file2.v @@ -0,0 +1,6 @@ + +From QuickInclude Require file1. + +Module M. Include file1.M. End M. +Module T. Include file1.T. End T. +Module F. Include file1.F. End F. diff --git a/test-suite/modules/Nat.v b/test-suite/modules/Nat.v index d2116d2183..95daa1bb0c 100644 --- a/test-suite/modules/Nat.v +++ b/test-suite/modules/Nat.v @@ -2,7 +2,7 @@ Definition T := nat. Definition le := le. -Hint Unfold le. +Hint Unfold le : core. Lemma le_refl : forall n : nat, le n n. auto. diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out index 6d65db9e22..5a548cfae4 100644 --- a/test-suite/output/Inductive.out +++ b/test-suite/output/Inductive.out @@ -1,6 +1,6 @@ The command has indeed failed with message: Last occurrence of "list'" must have "A" as 1st argument in - "A -> list' A -> list' (A * A)%type". + "A -> list' A -> list' (A * A)". Monomorphic Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 94b86fc222..bec4fc1579 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -72,7 +72,7 @@ Nil : forall A : Type, list A NIL : list nat : list nat -(false && I 3)%bool /\ I 6 +(false && I 3)%bool /\ (I 6)%bool : Prop [|1, 2, 3; 4, 5, 6|] : Z * Z * Z * (Z * Z * Z) diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index adab324cf0..2ffc3b14e2 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -30,7 +30,7 @@ Check (decomp (true,true) as t, u in (t,u)). Section A. -Notation "! A" := (forall _:nat, A) (at level 60). +Notation "! A" := (forall _:nat, A) (at level 60) : type_scope. Check ! (0=0). Check forall n, n=0. @@ -195,9 +195,9 @@ Open Scope nat_scope. Coercion is_true := fun b => b=true. Coercion of_nat n := match n with 0 => true | _ => false end. -Notation "'I' x" := (of_nat (S x) || true)%bool (at level 10). +Notation "'I' x" := (of_nat (S x) || true)%bool (at level 10) : bool_scope. -Check (false && I 3)%bool /\ I 6. +Check (false && I 3)%bool /\ (I 6)%bool. (**********************************************************************) (* Check notations with several recursive patterns *) diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v index bcb2468792..923caedace 100644 --- a/test-suite/output/Notations2.v +++ b/test-suite/output/Notations2.v @@ -71,6 +71,7 @@ Check let' f x y (a:=0) z (b:bool) := x+y+z+1 in f 0 1 2. (* Note: does not work for pattern *) Module A. Notation "f ( x )" := (f x) (at level 10, format "f ( x )"). +Open Scope nat_scope. Check fun f x => f x + S x. Open Scope list_scope. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index 48379f713d..f53313def9 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -128,25 +128,27 @@ return (1, 2, 3, 4) : nat *(1.2) : nat -! '{{x, y}}, x.y = 0 +! '{{x, y}}, x + y = 0 : Prop exists x : nat, nat -> exists y : nat, - nat -> exists '{{u, t}}, forall z1 : nat, z1 = 0 /\ x.y = 0 /\ u.t = 0 + nat -> + exists '{{u, t}}, forall z1 : nat, z1 = 0 /\ x + y = 0 /\ u + t = 0 : Prop exists x : nat, nat -> exists y : nat, - nat -> exists '{{z, t}}, forall z2 : nat, z2 = 0 /\ x.y = 0 /\ z.t = 0 + nat -> + exists '{{z, t}}, forall z2 : nat, z2 = 0 /\ x + y = 0 /\ z + t = 0 : Prop -exists_true '{{x, y}} (u := 0) '{{z, t}}, x.y = 0 /\ z.t = 0 +exists_true '{{x, y}} (u := 0) '{{z, t}}, x + y = 0 /\ z + t = 0 : Prop exists_true (A : Type) (R : A -> A -> Prop) (_ : Reflexive R), (forall x : A, R x x) : Prop exists_true (x : nat) (A : Type) (R : A -> A -> Prop) -(_ : Reflexive R) (y : nat), x.y = 0 -> forall z : A, R z z +(_ : Reflexive R) (y : nat), x + y = 0 -> forall z : A, R z z : Prop {{{{True, nat -> True}}, nat -> True}} : Prop * Prop * Prop @@ -182,22 +184,22 @@ pair (prod nat (prod nat nat))) (prod (prod nat nat) nat) fun x : nat => if x is n .+ 1 then n else 1 : nat -> nat -{'{{x, y}} : nat * nat | x.y = 0} +{'{{x, y}} : nat * nat | x + y = 0} : Set exists2' {{x, y}}, x = 0 & y = 0 : Prop myexists2 x : nat * nat, let '{{y, z}} := x in y > z & let '{{y, z}} := x in z > y : Prop -fun '({{x, y}} as z) => x.y = 0 /\ z = z +fun '({{x, y}} as z) => x + y = 0 /\ z = z : nat * nat -> Prop -myexists ({{x, y}} as z), x.y = 0 /\ z = z +myexists ({{x, y}} as z), x + y = 0 /\ z = z : Prop -exists '({{x, y}} as z), x.y = 0 /\ z = z +exists '({{x, y}} as z), x + y = 0 /\ z = z : Prop -∀ '({{x, y}} as z), x.y = 0 /\ z = z +∀ '({{x, y}} as z), x + y = 0 /\ z = z : Prop -fun '({{{{x, y}}, true}} | {{{{x, y}}, false}}) => x.y +fun '({{{{x, y}}, true}} | {{{{x, y}}, false}}) => x + y : nat * nat * bool -> nat myexists ({{{{x, y}}, true}} | {{{{x, y}}, false}}), x > y : Prop @@ -209,17 +211,17 @@ fun p : nat => if p is S n then n else 0 : nat -> nat fun p : comparison => if p is Lt then 1 else 0 : comparison -> nat -fun S : nat => [S | S.S] +fun S : nat => [S | S + S] : nat -> nat * (nat -> nat) -fun N : nat => [N | N.0] +fun N : nat => [N | N + 0] : nat -> nat * (nat -> nat) -fun S : nat => [[S | S.S]] +fun S : nat => [[S | S + S]] : nat -> nat * (nat -> nat) {I : nat | I = I} : Set {'I : True | I = I} : Prop -{'{{x, y}} : nat * nat | x.y = 0} +{'{{x, y}} : nat * nat | x + y = 0} : Set exists2 '{{y, z}} : nat * nat, y > z & z > y : Prop @@ -253,3 +255,17 @@ myfoo01 tt : nat myfoo01 tt : nat +[{0; 0}] + : list (list nat) +[{1; 2; 3}; + {4; 5; 6}; + {7; 8; 9}] + : list (list nat) +Monomorphic amatch = mmatch 0 (with 0 => 1| 1 => 2 end) + : unit + +amatch is not universe polymorphic +Monomorphic alist = [0; 1; 2] + : list nat + +alist is not universe polymorphic diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 180e8d337e..15211f1233 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -59,7 +59,7 @@ Check fun f => CURRYINVLEFT (x:nat) (y:bool), f. (* Notations with variables bound both as a term and as a binder *) (* This is #4592 *) -Notation "{# x | P }" := (ex2 (fun y => x = y) (fun x => P)). +Notation "{# x | P }" := (ex2 (fun y => x = y) (fun x => P)) : type_scope. Check forall n:nat, {# n | 1 > n}. Parameter foo : forall {T}(x : T)(P : T -> Prop), Prop. @@ -183,9 +183,13 @@ Check letpair x [1] = {0}; return (1,2,3,4). (* Test spacing in #5569 *) +Section S1. +Variable plus : nat -> nat -> nat. +Infix "+" := plus. Notation "{ { xL | xR // xcut } }" := (xL+xR+xcut) (at level 0, xR at level 39, format "{ { xL | xR // xcut } }"). Check 1+1+1. +End S1. (* Test presence of notation variables in the recursive parts (introduced in dfdaf4de) *) Notation "!!! x .. y , b" := ((fun x => b), .. ((fun y => b), True) ..) (at level 200, x binder). @@ -193,10 +197,12 @@ Check !!! (x y:nat), True. (* Allow level for leftmost nonterminal when printing-only, BZ#5739 *) -Notation "* x" := (id x) (only printing, at level 15, format "* x"). -Notation "x . y" := (x + y) (only printing, at level 20, x at level 14, left associativity, format "x . y"). +Section S2. +Notation "* x" := (id x) (only printing, at level 15, format "* x") : nat_scope. +Notation "x . y" := (x + y) (only printing, at level 20, x at level 14, left associativity, format "x . y") : nat_scope. Check (((id 1) + 2) + 3). Check (id (1 + 2)). +End S2. (* Test contraction of "forall x, let 'pat := x in ..." into "forall 'pat, ..." *) (* for isolated "forall" (was not working already in 8.6) *) @@ -410,3 +416,58 @@ Check myfoo0 1 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] Check myfoo01 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] *) End Issue8126. + +(* Test printing of notations guided by scope *) + +Module A. + +Declare Scope line_scope. +Delimit Scope line_scope with line. +Declare Scope matx_scope. +Notation "{ }" := nil (format "{ }") : line_scope. +Notation "{ x }" := (cons x nil) : line_scope. +Notation "{ x ; y ; .. ; z }" := (cons x (cons y .. (cons z nil) ..)) : line_scope. +Notation "[ ]" := nil (format "[ ]") : matx_scope. +Notation "[ l ]" := (cons l%line nil) : matx_scope. +Notation "[ l ; l' ; .. ; l'' ]" := (cons l%line (cons l'%line .. (cons l''%line nil) ..)) + (format "[ '[v' l ; '/' l' ; '/' .. ; '/' l'' ']' ]") : matx_scope. + +Open Scope matx_scope. +Check [[0;0]]. +Check [[1;2;3];[4;5;6];[7;8;9]]. + +End A. + +(* Example by Beta Ziliani *) + +Require Import Lists.List. + +Module B. + +Import ListNotations. + +Declare Scope pattern_scope. +Delimit Scope pattern_scope with pattern. + +Declare Scope patterns_scope. +Delimit Scope patterns_scope with patterns. + +Notation "a => b" := (a, b) (at level 201) : pattern_scope. +Notation "'with' p1 | .. | pn 'end'" := + ((cons p1%pattern (.. (cons pn%pattern nil) ..))) + (at level 91, p1 at level 210, pn at level 210) : patterns_scope. + +Definition mymatch (n:nat) (l : list (nat * nat)) := tt. +Arguments mymatch _ _%patterns. +Notation "'mmatch' n ls" := (mymatch n ls) (at level 0). + +Close Scope patterns_scope. +Close Scope pattern_scope. + +Definition amatch := mmatch 0 with 0 => 1 | 1 => 2 end. +Print amatch. (* Good: amatch = mmatch 0 (with 0 => 1| 1 => 2 end) *) + +Definition alist := [0;1;2]. +Print alist. + +End B. diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index 46784d1897..d58e4bf2d6 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -17,3 +17,31 @@ end : Expr -> Expr [(1 + 1)] : Expr +Let "x" e1 e2 + : expr +Let "x" e1 e2 + : expr +fun x : nat => (# x)%nat + : nat -> nat +fun x : nat => ## x + : nat -> nat +fun x : nat => # x + : nat -> nat +fun x : nat => ### x + : nat -> nat +fun x : nat => ## x + : nat -> nat +fun x : nat => (x.-1)%pred + : nat -> nat +∀ a : nat, a = 0 + : Prop +((∀ a : nat, a = 0) -> True)%type + : Prop +# + : Prop +# -> True + : Prop +((∀ a : nat, a = 0) -> True)%type + : Prop +## + : Prop diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 6bdbf1bed5..61206b6dd0 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -5,8 +5,8 @@ Module A. Declare Custom Entry myconstr. Notation "[ x ]" := x (x custom myconstr at level 6). -Notation "x + y" := (Nat.add x y) (in custom myconstr at level 5). -Notation "x * y" := (Nat.mul x y) (in custom myconstr at level 4). +Notation "x + y" := (Nat.add x y) (in custom myconstr at level 5) : nat_scope. +Notation "x * y" := (Nat.mul x y) (in custom myconstr at level 4) : nat_scope. Notation "< x >" := x (in custom myconstr at level 3, x constr at level 10). Check [ < 0 > + < 1 > * < 2 >]. @@ -70,3 +70,97 @@ Notation "( x )" := x (in custom expr at level 0, x at level 2). Check [1 + 1]. End C. + +(* An example of interaction between coercion and notations from + Robbert Krebbers. *) + +Require Import String. + +Module D. + +Inductive expr := + | Var : string -> expr + | Lam : string -> expr -> expr + | App : expr -> expr -> expr. + +Notation Let x e1 e2 := (App (Lam x e2) e1). + +Parameter e1 e2 : expr. + +Check (Let "x" e1 e2). + +Coercion App : expr >-> Funclass. + +Check (Let "x" e1 e2). + +End D. + +(* Check fix of #8551: a delimiter should be inserted because the + lonely notation hides the scope nat_scope, even though the latter + is open *) + +Module E. + +Notation "# x" := (S x) (at level 20) : nat_scope. +Notation "# x" := (Some x). +Check fun x => (# x)%nat. + +End E. + +(* Other tests of precedence *) + +Module F. + +Notation "# x" := (S x) (at level 20) : nat_scope. +Notation "## x" := (S x) (at level 20). +Check fun x => S x. +Open Scope nat_scope. +Check fun x => S x. +Notation "### x" := (S x) (at level 20) : nat_scope. +Check fun x => S x. +Close Scope nat_scope. +Check fun x => S x. + +End F. + +(* Lower priority of generic application rules *) + +Module G. + +Declare Scope predecessor_scope. +Delimit Scope predecessor_scope with pred. +Declare Scope app_scope. +Delimit Scope app_scope with app. +Notation "x .-1" := (Nat.pred x) (at level 10, format "x .-1") : predecessor_scope. +Notation "f ( x )" := (f x) (at level 10, format "f ( x )") : app_scope. +Check fun x => pred x. + +End G. + +(* Checking arbitration between in the presence of a notation in type scope *) + +Module H. + +Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) + (at level 200, x binder, y binder, right associativity, + format "'[ ' '[ ' ∀ x .. y ']' , '/' P ']'") : type_scope. +Check forall a, a = 0. + +Close Scope type_scope. +Check ((forall a, a = 0) -> True)%type. +Open Scope type_scope. + +Notation "#" := (forall a, a = 0). +Check #. +Check # -> True. + +Close Scope type_scope. +Check (# -> True)%type. +Open Scope type_scope. + +Declare Scope my_scope. +Notation "##" := (forall a, a = 0) : my_scope. +Open Scope my_scope. +Check ##. + +End H. diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index d76b307914..339f798240 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -165,19 +165,13 @@ Module binders. exact A. Defined. - Definition nomoreu@{i j | i < j +} (A : Type@{i}) : Type@{j}. - pose(foo:=Type). - exact A. - Fail Defined. - Abort. - - Polymorphic Definition moreu@{i j +} (A : Type@{i}) : Type@{j}. - pose(foo:=Type). - exact A. - Defined. + Polymorphic Lemma hidden_strict_type : Type. + Proof. + exact Type. + Qed. + Check hidden_strict_type@{_}. + Fail Check hidden_strict_type@{Set}. - Check moreu@{_ _ _ _}. - Fail Definition morec@{i j|} (A : Type@{i}) : Type@{j} := A. (* By default constraints are extensible *) diff --git a/test-suite/success/private_univs.v b/test-suite/success/private_univs.v new file mode 100644 index 0000000000..5c30b33435 --- /dev/null +++ b/test-suite/success/private_univs.v @@ -0,0 +1,50 @@ +Set Universe Polymorphism. Set Printing Universes. + +Definition internal_defined@{i j | i < j +} (A : Type@{i}) : Type@{j}. + pose(foo:=Type). (* 1 universe for the let body + 1 for the type *) + exact A. + Fail Defined. +Abort. + +Definition internal_defined@{i j +} (A : Type@{i}) : Type@{j}. +pose(foo:=Type). +exact A. +Defined. +Check internal_defined@{_ _ _ _}. + +Module M. +Lemma internal_qed@{i j|i<=j} (A:Type@{i}) : Type@{j}. +Proof. + pose (foo := Type). + exact A. +Qed. +Check internal_qed@{_ _}. +End M. +Include M. +(* be careful to remove const_private_univs in Include! will be coqchk'd *) + +Unset Strict Universe Declaration. +Lemma private_transitivity@{i j} (A:Type@{i}) : Type@{j}. +Proof. + pose (bar := Type : Type@{j}). + pose (foo := Type@{i} : bar). + exact bar. +Qed. + +Definition private_transitivity'@{i j|i < j} := private_transitivity@{i j}. +Fail Definition dummy@{i j|j <= i +} := private_transitivity@{i j}. + +Unset Private Polymorphic Universes. +Lemma internal_noprivate_qed@{i j|i<=j} (A:Type@{i}) : Type@{j}. +Proof. + pose (foo := Type). + exact A. + Fail Qed. +Abort. + +Lemma internal_noprivate_qed@{i j +} (A:Type@{i}) : Type@{j}. +Proof. + pose (foo := Type). + exact A. +Qed. +Check internal_noprivate_qed@{_ _ _ _}. diff --git a/theories/Compat/Coq89.v b/theories/Compat/Coq89.v index 49b9e4c951..81a087b525 100644 --- a/theories/Compat/Coq89.v +++ b/theories/Compat/Coq89.v @@ -10,3 +10,5 @@ (** Compatibility file for making Coq act similar to Coq v8.9 *) Local Set Warnings "-deprecated". + +Unset Private Polymorphic Universes. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index d5241e622c..af9050da29 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -2250,6 +2250,32 @@ Section Exists_Forall. End One_predicate. + Theorem Forall_inv_tail + : forall (P : A -> Prop) (x0 : A) (xs : list A), Forall P (x0 :: xs) -> Forall P xs. + Proof. + intros P x0 xs H. + apply Forall_forall with (l := xs). + assert (H0 : forall x : A, In x (x0 :: xs) -> P x). + apply Forall_forall with (P := P) (l := x0 :: xs). + exact H. + assert (H1 : forall (x : A) (H2 : In x xs), P x). + intros x H2. + apply (H0 x). + right. + exact H2. + intros x H2. + apply (H1 x H2). + Qed. + + Theorem Exists_impl + : forall (P Q : A -> Prop), (forall x : A, P x -> Q x) -> forall xs : list A, Exists P xs -> Exists Q xs. + Proof. + intros P Q H xs H0. + induction H0. + apply (Exists_cons_hd Q x l (H x H0)). + apply (Exists_cons_tl x IHExists). + Qed. + Lemma Forall_Exists_neg (P:A->Prop)(l:list A) : Forall (fun x => ~ P x) l <-> ~(Exists P l). Proof. diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 60c64d306b..1fb0a37e16 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -77,7 +77,7 @@ End CompareFacts. (** * Properties of [OrderedTypeFull] *) -Module Type OrderedTypeFullFacts (Import O:OrderedTypeFull'). +Module OrderedTypeFullFacts (Import O:OrderedTypeFull'). Module OrderTac := OTF_to_OrderTac O. Ltac order := OrderTac.order. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index b673225e40..4372ac72ae 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -102,7 +102,7 @@ CAMLOPTC ?= "$(OCAMLFIND)" opt -c CAMLLINK ?= "$(OCAMLFIND)" ocamlc -linkpkg -dontlink $(CAMLDONTLINK) CAMLOPTLINK ?= "$(OCAMLFIND)" opt -linkpkg -dontlink $(CAMLDONTLINK) CAMLDOC ?= "$(OCAMLFIND)" ocamldoc -CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack +CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .mlpack # DESTDIR is prepended to all installation paths DESTDIR ?= @@ -226,7 +226,6 @@ COQTOPINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)toploop) VDFILE := .coqdeps ALLSRCFILES := \ - $(ML4FILES) \ $(MLGFILES) \ $(MLFILES) \ $(MLPACKFILES) \ @@ -248,7 +247,6 @@ BEAUTYFILES = $(addsuffix .beautified,$(VFILES)) TEXFILES = $(VFILES:.v=.tex) GTEXFILES = $(VFILES:.v=.g.tex) CMOFILES = \ - $(ML4FILES:.ml4=.cmo) \ $(MLGFILES:.mlg=.cmo) \ $(MLFILES:.ml=.cmo) \ $(MLPACKFILES:.mlpack=.cmo) @@ -265,7 +263,7 @@ CMXSFILES = \ $(MLPACKFILES:.mlpack=.cmxs) \ $(CMXAFILES:.cmxa=.cmxs) \ $(if $(MLPACKFILES)$(CMXAFILES),,\ - $(ML4FILES:.ml4=.cmxs) $(MLGFILES:.mlg=.cmxs) $(MLFILES:.ml=.cmxs)) + $(MLGFILES:.mlg=.cmxs) $(MLFILES:.ml=.cmxs)) # files that are packed into a plugin (no extension) PACKEDFILES = \ @@ -583,14 +581,6 @@ $(MLIFILES:.mli=.cmi): %.cmi: %.mli $(SHOW)'CAMLC -c $<' $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< -$(ML4FILES:.ml4=.cmo): %.cmo: %.ml4 - $(SHOW)'CAMLC -pp -c $<' - $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(PP) -impl $< - -$(ML4FILES:.ml4=.cmx): %.cmx: %.ml4 - $(SHOW)'CAMLOPT -pp -c $(FOR_PACK) $<' - $(HIDE)$(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(PP) $(FOR_PACK) -impl $< - $(MLGFILES:.mlg=.ml): %.ml: %.mlg $(SHOW)'COQPP $<' $(HIDE)$(COQPP) $< @@ -642,7 +632,7 @@ $(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ # This rule is for _CoqProject with no .mllib nor .mlpack -$(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix .cmxs,$(PACKEDFILES)) $(addsuffix .cmxs,$(LIBEDFILES)),$(MLFILES:.ml=.cmxs) $(ML4FILES:.ml4=.cmxs) $(MLGFILES:.mlg=.cmxs)): %.cmxs: %.cmx +$(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix .cmxs,$(PACKEDFILES)) $(addsuffix .cmxs,$(LIBEDFILES)),$(MLFILES:.ml=.cmxs) $(MLGFILES:.mlg=.cmxs)): %.cmxs: %.cmx $(SHOW)'[deprecated,use-mllib-or-mlpack] CAMLOPT -shared -o $@' $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ -shared -o $@ $< @@ -703,17 +693,13 @@ endif redir_if_ok = > "$@" || ( RV=$$?; rm -f "$@"; exit $$RV ) -GENMLFILES:=$(MLGFILES:.mlg=.ml) $(ML4FILES:.ml4=.ml) +GENMLFILES:=$(MLGFILES:.mlg=.ml) $(addsuffix .d,$(ALLSRCFILES)): $(GENMLFILES) $(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli $(SHOW)'CAMLDEP $<' $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) -$(addsuffix .d,$(ML4FILES)): %.ml4.d: %.ml4 - $(SHOW)'CAMLDEP -pp $<' - $(HIDE)$(CAMLDEP) $(OCAMLLIBS) $(PP) -impl "$<" $(redir_if_ok) - $(addsuffix .d,$(MLGFILES)): %.mlg.d: %.ml $(SHOW)'CAMLDEP $<' $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index 84850e7158..41057a79e0 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -136,7 +136,7 @@ type vodep = { deps : string list; } -type ldep = | VO of vodep | ML4 of string | MLG of string +type ldep = | VO of vodep | MLG of string type ddir = ldep list DirMap.t (* Filter `.vio` etc... *) @@ -181,19 +181,13 @@ let pp_vo_dep dir fmt vo = let action = sprintf "(chdir %%{project_root} (run coqtop -boot %s %s %s -compile %s))" libflag eflag cflag source in pp_rule fmt [vo.target] deps action -let pp_ml4_dep _dir fmt ml = - let target = Filename.(remove_extension ml) ^ ".ml" in - let ml4_rule = "(run coqp5 -loc loc -impl %{pp-file} -o %{targets})" in - pp_rule fmt [target] [ml] ml4_rule - let pp_mlg_dep _dir fmt ml = let target = Filename.(remove_extension ml) ^ ".ml" in - let ml4_rule = "(run coqpp %{pp-file})" in - pp_rule fmt [target] [ml] ml4_rule + let mlg_rule = "(run coqpp %{pp-file})" in + pp_rule fmt [target] [ml] mlg_rule let pp_dep dir fmt oo = match oo with | VO vo -> pp_vo_dep dir fmt vo - | ML4 f -> pp_ml4_dep dir fmt f | MLG f -> pp_mlg_dep dir fmt f let out_install fmt dir ff = @@ -220,21 +214,17 @@ let record_dune d ff = eprintf "error in coq_dune, a directory disappeared: %s@\n%!" sd (* File Scanning *) -let choose_ml4g_form f = - if Filename.check_suffix f ".ml4" then ML4 f - else MLG f - -let scan_mlg4 m d = +let scan_mlg m d = let dir = ["plugins"; d] in let m = DirMap.add dir [] m in - let ml4 = Sys.(List.filter (fun f -> Filename.(check_suffix f ".ml4" || check_suffix f ".mlg")) + let mlg = Sys.(List.filter (fun f -> Filename.(check_suffix f ".mlg")) Array.(to_list @@ readdir (bpath dir))) in - List.fold_left (fun m f -> add_map_list ["plugins"; d] (choose_ml4g_form f) m) m ml4 + List.fold_left (fun m f -> add_map_list ["plugins"; d] (MLG f) m) m mlg let scan_plugins m = let is_plugin_directory dir = Sys.(is_directory dir && file_exists (bpath [dir;"plugin_base.dune"])) in let dirs = Sys.(List.filter (fun f -> is_plugin_directory @@ bpath ["plugins";f]) Array.(to_list @@ readdir "plugins")) in - List.fold_left scan_mlg4 m dirs + List.fold_left scan_mlg m dirs (* Process .vfiles.d and generate a skeleton for the dune file *) let parse_coqdep_line l = diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 8560bac786..5fd894e908 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -218,7 +218,7 @@ let generate_conf_coq_config oc = ;; let generate_conf_files oc - { v_files; mli_files; ml4_files; mlg_files; ml_files; mllib_files; mlpack_files; } + { v_files; mli_files; mlg_files; ml_files; mllib_files; mlpack_files; } = let module S = String in let map = map_sourced_list in @@ -226,7 +226,6 @@ let generate_conf_files oc fprintf oc "COQMF_VFILES = %s\n" (S.concat " " (map quote v_files)); fprintf oc "COQMF_MLIFILES = %s\n" (S.concat " " (map quote mli_files)); fprintf oc "COQMF_MLFILES = %s\n" (S.concat " " (map quote ml_files)); - fprintf oc "COQMF_ML4FILES = %s\n" (S.concat " " (map quote ml4_files)); fprintf oc "COQMF_MLGFILES = %s\n" (S.concat " " (map quote mlg_files)); fprintf oc "COQMF_MLPACKFILES = %s\n" (S.concat " " (map quote mlpack_files)); fprintf oc "COQMF_MLLIBFILES = %s\n" (S.concat " " (map quote mllib_files)); @@ -284,7 +283,7 @@ let generate_conf oc project args = let ensure_root_dir ({ ml_includes; r_includes; q_includes; - v_files; ml_files; mli_files; ml4_files; mlg_files; + v_files; ml_files; mli_files; mlg_files; mllib_files; mlpack_files } as project) = let exists f = List.exists (forget_source > f) in @@ -294,7 +293,7 @@ let ensure_root_dir || exists (fun ({ canonical_path = x },_) -> is_prefix x here) r_includes || exists (fun ({ canonical_path = x },_) -> is_prefix x here) q_includes || (not_tops v_files && - not_tops mli_files && not_tops ml4_files && not_tops mlg_files && + not_tops mli_files && not_tops mlg_files && not_tops ml_files && not_tops mllib_files && not_tops mlpack_files) then project diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index 713b2ad2b6..db2031c64b 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -62,7 +62,7 @@ let basename_noext filename = (** ML Files specified on the command line. In the entries: - the first string is the basename of the file, without extension nor directory part - - the second string of [mlAccu] is the extension (either .ml or .ml4) + - the second string of [mlAccu] is the extension (either .ml or .mlg) - the [dir] part is the directory, with None used as the current directory *) @@ -496,9 +496,9 @@ let rec suffixes = function let add_caml_known phys_dir _ f = let basename,suff = - get_extension f [".ml";".mli";".ml4";".mlg";".mllib";".mlpack"] in + get_extension f [".ml";".mli";".mlg";".mllib";".mlpack"] in match suff with - | ".ml"|".ml4"|".mlg" -> add_ml_known basename (Some phys_dir) suff + | ".ml"|".mlg" -> add_ml_known basename (Some phys_dir) suff | ".mli" -> add_mli_known basename (Some phys_dir) suff | ".mllib" -> add_mllib_known basename (Some phys_dir) suff | ".mlpack" -> add_mlpack_known basename (Some phys_dir) suff @@ -584,12 +584,12 @@ let rec treat_file old_dirname old_name = in Array.iter (treat_file (Some newdirname)) (Sys.readdir complete_name)) | S_REG -> - (match get_extension name [".v";".ml";".mli";".ml4";".mlg";".mllib";".mlpack"] with + (match get_extension name [".v";".ml";".mli";".mlg";".mllib";".mlpack"] with | (base,".v") -> let name = file_name base dirname and absname = absolute_file_name base dirname in addQueue vAccu (name, absname) - | (base,(".ml"|".ml4"|".mlg" as ext)) -> addQueue mlAccu (base,ext,dirname) + | (base,(".ml"|".mlg" as ext)) -> addQueue mlAccu (base,ext,dirname) | (base,".mli") -> addQueue mliAccu (base,dirname) | (base,".mllib") -> addQueue mllibAccu (base,dirname) | (base,".mlpack") -> addQueue mlpackAccu (base,dirname) diff --git a/tools/ocamllibdep.mll b/tools/ocamllibdep.mll index 155296362f..680c8f30ae 100644 --- a/tools/ocamllibdep.mll +++ b/tools/ocamllibdep.mll @@ -145,9 +145,9 @@ let mllibAccu = ref ([] : (string * dir) list) let mlpackAccu = ref ([] : (string * dir) list) let add_caml_known phys_dir f = - let basename,suff = get_extension f [".ml";".ml4";".mlg";".mlpack"] in + let basename,suff = get_extension f [".ml";".mlg";".mlpack"] in match suff with - | ".ml"|".ml4"|".mlg" -> add_ml_known basename (Some phys_dir) suff + | ".ml"|".mlg" -> add_ml_known basename (Some phys_dir) suff | ".mlpack" -> add_mlpack_known basename (Some phys_dir) suff | _ -> () diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml new file mode 100644 index 0000000000..b248b87880 --- /dev/null +++ b/toplevel/ccompile.ml @@ -0,0 +1,225 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open Coqargs + +let fatal_error msg = + Topfmt.std_logger Feedback.Error msg; + flush_all (); + exit 1 + +(******************************************************************************) +(* Interactive Load File Simulation *) +(******************************************************************************) +let load_vernacular opts ~state = + List.fold_left + (fun state (f_in, echo) -> + let s = Loadpath.locate_file f_in in + (* Should make the beautify logic clearer *) + let load_vernac f = Vernac.load_vernac ~echo ~interactive:false ~check:true ~state f in + if !Flags.beautify + then Flags.with_option Flags.beautify_file load_vernac f_in + else load_vernac s + ) state (List.rev opts.load_vernacular_list) + +let load_init_vernaculars opts ~state = + let state = + if opts.load_rcfile then + Topfmt.(in_phase ~phase:LoadingRcFile) (fun () -> + Coqinit.load_rcfile ~rcfile:opts.rcfile ~state) () + else begin + Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading."); + state + end in + + load_vernacular opts ~state + +(******************************************************************************) +(* File Compilation *) +(******************************************************************************) +let warn_file_no_extension = + CWarnings.create ~name:"file-no-extension" ~category:"filesystem" + (fun (f,ext) -> + str "File \"" ++ str f ++ + strbrk "\" has been implicitly expanded to \"" ++ + str f ++ str ext ++ str "\"") + +let ensure_ext ext f = + if Filename.check_suffix f ext then f + else begin + warn_file_no_extension (f,ext); + f ^ ext + end + +let chop_extension f = + try Filename.chop_extension f with _ -> f + +let ensure_bname src tgt = + let src, tgt = Filename.basename src, Filename.basename tgt in + let src, tgt = chop_extension src, chop_extension tgt in + if src <> tgt then + fatal_error (str "Source and target file names must coincide, directories can differ" ++ fnl () ++ + str "Source: " ++ str src ++ fnl () ++ + str "Target: " ++ str tgt) + +let ensure ext src tgt = ensure_bname src tgt; ensure_ext ext tgt + +let ensure_v v = ensure ".v" v v +let ensure_vo v vo = ensure ".vo" v vo +let ensure_vio v vio = ensure ".vio" v vio + +let ensure_exists f = + if not (Sys.file_exists f) then + fatal_error (hov 0 (str "Can't find file" ++ spc () ++ str f)) + +(* Compile a vernac file *) +let compile opts ~echo ~f_in ~f_out = + let open Vernac.State in + let check_pending_proofs () = + let pfs = Proof_global.get_all_proof_names () in + if not (CList.is_empty pfs) then + fatal_error (str "There are pending proofs: " + ++ (pfs + |> List.rev + |> prlist_with_sep pr_comma Names.Id.print) + ++ str ".") + in + let iload_path = build_load_path opts in + let require_libs = require_libs opts in + let stm_options = opts.stm_flags in + match opts.compilation_mode with + | BuildVo -> + Flags.record_aux_file := true; + let long_f_dot_v = ensure_v f_in in + ensure_exists long_f_dot_v; + let long_f_dot_vo = + match f_out with + | None -> long_f_dot_v ^ "o" + | Some f -> ensure_vo long_f_dot_v f in + + let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) + Stm.new_doc + Stm.{ doc_type = VoDoc long_f_dot_vo; + iload_path; require_libs; stm_options; + } in + let state = { doc; sid; proof = None; time = opts.time } in + let state = load_init_vernaculars opts ~state in + let ldir = Stm.get_ldir ~doc:state.doc in + Aux_file.(start_aux_file + ~aux_file:(aux_file_name_for long_f_dot_vo) + ~v_file:long_f_dot_v); + Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo; + Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n"); + let wall_clock1 = Unix.gettimeofday () in + let check = Stm.AsyncOpts.(stm_options.async_proofs_mode = APoff) in + let state = Vernac.load_vernac ~echo ~check ~interactive:false ~state long_f_dot_v in + let _doc = Stm.join ~doc:state.doc in + let wall_clock2 = Unix.gettimeofday () in + check_pending_proofs (); + Library.save_library_to ldir long_f_dot_vo (Global.opaque_tables ()); + Aux_file.record_in_aux_at "vo_compile_time" + (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); + Aux_file.stop_aux_file (); + Dumpglob.end_dump_glob () + + | BuildVio -> + Flags.record_aux_file := false; + Dumpglob.noglob (); + + let long_f_dot_v = ensure_v f_in in + ensure_exists long_f_dot_v; + + let long_f_dot_vio = + match f_out with + | None -> long_f_dot_v ^ "io" + | Some f -> ensure_vio long_f_dot_v f in + + (* We need to disable error resiliency, otherwise some errors + will be ignored in batch mode. c.f. #6707 + + This is not necessary in the vo case as it fully checks the + document anyways. *) + let stm_options = let open Stm.AsyncOpts in + { stm_options with + async_proofs_mode = APon; + async_proofs_n_workers = 0; + async_proofs_cmd_error_resilience = false; + async_proofs_tac_error_resilience = `None; + } in + + let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) + Stm.new_doc + Stm.{ doc_type = VioDoc long_f_dot_vio; + iload_path; require_libs; stm_options; + } in + + let state = { doc; sid; proof = None; time = opts.time } in + let state = load_init_vernaculars opts ~state in + let ldir = Stm.get_ldir ~doc:state.doc in + let state = Vernac.load_vernac ~echo ~check:false ~interactive:false ~state long_f_dot_v in + let doc = Stm.finish ~doc:state.doc in + check_pending_proofs (); + let _doc = Stm.snapshot_vio ~doc ldir long_f_dot_vio in + Stm.reset_task_queue () + + | Vio2Vo -> + let open Filename in + Flags.record_aux_file := false; + Dumpglob.noglob (); + let f = if check_suffix f_in ".vio" then chop_extension f_in else f_in in + let lfdv, sum, lib, univs, disch, tasks, proofs = Library.load_library_todo f in + let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in + Library.save_library_raw lfdv sum lib univs proofs + +let compile opts ~echo ~f_in ~f_out = + ignore(CoqworkmgrApi.get 1); + compile opts ~echo ~f_in ~f_out; + CoqworkmgrApi.giveback 1 + +let compile_file opts (f_in, echo) = + let f_out = opts.compilation_output_name in + if !Flags.beautify then + Flags.with_option Flags.beautify_file + (fun f_in -> compile opts ~echo ~f_in ~f_out) f_in + else + compile opts ~echo ~f_in ~f_out + +let compile_files opts = + let compile_list = List.rev opts.compile_list in + List.iter (compile_file opts) compile_list + +(******************************************************************************) +(* VIO Dispatching *) +(******************************************************************************) +let check_vio_tasks opts = + let rc = + List.fold_left (fun acc t -> Vio_checking.check_vio t && acc) + true (List.rev opts.vio_tasks) in + if not rc then fatal_error Pp.(str "VIO Task Check failed") + +(* vio files *) +let schedule_vio opts = + if opts.vio_checking then + Vio_checking.schedule_vio_checking opts.vio_files_j opts.vio_files + else + Vio_checking.schedule_vio_compilation opts.vio_files_j opts.vio_files + +let do_vio opts = + (* We must initialize the loadpath here as the vio scheduling + process happens outside of the STM *) + if opts.vio_files <> [] || opts.vio_tasks <> [] then + let iload_path = build_load_path opts in + List.iter Mltop.add_coq_path iload_path; + + (* Vio compile pass *) + if opts.vio_files <> [] then schedule_vio opts; + (* Vio task pass *) + if opts.vio_tasks <> [] then check_vio_tasks opts diff --git a/toplevel/ccompile.mli b/toplevel/ccompile.mli new file mode 100644 index 0000000000..757c91c408 --- /dev/null +++ b/toplevel/ccompile.mli @@ -0,0 +1,19 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** [load_init_vernaculars opts ~state] Load vernaculars from + the init (rc) file *) +val load_init_vernaculars : Coqargs.coq_cmdopts -> state:Vernac.State.t-> Vernac.State.t + +(** [compile_files opts] compile files specified in [opts] *) +val compile_files : Coqargs.coq_cmdopts -> unit + +(** [do_vio opts] process [.vio] files in [opts] *) +val do_vio : Coqargs.coq_cmdopts -> unit diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 7c28ef24d4..6c4ea9afa1 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -9,7 +9,7 @@ (************************************************************************) let fatal_error exn = - Topfmt.print_err_exn Topfmt.ParsingCommandLine exn; + Topfmt.(in_phase ~phase:ParsingCommandLine print_err_exn exn); let exit_code = if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 in exit exit_code @@ -40,8 +40,8 @@ type coq_cmdopts = { load_rcfile : bool; rcfile : string option; - ml_includes : string list; - vo_includes : (string * Names.DirPath.t * bool) list; + ml_includes : Mltop.coq_path list; + vo_includes : Mltop.coq_path list; vo_requires : (string * string option * bool option) list; (* None = No Import; Some false = Import; Some true = Export *) @@ -64,6 +64,7 @@ type coq_cmdopts = { color : color; impredicative_set : Declarations.set_predicativity; + indices_matter : bool; enable_VM : bool; enable_native_compiler : bool; stm_flags : Stm.AsyncOpts.stm_opt; @@ -90,7 +91,7 @@ type coq_cmdopts = { let default_toplevel = Names.(DirPath.make [Id.of_string "Top"]) -let init_args = { +let default_opts = { load_init = true; load_rcfile = true; @@ -118,6 +119,7 @@ let init_args = { color = `AUTO; impredicative_set = Declarations.PredicativeSet; + indices_matter = false; enable_VM = true; enable_native_compiler = Coq_config.native_compiler; stm_flags = Stm.AsyncOpts.default_opts; @@ -137,6 +139,8 @@ let init_args = { print_emacs = false; + (* Quiet / verbosity options should be here *) + inputstate = None; outputstate = None; } @@ -145,11 +149,14 @@ let init_args = { (* Functional arguments *) (******************************************************************************) let add_ml_include opts s = - { opts with ml_includes = s :: opts.ml_includes } + Mltop.{ opts with ml_includes = {recursive = false; path_spec = MlPath s} :: opts.ml_includes } -let add_vo_include opts d p implicit = - let p = Libnames.dirpath_of_string p in - { opts with vo_includes = (d, p, implicit) :: opts.vo_includes } +let add_vo_include opts unix_path coq_path implicit = + let open Mltop in + let coq_path = Libnames.dirpath_of_string coq_path in + { opts with vo_includes = { + recursive = true; + path_spec = VoPath { unix_path; coq_path; has_ml = AddNoML; implicit } } :: opts.vo_includes } let add_vo_require opts d p export = { opts with vo_requires = (d, p, export) :: opts.vo_requires } @@ -161,6 +168,7 @@ let add_compat_require opts v = | Flags.Current -> add_vo_require opts "Coq.Compat.Coq89" None (Some false) let set_batch_mode opts = + (* XXX: This should be in the argument record *) Flags.quiet := true; System.trust_file_cache := true; { opts with batch_mode = true } @@ -276,11 +284,6 @@ let get_cache opt = function | "force" -> Some Stm.AsyncOpts.Force | _ -> prerr_endline ("Error: force expected after "^opt); exit 1 -let get_identifier opt s = - try Names.Id.of_string s - with CErrors.UserError _ -> - prerr_endline ("Error: valid identifier expected after option "^opt); exit 1 - let is_not_dash_option = function | Some f when String.length f > 0 && f.[0] <> '-' -> true | _ -> false @@ -320,7 +323,7 @@ let usage batch = else Usage.print_usage_coqtop () (* Main parsing routine *) -let parse_args arglist : coq_cmdopts * string list = +let parse_args init_opts arglist : coq_cmdopts * string list = let args = ref arglist in let extras = ref [] in let rec parse oval = match !args with @@ -473,7 +476,9 @@ let parse_args arglist : coq_cmdopts * string list = add_load_vernacular oval true (next ()) |"-mangle-names" -> - Namegen.set_mangle_names_mode (get_identifier opt (next ())); oval + Goptions.set_bool_option_value ["Mangle"; "Names"] true; + Goptions.set_string_option_value ["Mangle"; "Names"; "Prefix"] (next ()); + oval |"-print-mod-uid" -> let s = String.concat " " (List.map get_native_name rem) in print_endline s; exit 0 @@ -538,10 +543,6 @@ let parse_args arglist : coq_cmdopts * string list = (* Options with zero arg *) |"-async-queries-always-delegate" |"-async-proofs-always-delegate" - |"-async-proofs-full" -> - { oval with stm_flags = { oval.stm_flags with - Stm.AsyncOpts.async_proofs_full = true; - }} |"-async-proofs-never-reopen-branch" -> { oval with stm_flags = { oval.stm_flags with Stm.AsyncOpts.async_proofs_never_reopen_branch = true @@ -565,7 +566,7 @@ let parse_args arglist : coq_cmdopts * string list = |"-filteropts" -> { oval with filter_opts = true } |"-impredicative-set" -> { oval with impredicative_set = Declarations.ImpredicativeSet } - |"-indices-matter" -> Indtypes.enforce_indices_matter (); oval + |"-indices-matter" -> { oval with indices_matter = true } |"-m"|"--memory" -> { oval with memory_stat = true } |"-noinit"|"-nois" -> { oval with load_init = false } |"-no-glob"|"-noglob" -> Dumpglob.noglob (); { oval with glob_opt = true } @@ -595,5 +596,21 @@ let parse_args arglist : coq_cmdopts * string list = parse noval in try - parse init_args + parse init_opts with any -> fatal_error any + +(******************************************************************************) +(* Startup LoadPath and Modules *) +(******************************************************************************) +(* prelude_data == From Coq Require Export Prelude. *) +let prelude_data = "Prelude", Some "Coq", Some false + +let require_libs opts = + if opts.load_init then prelude_data :: opts.vo_requires else opts.vo_requires + +let cmdline_load_path opts = + List.rev opts.vo_includes @ List.(rev opts.ml_includes) + +let build_load_path opts = + Coqinit.libs_init_load_path ~load_init:opts.load_init @ + cmdline_load_path opts diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index b709788dde..e645b0c126 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -19,8 +19,8 @@ type coq_cmdopts = { load_rcfile : bool; rcfile : string option; - ml_includes : string list; - vo_includes : (string * Names.DirPath.t * bool) list; + ml_includes : Mltop.coq_path list; + vo_includes : Mltop.coq_path list; vo_requires : (string * string option * bool option) list; (* Fuse these two? Currently, [batch_mode] is only used to @@ -43,6 +43,7 @@ type coq_cmdopts = { color : color; impredicative_set : Declarations.set_predicativity; + indices_matter : bool; enable_VM : bool; enable_native_compiler : bool; stm_flags : Stm.AsyncOpts.stm_opt; @@ -62,10 +63,18 @@ type coq_cmdopts = { print_emacs : bool; + (* Quiet / verbosity options should be here *) + inputstate : string option; outputstate : string option; } -val parse_args : string list -> coq_cmdopts * string list +(* Default options *) +val default_opts : coq_cmdopts + +val parse_args : coq_cmdopts -> string list -> coq_cmdopts * string list val exitcode : coq_cmdopts -> int + +val require_libs : coq_cmdopts -> (string * string option * bool option) list +val build_load_path : coq_cmdopts -> Mltop.coq_path list diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 6d5f049176..5cf2157044 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -150,10 +150,11 @@ let print_highlight_location ib loc = let valid_buffer_loc ib loc = let (b,e) = Loc.unloc loc in b-ib.start >= 0 && e-ib.start < ib.len && b<=e + (* Toplevel error explanation. *) -let error_info_for_buffer ?loc phase buf = +let error_info_for_buffer ?loc buf = match loc with - | None -> Topfmt.pr_phase ?loc phase + | None -> Topfmt.pr_phase ?loc () | Some loc -> let fname = loc.Loc.fname in (* We are in the toplevel *) @@ -161,17 +162,17 @@ let error_info_for_buffer ?loc phase buf = | Loc.ToplevelInput -> let nloc = adjust_loc_buf buf loc in if valid_buffer_loc buf loc then - match Topfmt.pr_phase ~loc:nloc phase with + match Topfmt.pr_phase ~loc:nloc () with | None -> None | Some hd -> Some (hd ++ fnl () ++ print_highlight_location buf nloc) (* in the toplevel, but not a valid buffer *) - else Topfmt.pr_phase ~loc phase + else Topfmt.pr_phase ~loc () (* we are in batch mode, don't adjust location *) - | Loc.InFile _ -> Topfmt.pr_phase ~loc phase + | Loc.InFile _ -> Topfmt.pr_phase ~loc () (* Actual printing routine *) -let print_error_for_buffer ?loc phase lvl msg buf = - let pre_hdr = error_info_for_buffer ?loc phase buf in +let print_error_for_buffer ?loc lvl msg buf = + let pre_hdr = error_info_for_buffer ?loc buf in if !print_emacs then Topfmt.emacs_logger ?pre_hdr lvl msg else Topfmt.std_logger ?pre_hdr lvl msg @@ -245,7 +246,7 @@ let parse_to_dot = | Tok.EOI -> raise Stm.End_of_input | _ -> dot st in - Pcoq.Gram.Entry.of_parser "Coqtoplevel.dot" dot + Pcoq.Entry.of_parser "Coqtoplevel.dot" dot (* If an error occurred while parsing, we try to read the input until a dot token is encountered. @@ -281,7 +282,7 @@ let extract_default_loc loc doc_id sid : Loc.t option = with _ -> loc (** Coqloop Console feedback handler *) -let coqloop_feed phase (fb : Feedback.feedback) = let open Feedback in +let coqloop_feed (fb : Feedback.feedback) = let open Feedback in match fb.contents with | Processed -> () | Incomplete -> () @@ -300,9 +301,9 @@ let coqloop_feed phase (fb : Feedback.feedback) = let open Feedback in (* TopErr.print_error_for_buffer ?loc lvl msg top_buffer *) | Message (Warning,loc,msg) -> let loc = extract_default_loc loc fb.doc_id fb.span_id in - TopErr.print_error_for_buffer ?loc phase Warning msg top_buffer + TopErr.print_error_for_buffer ?loc Warning msg top_buffer | Message (lvl,loc,msg) -> - TopErr.print_error_for_buffer ?loc phase lvl msg top_buffer + TopErr.print_error_for_buffer ?loc lvl msg top_buffer (** Main coq loop : read vernacular expressions until Drop is entered. Ctrl-C is handled internally as Sys.Break instead of aborting Coq. @@ -362,7 +363,7 @@ let top_goal_print ~doc c oldp newp = let (e, info) = CErrors.push exn in let loc = Loc.get_loc info in let msg = CErrors.iprint (e, info) in - TopErr.print_error_for_buffer ?loc Topfmt.InteractiveLoop Feedback.Error msg top_buffer + TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer (* Careful to keep this loop tail-rec *) let rec vernac_loop ~state = @@ -404,7 +405,7 @@ let rec vernac_loop ~state = let (e, info) = CErrors.push any in let loc = Loc.get_loc info in let msg = CErrors.iprint (e, info) in - TopErr.print_error_for_buffer ?loc Topfmt.InteractiveLoop Feedback.Error msg top_buffer; + TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer; vernac_loop ~state let rec loop ~state = @@ -430,7 +431,7 @@ let loop ~opts ~state = let open Coqargs in print_emacs := opts.print_emacs; (* We initialize the console only if we run the toploop_run *) - let tl_feed = Feedback.add_feeder (coqloop_feed Topfmt.InteractiveLoop) in + let tl_feed = Feedback.add_feeder coqloop_feed in if Dumpglob.dump () then begin Flags.if_verbose warning "Dumpglob cannot be used in interactive mode."; Dumpglob.noglob () diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index b11f13d3cb..7d03484412 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -27,7 +27,7 @@ val top_buffer : input_buffer val set_prompt : (unit -> string) -> unit (** Toplevel feedback printer. *) -val coqloop_feed : Topfmt.execution_phase -> Feedback.feedback -> unit +val coqloop_feed : Feedback.feedback -> unit (** Last document seen after `Drop` *) val drop_last_doc : Vernac.State.t option ref diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 66469ff0b9..edef741ca6 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -30,15 +30,6 @@ let print_header () = Feedback.msg_notice (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); flush_all () -(* Feedback received in the init stage, this is different as the STM - will not be generally be initialized, thus stateid, etc... may be - bogus. For now we just print to the console too *) -let coqtop_init_feed = Coqloop.coqloop_feed Topfmt.Initialization - -let coqtop_doc_feed = Coqloop.coqloop_feed Topfmt.LoadingPrelude - -let coqtop_rcfile_feed = Coqloop.coqloop_feed Topfmt.LoadingRcFile - let memory_stat = ref false let print_memory_stat () = begin (* -m|--memory from the command-line *) @@ -73,74 +64,13 @@ let outputstate opts = States.extern_state fname) opts.outputstate (******************************************************************************) -(* Interactive Load File Simulation *) -(******************************************************************************) -let load_vernacular opts ~state = - List.fold_left - (fun state (f_in, echo) -> - let s = Loadpath.locate_file f_in in - (* Should make the beautify logic clearer *) - let load_vernac f = Vernac.load_vernac ~echo ~interactive:false ~check:true ~state f in - if !Flags.beautify - then Flags.with_option Flags.beautify_file load_vernac f_in - else load_vernac s - ) state (List.rev opts.load_vernacular_list) - -let load_init_vernaculars cur_feeder opts ~state = - let state = - if opts.load_rcfile then begin - Feedback.del_feeder !cur_feeder; - let rc_feeder = Feedback.add_feeder coqtop_rcfile_feed in - let state = Coqinit.load_rcfile ~rcfile:opts.rcfile ~state in - Feedback.del_feeder rc_feeder; - cur_feeder := Feedback.add_feeder coqtop_init_feed; - state - end - else begin - Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading."); - state - end in - - load_vernacular opts ~state - -(******************************************************************************) -(* Startup LoadPath and Modules *) -(******************************************************************************) -(* prelude_data == From Coq Require Export Prelude. *) -let prelude_data = "Prelude", Some "Coq", Some false - -let require_libs opts = - if opts.load_init then prelude_data :: opts.vo_requires else opts.vo_requires - -let cmdline_load_path opts = - let open Mltop in - (* loadpaths given by options -Q and -R *) - List.map - (fun (unix_path, coq_path, implicit) -> - { recursive = true; - path_spec = VoPath { unix_path; coq_path; has_ml = Mltop.AddNoML; implicit } }) - (List.rev opts.vo_includes) @ - - (* additional ml directories, given with option -I *) - List.map (fun s -> {recursive = false; path_spec = MlPath s}) (List.rev opts.ml_includes) - -let build_load_path opts = - Coqinit.libs_init_load_path ~load_init:opts.load_init @ - cmdline_load_path opts - -(******************************************************************************) (* Fatal Errors *) (******************************************************************************) (** Prints info which is either an error or an anomaly and then exits with the appropriate error code *) -let fatal_error msg = - Topfmt.std_logger Feedback.Error msg; - flush_all (); - exit 1 - let fatal_error_exn exn = - Topfmt.print_err_exn Topfmt.Initialization exn; + Topfmt.(in_phase ~phase:Initialization print_err_exn exn); flush_all (); let exit_code = if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 @@ -148,195 +78,6 @@ let fatal_error_exn exn = exit exit_code (******************************************************************************) -(* File Compilation *) -(******************************************************************************) -let warn_file_no_extension = - CWarnings.create ~name:"file-no-extension" ~category:"filesystem" - (fun (f,ext) -> - str "File \"" ++ str f ++ - strbrk "\" has been implicitly expanded to \"" ++ - str f ++ str ext ++ str "\"") - -let ensure_ext ext f = - if Filename.check_suffix f ext then f - else begin - warn_file_no_extension (f,ext); - f ^ ext - end - -let chop_extension f = - try Filename.chop_extension f with _ -> f - -let ensure_bname src tgt = - let src, tgt = Filename.basename src, Filename.basename tgt in - let src, tgt = chop_extension src, chop_extension tgt in - if src <> tgt then - fatal_error (str "Source and target file names must coincide, directories can differ" ++ fnl () ++ - str "Source: " ++ str src ++ fnl () ++ - str "Target: " ++ str tgt) - -let ensure ext src tgt = ensure_bname src tgt; ensure_ext ext tgt - -let ensure_v v = ensure ".v" v v -let ensure_vo v vo = ensure ".vo" v vo -let ensure_vio v vio = ensure ".vio" v vio - -let ensure_exists f = - if not (Sys.file_exists f) then - fatal_error (hov 0 (str "Can't find file" ++ spc () ++ str f)) - -(* Compile a vernac file *) -let compile cur_feeder opts ~echo ~f_in ~f_out = - let open Vernac.State in - let check_pending_proofs () = - let pfs = Proof_global.get_all_proof_names () in - if not (CList.is_empty pfs) then - fatal_error (str "There are pending proofs: " - ++ (pfs - |> List.rev - |> prlist_with_sep pr_comma Names.Id.print) - ++ str ".") - in - let iload_path = build_load_path opts in - let require_libs = require_libs opts in - let stm_options = opts.stm_flags in - match opts.compilation_mode with - | BuildVo -> - Flags.record_aux_file := true; - let long_f_dot_v = ensure_v f_in in - ensure_exists long_f_dot_v; - let long_f_dot_vo = - match f_out with - | None -> long_f_dot_v ^ "o" - | Some f -> ensure_vo long_f_dot_v f in - - Feedback.del_feeder !cur_feeder; - let doc_feeder = Feedback.add_feeder coqtop_doc_feed in - let doc, sid = - Stm.(new_doc - { doc_type = VoDoc long_f_dot_vo; - iload_path; require_libs; stm_options; - }) in - Feedback.del_feeder doc_feeder; - cur_feeder := Feedback.add_feeder coqtop_init_feed; - - let state = { doc; sid; proof = None; time = opts.time } in - let state = load_init_vernaculars cur_feeder opts ~state in - let ldir = Stm.get_ldir ~doc:state.doc in - Aux_file.(start_aux_file - ~aux_file:(aux_file_name_for long_f_dot_vo) - ~v_file:long_f_dot_v); - Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo; - Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n"); - let wall_clock1 = Unix.gettimeofday () in - let state = Vernac.load_vernac ~echo ~check:true ~interactive:false ~state long_f_dot_v in - let _doc = Stm.join ~doc:state.doc in - let wall_clock2 = Unix.gettimeofday () in - check_pending_proofs (); - Library.save_library_to ldir long_f_dot_vo (Global.opaque_tables ()); - Aux_file.record_in_aux_at "vo_compile_time" - (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); - Aux_file.stop_aux_file (); - Dumpglob.end_dump_glob () - - | BuildVio -> - Flags.record_aux_file := false; - Dumpglob.noglob (); - - let long_f_dot_v = ensure_v f_in in - ensure_exists long_f_dot_v; - - let long_f_dot_vio = - match f_out with - | None -> long_f_dot_v ^ "io" - | Some f -> ensure_vio long_f_dot_v f in - - (* We need to disable error resiliency, otherwise some errors - will be ignored in batch mode. c.f. #6707 - - This is not necessary in the vo case as it fully checks the - document anyways. *) - let stm_options = let open Stm.AsyncOpts in - { stm_options with - async_proofs_cmd_error_resilience = false; - async_proofs_tac_error_resilience = `None; - } in - - Feedback.del_feeder !cur_feeder; - let doc_feeder = Feedback.add_feeder coqtop_doc_feed in - let doc, sid = - Stm.(new_doc - { doc_type = VioDoc long_f_dot_vio; - iload_path; require_libs; stm_options; - }) in - Feedback.del_feeder doc_feeder; - cur_feeder := Feedback.add_feeder coqtop_init_feed; - - let state = { doc; sid; proof = None; time = opts.time } in - let state = load_init_vernaculars cur_feeder opts ~state in - let ldir = Stm.get_ldir ~doc:state.doc in - let state = Vernac.load_vernac ~echo ~check:false ~interactive:false ~state long_f_dot_v in - let doc = Stm.finish ~doc:state.doc in - check_pending_proofs (); - let _doc = Stm.snapshot_vio ~doc ldir long_f_dot_vio in - Stm.reset_task_queue () - - | Vio2Vo -> - let open Filename in - Flags.record_aux_file := false; - Dumpglob.noglob (); - let f = if check_suffix f_in ".vio" then chop_extension f_in else f_in in - let lfdv, sum, lib, univs, disch, tasks, proofs = Library.load_library_todo f in - let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in - Library.save_library_raw lfdv sum lib univs proofs - -let compile cur_feeder opts ~echo ~f_in ~f_out = - ignore(CoqworkmgrApi.get 1); - compile cur_feeder opts ~echo ~f_in ~f_out; - CoqworkmgrApi.giveback 1 - -let compile_file cur_feeder opts (f_in, echo) = - let f_out = opts.compilation_output_name in - if !Flags.beautify then - Flags.with_option Flags.beautify_file - (fun f_in -> compile cur_feeder opts ~echo ~f_in ~f_out) f_in - else - compile cur_feeder opts ~echo ~f_in ~f_out - -let compile_files cur_feeder opts = - let compile_list = List.rev opts.compile_list in - List.iter (compile_file cur_feeder opts) compile_list - -(******************************************************************************) -(* VIO Dispatching *) -(******************************************************************************) -let check_vio_tasks opts = - let rc = - List.fold_left (fun acc t -> Vio_checking.check_vio t && acc) - true (List.rev opts.vio_tasks) in - if not rc then fatal_error Pp.(str "VIO Task Check failed") - -(* vio files *) -let schedule_vio opts = - if opts.vio_checking then - Vio_checking.schedule_vio_checking opts.vio_files_j opts.vio_files - else - Vio_checking.schedule_vio_compilation opts.vio_files_j opts.vio_files - -let do_vio opts = - (* We must initialize the loadpath here as the vio scheduling - process happens outside of the STM *) - if opts.vio_files <> [] || opts.vio_tasks <> [] then - let iload_path = build_load_path opts in - List.iter Mltop.add_coq_path iload_path; - - (* Vio compile pass *) - if opts.vio_files <> [] then schedule_vio opts; - (* Vio task pass *) - if opts.vio_tasks <> [] then check_vio_tasks opts - - -(******************************************************************************) (* Color Options *) (******************************************************************************) let init_color opts = @@ -407,14 +148,15 @@ let init_gc () = Gc.space_overhead = 120} (** Main init routine *) -let init_toplevel custom_init arglist = +let init_toplevel init_opts custom_init arglist = (* Coq's init process, phase 1: OCaml parameters, basic structures, and IO *) CProfile.init_profile (); init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) - let init_feeder = ref (Feedback.add_feeder coqtop_init_feed) in + let init_feeder = Feedback.add_feeder Coqloop.coqloop_feed in + Lib.init(); (* Coq's init process, phase 2: @@ -422,7 +164,7 @@ let init_toplevel custom_init arglist = *) let res = begin try - let opts,extras = parse_args arglist in + let opts,extras = parse_args init_opts arglist in memory_stat := opts.memory_stat; (* If we have been spawned by the Spawn module, this has to be done @@ -456,6 +198,7 @@ let init_toplevel custom_init arglist = Flags.if_verbose print_header (); Mltop.init_known_plugins (); Global.set_engagement opts.impredicative_set; + Global.set_indices_matter opts.indices_matter; Global.set_VM opts.enable_VM; Global.set_native_compiler opts.enable_native_compiler; @@ -485,23 +228,19 @@ let init_toplevel custom_init arglist = let require_libs = require_libs opts in let stm_options = opts.stm_flags in let open Vernac.State in - Feedback.del_feeder !init_feeder; - let doc_feeder = Feedback.add_feeder coqtop_doc_feed in - let doc, sid = - Stm.(new_doc - { doc_type = Interactive opts.toplevel_name; - iload_path; require_libs; stm_options; - }) in - Feedback.del_feeder doc_feeder; - init_feeder := Feedback.add_feeder coqtop_init_feed; + let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) + Stm.new_doc + Stm.{ doc_type = Interactive opts.toplevel_name; + iload_path; require_libs; stm_options; + } in let state = { doc; sid; proof = None; time = opts.time } in - Some (load_init_vernaculars init_feeder opts ~state), opts + Some (Ccompile.load_init_vernaculars opts ~state), opts (* Non interactive: we perform a sequence of compilation steps *) end else begin - compile_files init_feeder opts; + Ccompile.compile_files opts; (* Careful this will modify the load-path and state so after this point some stuff may not be safe anymore. *) - do_vio opts; + Ccompile.do_vio opts; (* Allow the user to output an arbitrary state *) outputstate opts; None, opts @@ -510,23 +249,28 @@ let init_toplevel custom_init arglist = flush_all(); fatal_error_exn any end in - Feedback.del_feeder !init_feeder; + Feedback.del_feeder init_feeder; res -type custom_toplevel = { - init : opts:coq_cmdopts -> string list -> coq_cmdopts * string list; - run : opts:coq_cmdopts -> state:Vernac.State.t -> unit; -} +type custom_toplevel = + { init : opts:coq_cmdopts -> string list -> coq_cmdopts * string list + ; run : opts:coq_cmdopts -> state:Vernac.State.t -> unit + ; opts : Coqargs.coq_cmdopts + } let coqtop_init ~opts extra = init_color opts; CoqworkmgrApi.(init !async_proofs_worker_priority); opts, extra -let coqtop_toplevel = { init = coqtop_init; run = Coqloop.loop; } +let coqtop_toplevel = + { init = coqtop_init + ; run = Coqloop.loop + ; opts = Coqargs.default_opts + } let start_coq custom = - match init_toplevel custom.init (List.tl (Array.to_list Sys.argv)) with + match init_toplevel custom.opts custom.init (List.tl (Array.to_list Sys.argv)) with (* Batch mode *) | Some state, opts when not opts.batch_mode -> custom.run ~opts ~state; diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index 641448f10a..c95d0aca55 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -12,10 +12,13 @@ [init] is used to do custom command line argument parsing. [run] launches a custom toplevel. *) -type custom_toplevel = { - init : opts:Coqargs.coq_cmdopts -> string list -> Coqargs.coq_cmdopts * string list; - run : opts:Coqargs.coq_cmdopts -> state:Vernac.State.t -> unit; -} +open Coqargs + +type custom_toplevel = + { init : opts:coq_cmdopts -> string list -> coq_cmdopts * string list + ; run : opts:coq_cmdopts -> state:Vernac.State.t -> unit + ; opts : Coqargs.coq_cmdopts + } val coqtop_toplevel : custom_toplevel diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib index 597173e5f5..732744eb42 100644 --- a/toplevel/toplevel.mllib +++ b/toplevel/toplevel.mllib @@ -4,5 +4,6 @@ Coqinit Coqargs G_toplevel Coqloop +Ccompile Coqtop WorkerLoop diff --git a/toplevel/workerLoop.ml b/toplevel/workerLoop.ml index ee6d5e8843..e4e9a87365 100644 --- a/toplevel/workerLoop.ml +++ b/toplevel/workerLoop.ml @@ -23,6 +23,7 @@ let arg_init init ~opts extra_args = let start ~init ~loop = let open Coqtop in let custom = { + opts = Coqargs.default_opts; init = arg_init init; run = (fun ~opts:_ ~state:_ -> loop ()); } in diff --git a/vernac/attributes.ml b/vernac/attributes.ml index bc0b0310b3..4f238f38e6 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -78,14 +78,6 @@ type deprecation = { since : string option ; note : string option } let mk_deprecation ?(since=None) ?(note=None) () = { since ; note } -type t = { - locality : bool option; - polymorphic : bool; - template : bool option; - program : bool; - deprecated : deprecation option; -} - let assert_empty k v = if v <> VernacFlagEmpty then user_err Pp.(str "Attribute " ++ str k ++ str " does not accept arguments") @@ -162,7 +154,7 @@ let universe_transform ~warn_unqualified : unit attribute = let universe_polymorphism_option_name = ["Universe"; "Polymorphism"] let is_universe_polymorphism = let b = ref false in - let _ = let open Goptions in + let () = let open Goptions in declare_bool_option { optdepr = false; optname = "universe polymorphism"; @@ -181,10 +173,9 @@ let polymorphic_nowarn = universe_transform ~warn_unqualified:false >> qualify_attribute ukey polymorphic_base -let universe_poly_template = - let template = bool_attribute ~name:"Template" ~on:"template" ~off:"notemplate" in +let template = universe_transform ~warn_unqualified:true >> - qualify_attribute ukey (polymorphic_base ++ template) + qualify_attribute ukey (bool_attribute ~name:"Template" ~on:"template" ~off:"notemplate") let polymorphic = universe_transform ~warn_unqualified:true >> @@ -207,12 +198,6 @@ let deprecation_parser : deprecation key_parser = fun orig args -> let deprecation = attribute_of_list ["deprecated",deprecation_parser] -let attributes_of_flags f = - let ((locality, deprecated), (polymorphic, template)), program = - parse (locality ++ deprecation ++ universe_poly_template ++ program) f - in - { polymorphic; program; locality; template; deprecated } - let only_locality atts = parse locality atts let only_polymorphism atts = parse polymorphic atts diff --git a/vernac/attributes.mli b/vernac/attributes.mli index c2dde4cbcc..6a32960a9d 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -49,28 +49,13 @@ val mk_deprecation : ?since: string option -> ?note: string option -> unit -> de val polymorphic : bool attribute val program : bool attribute -val universe_poly_template : (bool * bool option) attribute +val template : bool option attribute val locality : bool option attribute val deprecation : deprecation option attribute val program_opt : bool option attribute (** For internal use when messing with the global option. *) -type t = { - locality : bool option; - polymorphic : bool; - template : bool option; - program : bool; - deprecated : deprecation option; -} -(** Some attributes gathered in a adhoc record. Will probably be - removed at some point. *) - -val attributes_of_flags : vernac_flags -> t -(** Parse the attributes supported by type [t]. Errors on other - attributes. Polymorphism and Program use the global flags as - default values. *) - val only_locality : vernac_flags -> bool option (** Parse attributes allowing only locality. *) diff --git a/vernac/classes.ml b/vernac/classes.ml index 95e46b252b..d0cf1c6bee 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -30,13 +30,13 @@ open Entries let refine_instance = ref true -let _ = Goptions.declare_bool_option { - Goptions.optdepr = false; - Goptions.optname = "definition of instances by refining"; - Goptions.optkey = ["Refine";"Instance";"Mode"]; - Goptions.optread = (fun () -> !refine_instance); - Goptions.optwrite = (fun b -> refine_instance := b) -} +let () = Goptions.(declare_bool_option { + optdepr = false; + optname = "definition of instances by refining"; + optkey = ["Refine";"Instance";"Mode"]; + optread = (fun () -> !refine_instance); + optwrite = (fun b -> refine_instance := b) +}) let typeclasses_db = "typeclass_instances" @@ -44,7 +44,7 @@ let set_typeclass_transparency c local b = Hints.add_hints ~local [typeclasses_db] (Hints.HintsTransparencyEntry (Hints.HintsReferences [c], b)) -let _ = +let () = Hook.set Typeclasses.add_instance_hint_hook (fun inst path local info poly -> let inst' = match inst with IsConstr c -> Hints.IsConstr (EConstr.of_constr c, Univ.ContextSet.empty) @@ -163,10 +163,10 @@ let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id in obls, Some constr, typ | None -> [||], None, termtype in - let hook = Obligations.mk_univ_hook hook in + let univ_hook = Obligations.mk_univ_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,poly,Instance) ~univ_hook obls) else Flags.silently (fun () -> (* spiwack: it is hard to reorder the actions to do @@ -176,7 +176,7 @@ let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id let gls = List.rev (Evd.future_goals sigma) in let sigma = Evd.reset_future_goals sigma in Lemmas.start_proof id ~pl:decl kind sigma (EConstr.of_constr termtype) - (Lemmas.mk_hook + ~hook:(Lemmas.mk_hook (fun _ -> instance_hook k pri global imps ?hook)); (* spiwack: I don't know what to do with the status here. *) if not (Option.is_empty term) then @@ -423,8 +423,7 @@ let context poly l = | Some b -> let decl = (Discharge, poly, Definition) in let entry = Declare.definition_entry ~univs ~types:t b in - let hook = Lemmas.mk_hook (fun _ _ -> ()) in - let _ = DeclareDef.declare_definition id decl entry UnivNames.empty_binders [] hook in + let _ = DeclareDef.declare_definition id decl entry UnivNames.empty_binders [] in Lib.sections_are_opened () || Lib.is_modtype_strict () in status && nstatus diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index ef28fc2d77..4b8371f5c3 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -26,7 +26,7 @@ open Entries let axiom_into_instance = ref false -let _ = +let () = let open Goptions in declare_bool_option { optdepr = true; @@ -156,7 +156,7 @@ let do_assumptions kind nl l = ((sigma,env,ienv),((is_coe,idl),t,imps))) (sigma,env,empty_internalization_env) l in - let sigma = solve_remaining_evars all_and_fail_flags env sigma (Evd.from_env env) in + let sigma = solve_remaining_evars all_and_fail_flags env sigma in (* The universe constraints come from the whole telescope. *) let sigma = Evd.minimize_universes sigma in let nf_evar c = EConstr.to_constr sigma c in diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 472411ac3a..79d45880fc 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -87,11 +87,10 @@ let interp_definition pl bl poly red_option c ctypopt = let check_definition (ce, evd, _, imps) = let env = Global.env () in - let empty_sigma = Evd.from_env env in - check_evars_are_solved env evd empty_sigma; + check_evars_are_solved env evd; ce -let do_definition ~program_mode ident k univdecl bl red_option c ctypopt hook = +let do_definition ~program_mode ?hook ident k univdecl bl red_option c ctypopt = let (ce, evd, univdecl, imps as def) = interp_definition univdecl bl (pi2 k) red_option c ctypopt in @@ -109,8 +108,8 @@ let do_definition ~program_mode ident k univdecl bl red_option c ctypopt hook = Obligations.eterm_obligations env ident evd 0 c typ in let ctx = Evd.evar_universe_context evd in - let hook = Obligations.mk_univ_hook (fun _ _ l r -> Lemmas.call_hook (fun x -> x) hook l r) in + let univ_hook = Obligations.mk_univ_hook (fun _ _ l r -> Lemmas.call_hook ?hook l r) in ignore(Obligations.add_definition - ident ~term:c cty ctx ~univdecl ~implicits:imps ~kind:k ~hook obls) + ident ~term:c cty ctx ~univdecl ~implicits:imps ~kind:k ~univ_hook obls) else let ce = check_definition def in - ignore(DeclareDef.declare_definition ident k ce (Evd.universe_binders evd) imps hook) + ignore(DeclareDef.declare_definition ident k ce (Evd.universe_binders evd) imps ?hook) diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 58007e6a88..0ac5762f71 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -17,9 +17,10 @@ open Constrexpr (** {6 Definitions/Let} *) val do_definition : program_mode:bool -> + ?hook:Lemmas.declaration_hook -> Id.t -> definition_kind -> universe_decl_expr option -> local_binder_expr list -> red_expr option -> constr_expr -> - constr_expr option -> Lemmas.declaration_hook -> unit + constr_expr option -> unit (************************************************************************) (** Internal API *) diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index a9c499b192..77227b64e6 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -239,7 +239,7 @@ let check_recursive isfix env evd (fixnames,fixdefs,_) = end let ground_fixpoint env evd (fixnames,fixdefs,fixtypes) = - check_evars_are_solved env evd (Evd.from_env env); + check_evars_are_solved env evd; let fixdefs = List.map (fun c -> Option.map EConstr.(to_constr evd) c) fixdefs in let fixtypes = List.map EConstr.(to_constr evd) fixtypes in Evd.evar_universe_context evd, (fixnames,fixdefs,fixtypes) @@ -261,7 +261,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind fixdefs) in let evd = Evd.from_ctx ctx in Lemmas.start_proof_with_initialization (local,poly,DefinitionBody Fixpoint) - evd pl (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) + evd pl (Some(false,indexes,init_tac)) thms None else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in @@ -296,7 +296,7 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n fixdefs) in let evd = Evd.from_ctx ctx in Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) - evd pl (Some(true,[],init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) + evd pl (Some(true,[],init_tac)) thms None else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index f405c4d5a9..8b9cf7d269 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -37,7 +37,7 @@ module RelDecl = Context.Rel.Declaration let should_auto_template = let open Goptions in let auto = ref true in - let _ = declare_bool_option + let () = declare_bool_option { optdepr = false; optname = "Automatically make some inductive types template polymorphic"; optkey = ["Auto";"Template";"Polymorphism"]; @@ -266,7 +266,7 @@ let inductive_levels env evd poly arities inds = in let minlev = (** Indices contribute. *) - if Indtypes.is_indices_matter () && List.length ctx > 0 then ( + if indices_matter env && List.length ctx > 0 then ( let ilev = sign_level env evd ctx in Univ.sup ilev minlev) else minlev @@ -402,7 +402,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let env_ar_params = EConstr.push_rel_context ctx_params env_ar in (* Try further to solve evars, and instantiate them *) - let sigma = solve_remaining_evars all_and_fail_flags env_params sigma (Evd.from_env env_params) in + let sigma = solve_remaining_evars all_and_fail_flags env_params sigma in (* Compute renewed arities *) let sigma = Evd.minimize_universes sigma in let nf = Evarutil.nf_evars_universes sigma in diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index ebedfb1e0d..e62ae99159 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -227,7 +227,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = in hook, recname, typ in (* XXX: Capturing sigma here... bad bad *) - let hook = Obligations.mk_univ_hook (hook sigma) in + let univ_hook = Obligations.mk_univ_hook (hook sigma) in (* XXX: Grounding non-ground terms here... bad bad *) let fullcoqc = EConstr.to_constr ~abort_on_undefined_evars:false sigma def in let fullctyp = EConstr.to_constr sigma typ in @@ -237,7 +237,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = in let ctx = Evd.evar_universe_context sigma in ignore(Obligations.add_definition recname ~term:evars_def ~univdecl:decl - evars_typ ctx evars ~hook) + evars_typ ctx evars ~univ_hook) let out_def = function | Some def -> def diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 2fe03a8ec5..898de7b166 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -33,7 +33,7 @@ let get_locality id ~kind = function | Local -> true | Global -> false -let declare_definition ident (local, p, k) ce pl imps hook = +let declare_definition ident (local, p, k) ?hook 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 () -> @@ -49,8 +49,28 @@ let declare_definition ident (local, p, k) ce pl imps hook = in let () = maybe_declare_manual_implicits false gr imps in let () = definition_message ident in - Lemmas.call_hook fix_exn hook local gr; gr + Lemmas.call_hook ~fix_exn ?hook local gr; gr let declare_fix ?(opaque = false) (_,poly,_ as kind) pl univs f ((def,_),eff) t imps = let ce = definition_entry ~opaque ~types:t ~univs ~eff def in - declare_definition f kind ce pl imps (Lemmas.mk_hook (fun _ _ -> ())) + declare_definition f kind ce pl imps + +let check_definition_evars ~allow_evars sigma = + let env = Global.env () in + if not allow_evars then Pretyping.check_evars_are_solved env sigma + +let prepare_definition ~allow_evars ?opaque ?inline ~poly sigma udecl ~types ~body = + check_definition_evars ~allow_evars sigma; + let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:(not allow_evars) + sigma (fun nf -> nf body, Option.map nf types) + in + let univs = Evd.check_univ_decl ~poly sigma udecl in + sigma, definition_entry ?opaque ?inline ?types ~univs body + +let prepare_parameter ~allow_evars ~poly sigma udecl typ = + check_definition_evars ~allow_evars sigma; + let sigma, typ = Evarutil.finalize ~abort_on_undefined_evars:(not allow_evars) + sigma (fun nf -> nf typ) + in + let univs = Evd.check_univ_decl ~poly sigma udecl in + sigma, (None(*proof using*), (typ, univs), None(*inline*)) diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index da11d4d9c0..1e3644c371 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -14,11 +14,22 @@ open Decl_kinds val get_locality : Id.t -> kind:string -> Decl_kinds.locality -> bool val declare_definition : Id.t -> definition_kind -> + ?hook:Lemmas.declaration_hook -> Safe_typing.private_constants Entries.definition_entry -> UnivNames.universe_binders -> Impargs.manual_implicits -> - Lemmas.declaration_hook -> GlobRef.t + GlobRef.t val declare_fix : ?opaque:bool -> definition_kind -> UnivNames.universe_binders -> Entries.constant_universes_entry -> Id.t -> Safe_typing.private_constants Entries.proof_output -> Constr.types -> Impargs.manual_implicits -> GlobRef.t + +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 + +val prepare_parameter : allow_evars:bool -> + poly:bool -> Evd.evar_map -> UState.universe_decl -> EConstr.types -> + Evd.evar_map * Entries.parameter_entry diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index 16101396cf..43abc0a200 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -33,24 +33,24 @@ open Pcoq let constr_level = string_of_int let default_levels = - [200,Extend.RightA,false; - 100,Extend.RightA,false; - 99,Extend.RightA,true; - 90,Extend.RightA,true; - 10,Extend.LeftA,false; - 9,Extend.RightA,false; - 8,Extend.RightA,true; - 1,Extend.LeftA,false; - 0,Extend.RightA,false] + [200,Gramlib.Gramext.RightA,false; + 100,Gramlib.Gramext.RightA,false; + 99,Gramlib.Gramext.RightA,true; + 90,Gramlib.Gramext.RightA,true; + 10,Gramlib.Gramext.LeftA,false; + 9,Gramlib.Gramext.RightA,false; + 8,Gramlib.Gramext.RightA,true; + 1,Gramlib.Gramext.LeftA,false; + 0,Gramlib.Gramext.RightA,false] let default_pattern_levels = - [200,Extend.RightA,true; - 100,Extend.RightA,false; - 99,Extend.RightA,true; - 90,Extend.RightA,true; - 10,Extend.LeftA,false; - 1,Extend.LeftA,false; - 0,Extend.RightA,false] + [200,Gramlib.Gramext.RightA,true; + 100,Gramlib.Gramext.RightA,false; + 99,Gramlib.Gramext.RightA,true; + 90,Gramlib.Gramext.RightA,true; + 10,Gramlib.Gramext.LeftA,false; + 1,Gramlib.Gramext.LeftA,false; + 0,Gramlib.Gramext.RightA,false] let default_constr_levels = (default_levels, default_pattern_levels) @@ -70,28 +70,28 @@ let save_levels levels custom lev = (* first LeftA, then RightA and NoneA together *) let admissible_assoc = function - | Extend.LeftA, Some (Extend.RightA | Extend.NonA) -> false - | Extend.RightA, Some Extend.LeftA -> false + | Gramlib.Gramext.LeftA, Some (Gramlib.Gramext.RightA | Gramlib.Gramext.NonA) -> false + | Gramlib.Gramext.RightA, Some Gramlib.Gramext.LeftA -> false | _ -> true let create_assoc = function - | None -> Extend.RightA + | None -> Gramlib.Gramext.RightA | Some a -> a let error_level_assoc p current expected = let open Pp in let pr_assoc = function - | Extend.LeftA -> str "left" - | Extend.RightA -> str "right" - | Extend.NonA -> str "non" in + | Gramlib.Gramext.LeftA -> str "left" + | Gramlib.Gramext.RightA -> str "right" + | Gramlib.Gramext.NonA -> str "non" in user_err (str "Level " ++ int p ++ str " is already declared " ++ pr_assoc current ++ str " associative while it is now expected to be " ++ pr_assoc expected ++ str " associative.") let create_pos = function - | None -> Extend.First - | Some lev -> Extend.After (constr_level lev) + | None -> Gramlib.Gramext.First + | Some lev -> Gramlib.Gramext.After (constr_level lev) let find_position_gen current ensure assoc lev = match lev with @@ -121,13 +121,13 @@ let find_position_gen current ensure assoc lev = updated, (Some (create_pos !after), Some assoc, Some (constr_level n), None) | _ -> (* The reinit flag has been updated *) - updated, (Some (Extend.Level (constr_level n)), None, None, !init) + updated, (Some (Gramlib.Gramext.Level (constr_level n)), None, None, !init) end with (* Nothing has changed *) Exit -> (* Just inherit the existing associativity and name (None) *) - current, (Some (Extend.Level (constr_level n)), None, None, None) + current, (Some (Gramlib.Gramext.Level (constr_level n)), None, None, None) let rec list_mem_assoc_triple x = function | [] -> false @@ -186,15 +186,18 @@ let find_position accu custom forpat assoc level = (* Binding constr entry keys to entries *) (* Camlp5 levels do not treat NonA: use RightA with a NEXT on the left *) -let camlp5_assoc = function - | Some NonA | Some RightA -> RightA - | None | Some LeftA -> LeftA - -let assoc_eq al ar = match al, ar with -| NonA, NonA -| RightA, RightA -| LeftA, LeftA -> true -| _, _ -> false +let camlp5_assoc = + let open Gramlib.Gramext in function + | Some NonA | Some RightA -> RightA + | None | Some LeftA -> LeftA + +let assoc_eq al ar = + let open Gramlib.Gramext in + match al, ar with + | NonA, NonA + | RightA, RightA + | LeftA, LeftA -> true + | _, _ -> false (* [adjust_level assoc from prod] where [assoc] and [from] are the name and associativity of the level where to add the rule; the meaning of @@ -204,7 +207,7 @@ let assoc_eq al ar = match al, ar with Some None = NEXT Some (Some (n,cur)) = constr LEVEL n s.t. if [cur] is set then [n] is the same as the [from] level *) -let adjust_level assoc from = function +let adjust_level assoc from = let open Gramlib.Gramext in function (* Associativity is None means force the level *) | (NumLevel n,BorderProd (_,None)) -> Some (Some (n,true)) (* Compute production name on the right side *) diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 3cdf81ced0..22528a607f 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -474,7 +474,7 @@ END { let only_starredidentrefs = - Gram.Entry.of_parser "test_only_starredidentrefs" + Pcoq.Entry.of_parser "test_only_starredidentrefs" (fun strm -> let rec aux n = match Util.stream_nth n strm with @@ -1175,9 +1175,9 @@ GRAMMAR EXTEND Gram | "in"; IDENT "custom"; x = IDENT -> { SetCustomEntry (x,None) } | "in"; IDENT "custom"; x = IDENT; "at"; IDENT "level"; n = natural -> { SetCustomEntry (x,Some n) } - | IDENT "left"; IDENT "associativity" -> { SetAssoc LeftA } - | IDENT "right"; IDENT "associativity" -> { SetAssoc RightA } - | IDENT "no"; IDENT "associativity" -> { SetAssoc NonA } + | IDENT "left"; IDENT "associativity" -> { SetAssoc Gramlib.Gramext.LeftA } + | IDENT "right"; IDENT "associativity" -> { SetAssoc Gramlib.Gramext.RightA } + | IDENT "no"; IDENT "associativity" -> { SetAssoc Gramlib.Gramext.NonA } | IDENT "only"; IDENT "printing" -> { SetOnlyPrinting } | IDENT "only"; IDENT "parsing" -> { SetOnlyParsing } | IDENT "compat"; s = STRING -> diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index c1343fb592..9bd095aa52 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -44,7 +44,7 @@ open Context.Rel.Declaration (* Flags governing automatic synthesis of schemes *) let elim_flag = ref true -let _ = +let () = declare_bool_option { optdepr = false; optname = "automatic declaration of induction schemes"; @@ -53,7 +53,7 @@ let _ = optwrite = (fun b -> elim_flag := b) } let bifinite_elim_flag = ref false -let _ = +let () = declare_bool_option { optdepr = false; optname = "automatic declaration of induction schemes for non-recursive types"; @@ -62,7 +62,7 @@ let _ = optwrite = (fun b -> bifinite_elim_flag := b) } let case_flag = ref false -let _ = +let () = declare_bool_option { optdepr = false; optname = "automatic declaration of case analysis schemes"; @@ -71,7 +71,7 @@ let _ = optwrite = (fun b -> case_flag := b) } let eq_flag = ref false -let _ = +let () = declare_bool_option { optdepr = false; optname = "automatic declaration of boolean equality"; @@ -82,7 +82,7 @@ let _ = let is_eq_flag () = !eq_flag let eq_dec_flag = ref false -let _ = +let () = declare_bool_option { optdepr = false; optname = "automatic declaration of decidable equality"; @@ -91,7 +91,7 @@ let _ = optwrite = (fun b -> eq_dec_flag := b) } let rewriting_flag = ref false -let _ = +let () = declare_bool_option { optdepr = false; optname ="automatic declaration of rewriting schemes for equality types"; diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index de020926f6..1a6eda446c 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -36,11 +36,12 @@ module NamedDecl = Context.Named.Declaration type declaration_hook = Decl_kinds.locality -> GlobRef.t -> unit let mk_hook hook = hook -let call_hook fix_exn hook l c = - try hook l c +let call_hook ?hook ?fix_exn l c = + try Option.iter (fun hook -> hook l c) hook with e when CErrors.noncritical e -> let e = CErrors.push e in - iraise (fix_exn e) + let e = Option.cata (fun fix -> fix e) e fix_exn in + iraise e (* Support for mutually proved theorems *) @@ -202,7 +203,7 @@ let save ?export_seff id const uctx do_guard (locality,poly,kind) hook = gr in definition_message id; - call_hook (fun exn -> exn) hook locality r + call_hook ?hook locality r with e when CErrors.noncritical e -> let e = CErrors.push e in iraise (fix_exn e) @@ -288,7 +289,7 @@ let warn_let_as_axiom = (fun id -> strbrk "Let definition" ++ spc () ++ Id.print id ++ spc () ++ strbrk "declared as an axiom.") -let admit (id,k,e) pl hook () = +let admit ?hook (id,k,e) pl () = let kn = declare_constant id (ParameterEntry e, IsAssumption Conjectural) in let () = match k with | Global, _, _ -> () @@ -296,32 +297,35 @@ let admit (id,k,e) pl hook () = in let () = assumption_message id in Declare.declare_univ_binders (ConstRef kn) pl; - call_hook (fun exn -> exn) hook Global (ConstRef kn) + call_hook ?hook Global (ConstRef kn) (* Starting a goal *) -let universe_proof_terminator compute_guard hook = +let universe_proof_terminator ?univ_hook compute_guard = let open Proof_global in make_terminator begin function | Admitted (id,k,pe,ctx) -> - admit (id,k,pe) (UState.universe_binders ctx) (hook (Some ctx)) (); - Feedback.feedback Feedback.AddedAxiom + let hook = Option.map (fun univ_hook -> univ_hook (Some ctx)) univ_hook in + admit ?hook (id,k,pe) (UState.universe_binders ctx) (); + Feedback.feedback Feedback.AddedAxiom | Proved (opaque,idopt, { id; entries=[const]; persistence; universes } ) -> let is_opaque, export_seff = match opaque with | Transparent -> false, true | Opaque -> true, false in - let const = {const with const_entry_opaque = is_opaque} in + assert (is_opaque == const.const_entry_opaque); let id = match idopt with | None -> id | Some { CAst.v = save_id } -> check_anonymity id save_id; save_id in - save ~export_seff id const universes compute_guard persistence (hook (Some universes)) + let hook = Option.map (fun univ_hook -> univ_hook (Some universes)) univ_hook in + save ~export_seff id const universes compute_guard persistence hook | Proved (opaque,idopt, _ ) -> CErrors.anomaly Pp.(str "[universe_proof_terminator] close_proof returned more than one proof term") end -let standard_proof_terminator compute_guard hook = - universe_proof_terminator compute_guard (fun _ -> hook) +let standard_proof_terminator ?hook compute_guard = + let univ_hook = Option.map (fun hook _ -> hook) hook in + universe_proof_terminator ?univ_hook compute_guard let initialize_named_context_for_proof () = let sign = Global.named_context () in @@ -331,10 +335,10 @@ let initialize_named_context_for_proof () = let d = if variable_opacity id then NamedDecl.LocalAssum (id, NamedDecl.get_type 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 c ?(compute_guard=[]) hook = +let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?hook c = let terminator = match terminator with - | None -> standard_proof_terminator compute_guard hook - | Some terminator -> terminator compute_guard hook + | None -> standard_proof_terminator ?hook compute_guard + | Some terminator -> terminator ?hook compute_guard in let sign = match sign with @@ -344,10 +348,11 @@ let start_proof id ?pl kind sigma ?terminator ?sign c ?(compute_guard=[]) hook = let goals = [ Global.env_of_context sign , c ] in Proof_global.start_proof sigma id ?pl kind goals terminator -let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?(compute_guard=[]) hook = +let start_proof_univs id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?univ_hook c = let terminator = match terminator with - | None -> universe_proof_terminator compute_guard hook - | Some terminator -> terminator compute_guard hook + | None -> + universe_proof_terminator ?univ_hook compute_guard + | Some terminator -> terminator ?univ_hook compute_guard in let sign = match sign with @@ -371,7 +376,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 kind sigma decl recguard thms snl hook = +let start_proof_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) -> @@ -405,14 +410,14 @@ let start_proof_with_initialization kind sigma decl recguard thms snl hook = let thms_data = (strength,ref,imps)::other_thms_data in List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; - call_hook (fun exn -> exn) hook strength ref) thms_data in - start_proof_univs id ~pl:decl kind sigma t (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard; + call_hook ?hook strength ref) thms_data in + start_proof_univs id ~pl:decl kind sigma t ~univ_hook:(fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard; ignore (Proof_global.with_current_proof (fun _ p -> match init_tac with | None -> p,(true,[]) | Some tac -> Proof.run_tactic Global.(env ()) tac p)) -let start_proof_com ?inference_hook kind thms hook = +let start_proof_com ?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 @@ -421,7 +426,7 @@ let start_proof_com ?inference_hook kind thms hook = let evd, (t', imps') = interp_type_evars_impls ~impls env evd t in let flags = all_and_fail_flags in let hook = inference_hook in - let evd = solve_remaining_evars ?hook flags env evd Evd.empty in + let evd = solve_remaining_evars ?hook flags env evd in let ids = List.map RelDecl.get_name ctx in check_name_freshness (pi1 kind) id; (* XXX: The nf_evar is critical !! *) @@ -444,13 +449,13 @@ let start_proof_com ?inference_hook kind thms hook = else (* We fix the variables to ensure they won't be lowered to Set *) Evd.fix_undefined_variables evd in - start_proof_with_initialization kind evd decl recguard thms snl hook + start_proof_with_initialization ?hook kind evd decl recguard thms snl (* Saving a proof *) let keep_admitted_vars = ref true -let _ = +let () = let open Goptions in declare_bool_option { optdepr = false; @@ -498,13 +503,13 @@ let save_proof ?proof = function Admitted(id,k,(sec_vars, (typ, ctx), None), universes) in Proof_global.apply_terminator (Proof_global.get_terminator ()) pe - | Vernacexpr.Proved (is_opaque,idopt) -> + | Vernacexpr.Proved (opaque,idopt) -> let (proof_obj,terminator) = match proof with | None -> - Proof_global.close_proof ~keep_body_ucst_separate:false (fun x -> x) + Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) | Some proof -> proof in (* if the proof is given explicitly, nothing has to be deleted *) if Option.is_empty proof then Proof_global.discard_current (); - Proof_global.(apply_terminator terminator (Proved (is_opaque,idopt,proof_obj))) + Proof_global.(apply_terminator terminator (Proved (opaque,idopt,proof_obj))) diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 246d8cbe6d..3ac12d3b0b 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -12,41 +12,45 @@ open Names open Decl_kinds type declaration_hook + val mk_hook : (Decl_kinds.locality -> GlobRef.t -> unit) -> declaration_hook -val call_hook : Future.fix_exn -> declaration_hook -> Decl_kinds.locality -> GlobRef.t -> unit +val call_hook : + ?hook:declaration_hook -> ?fix_exn:Future.fix_exn -> + Decl_kinds.locality -> GlobRef.t -> unit val start_proof : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> - ?terminator:(Proof_global.lemma_possible_guards -> declaration_hook -> Proof_global.proof_terminator) -> - ?sign:Environ.named_context_val -> EConstr.types -> + ?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 -> - declaration_hook -> unit + ?hook:declaration_hook -> EConstr.types -> unit val start_proof_univs : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> - ?terminator:(Proof_global.lemma_possible_guards -> (UState.t option -> declaration_hook) -> Proof_global.proof_terminator) -> - ?sign:Environ.named_context_val -> EConstr.types -> + ?terminator:(?univ_hook:(UState.t option -> declaration_hook) -> Proof_global.lemma_possible_guards -> Proof_global.proof_terminator) -> + ?sign:Environ.named_context_val -> ?compute_guard:Proof_global.lemma_possible_guards -> - (UState.t option -> declaration_hook) -> unit + ?univ_hook:(UState.t option -> declaration_hook) -> EConstr.types -> unit val start_proof_com : ?inference_hook:Pretyping.inference_hook -> - goal_kind -> Vernacexpr.proof_expr list -> - declaration_hook -> unit + ?hook:declaration_hook -> goal_kind -> Vernacexpr.proof_expr list -> + unit 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 -> declaration_hook -> unit + (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list -> + int list option -> unit val universe_proof_terminator : + ?univ_hook:(UState.t option -> declaration_hook) -> Proof_global.lemma_possible_guards -> - (UState.t option -> declaration_hook) -> - Proof_global.proof_terminator + Proof_global.proof_terminator val standard_proof_terminator : - Proof_global.lemma_possible_guards -> declaration_hook -> - Proof_global.proof_terminator + ?hook:declaration_hook -> Proof_global.lemma_possible_guards -> + Proof_global.proof_terminator val fresh_name_for_anonymous_theorem : unit -> Id.t diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 2e5e11bb09..82434afbbd 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -58,7 +58,7 @@ let pr_registered_grammar name = | None -> user_err Pp.(str "Unknown or unprintable grammar entry.") | Some entries -> let pr_one (Pcoq.AnyEntry e) = - str "Entry " ++ str (Pcoq.Gram.Entry.name e) ++ str " is" ++ fnl () ++ + str "Entry " ++ str (Pcoq.Entry.name e) ++ str " is" ++ fnl () ++ pr_entry e in prlist pr_one entries @@ -287,7 +287,7 @@ let pr_notation_entry = function | InConstrEntry -> str "constr" | InCustomEntry s -> str "custom " ++ str s -let prec_assoc = function +let prec_assoc = let open Gramlib.Gramext in function | RightA -> (L,E) | LeftA -> (E,L) | NonA -> (L,L) @@ -685,7 +685,7 @@ let border = function | (_,(ETConstr(_,_,(_,BorderProd (_,a))))) :: _ -> a | _ -> None -let recompute_assoc typs = +let recompute_assoc typs = let open Gramlib.Gramext in match border typs, border (List.rev typs) with | Some LeftA, Some RightA -> assert false | Some LeftA, _ -> Some LeftA @@ -802,7 +802,7 @@ let inSyntaxExtension : syntax_extension_obj -> obj = module NotationMods = struct type notation_modifier = { - assoc : gram_assoc option; + assoc : Gramlib.Gramext.g_assoc option; level : int option; custom : notation_entry; etyps : (Id.t * simple_constr_prod_entry_key) list; @@ -1230,7 +1230,7 @@ let compute_syntax_data local df modifiers = let onlyprint = mods.only_printing in let onlyparse = mods.only_parsing 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 NonA) in + let assoc = Option.append mods.assoc (Some Gramlib.Gramext.NonA) in let (recvars,mainvars,symbols) = analyze_notation_tokens ~onlyprint df in let _ = check_useless_entry_types recvars mainvars mods.etyps in let _ = check_binder_type recvars mods.etyps in diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 8baf391c70..f18227039f 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -22,11 +22,12 @@ open Util type univ_declaration_hook = UState.t -> (Id.t * constr) list -> Decl_kinds.locality -> GlobRef.t -> unit let mk_univ_hook f = f -let call_univ_hook fix_exn hook uctx trans l c = - try hook uctx trans l c +let call_univ_hook ?univ_hook ?fix_exn uctx trans l c = + try Option.iter (fun hook -> hook uctx trans l c) univ_hook with e when CErrors.noncritical e -> let e = CErrors.push e in - iraise (fix_exn e) + let e = Option.cata (fun fix -> fix e) e fix_exn in + iraise e module NamedDecl = Context.Named.Declaration @@ -320,7 +321,7 @@ type program_info_aux = { prg_notations : notations ; prg_kind : definition_kind; prg_reduce : constr -> constr; - prg_hook : univ_declaration_hook; + prg_hook : univ_declaration_hook option; prg_opaque : bool; prg_sign: named_context_val; } @@ -337,32 +338,20 @@ let assumption_message = Declare.assumption_message let default_tactic = ref (Proofview.tclUNIT ()) (* true = hide obligations *) -let hide_obligations = ref false +let get_hide_obligations = + Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"Hidding of Program obligations" + ~key:["Hide";"Obligations"] + ~value:false -let set_hide_obligations = (:=) hide_obligations -let get_hide_obligations () = !hide_obligations -open Goptions -let _ = - declare_bool_option - { optdepr = false; - optname = "Hiding of Program obligations"; - optkey = ["Hide";"Obligations"]; - optread = get_hide_obligations; - optwrite = set_hide_obligations; } - -let shrink_obligations = ref true - -let set_shrink_obligations = (:=) shrink_obligations -let get_shrink_obligations () = !shrink_obligations - -let _ = - declare_bool_option - { optdepr = true; (* remove in 8.8 *) - optname = "Shrinking of Program obligations"; - optkey = ["Shrink";"Obligations"]; - optread = get_shrink_obligations; - optwrite = set_shrink_obligations; } +let get_shrink_obligations = + Goptions.declare_bool_option_and_ref + ~depr:true (* remove in 8.8 *) + ~name:"Shrinking of Program obligations" + ~key:["Shrink";"Obligations"] + ~value:true let evar_of_obligation o = make_evar (Global.named_context_val ()) (EConstr.of_constr o.obl_type) @@ -493,9 +482,9 @@ let declare_definition prg = let ce = definition_entry ~fix_exn ~opaque ~types:typ ~univs body in let () = progmap_remove prg in let ubinders = UState.universe_binders uctx in + let hook = Lemmas.mk_hook (fun l r -> call_univ_hook ?univ_hook:prg.prg_hook ~fix_exn uctx obls l r; ()) in DeclareDef.declare_definition prg.prg_name - prg.prg_kind ce ubinders prg.prg_implicits - (Lemmas.mk_hook (fun l r -> call_univ_hook fix_exn prg.prg_hook uctx obls l r ; ())) + prg.prg_kind ce ubinders prg.prg_implicits ~hook let rec lam_index n t acc = match Constr.kind t with @@ -576,7 +565,7 @@ let declare_mutual_definition l = List.iter (Metasyntax.add_notation_interpretation (Global.env())) first.prg_notations; Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; let gr = List.hd kns in - call_univ_hook fix_exn first.prg_hook first.prg_ctx obls local gr; + call_univ_hook ?univ_hook:first.prg_hook ~fix_exn first.prg_ctx obls local gr; List.iter progmap_remove l; gr let decompose_lam_prod c ty = @@ -674,8 +663,8 @@ let declare_obligation prg obl body ty uctx = in true, { obl with obl_body = body } -let init_prog_info ?(opaque = false) sign n udecl b t ctx deps fixkind - notations obls impls kind reduce hook = +let init_prog_info ?(opaque = false) ?univ_hook sign n udecl b t ctx deps fixkind + notations obls impls kind reduce = let obls', b = match b with | None -> @@ -700,7 +689,7 @@ let init_prog_info ?(opaque = false) sign n udecl b t ctx deps fixkind prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; - prg_hook = hook; prg_opaque = opaque; + prg_hook = univ_hook; prg_opaque = opaque; prg_sign = sign } let map_cardinal m = @@ -855,9 +844,9 @@ let solve_by_tac ?loc name evi t poly ctx = warn_solve_errored ?loc err; None -let obligation_terminator name num guard hook auto pf = +let obligation_terminator ?univ_hook name num guard auto pf = let open Proof_global in - let term = Lemmas.universe_proof_terminator guard hook in + let term = Lemmas.universe_proof_terminator ?univ_hook guard in match pf with | Admitted _ -> apply_terminator term pf | Proved (opq, id, { entries=[entry]; universes=uctx } ) -> begin @@ -893,7 +882,7 @@ let obligation_terminator name num guard hook auto pf = let uctx = UState.const_univ_entry ~poly:(pi2 prg.prg_kind) ctx in let (defined, obl) = declare_obligation prg obl body ty uctx in let obls = Array.copy obls in - let _ = obls.(num) <- obl in + let () = obls.(num) <- obl in let prg_ctx = if pi2 (prg.prg_kind) then (* Polymorphic *) (** We merge the new universes and constraints of the @@ -949,7 +938,7 @@ in let obl = { obl with obl_body = Some (DefinedObl (cst, inst)) } in let () = if transparent then add_hint true prg cst in let obls = Array.copy obls in - let _ = obls.(num) <- obl in + let () = obls.(num) <- obl in let prg = { prg with prg_ctx = ctx' } in let () = try ignore (update_obls prg obls (pred rem)) @@ -980,11 +969,11 @@ let rec solve_obligation prg num tac = let evd = Evd.from_ctx prg.prg_ctx in let evd = Evd.update_sigma_env evd (Global.env ()) in let auto n tac oblset = auto_solve_obligations n ~oblset tac in - let terminator guard hook = + let terminator ?univ_hook guard = Proof_global.make_terminator - (obligation_terminator prg.prg_name num guard hook auto) in - let hook ctx = Lemmas.mk_hook (obligation_hook prg obl num auto ctx) in - let () = Lemmas.start_proof_univs ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator hook in + (obligation_terminator ?univ_hook prg.prg_name num guard auto) in + let univ_hook ctx = Lemmas.mk_hook (obligation_hook prg obl num auto ctx) in + let () = Lemmas.start_proof_univs ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator ~univ_hook in let _ = Pfedit.by !default_tactic in Option.iter (fun tac -> Proof_global.set_endline_tactic tac) tac @@ -1045,7 +1034,7 @@ and solve_prg_obligations prg ?oblset tac = (fun i -> Int.Set.mem i !set) in let prgref = ref prg in - let _ = + let () = Array.iteri (fun i x -> if p i then match solve_obligation_by_tac !prgref obls' i tac with @@ -1121,10 +1110,10 @@ let show_term n = let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic - ?(reduce=reduce) ?(hook=mk_univ_hook (fun _ _ _ _ -> ())) ?(opaque = false) obls = + ?(reduce=reduce) ?univ_hook ?(opaque = false) obls = let sign = Lemmas.initialize_named_context_for_proof () in let info = Id.print n ++ str " has type-checked" in - let prg = init_prog_info sign ~opaque n univdecl term t ctx [] None [] obls implicits kind reduce hook in + let prg = init_prog_info sign ~opaque n univdecl term t ctx [] None [] obls implicits kind reduce ?univ_hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose Feedback.msg_info (info ++ str "."); @@ -1132,7 +1121,7 @@ let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) Defined cst) else ( let len = Array.length obls in - let _ = Flags.if_verbose Feedback.msg_info (info ++ str ", generating " ++ int len ++ str (String.plural len " obligation")) in + let () = Flags.if_verbose Feedback.msg_info (info ++ str ", generating " ++ int len ++ str (String.plural len " obligation")) in progmap_add n (CEphemeron.create prg); let res = auto_solve_obligations (Some n) tactic in match res with @@ -1141,13 +1130,13 @@ let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) let add_mutual_definitions l ctx ?(univdecl=UState.default_univ_decl) ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) - ?(hook=mk_univ_hook (fun _ _ _ _ -> ())) ?(opaque = false) notations fixkind = + ?univ_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 List.iter (fun (n, b, t, imps, obls) -> let prg = init_prog_info sign ~opaque n univdecl (Some b) t ctx deps (Some fixkind) - notations obls imps kind reduce hook + notations obls imps kind reduce ?univ_hook in progmap_add n (CEphemeron.create prg)) l; let _defined = List.fold_left (fun finished x -> diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 57040b3f7c..c670e3a3b5 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -14,8 +14,10 @@ open Evd open Names type univ_declaration_hook -val mk_univ_hook : (UState.t -> (Id.t * constr) list -> Decl_kinds.locality -> GlobRef.t -> unit) -> univ_declaration_hook -val call_univ_hook : Future.fix_exn -> univ_declaration_hook -> UState.t -> (Id.t * constr) list -> Decl_kinds.locality -> GlobRef.t -> unit +val mk_univ_hook : (UState.t -> (Id.t * constr) list -> Decl_kinds.locality -> GlobRef.t -> unit) -> + univ_declaration_hook +val call_univ_hook : ?univ_hook:univ_declaration_hook -> ?fix_exn:Future.fix_exn -> + UState.t -> (Id.t * constr) list -> Decl_kinds.locality -> GlobRef.t -> unit (* This is a hack to make it possible for Obligations to craft a Qed * behind the scenes. The fix_exn the Stm attaches to the Future proof @@ -56,14 +58,14 @@ type progress = (* Resolution status of a program *) val default_tactic : unit Proofview.tactic ref -val add_definition : Names.Id.t -> ?term:constr -> types -> +val add_definition : Names.Id.t -> ?term:constr -> types -> UState.t -> ?univdecl:UState.universe_decl -> (* Universe binders and constraints *) ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> ?tactic:unit Proofview.tactic -> ?reduce:(constr -> constr) -> - ?hook:univ_declaration_hook -> ?opaque:bool -> obligation_info -> progress + ?univ_hook:univ_declaration_hook -> ?opaque:bool -> obligation_info -> progress type notations = (lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list @@ -80,7 +82,7 @@ val add_mutual_definitions : ?tactic:unit Proofview.tactic -> ?kind:Decl_kinds.definition_kind -> ?reduce:(constr -> constr) -> - ?hook:univ_declaration_hook -> ?opaque:bool -> + ?univ_hook:univ_declaration_hook -> ?opaque:bool -> notations -> fixpoint_kind -> unit diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 2ddd210365..e7c1e29beb 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -380,7 +380,7 @@ open Pputils let pr_thm_token k = keyword (Kindops.string_of_theorem_kind k) - let pr_syntax_modifier = function + let pr_syntax_modifier = let open Gramlib.Gramext in function | SetItemLevel (l,bko,n) -> prlist_with_sep sep_v2 str l ++ spc () ++ pr_at_level_opt n ++ pr_opt pr_constr_as_binder_kind bko diff --git a/vernac/proof_using.ml b/vernac/proof_using.ml index 3e2bd98720..526845084a 100644 --- a/vernac/proof_using.ml +++ b/vernac/proof_using.ml @@ -137,13 +137,13 @@ let suggest_common env ppid used ids_typ skip = let suggest_proof_using = ref false -let _ = - Goptions.declare_bool_option - { Goptions.optdepr = false; - Goptions.optname = "suggest Proof using"; - Goptions.optkey = ["Suggest";"Proof";"Using"]; - Goptions.optread = (fun () -> !suggest_proof_using); - Goptions.optwrite = ((:=) suggest_proof_using) } +let () = + Goptions.(declare_bool_option + { optdepr = false; + optname = "suggest Proof using"; + optkey = ["Suggest";"Proof";"Using"]; + optread = (fun () -> !suggest_proof_using); + optwrite = ((:=) suggest_proof_using) }) let suggest_constant env kn = if !suggest_proof_using @@ -172,13 +172,13 @@ let value = ref None let using_to_string us = Pp.string_of_ppcmds (Ppvernac.pr_using us) let using_from_string us = Pcoq.Entry.parse G_vernac.section_subset_expr (Pcoq.Parsable.make (Stream.of_string us)) -let _ = - Goptions.declare_stringopt_option - { Goptions.optdepr = false; - Goptions.optname = "default value for Proof using"; - Goptions.optkey = ["Default";"Proof";"Using"]; - Goptions.optread = (fun () -> Option.map using_to_string !value); - Goptions.optwrite = (fun b -> value := Option.map using_from_string b); - } +let () = + Goptions.(declare_stringopt_option + { optdepr = false; + optname = "default value for Proof using"; + optkey = ["Default";"Proof";"Using"]; + optread = (fun () -> Option.map using_to_string !value); + optwrite = (fun b -> value := Option.map using_from_string b); + }) let get_default_proof_using () = !value diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index 4761e4bbc2..f26e0d0885 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -41,8 +41,8 @@ module Vernac_ = let command_entry_ref = ref noedit_mode let command_entry = - Gram.Entry.of_parser "command_entry" - (fun strm -> Gram.Entry.parse_token_stream !command_entry_ref strm) + Pcoq.Entry.of_parser "command_entry" + (fun strm -> Pcoq.Entry.parse_token_stream !command_entry_ref strm) end diff --git a/vernac/record.ml b/vernac/record.ml index ac84003266..f6dbcb5291 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -36,7 +36,7 @@ module RelDecl = Context.Rel.Declaration (** Flag governing use of primitive projections. Disabled by default. *) let primitive_flag = ref false -let _ = +let () = declare_bool_option { optdepr = false; optname = "use of primitive projections"; @@ -45,7 +45,7 @@ let _ = optwrite = (fun b -> primitive_flag := b) } let typeclasses_strict = ref false -let _ = +let () = declare_bool_option { optdepr = false; optname = "strict typeclass resolution"; @@ -54,7 +54,7 @@ let _ = optwrite = (fun b -> typeclasses_strict := b); } let typeclasses_unique = ref false -let _ = +let () = declare_bool_option { optdepr = false; optname = "unique typeclass instances"; @@ -103,7 +103,7 @@ let binders_of_decls = List.map binder_of_decl let typecheck_params_and_fields finite def poly pl ps records = let env0 = Global.env () in let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env0 pl in - let _ = + let () = let error bk {CAst.loc; v=name} = match bk, name with | Default _, Anonymous -> @@ -160,7 +160,7 @@ let typecheck_params_and_fields finite def poly pl ps records = in let (sigma, data) = List.fold_left2_map fold sigma records arities in let sigma = - Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar sigma (Evd.from_env env_ar) in + Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar sigma in let fold sigma (typ, sort) (_, newfs) = let _, univ = compute_constructor_level sigma env_ar newfs in if not def && (Sorts.is_prop sort || @@ -458,7 +458,7 @@ let implicits_of_context ctx = in ExplByPos (i, explname), (true, true, true)) 1 (List.rev (Anonymous :: (List.map RelDecl.get_name ctx))) -let declare_class finite def cum ubinders univs id idbuild paramimpls params arity +let declare_class def cum ubinders univs id idbuild paramimpls params arity template fieldimpls fields ?(kind=StructureComponent) coers priorities = let fieldimpls = (* Make the class implicit in the projections, and the params if applicable. *) @@ -671,7 +671,7 @@ let definition_structure udecl kind ~template cum poly finite records = in let priorities = List.map (fun ((_, id), _) -> {hint_priority = id; hint_pattern = None}) cfs in let coers = List.map (fun (((coe, _), _), _) -> coe) cfs in - declare_class finite def cum ubinders univs id.CAst.v idbuild + declare_class def cum ubinders univs id.CAst.v idbuild implpars params arity template implfs fields coers priorities | _ -> let map impls = implpars @ Impargs.lift_implicits (succ (List.length params)) impls in diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index f842ca5ead..4bf76dae51 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -335,6 +335,20 @@ type execution_phase = | LoadingRcFile | InteractiveLoop +let default_phase = ref InteractiveLoop + +let in_phase ~phase f x = + let op = !default_phase in + default_phase := phase; + try + let res = f x in + default_phase := op; + res + with exn -> + let iexn = Backtrace.add_backtrace exn in + default_phase := op; + Util.iraise iexn + let pr_loc loc = let fname = loc.Loc.fname in match fname with @@ -347,8 +361,8 @@ let pr_loc loc = int (loc.bp-loc.bol_pos) ++ str"-" ++ int (loc.ep-loc.bol_pos) ++ str":") -let pr_phase ?loc phase = - match phase, loc with +let pr_phase ?loc () = + match !default_phase, loc with | LoadingRcFile, loc -> (* For when all errors go through feedback: str "While loading rcfile:" ++ @@ -363,10 +377,10 @@ let pr_phase ?loc phase = (* Note: interactive messages such as "foo is defined" are not located *) None -let print_err_exn phase any = +let print_err_exn any = let (e, info) = CErrors.push any in let loc = Loc.get_loc info in - let pre_hdr = pr_phase ?loc phase in + let pre_hdr = pr_phase ?loc () in let msg = CErrors.iprint (e, info) ++ fnl () in std_logger ?pre_hdr Feedback.Error msg diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index 73dcb0064b..0ddf474970 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -61,9 +61,11 @@ type execution_phase = | LoadingRcFile | InteractiveLoop +val in_phase : phase:execution_phase -> ('a -> 'b) -> 'a -> 'b + val pr_loc : Loc.t -> Pp.t -val pr_phase : ?loc:Loc.t -> execution_phase -> Pp.t option -val print_err_exn : execution_phase -> exn -> unit +val pr_phase : ?loc:Loc.t -> unit -> Pp.t option +val print_err_exn : exn -> unit (** [with_output_to_file file f x] executes [f x] with logging redirected to a file [file] *) diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index a78329ad1d..f5d68a2199 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -52,6 +52,23 @@ let cl_of_qualid = function let scope_class_of_qualid qid = Notation.scope_class_of_class (cl_of_qualid qid) +(** Standard attributes for definition-like commands. *) +module DefAttributes = struct + type t = { + locality : bool option; + polymorphic : bool; + program : bool; + deprecated : deprecation option; + } + + let parse f = + let open Attributes in + let ((locality, deprecated), polymorphic), program = + parse Notations.(locality ++ deprecation ++ polymorphic ++ program) f + in + { polymorphic; program; locality; deprecated } +end + (*******************) (* "Show" commands *) @@ -475,7 +492,7 @@ let vernac_custom_entry ~module_local s = (***********) (* Gallina *) -let start_proof_and_print k l hook = +let start_proof_and_print ?hook k l = let inference_hook = if Flags.is_program_mode () then let hook env sigma ev = @@ -497,21 +514,20 @@ let start_proof_and_print k l hook = in Some hook else None in - start_proof_com ?inference_hook k l hook - -let no_hook = Lemmas.mk_hook (fun _ _ -> ()) + start_proof_com ?inference_hook ?hook k l let vernac_definition_hook p = function | Coercion -> - Class.add_coercion_hook p + Some (Class.add_coercion_hook p) | CanonicalStructure -> - Lemmas.mk_hook (fun _ -> Recordops.declare_canonical_structure) + Some (Lemmas.mk_hook (fun _ -> Recordops.declare_canonical_structure)) | SubClass -> - Class.add_subclass_hook p -| _ -> no_hook + Some (Class.add_subclass_hook p) +| _ -> None let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = - let atts = attributes_of_flags atts in + let open DefAttributes in + let atts = parse atts in let local = enforce_locality_exp atts.locality discharge in let hook = vernac_definition_hook atts.polymorphic kind in let () = @@ -531,7 +547,7 @@ let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = (match def with | ProveBody (bl,t) -> (* local binders, typ *) start_proof_and_print (local, atts.polymorphic, DefinitionBody kind) - [(CAst.make ?loc name, pl), (bl, t)] hook + ?hook [(CAst.make ?loc name, pl), (bl, t)] | DefineBody (bl,red_option,c,typ_opt) -> let red_option = match red_option with | None -> None @@ -539,14 +555,15 @@ let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = let sigma, env = Pfedit.get_current_context () in Some (snd (Hook.get f_interp_redexp env sigma r)) in ComDefinition.do_definition ~program_mode name - (local, atts.polymorphic, kind) pl bl red_option c typ_opt hook) + (local, atts.polymorphic, kind) pl bl red_option c typ_opt ?hook) let vernac_start_proof ~atts kind l = - let atts = attributes_of_flags atts in + let open DefAttributes in + let atts = parse atts in let local = enforce_locality_exp atts.locality NoDischarge in if Dumpglob.dump () then List.iter (fun ((id, _), _) -> Dumpglob.dump_definition id false "prf") l; - start_proof_and_print (local, atts.polymorphic, Proof kind) l no_hook + start_proof_and_print (local, atts.polymorphic, Proof kind) l let vernac_end_proof ?proof = function | Admitted -> save_proof ?proof Admitted @@ -560,7 +577,8 @@ let vernac_exact_proof c = if not status then Feedback.feedback Feedback.AddedAxiom let vernac_assumption ~atts discharge kind l nl = - let atts = attributes_of_flags atts in + let open DefAttributes in + let atts = parse atts in let local = enforce_locality_exp atts.locality discharge in let global = local == Global in let kind = local, atts.polymorphic, kind in @@ -582,10 +600,15 @@ let should_treat_as_cumulative cum poly = else user_err Pp.(str "The NonCumulative prefix can only be used in a polymorphic context.") | None -> poly && Flags.is_polymorphic_inductive_cumulativity () -let uniform_inductive_parameters = ref false +let get_uniform_inductive_parameters = + Goptions.declare_bool_option_and_ref + ~depr:false + ~name:"Uniform inductive parameters" + ~key:["Uniform"; "Inductive"; "Parameters"] + ~value:false let should_treat_as_uniform () = - if !uniform_inductive_parameters + if get_uniform_inductive_parameters () then ComInductive.UniformParameters else ComInductive.NonUniformParameters @@ -630,7 +653,9 @@ let extract_inductive_udecl (indl:(inductive_expr * decl_notation list) list) = indicates whether the type is inductive, co-inductive or neither. *) let vernac_inductive ~atts cum lo finite indl = - let atts = attributes_of_flags atts in + let open DefAttributes in + let atts, template = Attributes.(parse_with_extra template atts) in + let atts = parse atts in let open Pp in let udecl, indl = extract_inductive_udecl indl in if Dumpglob.dump () then @@ -655,7 +680,6 @@ let vernac_inductive ~atts cum lo finite indl = | [ ( id , bl , c , Class _, Constructors [l]), [] ] -> Some (id, bl, c, l) | _ -> None in - let template = atts.template in if Option.has_some is_defclass then (** Definitional class case *) let (id, bl, c, l) = Option.get is_defclass in @@ -726,7 +750,8 @@ let vernac_inductive ~atts cum lo finite indl = *) let vernac_fixpoint ~atts discharge l = - let atts = attributes_of_flags atts in + let open DefAttributes in + let atts = parse atts in let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; @@ -739,7 +764,8 @@ let vernac_fixpoint ~atts discharge l = do_fixpoint local atts.polymorphic l let vernac_cofixpoint ~atts discharge l = - let atts = attributes_of_flags atts in + let open DefAttributes in + let atts = parse atts in let local = enforce_locality_exp atts.locality discharge in if Dumpglob.dump () then List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; @@ -980,7 +1006,8 @@ let vernac_identity_coercion ~atts id qids qidt = (* Type classes *) let vernac_instance ~atts abst sup inst props pri = - let atts = attributes_of_flags atts in + let open DefAttributes in + let atts = parse atts in let global = not (make_section_locality atts.locality) in Dumpglob.dump_constraint (fst (pi1 inst)) false "inst"; let program_mode = Flags.is_program_mode () in @@ -1030,13 +1057,9 @@ let vernac_set_used_variables e = user_err ~hdr:"vernac_set_used_variables" (str "Unknown variable: " ++ Id.print id)) l; - let _, to_clear = Proof_global.set_used_variables l in - let to_clear = List.map (fun x -> x.CAst.v) to_clear in + ignore (Proof_global.set_used_variables l); Proof_global.with_current_proof begin fun _ p -> - if List.is_empty to_clear then (p, ()) - else - let tac = Tactics.clear to_clear in - fst (Pfedit.solve Goal_select.SelectAll None tac p), () + (p, ()) end (*****************************) @@ -1409,7 +1432,7 @@ let vernac_generalizable ~local = let local = Option.default true local in Implicit_quantifiers.declare_generalizable ~local -let _ = +let () = declare_bool_option { optdepr = false; optname = "silent"; @@ -1417,7 +1440,7 @@ let _ = optread = (fun () -> !Flags.quiet); optwrite = ((:=) Flags.quiet) } -let _ = +let () = declare_bool_option { optdepr = false; optname = "implicit arguments"; @@ -1425,7 +1448,7 @@ let _ = optread = Impargs.is_implicit_args; optwrite = Impargs.make_implicit_args } -let _ = +let () = declare_bool_option { optdepr = false; optname = "strict implicit arguments"; @@ -1433,7 +1456,7 @@ let _ = optread = Impargs.is_strict_implicit_args; optwrite = Impargs.make_strict_implicit_args } -let _ = +let () = declare_bool_option { optdepr = false; optname = "strong strict implicit arguments"; @@ -1441,7 +1464,7 @@ let _ = optread = Impargs.is_strongly_strict_implicit_args; optwrite = Impargs.make_strongly_strict_implicit_args } -let _ = +let () = declare_bool_option { optdepr = false; optname = "contextual implicit arguments"; @@ -1449,7 +1472,7 @@ let _ = optread = Impargs.is_contextual_implicit_args; optwrite = Impargs.make_contextual_implicit_args } -let _ = +let () = declare_bool_option { optdepr = false; optname = "implicit status of reversible patterns"; @@ -1457,7 +1480,7 @@ let _ = optread = Impargs.is_reversible_pattern_implicit_args; optwrite = Impargs.make_reversible_pattern_implicit_args } -let _ = +let () = declare_bool_option { optdepr = false; optname = "maximal insertion of implicit"; @@ -1465,7 +1488,7 @@ let _ = optread = Impargs.is_maximal_implicit_args; optwrite = Impargs.make_maximal_implicit_args } -let _ = +let () = declare_bool_option { optdepr = false; optname = "coercion printing"; @@ -1473,7 +1496,7 @@ let _ = optread = (fun () -> !Constrextern.print_coercions); optwrite = (fun b -> Constrextern.print_coercions := b) } -let _ = +let () = declare_bool_option { optdepr = false; optname = "printing of existential variable instances"; @@ -1481,7 +1504,7 @@ let _ = optread = (fun () -> !Detyping.print_evar_arguments); optwrite = (:=) Detyping.print_evar_arguments } -let _ = +let () = declare_bool_option { optdepr = false; optname = "implicit arguments printing"; @@ -1489,7 +1512,7 @@ let _ = optread = (fun () -> !Constrextern.print_implicits); optwrite = (fun b -> Constrextern.print_implicits := b) } -let _ = +let () = declare_bool_option { optdepr = false; optname = "implicit arguments defensive printing"; @@ -1497,7 +1520,7 @@ let _ = optread = (fun () -> !Constrextern.print_implicits_defensive); optwrite = (fun b -> Constrextern.print_implicits_defensive := b) } -let _ = +let () = declare_bool_option { optdepr = false; optname = "projection printing using dot notation"; @@ -1505,7 +1528,7 @@ let _ = optread = (fun () -> !Constrextern.print_projections); optwrite = (fun b -> Constrextern.print_projections := b) } -let _ = +let () = declare_bool_option { optdepr = false; optname = "notations printing"; @@ -1513,7 +1536,7 @@ let _ = optread = (fun () -> not !Constrextern.print_no_symbol); optwrite = (fun b -> Constrextern.print_no_symbol := not b) } -let _ = +let () = declare_bool_option { optdepr = false; optname = "raw printing"; @@ -1521,7 +1544,7 @@ let _ = optread = (fun () -> !Flags.raw_print); optwrite = (fun b -> Flags.raw_print := b) } -let _ = +let () = declare_bool_option { optdepr = false; optname = "use of the program extension"; @@ -1529,7 +1552,7 @@ let _ = optread = (fun () -> !Flags.program_mode); optwrite = (fun b -> Flags.program_mode:=b) } -let _ = +let () = declare_bool_option { optdepr = false; optname = "Polymorphic inductive cumulativity"; @@ -1537,15 +1560,7 @@ let _ = optread = Flags.is_polymorphic_inductive_cumulativity; optwrite = Flags.make_polymorphic_inductive_cumulativity } -let _ = - declare_bool_option - { optdepr = false; - optname = "Uniform inductive parameters"; - optkey = ["Uniform"; "Inductive"; "Parameters"]; - optread = (fun () -> !uniform_inductive_parameters); - optwrite = (fun b -> uniform_inductive_parameters := b) } - -let _ = +let () = declare_int_option { optdepr = false; optname = "the level of inlining during functor application"; @@ -1555,7 +1570,7 @@ let _ = let lev = Option.default Flags.default_inline_level o in Flags.set_inline_level lev) } -let _ = +let () = declare_bool_option { optdepr = false; optname = "kernel term sharing"; @@ -1563,7 +1578,7 @@ let _ = optread = (fun () -> (Global.typing_flags ()).Declarations.share_reduction); optwrite = Global.set_share_reduction } -let _ = +let () = declare_bool_option { optdepr = false; optname = "display compact goal contexts"; @@ -1571,7 +1586,7 @@ let _ = optread = (fun () -> Printer.get_compact_context()); optwrite = (fun b -> Printer.set_compact_context b) } -let _ = +let () = declare_int_option { optdepr = false; optname = "the printing depth"; @@ -1579,7 +1594,7 @@ let _ = optread = Topfmt.get_depth_boxes; optwrite = Topfmt.set_depth_boxes } -let _ = +let () = declare_int_option { optdepr = false; optname = "the printing width"; @@ -1587,7 +1602,7 @@ let _ = optread = Topfmt.get_margin; optwrite = Topfmt.set_margin } -let _ = +let () = declare_bool_option { optdepr = false; optname = "printing of universes"; @@ -1595,7 +1610,7 @@ let _ = optread = (fun () -> !Constrextern.print_universes); optwrite = (fun b -> Constrextern.print_universes:=b) } -let _ = +let () = declare_bool_option { optdepr = false; optname = "dumping bytecode after compilation"; @@ -1603,7 +1618,7 @@ let _ = optread = (fun () -> !Cbytegen.dump_bytecode); optwrite = (:=) Cbytegen.dump_bytecode } -let _ = +let () = declare_bool_option { optdepr = false; optname = "dumping VM lambda code after compilation"; @@ -1611,7 +1626,7 @@ let _ = optread = (fun () -> !Clambda.dump_lambda); optwrite = (:=) Clambda.dump_lambda } -let _ = +let () = declare_bool_option { optdepr = false; optname = "explicitly parsing implicit arguments"; @@ -1619,7 +1634,7 @@ let _ = optread = (fun () -> !Constrintern.parsing_explicit); optwrite = (fun b -> Constrintern.parsing_explicit := b) } -let _ = +let () = declare_string_option ~preprocess:CWarnings.normalize_flags_string { optdepr = false; optname = "warnings display"; @@ -1627,7 +1642,7 @@ let _ = optread = CWarnings.get_flags; optwrite = CWarnings.set_flags } -let _ = +let () = declare_string_option { optdepr = false; optname = "native_compute profiler output"; @@ -1635,7 +1650,7 @@ let _ = optread = Nativenorm.get_profile_filename; optwrite = Nativenorm.set_profile_filename } -let _ = +let () = declare_bool_option { optdepr = false; optname = "enable native compute profiling"; @@ -1933,7 +1948,7 @@ let interp_search_about_item env sigma = *) let search_output_name_only = ref false -let _ = +let () = declare_bool_option { optdepr = false; optname = "output-name-only search"; @@ -2303,13 +2318,13 @@ let interp ?proof ~atts ~st c = let default_timeout = ref None -let _ = - Goptions.declare_int_option - { Goptions.optdepr = false; - Goptions.optname = "the default timeout"; - Goptions.optkey = ["Default";"Timeout"]; - Goptions.optread = (fun () -> !default_timeout); - Goptions.optwrite = ((:=) default_timeout) } +let () = + declare_int_option + { optdepr = false; + optname = "the default timeout"; + optkey = ["Default";"Timeout"]; + optread = (fun () -> !default_timeout); + optwrite = ((:=) default_timeout) } (** When interpreting a command, the current timeout is initially the default one, but may be modified locally by a Timeout command. *) diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 122005e011..1e6c40c829 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -167,7 +167,7 @@ type syntax_modifier = | SetItemLevel of string list * Notation_term.constr_as_binder_kind option * Extend.production_level option | SetLevel of int | SetCustomEntry of string * int option - | SetAssoc of Extend.gram_assoc + | SetAssoc of Gramlib.Gramext.g_assoc | SetEntryType of string * Extend.simple_constr_prod_entry_key | SetOnlyParsing | SetOnlyPrinting diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 3a321ecdb4..2541f73582 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -12,6 +12,10 @@ open Util open Pp open CErrors +type vernac_keep_as = VtKeepAxiom | VtKeepDefined | VtKeepOpaque + +type vernac_qed_type = VtKeep of vernac_keep_as | VtDrop + type vernac_type = (* Start of a proof *) | VtStartProof of vernac_start @@ -33,7 +37,6 @@ type vernac_type = (* To be removed *) | VtMeta | VtUnknown -and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *) and vernac_start = string * opacity_guarantee * Names.Id.t list and vernac_sideff_type = Names.Id.t list and opacity_guarantee = @@ -190,7 +193,7 @@ let vernac_extend ~command ?classifier ?entry ext = | None -> let e = match entry with | None -> "COMMAND" - | Some e -> Pcoq.Gram.Entry.name e + | Some e -> Pcoq.Entry.name e in let msg = Printf.sprintf "\ Vernac entry \"%s\" misses a classifier. \ diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 7feaccd9a3..8b07be8b16 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -27,6 +27,11 @@ considered safe to delegate to a worker. *) + +type vernac_keep_as = VtKeepAxiom | VtKeepDefined | VtKeepOpaque + +type vernac_qed_type = VtKeep of vernac_keep_as | VtDrop + type vernac_type = (* Start of a proof *) | VtStartProof of vernac_start @@ -48,7 +53,6 @@ type vernac_type = (* To be removed *) | VtMeta | VtUnknown -and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *) and vernac_start = string * opacity_guarantee * Names.Id.t list and vernac_sideff_type = Names.Id.t list and opacity_guarantee = |