diff options
301 files changed, 7302 insertions, 3017 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 2a325f2d71..6c7b7a9a1c 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -1,10 +1,17 @@ # This file describes the maintainers for the main components. See # `dev/doc/MERGING.md`. -########## GitHub metadata, including this file ########## +########## Contributing process ########## -/.github/ @maximedenes -# Secondary maintainer @Zimmi48 +/.github/ @coq/contributing-process-maintainers + +/CONTRIBUTING.md @coq/contributing-process-maintainers + +/dev/doc/release-process.md @coq/contributing-process-maintainers + +/dev/doc/MERGING.md @coq/pushers +# This ensures that all members of the @coq/pushers +# team are notified when the merging doc changes. ########## Build system ########## @@ -45,19 +52,12 @@ azure-pipelines.yml @coq/ci-maintainers /INSTALL* @Zimmi48 # Secondary maintainer @maximedenes -/CONTRIBUTING.md @Zimmi48 -# Secondary maintainer @maximedenes - /CODE_OF_CONDUCT.md @Zimmi48 # Secondary maintainer @mattam82 /dev/doc/ @Zimmi48 # Secondary maintainer @maximedenes -/dev/doc/MERGING.md @coq/pushers -# This ensures that all members of the @coq/pushers -# team are notified when the merging doc changes. - /dev/doc/changes.md @ghost # Trick to avoid getting review requests # each time someone modifies the dev changelog @@ -161,8 +161,7 @@ azure-pipelines.yml @coq/ci-maintainers /plugins/nsatz/ @thery # Secondary maintainer @ppedrot -/plugins/setoid_ring/ @amahboubi -# Secondary maintainer @bgregoir +/plugins/setoid_ring/ @coq/ring-maintainers /plugins/ssrmatching/ @coq/ssreflect-maintainers /plugins/ssr/ @coq/ssreflect-maintainers diff --git a/.gitignore b/.gitignore index 93b874eae3..587a6191ab 100644 --- a/.gitignore +++ b/.gitignore @@ -191,3 +191,5 @@ theories/*/*/*/dune /user-contrib/Ltac2/dune *.install !Makefile.install + +ide/coqide.keys diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ce0c1d9af7..8b37403960 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -8,14 +8,17 @@ stages: - stage-4 # Only dependencies in stage 1, 2 and 3 - deploy -# When a job has no dependencies, it goes to stage 1. -# Otherwise, we set "needs" and "dependencies" to the same value. +# When a job has no dependencies, it goes to stage 1. Otherwise, we +# set both "needs" and "dependencies". "needs" is a superset of +# "dependencies" that should include all the transitive dependencies. +# "dependencies" only list the previous jobs whose artifact we need to +# keep. # some default values variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-07-06-V22" + CACHEKEY: "bionic_coq-V2019-07-09-V01" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -376,6 +379,9 @@ pkg:nix:deploy:channel: name: cachix url: https://coq.cachix.org only: + refs: # Repeat conditions from pkg:nix:deploy + - master + - /^v.*\..*$/ variables: - $CACHIX_DEPLOYMENT_KEY dependencies: [] @@ -654,6 +660,7 @@ library:ci-corn: stage: stage-4 needs: - build:edge+flambda + - plugin:ci-bignums - library:ci-math-classes dependencies: - build:edge+flambda @@ -687,6 +694,7 @@ library:ci-math-comp: library:ci-sf: extends: .ci-template + allow_failure: true # Waiting for integration of the fix for #10476 library:ci-stdlib2: extends: .ci-template-flambda diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 529a912bb6..cbead97529 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -21,6 +21,7 @@ well. - [Support](#support) - [Standard libraries](#standard-libraries) - [Maintaining existing packages in coq-community](#maintaining-existing-packages-in-coq-community) + - [Contributing to the editor support packages](#contributing-to-the-editor-support-packages) - [Contributing to the website or the package archive](#contributing-to-the-website-or-the-package-archive) - [Other ways of creating content](#other-ways-of-creating-content) - [Issues](#issues) @@ -208,6 +209,10 @@ manifesto's README][coq-community-manifesto]. ### Contributing to the editor support packages ### +Besides CoqIDE, whose sources are available in this repository, and to +which you are welcome to contribute, there are a number of alternative +user interfaces for Coq, more often as an editor support package. + Here are the URLs of the repositories of the various editor support packages: @@ -216,6 +221,11 @@ packages: - Coqtail (Vim) <https://github.com/whonore/Coqtail> - VsCoq Reloaded (VsCode) <https://github.com/coq-community/vscoq> +And here are alternative user interfaces to be run in the web browser: + +- JsCoq (Coq executed in your browser) <https://github.com/ejgallego/jscoq> +- Jupyter kernel for Coq <https://github.com/EugeneLoy/coq_jupyter/> + Each of them has their own contribution process. ### Contributing to the website or the package archive ### @@ -616,8 +626,26 @@ documentation][coqdoc-documentation] to learn more. ### Fixing bugs and performing small changes ### -Just open a PR with your fix. If it is not yet completed, do not -hesitate to open a [*draft PR*][GitHub-draft-PR] to get early +Before fixing a bug, it is best to check that it was reported before: + +- If it was already reported and you intend to fix it, self-assign the + issue (if you have the permission), or leave a comment marking your + intention to work on it (and a contributor with write-access may + then assign the issue to you). + +- If the issue already has an assignee, you should check with them if + they still intend to work on it. If the assignment is several + weeks, months, or even years (!) old, there are good chances that it + does not reflect their current priorities. + +- If the bug has not been reported before, it can be a good idea to + open an issue about it, while stating that you are preparing a fix. + The issue can be the place to discuss about the bug itself while the + PR will be the place to discuss your proposed fix. + +In any case, feel free to just ignore the recommendation above, and +jump ahead and open a PR with your fix. If it is not yet complete, do +not hesitate to open a [*draft PR*][GitHub-draft-PR] to get early feedback, and talk to developers on [Gitter][]. It is generally a good idea to add a regression test to the @@ -638,12 +666,12 @@ merged. So it is recommended that before spending a lot of time coding, you seek feedback from maintainers to see if your change would be -supported, and if they have recommendation about its implementation. +supported, and if they have recommendations about its implementation. You can do this informally by opening an issue, or more formally by producing a design document as a [Coq Enhancement Proposal][CEP]. Another recommendation is that you do not put several unrelated -changes (even if you produced them together) in the same PR. In +changes in the same PR (even if you produced them together). In particular, make sure you split bug fixes into separate PRs when this is possible. More generally, smaller-sized PRs, or PRs changing less components, are more likely to be reviewed and merged promptly. @@ -112,6 +112,7 @@ of the Coq Proof assistant during the indicated time: Hugo Herbelin (INRIA, 1996-now) Sébastien Hinderer (INRIA, 2014) Gérard Huet (INRIA, 1985-1997) + Konstantinos Kallas (U. Penn, 2019) Matej KoÅ¡Ãk (INRIA, 2015-2017) Leonidas Lampropoulos (University of Pennsylvania, 2018) Pierre Letouzey (LRI, 2000-2004, PPS, 2005-2008, @@ -119,7 +120,7 @@ of the Coq Proof assistant during the indicated time: Yao Li (ORCID: https://orcid.org/0000-0001-8720-883X, University of Pennsylvania, 2018) Yishuai Li (ORCID: https://orcid.org/0000-0002-5728-5903 - U. Penn, 2018) + U. Penn, 2018-2019) Patrick Loiseleur (Paris Sud, 1997-1999) Evgeny Makarov (INRIA, 2007) Gregory Malecha (Harvard University 2013-2015, @@ -9,7 +9,7 @@ WHAT DO YOU NEED ? - OCaml (version >= 4.05.0) (available at https://ocaml.org/) - (This version of Coq has been tested up to OCaml 4.08.0) + (This version of Coq has been tested up to OCaml 4.08.1) - The Num package, which used to be part of the OCaml standard library, if you are using an OCaml version >= 4.06.0 diff --git a/Makefile.build b/Makefile.build index d1ed9a6f96..610af5fe40 100644 --- a/Makefile.build +++ b/Makefile.build @@ -396,9 +396,8 @@ doc_gram_rsts: doc/tools/docgram/orderedGrammar ########################################################################### # Specific rules for Uint63 ########################################################################### -kernel/uint63.ml: kernel/write_uint63.ml kernel/uint63_i386_31.ml kernel/uint63_amd64_63.ml - $(SHOW)'WRITE $@' - $(HIDE)(cd kernel && ocaml unix.cma $(shell basename $<)) +kernel/uint63.ml: kernel/uint63_$(OCAML_INT_SIZE).ml + rm -f $@ && cp $< $@ && chmod a-w $@ ########################################################################### # Main targets (coqtop.opt, coqtop.byte) @@ -642,12 +641,6 @@ gramlib/.pack/gramlib__G%: gramlib/g% | gramlib/.pack # Specific rules for gramlib to pack it Dune / OCaml 4.08 style GRAMOBJS=$(addsuffix .cmo, $(GRAMFILES)) -gramlib/.pack/%: COND_BYTEFLAGS+=-no-alias-deps -w -49 -gramlib/.pack/%: COND_OPTFLAGS+=-no-alias-deps -w -49 - -gramlib/.pack/gramlib.%: COND_OPENFLAGS= -gramlib/.pack/gramlib__%: COND_OPENFLAGS=-open Gramlib - gramlib/.pack/gramlib.cma: $(GRAMOBJS) gramlib/.pack/gramlib.cmo $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $^ @@ -701,14 +694,15 @@ kernel/kernel.cmxa: kernel/kernel.mllib COND_IDEFLAGS=$(if $(filter ide/fake_ide% tools/coq_makefile%,$<), -I ide -I ide/protocol,) COND_PRINTERFLAGS=$(if $(filter dev/%,$<), -I dev,) -# For module packing -COND_OPENFLAGS= +COND_GRAMFLAGS=$(if $(filter gramlib/.pack/%,$<),-no-alias-deps -w -49,) $(if $(filter gramlib/.pack/gramlib__%,$<),-open Gramlib,) + +COND_KERFLAGS=$(if $(filter kernel/%,$<),-w +a-4-44-50,) COND_BYTEFLAGS= \ - $(COND_IDEFLAGS) $(COND_PRINTERFLAGS) $(MLINCLUDES) $(BYTEFLAGS) $(COND_OPENFLAGS) + $(COND_IDEFLAGS) $(COND_PRINTERFLAGS) $(MLINCLUDES) $(BYTEFLAGS) $(COND_GRAMFLAGS) $(COND_KERFLAGS) COND_OPTFLAGS= \ - $(COND_IDEFLAGS) $(MLINCLUDES) $(OPTFLAGS) $(COND_OPENFLAGS) + $(COND_IDEFLAGS) $(MLINCLUDES) $(OPTFLAGS) $(COND_GRAMFLAGS) $(COND_KERFLAGS) plugins/micromega/%.cmi: plugins/micromega/%.mli $(SHOW)'OCAMLC $<' @@ -718,8 +712,6 @@ plugins/nsatz/%.cmi: plugins/nsatz/%.mli $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< -kernel/%.cmi: COND_BYTEFLAGS+=-w +a-4-44-50 - %.cmi: %.mli $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< @@ -732,8 +724,6 @@ plugins/nsatz/%.cmo: plugins/nsatz/%.ml $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< -kernel/%.cmo: COND_BYTEFLAGS+=-w +a-4-44-50 - %.cmo: %.ml $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< @@ -783,8 +773,6 @@ user-contrib/%.cmx: user-contrib/%.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -c $< -kernel/%.cmx: COND_OPTFLAGS+=-w +a-4-44-50 - %.cmx: %.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) -c $< diff --git a/Makefile.common b/Makefile.common index dd23d7dd2f..2d1200c071 100644 --- a/Makefile.common +++ b/Makefile.common @@ -155,13 +155,14 @@ LTACCMO:=plugins/ltac/ltac_plugin.cmo plugins/ltac/tauto_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo SSRCMO:=plugins/ssr/ssreflect_plugin.cmo LTAC2CMO:=user-contrib/Ltac2/ltac2_plugin.cmo +ZIFYCMO:=plugins/micromega/zify_plugin.cmo PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(MICROMEGACMO) \ $(RINGCMO) \ $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(SYNTAXCMO) \ - $(DERIVECMO) $(SSRMATCHINGCMO) $(SSRCMO) $(LTAC2CMO) + $(DERIVECMO) $(SSRMATCHINGCMO) $(SSRCMO) $(LTAC2CMO) $(ZIFYCMO) ifeq ($(HASNATDYNLINK)-$(BEST),false-opt) STATICPLUGINS:=$(PLUGINSCMO) diff --git a/Makefile.ide b/Makefile.ide index cb026cdf43..081d15a1a2 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -59,7 +59,7 @@ IDEBINDINGS:=ide/default.bindings IDEBINDINGSSRC:=ide/default_bindings_src.ml IDEBINDINGSEXE:=ide/default_bindings_src.exe -IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_accel_map $(IDEBINDINGS) +IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png $(IDEBINDINGS) ## GTK for Coqide MacOS bundle @@ -121,7 +121,7 @@ $(COQIDEBYTE): $(LINKIDE) ide/coqide_os_specific.ml: ide/coqide_$(IDEINT).ml.in config/Makefile @rm -f $@ cp $< $@ - @chmod -w $@ + @chmod a-w $@ ide/%.cmi: ide/%.mli $(SHOW)'OCAMLC $<' @@ -175,7 +175,6 @@ $(IDEBINDINGSEXE): $(IDEBINDINGSSRC) $(IDEBINDINGS): $(IDEBINDINGSEXE) $< $@ - #################### ## Install targets #################### @@ -224,7 +223,6 @@ install-ide-files: #Please update $(COQIDEAPP)/Contents/Resources/ at the same t $(MKDIR) $(FULLDATADIR) $(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $(IDEBINDINGS) $(FULLDATADIR) $(MKDIR) $(FULLCONFIGDIR) - if [ $(IDEINT) = QUARTZ ] ; then $(INSTALLLIB) ide/mac_default_accel_map $(FULLCONFIGDIR)/coqide.keys ; fi install-ide-info: $(MKDIR) $(FULLDOCDIR) @@ -271,7 +269,6 @@ $(COQIDEAPP)/Contents/Resources/immodules: $(COQIDEAPP)/Contents $(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib $(MKDIR) $@/xdg/coq - $(INSTALLLIB) ide/MacOS/default_accel_map $@/xdg/coq/coqide.keys $(MKDIR) $@/gtk-3.0 { "$(PIXBUFBIN)/gdk-pixbuf-query-loaders" $@/../loaders/*.so |\ sed -e "s!/.*\(/loaders/.*.so\)!@executable_path/../Resources/\1!"; } \ diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 862c54900f..84f080cc73 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -72,7 +72,7 @@ jobs: opam list displayName: 'Install OCaml dependencies' env: - COMPILER: "4.08.0" + COMPILER: "4.08.1" FINDLIB_VER: ".1.8.0" OPAMYES: "true" diff --git a/checker/check.ml b/checker/check.ml index ecf84fda9c..69de2536c5 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -262,7 +262,6 @@ let raw_intern_library f = type summary_disk = { md_name : compilation_unit_name; - md_imports : compilation_unit_name array; md_deps : (compilation_unit_name * Safe_typing.vodigest) array; } diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 09b8c48c15..3128e125dd 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -17,51 +17,55 @@ let set_indirect_accessor f = indirect_accessor := f let check_constant_declaration env kn cb = Flags.if_verbose Feedback.msg_notice (str " checking cst:" ++ Constant.print kn); - (* Locally set typing flags for further typechecking *) - let orig_flags = env.env_typing_flags in let cb_flags = cb.const_typing_flags in - let env = Environ.set_typing_flags {orig_flags with check_guarded = cb_flags.check_guarded; - check_universes = cb_flags.check_universes; - conv_oracle = cb_flags.conv_oracle} env in - (* [env'] contains De Bruijn universe variables *) - let poly, env' = + let env = Environ.set_typing_flags + {env.env_typing_flags with + check_guarded = cb_flags.check_guarded; + check_universes = cb_flags.check_universes; + conv_oracle = cb_flags.conv_oracle;} + env + in + let poly, env = match cb.const_universes with - | Monomorphic ctx -> false, env + | Monomorphic ctx -> + (* Monomorphic universes are stored at the library level, the + ones in const_universes should not be needed *) + false, env | Polymorphic auctx -> let ctx = Univ.AUContext.repr auctx in + (* [env] contains De Bruijn universe variables *) let env = push_context ~strict:false ctx env in true, env in let ty = cb.const_type in - let _ = infer_type env' ty in - let otab = Environ.opaque_tables env' in - let body, env' = match cb.const_body with - | Undef _ | Primitive _ -> None, env' - | Def c -> Some (Mod_subst.force_constr c), env' - | OpaqueDef o -> - let c, u = Opaqueproof.force_proof !indirect_accessor otab o in - let env' = match u, cb.const_universes with - | Opaqueproof.PrivateMonomorphic (), Monomorphic _ -> env' - | Opaqueproof.PrivatePolymorphic (_, local), Polymorphic _ -> - push_subgraph local env' - | _ -> assert false - in - Some c, env' + let _ = infer_type env ty in + let otab = Environ.opaque_tables env in + let body, env = match cb.const_body with + | Undef _ | Primitive _ -> None, env + | Def c -> Some (Mod_subst.force_constr c), env + | OpaqueDef o -> + let c, u = Opaqueproof.force_proof !indirect_accessor otab o in + let env = match u, cb.const_universes with + | Opaqueproof.PrivateMonomorphic (), Monomorphic _ -> env + | Opaqueproof.PrivatePolymorphic (_, local), Polymorphic _ -> + push_subgraph local env + | _ -> assert false + in + Some c, env in let () = match body with | Some bd -> - let j = infer env' bd in - (try conv_leq env' j.uj_type ty + let j = infer env bd in + (try conv_leq env j.uj_type ty with NotConvertible -> Type_errors.error_actual_type env j ty) | None -> () in - let env = - if poly then add_constant kn cb env - else add_constant kn cb env' - in - (* Reset the value of the typing flags *) - Environ.set_typing_flags orig_flags env + () + +let check_constant_declaration env kn cb = + let () = check_constant_declaration env kn cb in + Environ.add_constant kn cb env (** {6 Checking modules } *) diff --git a/checker/values.ml b/checker/values.ml index ac9bc26344..6b340635d7 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -219,7 +219,7 @@ let v_cst_def = [|[|Opt Int|]; [|v_cstr_subst|]; [|v_lazy_constr|]; [|v_primitive|]|] let v_typing_flags = - v_tuple "typing_flags" [|v_bool; v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool; v_bool|] + v_tuple "typing_flags" [|v_bool; v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool; v_bool; v_bool|] let v_univs = v_sum "universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] @@ -357,7 +357,7 @@ and v_libobjt = Sum("Libobject.t",0, [| v_substobjs |]; [| v_aobjs |]; [| v_libobjs |]; - [| v_bool; v_mp |]; + [| List v_mp |]; [| v_obj |] |]) @@ -395,7 +395,7 @@ let v_stm_seg = v_pair v_tasks v_counters (** Toplevel structures in a vo (see Cic.mli) *) let v_libsum = - Tuple ("summary", [|v_dp;Array v_dp;v_deps|]) + Tuple ("summary", [|v_dp;v_deps|]) let v_lib = Tuple ("library",[|v_compiled_lib;v_libraryobjs|]) diff --git a/clib/cString.ml b/clib/cString.ml index 60915efe86..99fb7d2b78 100644 --- a/clib/cString.ml +++ b/clib/cString.ml @@ -24,6 +24,7 @@ sig val conjugate_verb_to_be : int -> string val ordinal : int -> string val is_sub : string -> string -> int -> bool + val is_prefix : string -> string -> bool module Set : Set.S with type elt = t module Map : CMap.ExtS with type key = t and module Set := Set module List : CList.MonoS with type elt = t @@ -101,6 +102,9 @@ let is_sub p s off = in aux 0 +let is_prefix p s = + is_sub p s 0 + let plural n s = if n<>1 then s^"s" else s let conjugate_verb_to_be n = if n<>1 then "are" else "is" diff --git a/clib/cString.mli b/clib/cString.mli index 8a4fe62a1c..d02be2d15f 100644 --- a/clib/cString.mli +++ b/clib/cString.mli @@ -51,6 +51,9 @@ sig val is_sub : string -> string -> int -> bool (** [is_sub p s off] tests whether [s] contains [p] at offset [off]. *) + val is_prefix : string -> string -> bool + (** [is_prefix p s] tests whether [p] is a prefix of [s]. *) + (** {6 Generic operations} **) module Set : Set.S with type elt = t diff --git a/configure.ml b/configure.ml index 3ced82718e..d7370b28c1 100644 --- a/configure.ml +++ b/configure.ml @@ -1141,6 +1141,7 @@ let write_makefile f = pr "# Your architecture\n"; pr "# Can be obtain by UNIX command arch\n"; pr "ARCH=%s\n" arch; + pr "OCAML_INT_SIZE:=%d\n" Sys.int_size; pr "HASNATDYNLINK=%s\n\n" natdynlinkflag; pr "# Supplementary libs for some systems, currently:\n"; pr "# . Sun Solaris: -cclib -lunix -cclib -lnsl -cclib -lsocket\n"; @@ -1199,8 +1200,8 @@ let write_macos_metadata exec = let () = close_out o in Unix.chmod f 0o444 -let () = if arch = "Darwin" then -List.iter write_macos_metadata distributed_exec +let () = + if arch = "Darwin" then List.iter write_macos_metadata distributed_exec let write_configpy f = safe_remove f; diff --git a/dev/ci/azure-opam.sh b/dev/ci/azure-opam.sh index 34d748e1cc..03ce5a6b5d 100755 --- a/dev/ci/azure-opam.sh +++ b/dev/ci/azure-opam.sh @@ -2,7 +2,7 @@ set -e -x -OPAM_VARIANT=ocaml-variants.4.08.0+mingw64c +OPAM_VARIANT=ocaml-variants.4.08.1+mingw64c 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 diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 011c7fbdec..567f0539ab 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-07-06-V22" +# CACHEKEY: "bionic_coq-V2019-07-09-V01" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -39,7 +39,7 @@ ENV COMPILER="4.05.0" # with the compiler version. ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.10.0 ounit.2.0.8 odoc.1.4.0" \ CI_OPAM="menhir.20190626 ocamlgraph.1.8.8" \ - BASE_ONLY_OPAM="elpi.1.4.0" + BASE_ONLY_OPAM="elpi.1.7.0" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV COQIDE_OPAM="cairo2.0.6 lablgtk3-sourceview3.3.0.beta5" @@ -56,7 +56,7 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ opam install $BASE_OPAM # EDGE switch -ENV COMPILER_EDGE="4.08.0" \ +ENV COMPILER_EDGE="4.08.1" \ COQIDE_OPAM_EDGE="cairo2.0.6 lablgtk3-sourceview3.3.0.beta6" \ BASE_OPAM_EDGE="dune-release.1.3.1" diff --git a/dev/ci/user-overlays/10416-gares-elpi-14.sh b/dev/ci/user-overlays/10416-gares-elpi-14.sh deleted file mode 100644 index 52d1005a7d..0000000000 --- a/dev/ci/user-overlays/10416-gares-elpi-14.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10416" ] || [ "$CI_BRANCH" = "elpi-14" ]; then - - elpi_CI_REF="coq-master-elpi-14" - elpi_CI_GITURL=https://github.com/LPCIC/coq-elpi - -fi diff --git a/dev/ci/user-overlays/10476-maximedenes-rm-library-optim.sh b/dev/ci/user-overlays/10476-maximedenes-rm-library-optim.sh new file mode 100644 index 0000000000..10526a9ffe --- /dev/null +++ b/dev/ci/user-overlays/10476-maximedenes-rm-library-optim.sh @@ -0,0 +1,10 @@ +if [ "$CI_PULL_REQUEST" = "10476" ] || [ "$CI_BRANCH" = "rm-library-optim" ]; then + + sf_lf_CI_TARURL=https://www.maximedenes.fr/download/lf.tgz + sf_plf_CI_TARURL=https://www.maximedenes.fr/download/plf.tgz + sf_vfa_CI_TARURL=https://www.maximedenes.fr/download/vfa.tgz + + vst_CI_REF=fix-export + vst_CI_GITURL=https://github.com/maximedenes/VST + +fi diff --git a/dev/ci/user-overlays/10660-ejgallego-errors+private.sh b/dev/ci/user-overlays/10660-ejgallego-errors+private.sh new file mode 100644 index 0000000000..21ff60493b --- /dev/null +++ b/dev/ci/user-overlays/10660-ejgallego-errors+private.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10660" ] || [ "$CI_BRANCH" = "errors+private" ]; then + + coqhammer_CI_REF=errors+private + coqhammer_CI_GITURL=https://github.com/ejgallego/coqhammer + +fi diff --git a/dev/ci/user-overlays/10674-ejgallego-proofs+declare_unif.sh b/dev/ci/user-overlays/10674-ejgallego-proofs+declare_unif.sh new file mode 100644 index 0000000000..6dc44aa627 --- /dev/null +++ b/dev/ci/user-overlays/10674-ejgallego-proofs+declare_unif.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10674" ] || [ "$CI_BRANCH" = "proofs+declare_unif" ]; then + + equations_CI_REF=proofs+declare_unif + equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/10738-gares-elpi1.7.sh b/dev/ci/user-overlays/10738-gares-elpi1.7.sh new file mode 100644 index 0000000000..8922badf90 --- /dev/null +++ b/dev/ci/user-overlays/10738-gares-elpi1.7.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10738" ] || [ "$CI_BRANCH" = "elpi1.7" ]; then + + elpi_CI_REF="coq-master+elpi1.7" + elpi_CI_GITURL=https://github.com/LPCIC/coq-elpi + +fi diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 01c2b574a2..d00c8cb11a 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -119,6 +119,16 @@ Universes GH issue number: #8341 risk: unlikely to be activated by chance (requires a plugin) + component: template polymorphism + summary: template polymorphism not collecting side constrains on the universe level of a parameter; this is a general form of the previous issue about template polymorphism exploiting other ways to generate untracked constraints introduced: morally at the introduction of template polymorphism, 23 May 2006, 9c2d70b, r8845, Herbelin impacted released versions: at least V8.4-V8.4pl6, V8.5-V8.5pl3, V8.6-V8.6pl2, V8.7.0-V8.7.1, V8.8.0-V8.8.1, V8.9.0-V8.9.1, in theory also V8.1-V8.1pl4, V8.2-V8.2pl2, V8.3-V8.3pl2 but not exploit found there yet (an exploit using a plugin to force sharing of universe level is in principle possible though) + impacted development branches: all from 8.4 to 8.9 at the time of writing and suspectingly also all from 8.1 to 8.4 if a way to create untracked constraints can be found + impacted coqchk versions: a priori all (tested with V8.4 and V8.9 which accept the exploit) + fixed in: soon in master and V8.10.0 (PR #9918, Aug 2019, Dénès and Sozeau) + found by: Gilbert using explicit sharing of universes, exploit found for 8.5-8.9 by Pédrot, other variants generating sharing using sections, or using ltac tricks by Sozeau, exploit in 8.4 by Herbelin and Jason Gross by adding new tricks to Sozeau's variants + exploit: test-suite/failure/Template.v + GH issue number: #9294 + risk: moderate risk to be activated by chance + Primitive projections component: primitive projections, guard condition diff --git a/dev/dune-workspace.all b/dev/dune-workspace.all index c7f36ee964..7e53f13e45 100644 --- a/dev/dune-workspace.all +++ b/dev/dune-workspace.all @@ -3,5 +3,5 @@ ; Add custom flags here. Default developer profile is `dev` (context (opam (switch 4.05.0))) (context (opam (switch 4.05.0+32bit))) -(context (opam (switch 4.08.0))) -(context (opam (switch 4.08.0+flambda))) +(context (opam (switch 4.08.1))) +(context (opam (switch 4.08.1+flambda))) diff --git a/doc/changelog/02-specification-language/10758-fix-10757.rst b/doc/changelog/02-specification-language/10758-fix-10757.rst new file mode 100644 index 0000000000..4cce26aedc --- /dev/null +++ b/doc/changelog/02-specification-language/10758-fix-10757.rst @@ -0,0 +1,5 @@ +- ``Program Fixpoint`` now uses ``ex`` and ``sig`` to make telescopes + involving ``Prop`` types (`#10758 + <https://github.com/coq/coq/pull/10758>`_, by Gaëtan Gilbert, fixing + `#10757 <https://github.com/coq/coq/issues/10757>`_ reported by + Xavier Leroy). diff --git a/doc/changelog/04-tactics/09856-zify.rst b/doc/changelog/04-tactics/09856-zify.rst new file mode 100644 index 0000000000..6b9143c77b --- /dev/null +++ b/doc/changelog/04-tactics/09856-zify.rst @@ -0,0 +1,7 @@ +- Reimplementation of the :tacn:`zify` tactic. The tactic is more efficient and copes with dependent hypotheses. + It can also be extended by redefining the tactic ``zify_post_hook``. + (`#9856 <https://github.com/coq/coq/pull/9856>`_ fixes + `#8898 <https://github.com/coq/coq/issues/8898>`_, + `#7886 <https://github.com/coq/coq/issues/7886>`_, + `#9848 <https://github.com/coq/coq/issues/9848>`_ and + `#5155 <https://github.com/coq/coq/issues/5155>`_, by Frédéric Besson). diff --git a/doc/changelog/04-tactics/10774-zify-Z_to_N.rst b/doc/changelog/04-tactics/10774-zify-Z_to_N.rst new file mode 100644 index 0000000000..ed46cb101e --- /dev/null +++ b/doc/changelog/04-tactics/10774-zify-Z_to_N.rst @@ -0,0 +1,3 @@ +- The :tacn:`zify` tactic is now aware of `Z.to_N`. + (`#10774 <https://github.com/coq/coq/pull/10774>`_ fixes + `#9162 <https://github.com/coq/coq/issues/9162>`_, by Kazuhiko Sakaguchi). diff --git a/doc/changelog/07-commands-and-options/10336-ambiguous-paths.rst b/doc/changelog/07-commands-and-options/10336-ambiguous-paths.rst deleted file mode 100644 index 151c400b2c..0000000000 --- a/doc/changelog/07-commands-and-options/10336-ambiguous-paths.rst +++ /dev/null @@ -1,5 +0,0 @@ -- Improve the ambiguous paths warning to indicate which path is ambiguous with - new one - (`#10336 <https://github.com/coq/coq/pull/10336>`_, - closes `#3219 <https://github.com/coq/coq/issues/3219>`_, - by Kazuhiko Sakaguchi). diff --git a/doc/changelog/07-commands-and-options/10476-fix-export.rst b/doc/changelog/07-commands-and-options/10476-fix-export.rst new file mode 100644 index 0000000000..ba71e1c337 --- /dev/null +++ b/doc/changelog/07-commands-and-options/10476-fix-export.rst @@ -0,0 +1,5 @@ +- Fix two bugs in `Export`. This can have an impact on the behavior of the + `Import` command on libraries. `Import A` when `A` imports `B` which exports + `C` was importing `C`, whereas `Import` is not transitive. Also, after + `Import A B`, the import of `B` was sometimes incomplete. + (`#10476 <https://github.com/coq/coq/pull/10476>`_, by Maxime Dénès). diff --git a/doc/changelog/08-tools/10430-extraction-int63.rst b/doc/changelog/08-tools/10430-extraction-int63.rst deleted file mode 100644 index 68ae4591a4..0000000000 --- a/doc/changelog/08-tools/10430-extraction-int63.rst +++ /dev/null @@ -1,5 +0,0 @@ -- Fix extraction to OCaml of primitive machine integers; - see :ref:`primitive-integers` - (`#10430 <https://github.com/coq/coq/pull/10430>`_, - fixes `#10361 <https://github.com/coq/coq/issues/10361>`_, - by Vincent Laporte). diff --git a/doc/changelog/10-standard-library/10651-new-lemmas-for-lists.rst b/doc/changelog/10-standard-library/10651-new-lemmas-for-lists.rst new file mode 100644 index 0000000000..864c4e6a7e --- /dev/null +++ b/doc/changelog/10-standard-library/10651-new-lemmas-for-lists.rst @@ -0,0 +1,6 @@ +- New lemmas on :g:`combine`, :g:`filter`, :g:`nodup`, :g:`nth`, and + :g:`nth_error` functions on lists. The lemma :g:`filter_app` was moved to the + :g:`List` module. + + See `#10651 <https://github.com/coq/coq/pull/10651>`_, and + `#10731 <https://github.com/coq/coq/pull/10731>`_, by Oliver Nash. diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index e56b36caad..238106b2e7 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -9,9 +9,11 @@ Short description of the tactics -------------------------------- The Psatz module (``Require Import Psatz.``) gives access to several -tactics for solving arithmetic goals over :math:`\mathbb{Z}`, :math:`\mathbb{Q}`, and :math:`\mathbb{R}` [#]_. -It also possible to get the tactics for integers by a ``Require Import Lia``, -rationals ``Require Import Lqa`` and reals ``Require Import Lra``. +tactics for solving arithmetic goals over :math:`\mathbb{Q}`, +:math:`\mathbb{R}`, and :math:`\mathbb{Z}` but also :g:`nat` and +:g:`N`. It also possible to get the tactics for integers by a +``Require Import Lia``, rationals ``Require Import Lqa`` and reals +``Require Import Lra``. + :tacn:`lia` is a decision procedure for linear integer arithmetic; + :tacn:`nia` is an incomplete proof procedure for integer non-linear @@ -23,7 +25,7 @@ rationals ``Require Import Lqa`` and reals ``Require Import Lra``. ``n`` is an optional integer limiting the proof search depth, is an incomplete proof procedure for non-linear arithmetic. It is based on John Harrison’s HOL Light - driver to the external prover `csdp` [#]_. Note that the `csdp` driver is + driver to the external prover `csdp` [#csdp]_. Note that the `csdp` driver is generating a *proof cache* which makes it possible to rerun scripts even without `csdp`. @@ -78,7 +80,7 @@ closed under the following rules: \end{array}` The following theorem provides a proof principle for checking that a -set of polynomial inequalities does not have solutions [#]_. +set of polynomial inequalities does not have solutions [#fnpsatz]_. .. _psatz_thm: @@ -111,32 +113,21 @@ and checked to be :math:`-1`. The deductive power of :tacn:`lra` overlaps with the one of :tacn:`field` tactic *e.g.*, :math:`x = 10 * x / 10` is solved by :tacn:`lra`. - `lia`: a tactic for linear integer arithmetic --------------------------------------------- .. tacn:: lia :name: lia - This tactic offers an alternative to the :tacn:`omega` tactic. Roughly - speaking, the deductive power of lia is the combined deductive power of - :tacn:`ring_simplify` and :tacn:`omega`. However, it solves linear goals - that :tacn:`omega` does not solve, such as the following so-called *omega - nightmare* :cite:`TheOmegaPaper`. - -.. coqdoc:: - - Goal forall x y, - 27 <= 11 * x + 13 * y <= 45 -> - -10 <= 7 * x - 9 * y <= 4 -> False. + This tactic solves linear goals over :g:`Z` by searching for *linear* refutations and cutting planes. + :tacn:`lia` provides support for :g:`Z`, :g:`nat`, :g:`positive` and :g:`N` by pre-processing via the :tacn:`zify` tactic. -The estimation of the relative efficiency of :tacn:`lia` *vs* :tacn:`omega` is under evaluation. High level view of `lia` ~~~~~~~~~~~~~~~~~~~~~~~~ Over :math:`\mathbb{R}`, *positivstellensatz* refutations are a complete proof -principle [#]_. However, this is not the case over :math:`\mathbb{Z}`. Actually, +principle [#mayfail]_. However, this is not the case over :math:`\mathbb{Z}`. Actually, *positivstellensatz* refutations are not even sufficient to decide linear *integer* arithmetic. The canonical example is :math:`2 * x = 1 -> \mathtt{False}` which is a theorem of :math:`\mathbb{Z}` but not a theorem of :math:`{\mathbb{R}}`. To remedy this @@ -249,21 +240,55 @@ 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 :g:`nat` and :g:`N` is obtained by pre-processing the goal with - the ``zify`` tactic. -.. [#] Support for :g:`Z.div` and :g:`Z.modulo` may be obtained by - pre-processing the goal with the ``Z.div_mod_to_equations`` tactic (you may - need to manually run ``zify`` first). -.. [#] Support for :g:`Z.quot` and :g:`Z.rem` may be obtained by pre-processing - the goal with the ``Z.quot_rem_to_equations`` tactic (you may need to manually - run ``zify`` first). -.. [#] Note that support for :g:`Z.div`, :g:`Z.modulo`, :g:`Z.quot`, and - :g:`Z.rem` may be simultaneously obtained by pre-processing the goal with the - ``Z.to_euclidean_division_equations`` tactic (you may need to manually run - ``zify`` first). -.. [#] Sources and binaries can be found at https://projects.coin-or.org/Csdp -.. [#] Variants deal with equalities and strict inequalities. -.. [#] In practice, the oracle might fail to produce such a refutation. +`zify`: pre-processing of arithmetic goals +------------------------------------------ + +.. tacn:: zify + :name: zify + + This tactic is internally called by :tacn:`lia` to support additional types e.g., :g:`nat`, :g:`positive` and :g:`N`. + By requiring the module ``ZifyBool``, the boolean type :g:`bool` and some comparison operators are also supported. + :tacn:`zify` can also be extended by rebinding the tactic `Zify.zify_post_hook` that is run immediately after :tacn:`zify`. + + + To support :g:`Z.div` and :g:`Z.modulo`: ``Ltac Zify.zify_post_hook ::= Z.div_mod_to_equations``. + + To support :g:`Z.quot` and :g:`Z.rem`: ``Ltac Zify.zify_post_hook ::= Z.quot_rem_to_equations``. + + To support :g:`Z.div`, :g:`Z.modulo`, :g:`Z.quot`, and :g:`Z.rem`: ``Ltac Zify.zify_post_hook ::= Z.to_euclidean_division_equations``. + + +.. cmd:: Show Zify InjTyp + :name: Show Zify InjTyp + + This command shows the list of types that can be injected into :g:`Z`. + +.. cmd:: Show Zify BinOp + :name: Show Zify BinOp + + This command shows the list of binary operators processed by :tacn:`zify`. + +.. cmd:: Show Zify BinRel + :name: Show Zify BinRel + + This command shows the list of binary relations processed by :tacn:`zify`. + + +.. cmd:: Show Zify UnOp + :name: Show Zify UnOp + + This command shows the list of unary operators processed by :tacn:`zify`. + +.. cmd:: Show Zify CstOp + :name: Show Zify CstOp + + This command shows the list of constants processed by :tacn:`zify`. + +.. cmd:: Show Zify Spec + :name: Show Zify Spec + + This command shows the list of operators over :g:`Z` that are compiled using their specification e.g., :g:`Z.min`. + +.. [#csdp] Sources and binaries can be found at https://projects.coin-or.org/Csdp +.. [#fnpsatz] Variants deal with equalities and strict inequalities. +.. [#mayfail] In practice, the oracle might fail to produce such a refutation. .. comment in original TeX: .. %% \paragraph{The {\tt sos} tactic} -- where {\tt sos} stands for \emph{sum of squares} -- tries to prove that a diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index c591a1f1de..38b3c34209 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -649,6 +649,74 @@ Many bug fixes and documentation improvements, in particular: (in Proof General) `#421 <https://github.com/ProofGeneral/PG/pull/421>`_, by Jim Fehrle). +Changes in 8.10+beta3 +~~~~~~~~~~~~~~~~~~~~~ + +**Kernel** + +- Fix soundness issue with template polymorphism (`#9294 + <https://github.com/coq/coq/issues/9294>`_). + + Declarations of template-polymorphic inductive types ignored the + provenance of the universes they were abstracting on and did not + detect if they should be greater or equal to :math:`\Set` in + general. Previous universes and universes introduced by the inductive + definition could have constraints that prevented their instantiation + with e.g. :math:`\Prop`, resulting in unsound instantiations later. The + implemented fix only allows abstraction over universes introduced by + the inductive declaration, and properly records all their constraints + by making them by default only :math:`>= \Prop`. It is also checked + that a template polymorphic inductive actually is polymorphic on at + least one universe. + + This prevents inductive declarations in sections to be universe + polymorphic over section parameters. For a backward compatible fix, + simply hoist the inductive definition out of the section. + An alternative is to declare the inductive as universe-polymorphic and + cumulative in a universe-polymorphic section: all universes and + constraints will be properly gathered in this case. + See :ref:`Template-polymorphism` for a detailed exposition of the + rules governing template-polymorphic types. + + To help users incrementally fix this issue, a command line option + `-no-template-check` and a global flag :flag:`Template Check` are + available to selectively disable the new check. Use at your own risk. + + (`#9918 <https://github.com/coq/coq/pull/9918>`_, by Matthieu Sozeau + and Maxime Dénès). + +**User messages** + +- Improve the ambiguous paths warning to indicate which path is ambiguous with + new one + (`#10336 <https://github.com/coq/coq/pull/10336>`_, + closes `#3219 <https://github.com/coq/coq/issues/3219>`_, + by Kazuhiko Sakaguchi). + +**Extraction** + +- Fix extraction to OCaml of primitive machine integers; + see :ref:`primitive-integers` + (`#10430 <https://github.com/coq/coq/pull/10430>`_, + fixes `#10361 <https://github.com/coq/coq/issues/10361>`_, + by Vincent Laporte). +- Fix a printing bug of OCaml extraction on dependent record projections, which + produced improper `assert false`. This change makes the OCaml extractor + internally inline record projections by default; thus the monolithic OCaml + extraction (:cmd:`Extraction` and :cmd:`Recursive Extraction`) does not + produce record projection constants anymore except for record projections + explicitly instructed to extract, and records declared in opaque modules + (`#10577 <https://github.com/coq/coq/pull/10577>`_, + fixes `#7348 <https://github.com/coq/coq/issues/7348>`_, + by Kazuhiko Sakaguchi). + +**Standard library** + +- Added ``splitat`` function and lemmas about ``splitat`` and ``uncons`` + (`#9379 <https://github.com/coq/coq/pull/9379>`_, + by Yishuai Li, with help of Konstantinos Kallas, + follow-up of `#8365 <https://github.com/coq/coq/pull/8365>`_, + which added ``uncons`` in 8.10+beta1). Version 8.9 ----------- diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index ef183174d7..1611e9dd52 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -70,7 +70,7 @@ and function types over these sorts. Formally, we call :math:`\Sort` the set of sorts which is defined by: .. math:: - + \Sort \equiv \{\SProp,\Prop,\Set,\Type(i)\;|\; i~∈ â„•\} Their properties, such as: :math:`\Prop:\Type(1)`, :math:`\Set:\Type(1)`, and @@ -436,7 +436,7 @@ instance the identity function over a given type :math:`T` can be written this a *reduction* (or a *conversion*) rule we call :math:`β`: .. math:: - + E[Γ] ⊢ ((λx:T.~t)~u)~\triangleright_β~\subst{t}{x}{u} We say that :math:`\subst{t}{x}{u}` is the *β-contraction* of @@ -474,14 +474,14 @@ with its value, that is to expand (or unfold) it into its value. This reduction is called δ-reduction and shows as follows. .. inference:: Delta-Local - + \WFE{\Gamma} (x:=t:T) ∈ Γ -------------- E[Γ] ⊢ x~\triangleright_Δ~t .. inference:: Delta-Global - + \WFE{\Gamma} (c:=t:T) ∈ E -------------- @@ -499,7 +499,7 @@ destroyed, this reduction differs from δ-reduction. It is called ζ-reduction and shows as follows. .. inference:: Zeta - + \WFE{\Gamma} \WTEG{u}{U} \WTE{\Gamma::(x:=u:U)}{t}{T} @@ -533,17 +533,17 @@ for :math:`x` an arbitrary variable name fresh in :math:`t`. .. math:: f ~:~ ∀ x:\Type(2),~\Type(1) - + then .. math:: λ x:\Type(1).~(f~x) ~:~ ∀ x:\Type(1),~\Type(1) - + We could not allow .. math:: λ x:\Type(1).~(f~x) ~\triangleright_η~ f - + because the type of the reduced term :math:`∀ x:\Type(2),~\Type(1)` would not be convertible to the type of the original term :math:`∀ x:\Type(1),~\Type(1)`. @@ -665,7 +665,7 @@ a *subtyping* relation inductively defined by: .. math:: [c_1 : ∀Γ_P' ,∀ T_{1,1}' … T_{1,n_1}' ,~t'~v_{1,1}' … v_{1,m}' ;~…;~ c_k : ∀Γ_P' ,∀ T_{k,1}' … T_{k,n_k}' ,~t'~v_{k,1}' … v_{k,m}' ] - + respectively then .. math:: @@ -695,7 +695,7 @@ a *subtyping* relation inductively defined by: The conversion rule up to subtyping is now exactly: .. inference:: Conv - + E[Γ] ⊢ U : s E[Γ] ⊢ t : T E[Γ] ⊢ T ≤_{βδιζη} U @@ -716,13 +716,13 @@ that :math:`t_0` is :math:`λ x:T.~u_0` then one step of β-head reduction of :m .. math:: λ x_1 :T_1 .~… λ x_k :T_k .~(λ x:T.~u_0~t_1 … t_n ) ~\triangleright~ λ (x_1 :T_1 )…(x_k :T_k ).~(\subst{u_0}{x}{t_1}~t_2 … t_n ) - + Iterating the process of head reduction until the head of the reduced term is no more an abstraction leads to the *β-head normal form* of :math:`t`: .. math:: t \triangleright … \triangleright λ x_1 :T_1 .~…λ x_k :T_k .~(v~u_1 … u_m ) - + where :math:`v` is not an abstraction (nor an application). Note that the head normal form must not be confused with the normal form since some :math:`u_i` can be reducible. Similar notions of head-normal forms involving δ, ι @@ -828,7 +828,7 @@ We have to give the type of constants in a global environment :math:`E` which contains an inductive definition. .. inference:: Ind - + \WFE{Γ} \ind{p}{Γ_I}{Γ_C} ∈ E (a:A)∈Γ_I @@ -836,7 +836,7 @@ contains an inductive definition. E[Γ] ⊢ a : A .. inference:: Constr - + \WFE{Γ} \ind{p}{Γ_I}{Γ_C} ∈ E (c:C)∈Γ_C @@ -917,7 +917,7 @@ condition* for a constant :math:`X` in the following cases: + :math:`T=(X~t_1 … t_n )` and :math:`X` does not occur free in any :math:`t_i` + :math:`T=∀ x:U,~V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` satisfies the positivity condition for :math:`X`. - + Strict positivity +++++++++++++++++ @@ -931,10 +931,10 @@ cases: strictly positively in type :math:`V` + :math:`T` converts to :math:`(I~a_1 … a_m~t_1 … t_p )` where :math:`I` is the name of an inductive definition of the form - + .. math:: \ind{m}{I:A}{c_1 :∀ p_1 :P_1 ,… ∀p_m :P_m ,~C_1 ;~…;~c_n :∀ p_1 :P_1 ,… ∀p_m :P_m ,~C_n} - + (in particular, it is not mutually defined and it has :math:`m` parameters) and :math:`X` does not occur in any of the :math:`t_i`, and the (instantiated) types of constructor @@ -998,7 +998,7 @@ such that :math:`Γ_I` is :math:`[I_1 :∀ Γ_P ,A_1 ;~…;~I_k :∀ Γ_P ,A_k]` (E[Γ_I ;Γ_P ] ⊢ C_i : s_{q_i} )_{i=1… n} ------------------------------------------ \WF{E;~\ind{p}{Γ_I}{Γ_C}}{} - + provided that the following side conditions hold: @@ -1052,30 +1052,10 @@ between universes for inductive types in the Type hierarchy. Template polymorphism +++++++++++++++++++++ -Inductive types can be made polymorphic over their arguments -in :math:`\Type`. - -.. flag:: Auto Template Polymorphism - - This option, enabled by default, makes every inductive type declared - at level :math:`\Type` (without annotations or hiding it behind a - definition) template polymorphic. - - This can be prevented using the ``notemplate`` attribute. - - An inductive type can be forced to be template polymorphic using the - ``template`` attribute. - - Template polymorphism and universe polymorphism (see Chapter - :ref:`polymorphicuniverses`) are incompatible, so if the later is - enabled it will prevail over automatic template polymorphism and - cause an error when using the ``template`` attribute. - -.. warn:: Automatically declaring @ident as template polymorphic. - - Warning ``auto-template`` can be used to find which types are - implicitly declared template polymorphic by :flag:`Auto Template - Polymorphism`. +Inductive types can be made polymorphic over the universes introduced by +their parameters in :math:`\Type`, if the minimal inferred sort of the +inductive declarations either mention some of those parameter universes +or is computed to be :math:`\Prop` or :math:`\Set`. If :math:`A` is an arity of some sort and :math:`s` is a sort, we write :math:`A_{/s}` for the arity obtained from :math:`A` by replacing its sort with :math:`s`. @@ -1117,10 +1097,11 @@ provided that the following side conditions hold: + there are sorts :math:`s_i`, for :math:`1 ≤ i ≤ k` such that, for :math:`Γ_{I'} = [I_1 :∀ Γ_{P'} ,(A_1)_{/s_1} ;~…;~I_k :∀ Γ_{P'} ,(A_k)_{/s_k}]` we have :math:`(E[Γ_{I′} ;Γ_{P′}] ⊢ C_i : s_{q_i})_{i=1… n}` ; - + the sorts :math:`s_i` are such that all eliminations, to - :math:`\Prop`, :math:`\Set` and :math:`\Type(j)`, are allowed - (see Section :ref:`Destructors`). - + + the sorts :math:`s_i` are all introduced by the inductive + declaration and have no universe constraints beside being greater + than or equal to :math:`\Prop`, and such that all + eliminations, to :math:`\Prop`, :math:`\Set` and :math:`\Type(j)`, + are allowed (see Section :ref:`Destructors`). Notice that if :math:`I_j~q_1 … q_r` is typable using the rules **Ind-Const** and @@ -1141,6 +1122,61 @@ Conversion is preserved as any (partial) instance :math:`I_j~q_1 … q_r` or :math:`C_i~q_1 … q_r` is mapped to the names chosen in the specific instance of :math:`\ind{p}{Γ_I}{Γ_C}`. +.. warning:: + + The restriction that sorts are introduced by the inductive + declaration prevents inductive types declared in sections to be + template-polymorphic on universes introduced previously in the + section: they cannot parameterize over the universes introduced with + section variables that become parameters at section closing time, as + these may be shared with other definitions from the same section + which can impose constraints on them. + +.. flag:: Auto Template Polymorphism + + This option, enabled by default, makes every inductive type declared + at level :math:`\Type` (without annotations or hiding it behind a + definition) template polymorphic if possible. + + This can be prevented using the ``notemplate`` attribute. + +.. warn:: Automatically declaring @ident as template polymorphic. + + Warning ``auto-template`` can be used to find which types are + implicitly declared template polymorphic by :flag:`Auto Template + Polymorphism`. + + An inductive type can be forced to be template polymorphic using the + ``template`` attribute: it should then fullfill the criterion to + be template polymorphic or an error is raised. + +.. exn:: Inductive @ident cannot be made template polymorphic. + + This error is raised when the `#[universes(template)]` attribute is + on but the inductive cannot be made polymorphic on any universe or be + inferred to live in :math:`\Prop` or :math:`\Set`. + + Template polymorphism and universe polymorphism (see Chapter + :ref:`polymorphicuniverses`) are incompatible, so if the later is + enabled it will prevail over automatic template polymorphism and + cause an error when using the ``template`` attribute. + +.. flag:: Template Check + + Unsetting option :flag:`Template Check` disables the check of + locality of the sorts when abstracting the inductive over its + parameters. This is a deprecated and *unsafe* flag that can introduce + inconsistencies, it is only meant to help users incrementally update + code from Coq versions < 8.10 which did not implement this check. + The `Coq89.v` compatibility file sets this flag globally. A global + ``-no-template-check`` command line option is also available. Use at + your own risk. Use of this flag is recorded in the typing flags + associated to a definition but is *not* supported by the |Coq| + checker (`coqchk`). It will appear in :g:`Print Assumptions` and + :g:`About @ident` output involving inductive declarations that were + (potentially unsoundly) assumed to be template polymorphic. + + In practice, the rule **Ind-Family** is used by |Coq| only when all the inductive types of the inductive definition are declared with an arity whose sort is in the Type hierarchy. Then, the polymorphism is over @@ -1154,10 +1190,10 @@ inductive type is set in :math:`\Set` (even in case :math:`\Set` is impredicativ Section The-Calculus-of-Inductive-Construction-with-impredicative-Set_), and otherwise in the Type hierarchy. -Note that the side-condition about allowed elimination sorts in the -rule **Ind-Family** is just to avoid to recompute the allowed elimination -sorts at each instance of a pattern matching (see Section :ref:`Destructors`). As -an example, let us consider the following definition: +Note that the side-condition about allowed elimination sorts in the rule +**Ind-Family** avoids to recompute the allowed elimination sorts at each +instance of a pattern matching (see Section :ref:`Destructors`). As an +example, let us consider the following definition: .. example:: @@ -1320,7 +1356,7 @@ using the syntax: \Match~m~\as~x~\In~I~\_~a~\return~P~\with~ (c_1~x_{11} ... x_{1p_1} ) ⇒ f_1 | … | (c_n~x_{n1} ... x_{np_n} ) ⇒ f_n~\kwend - + The :math:`\as` part can be omitted if either the result type does not depend on :math:`m` (non-dependent elimination) or :math:`m` is a variable (in this case, :math:`m` can occur in :math:`P` where it is considered a bound variable). The :math:`\In` part @@ -1360,7 +1396,7 @@ There is no restriction on the sort of the predicate to be eliminated. ----------------------- [I:∀ x:A,~A′|∀ x:A,~B′] - + .. inference:: Set & Type s_1 ∈ \{\Set,\Type(j)\} @@ -1376,7 +1412,7 @@ is also of sort :math:`\Prop` or is of the morally smaller sort :math:`\SProp`. .. inference:: Prop - + s ∈ \{\SProp,\Prop\} -------------------- [I:\Prop|I→s] @@ -1404,7 +1440,7 @@ the proof of :g:`or A B` is not accepted: Fail Definition choice (A B: Prop) (x:or A B) := match x with or_introl _ _ a => true | or_intror _ _ b => false end. - + From the computational point of view, the structure of the proof of :g:`(or A B)` in this term is needed for computing the boolean value. @@ -1441,7 +1477,7 @@ this type. :math:`\Prop` for which more eliminations are allowed. .. inference:: Prop-extended - + I~\kw{is an empty or singleton definition} s ∈ \Sort ------------------------------------- @@ -1589,7 +1625,7 @@ An ι-redex is a term of the following form: .. math:: \case((c_{p_i}~q_1 … q_r~a_1 … a_m ),P,f_1 |… |f_l ) - + with :math:`c_{p_i}` the :math:`i`-th constructor of the inductive type :math:`I` with :math:`r` parameters. @@ -1636,7 +1672,7 @@ Typing rule The typing rule is the expected one for a fixpoint. .. inference:: Fix - + (E[Γ] ⊢ A_i : s_i )_{i=1… n} (E[Γ;~f_1 :A_1 ;~…;~f_n :A_n ] ⊢ t_i : A_i )_{i=1… n} ------------------------------------------------------- @@ -1749,7 +1785,7 @@ The reduction for fixpoints is: .. math:: (\Fix~f_i \{F\}~a_1 …a_{k_i}) ~\triangleright_ι~ \subst{t_i}{f_k}{\Fix~f_k \{F\}}_{k=1… n} ~a_1 … a_{k_i} - + when :math:`a_{k_i}` starts with a constructor. This last restriction is needed in order to keep strong normalization and corresponds to the reduction for primitive recursive operators. The following reductions are now @@ -1808,11 +1844,11 @@ and :math:`\subst{E}{|Γ|}{|Γ|c}` to mean the parallel substitution {\WF{E;~c:U;~E′;~c′:=λ x:U.~\subst{t}{c}{x}:∀x:U,~\subst{T}{c}{x};~\subst{E″}{c′}{(c′~c)}} {\subst{Γ}{c′}{(c′~c)}}} - + .. math:: \frac{\WF{E;~c:U;~E′;~c′:T;~E″}{Γ}} {\WF{E;~c:U;~E′;~c′:∀ x:U,~\subst{T}{c}{x};~\subst{E″}{c′}{(c′~c)}}{\subst{Γ}{c′}{(c′~c)}}} - + .. math:: \frac{\WF{E;~c:U;~E′;~\ind{p}{Γ_I}{Γ_C};~E″}{Γ}} {\WFTWOLINES{E;~c:U;~E′;~\ind{p+1}{∀ x:U,~\subst{Γ_I}{c}{x}}{∀ x:U,~\subst{Γ_C}{c}{x}};~ @@ -1853,7 +1889,7 @@ One can consequently derive the following property. .. _First-pruning-property: .. inference:: First pruning property: - + \WF{E;~c:U;~E′}{Γ} c~\kw{does not occur in}~E′~\kw{and}~Γ -------------------------------------- @@ -1933,5 +1969,3 @@ impredicative system for sort :math:`\Set` become: s ∈ \{\Type(i)\} ---------------- [I:\Set|I→ s] - - diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index 7d6171285e..b1f392c337 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -179,10 +179,13 @@ compilation, printing, web browsing. In the browser command, you may use `%s` to denote the URL to open, for example: `firefox -remote "OpenURL(%s)"`. -Notice that these settings are saved in the file `.coqiderc` of your -home directory. +Notice that these settings are saved in the file ``coqiderc`` in the +``coq`` subdirectory of the user configuration directory which +is the value of ``$XDG_CONFIG_HOME`` if this environment variable is +set and which otherwise is ``$HOME/.config/``. -A Gtk2 accelerator keymap is saved under the name `.coqide.keys`. It +A GTK+ accelerator keymap is saved under the name ``coqide.keys`` in +the same ``coq`` subdirectory of the user configuration directory. It is not recommended to edit this file manually: to modify a given menu shortcut, go to the corresponding menu item without releasing the mouse button, press the key you want for the new shortcut, and release @@ -259,8 +262,9 @@ Adding custom bindings ~~~~~~~~~~~~~~~~~~~~~~ To extend the default set of bindings, create a file named ``coqide.bindings`` -and place it in the same folder as ``coqide.keys``. On Linux, this would be -the folder ``~/.config/coq``. The file `coqide.bindings` should contain one +and place it in the same folder as ``coqide.keys``. This would be +the folder ``$XDG_CONFIG_HOME/coq``, defaulting to ``~/.config/coq`` +if ``XDG_CONFIG_HOME`` is unset. The file `coqide.bindings` should contain one binding per line, in the form ``\key value``, followed by an optional priority integer. (The key and value should not contain any space character.) diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index c391cc949d..2885d6dc33 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -627,6 +627,7 @@ file is a particular case of module called *library file*. as ``Export``. .. cmdv:: From @dirpath Require @qualid + :name: From ... Require ... This command acts as :cmd:`Require`, but picks any library whose absolute name is of the form :n:`@dirpath.@dirpath’.@qualid` diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index 46175e37ed..bc4d8b95ab 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -42,6 +42,10 @@ plugins/micromega/Tauto.v plugins/micromega/VarMap.v plugins/micromega/ZCoeff.v plugins/micromega/ZMicromega.v +plugins/micromega/ZifyInst.v +plugins/micromega/ZifyBool.v +plugins/micromega/ZifyClasses.v +plugins/micromega/Zify.v plugins/nsatz/Nsatz.v plugins/omega/Omega.v plugins/omega/OmegaLemmas.v diff --git a/engine/evarutil.ml b/engine/evarutil.ml index ea71be8e43..c946125d3f 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -861,12 +861,12 @@ let compare_constructor_instances evd u u' = in Evd.add_universe_constraints evd soft -(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and - [u] up to existential variable instantiation and equalisable - universes. The term [t] is interpreted in [sigma1] while [u] is - interpreted in [sigma2]. The universe constraints in [sigma2] are - assumed to be an extension of those in [sigma1]. *) -let eq_constr_univs_test sigma1 sigma2 t u = +(** [eq_constr_univs_test ~evd ~extended_evd t u] tests equality of + [t] and [u] up to existential variable instantiation and + equalisable universes. The term [t] is interpreted in [evd] while + [u] is interpreted in [extended_evd]. The universe constraints in + [extended_evd] are assumed to be an extension of those in [evd]. *) +let eq_constr_univs_test ~evd ~extended_evd t u = (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *) let open Evd in let t = EConstr.Unsafe.to_constr t @@ -877,8 +877,8 @@ let eq_constr_univs_test sigma1 sigma2 t u = in let ans = UnivProblem.eq_constr_univs_infer_with - (fun t -> kind_of_term_upto sigma1 t) - (fun u -> kind_of_term_upto sigma2 u) - (universes sigma2) fold t u sigma2 + (fun t -> kind_of_term_upto evd t) + (fun u -> kind_of_term_upto extended_evd u) + (universes extended_evd) fold t u extended_evd in match ans with None -> false | Some _ -> true diff --git a/engine/evarutil.mli b/engine/evarutil.mli index e9d579af32..7877b94582 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -204,12 +204,17 @@ val finalize : ?abort_on_undefined_evars:bool -> evar_map -> val kind_of_term_upto : evar_map -> Constr.constr -> (Constr.constr, Constr.types, Sorts.t, Univ.Instance.t) kind_of_term -(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and - [u] up to existential variable instantiation and equalisable - universes. The term [t] is interpreted in [sigma1] while [u] is - interpreted in [sigma2]. The universe constraints in [sigma2] are - assumed to be an extension of those in [sigma1]. *) -val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool +(** [eq_constr_univs_test ~evd ~extended_evd t u] tests equality of + [t] and [u] up to existential variable instantiation and + equalisable universes. The term [t] is interpreted in [evd] while + [u] is interpreted in [extended_evd]. The universe constraints in + [extended_evd] are assumed to be an extension of those in [evd]. *) +val eq_constr_univs_test : + evd:Evd.evar_map -> + extended_evd:Evd.evar_map -> + constr -> + constr -> + bool (** [compare_cumulative_instances cv_pb variance u1 u2 sigma] Returns [Inl sigma'] where [sigma'] is [sigma] augmented with universe diff --git a/engine/evd.ml b/engine/evd.ml index b621a3fe2f..6a721a1a8a 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -702,7 +702,7 @@ let empty = { } let from_env e = - { empty with universes = UState.make (Environ.universes e) } + { empty with universes = UState.make ~lbound:(Environ.universes_lbound e) (Environ.universes e) } let from_ctx ctx = { empty with universes = ctx } diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index 7c06bb59f1..3c383b2e00 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -30,7 +30,7 @@ exception Exception of exn (** This exception is used to signal abortion in [timeout] functions. *) -exception Timeout +exception Tac_Timeout (** This exception is used by the tactics to signal failure by lack of successes, rather than some other exceptions (like system @@ -38,7 +38,6 @@ exception Timeout exception TacticFailure of exn let _ = CErrors.register_handler begin function - | Timeout -> CErrors.user_err ~hdr:"Some timeout function" (Pp.str"Timeout!") | Exception e -> CErrors.print e | TacticFailure e -> CErrors.print e | _ -> raise CErrors.Unhandled @@ -99,7 +98,7 @@ struct let print_char = fun c -> (); fun () -> print_char c let timeout = fun n t -> (); fun () -> - Control.timeout n t () (Exception Timeout) + Control.timeout n t () (Exception Tac_Timeout) let make f = (); fun () -> try f () @@ -108,7 +107,7 @@ struct Util.iraise (Exception e, info) (** Use the current logger. The buffer is also flushed. *) - let print_debug s = make (fun _ -> Feedback.msg_info s) + let print_debug s = make (fun _ -> Feedback.msg_debug s) let print_info s = make (fun _ -> Feedback.msg_info s) let print_warning s = make (fun _ -> Feedback.msg_warning s) let print_notice s = make (fun _ -> Feedback.msg_notice s) diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli index 90c920439a..75920455ce 100644 --- a/engine/logic_monad.mli +++ b/engine/logic_monad.mli @@ -30,7 +30,7 @@ exception Exception of exn (** This exception is used to signal abortion in [timeout] functions. *) -exception Timeout +exception Tac_Timeout (** This exception is used by the tactics to signal failure by lack of successes, rather than some other exceptions (like system diff --git a/engine/proofview.ml b/engine/proofview.ml index 8b5bd4cd80..1f076470c1 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -849,7 +849,8 @@ let give_up = module Progress = struct - let eq_constr = Evarutil.eq_constr_univs_test + let eq_constr evd extended_evd = + Evarutil.eq_constr_univs_test ~evd ~extended_evd (** equality function on hypothesis contexts *) let eq_named_context_val sigma1 sigma2 ctx1 ctx2 = @@ -879,10 +880,10 @@ module Progress = struct eq_evar_body sigma1 sigma2 ei1.evar_body ei2.evar_body (** Equality function on goals *) - let goal_equal evars1 gl1 evars2 gl2 = - let evi1 = Evd.find evars1 gl1 in - let evi2 = Evd.find evars2 gl2 in - eq_evar_info evars1 evars2 evi1 evi2 + let goal_equal ~evd ~extended_evd evar extended_evar = + let evi = Evd.find evd evar in + let extended_evi = Evd.find extended_evd extended_evar in + eq_evar_info evd extended_evd evi extended_evi end @@ -899,17 +900,17 @@ let tclPROGRESS t = let test = quick_test || Util.List.for_all2eq begin fun i f -> - Progress.goal_equal initial.solution (drop_state i) final.solution (drop_state f) + Progress.goal_equal ~evd:initial.solution + ~extended_evd:final.solution (drop_state i) (drop_state f) end initial.comb final.comb in if not test then tclUNIT res else - tclZERO (CErrors.UserError (Some "Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) + tclZERO (CErrors.UserError (Some "Proofview.tclPROGRESS", Pp.str "Failed to progress.")) -exception Timeout let _ = CErrors.register_handler begin function - | Timeout -> CErrors.user_err ~hdr:"Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") + | Logic_monad.Tac_Timeout -> CErrors.user_err ~hdr:"Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") | _ -> raise CErrors.Unhandled end @@ -934,7 +935,8 @@ let tclTIMEOUT n t = end begin let open Logic_monad.NonLogical in function (e, info) -> match e with - | Logic_monad.Timeout -> return (Util.Inr (Timeout, info)) + | Logic_monad.Tac_Timeout -> + return (Util.Inr (Logic_monad.Tac_Timeout, info)) | Logic_monad.TacticFailure e -> return (Util.Inr (e, info)) | e -> Logic_monad.NonLogical.raise ~info e diff --git a/engine/proofview.mli b/engine/proofview.mli index f90f02f3e1..764a4a0058 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -398,14 +398,23 @@ val give_up : unit tactic val tclPROGRESS : 'a tactic -> 'a tactic module Progress : sig - val goal_equal : Evd.evar_map -> Evar.t -> Evd.evar_map -> Evar.t -> bool +(** [goal_equal ~evd ~extended_evd evar extended_evar] tests whether + the [evar_info] from [evd] corresponding to [evar] is equal to that + from [extended_evd] corresponding to [extended_evar], up to + existential variable instantiation and equalisable universes. The + universe constraints in [extended_evd] are assumed to be an + extension of the universe constraints in [evd]. *) + val goal_equal : + evd:Evd.evar_map -> + extended_evd:Evd.evar_map -> + Evar.t -> + Evar.t -> + bool end (** Checks for interrupts *) val tclCHECKINTERRUPT : unit tactic -exception Timeout - (** [tclTIMEOUT n t] can have only one success. In case of timeout if fails with [tclZERO Timeout]. *) val tclTIMEOUT : int -> 'a tactic -> 'a tactic diff --git a/engine/uState.ml b/engine/uState.ml index 5ed016e0d0..cb40e6eadd 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -34,6 +34,7 @@ type t = (** The subset of unification variables that can be instantiated with algebraic universes as they appear in inferred types only. *) uctx_universes : UGraph.t; (** The current graph extended with the local constraints *) + uctx_universes_lbound : Univ.Level.t; (** The lower bound on universes (e.g. Set or Prop) *) uctx_initial_universes : UGraph.t; (** The graph at the creation of the evar_map *) uctx_weak_constraints : UPairSet.t } @@ -47,6 +48,7 @@ let empty = uctx_univ_variables = LMap.empty; uctx_univ_algebraic = LSet.empty; uctx_universes = initial_sprop_cumulative; + uctx_universes_lbound = Univ.Level.set; uctx_initial_universes = initial_sprop_cumulative; uctx_weak_constraints = UPairSet.empty; } @@ -54,10 +56,12 @@ let elaboration_sprop_cumul = Goptions.declare_bool_option_and_ref ~depr:false ~name:"SProp cumulativity during elaboration" ~key:["Elaboration";"StrictProp";"Cumulativity"] ~value:true -let make u = +let make ~lbound u = let u = if elaboration_sprop_cumul () then UGraph.make_sprop_cumulative u else u in - { empty with - uctx_universes = u; uctx_initial_universes = u} + { empty with + uctx_universes = u; + uctx_universes_lbound = lbound; + uctx_initial_universes = u} let is_empty ctx = ContextSet.is_empty ctx.uctx_local && @@ -83,7 +87,7 @@ let union ctx ctx' = let newus = LSet.diff newus (LMap.domain ctx.uctx_univ_variables) in let weak = UPairSet.union ctx.uctx_weak_constraints ctx'.uctx_weak_constraints in let declarenew g = - LSet.fold (fun u g -> UGraph.add_universe u false g) newus g + LSet.fold (fun u g -> UGraph.add_universe u ~lbound:ctx.uctx_universes_lbound ~strict:false g) newus g in let names_rev = LMap.lunion (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); @@ -99,6 +103,7 @@ let union ctx ctx' = else let cstrsr = ContextSet.constraints ctx'.uctx_local in UGraph.merge_constraints cstrsr (declarenew ctx.uctx_universes)); + uctx_universes_lbound = ctx.uctx_universes_lbound; uctx_weak_constraints = weak} let context_set ctx = ctx.uctx_local @@ -431,18 +436,19 @@ let check_univ_decl ~poly uctx decl = (ContextSet.constraints uctx.uctx_local); ctx -let restrict_universe_context (univs, csts) keep = +let restrict_universe_context ~lbound (univs, csts) keep = let removed = LSet.diff univs keep in 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.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 = LSet.fold (fun v g -> if Level.is_small v then g else + UGraph.add_universe v ~lbound ~strict:false g) allunivs g in let g = UGraph.merge_constraints csts g 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 + not ((Level.equal l lbound && d == Le) || (Level.is_prop l && d == Lt && Level.is_set r))) csts in (LSet.inter univs keep, csts) let restrict ctx vars = @@ -450,7 +456,7 @@ let restrict ctx vars = let vars = Names.Id.Map.fold (fun na l vars -> LSet.add l vars) (fst ctx.uctx_names) vars in - let uctx' = restrict_universe_context ctx.uctx_local vars in + let uctx' = restrict_universe_context ~lbound:ctx.uctx_universes_lbound ctx.uctx_local vars in { ctx with uctx_local = uctx' } let demote_seff_univs universes uctx = @@ -497,7 +503,7 @@ let merge ?loc ~sideff ~extend rigid uctx ctx' = else ContextSet.append ctx' uctx.uctx_local in let declare g = LSet.fold (fun u g -> - try UGraph.add_universe u false g + try UGraph.add_universe ~lbound:uctx.uctx_universes_lbound ~strict:false u g with UGraph.AlreadyDeclared when sideff -> g) levels g in @@ -544,16 +550,17 @@ let new_univ_variable ?loc rigid name | None -> add_uctx_loc u loc uctx.uctx_names in let initial = - UGraph.add_universe u false uctx.uctx_initial_universes + UGraph.add_universe ~lbound:uctx.uctx_universes_lbound ~strict:false u uctx.uctx_initial_universes in let uctx' = {uctx' with uctx_names = names; uctx_local = ctx'; - uctx_universes = UGraph.add_universe u false uctx.uctx_universes; + uctx_universes = UGraph.add_universe ~lbound:uctx.uctx_universes_lbound ~strict:false + u uctx.uctx_universes; uctx_initial_universes = initial} in uctx', u -let make_with_initial_binders e us = - let uctx = make e in +let make_with_initial_binders ~lbound e us = + let uctx = make ~lbound e in List.fold_left (fun uctx { CAst.loc; v = id } -> fst (new_univ_variable ?loc univ_rigid (Some id) uctx)) @@ -561,10 +568,10 @@ let make_with_initial_binders e us = let add_global_univ uctx u = let initial = - UGraph.add_universe u true uctx.uctx_initial_universes + UGraph.add_universe ~lbound:Univ.Level.set ~strict:true u uctx.uctx_initial_universes in let univs = - UGraph.add_universe u true uctx.uctx_universes + UGraph.add_universe ~lbound:Univ.Level.set ~strict:true u uctx.uctx_universes in { uctx with uctx_local = ContextSet.add_universe u uctx.uctx_local; uctx_initial_universes = initial; @@ -679,8 +686,9 @@ let refresh_undefined_univ_variables uctx = uctx.uctx_univ_variables LMap.empty in let weak = UPairSet.fold (fun (u,v) acc -> UPairSet.add (subst_fn u, subst_fn v) acc) uctx.uctx_weak_constraints UPairSet.empty in - let declare g = LSet.fold (fun u g -> UGraph.add_universe u false g) - (ContextSet.levels ctx') g in + let lbound = uctx.uctx_universes_lbound in + let declare g = LSet.fold (fun u g -> UGraph.add_universe u ~lbound ~strict:false g) + (ContextSet.levels ctx') g in let initial = declare uctx.uctx_initial_universes in let univs = declare UGraph.initial_universes in let uctx' = {uctx_names = uctx.uctx_names; @@ -688,14 +696,16 @@ let refresh_undefined_univ_variables uctx = uctx_seff_univs = uctx.uctx_seff_univs; uctx_univ_variables = vars; uctx_univ_algebraic = alg; uctx_universes = univs; + uctx_universes_lbound = lbound; uctx_initial_universes = initial; uctx_weak_constraints = weak; } in uctx', subst let minimize uctx = let open UnivMinim in + let lbound = uctx.uctx_universes_lbound in let ((vars',algs'), us') = - normalize_context_set uctx.uctx_universes uctx.uctx_local uctx.uctx_univ_variables + normalize_context_set ~lbound uctx.uctx_universes uctx.uctx_local uctx.uctx_univ_variables uctx.uctx_univ_algebraic uctx.uctx_weak_constraints in if ContextSet.equal us' uctx.uctx_local then uctx @@ -709,6 +719,7 @@ let minimize uctx = uctx_univ_variables = vars'; uctx_univ_algebraic = algs'; uctx_universes = universes; + uctx_universes_lbound = lbound; uctx_initial_universes = uctx.uctx_initial_universes; uctx_weak_constraints = UPairSet.empty; (* weak constraints are consumed *) } diff --git a/engine/uState.mli b/engine/uState.mli index 9689f2e961..52e48c4eeb 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -25,9 +25,9 @@ type t val empty : t -val make : UGraph.t -> t +val make : lbound:Univ.Level.t -> UGraph.t -> t -val make_with_initial_binders : UGraph.t -> lident list -> t +val make_with_initial_binders : lbound:Univ.Level.t -> UGraph.t -> lident list -> t val is_empty : t -> bool @@ -88,11 +88,11 @@ val universe_of_name : t -> Id.t -> Univ.Level.t (** {5 Unification} *) -(** [restrict_universe_context (univs,csts) keep] restricts [univs] to +(** [restrict_universe_context lbound (univs,csts) keep] restricts [univs] to the universes in [keep]. The constraints [csts] are adjusted so that transitive constraints between remaining universes (those in [keep] and those not in [univs]) are preserved. *) -val restrict_universe_context : ContextSet.t -> LSet.t -> ContextSet.t +val restrict_universe_context : lbound:Univ.Level.t -> ContextSet.t -> LSet.t -> ContextSet.t (** [restrict uctx ctx] restricts the local universes of [uctx] to [ctx] extended by local named universes and side effect universes diff --git a/engine/univMinim.ml b/engine/univMinim.ml index 1b7c33b9c1..30fdd28997 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -269,11 +269,11 @@ module UPairs = OrderedType.UnorderedPair(Univ.Level) module UPairSet = Set.Make (UPairs) (* TODO check is_small/sprop *) -let normalize_context_set g ctx us algs weak = +let normalize_context_set ~lbound g ctx us algs weak = let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in (* Keep the Prop/Set <= i constraints separate for minimization *) let smallles, csts = - Constraint.partition (fun (l,d,r) -> d == Le && Level.is_small l) csts + Constraint.partition (fun (l,d,r) -> d == Le && (Level.equal l lbound || Level.is_sprop l)) csts in let smallles = if get_set_minimization () then Constraint.filter (fun (l,d,r) -> LSet.mem r ctx && not (Level.is_sprop l)) smallles @@ -282,12 +282,12 @@ let normalize_context_set g ctx us algs weak = let csts, partition = (* We first put constraints in a normal-form: all self-loops are collapsed to equalities. *) - let g = LSet.fold (fun v g -> UGraph.add_universe v false g) + let g = LSet.fold (fun v g -> UGraph.add_universe ~lbound ~strict:false v g) ctx UGraph.initial_universes in let add_soft u g = if not (Level.is_small u || LSet.mem u ctx) - then try UGraph.add_universe u false g with UGraph.AlreadyDeclared -> g + then try UGraph.add_universe ~lbound ~strict:false u g with UGraph.AlreadyDeclared -> g else g in let g = Constraint.fold @@ -300,7 +300,7 @@ let normalize_context_set g ctx us algs weak = (* We ignore the trivial Prop/Set <= i constraints. *) let noneqs = Constraint.filter - (fun (l,d,r) -> not ((d == Le && Level.is_small l) || + (fun (l,d,r) -> not ((d == Le && Level.equal l lbound) || (Level.is_prop l && d == Lt && Level.is_set r))) csts in diff --git a/engine/univMinim.mli b/engine/univMinim.mli index 21f6efe86a..72b432e62f 100644 --- a/engine/univMinim.mli +++ b/engine/univMinim.mli @@ -25,7 +25,7 @@ module UPairSet : CSet.S with type elt = (Level.t * Level.t) (a global one if there is one) and transitively saturate the constraints w.r.t to the equalities. *) -val normalize_context_set : UGraph.t -> ContextSet.t -> +val normalize_context_set : lbound:Univ.Level.t -> UGraph.t -> ContextSet.t -> universe_opt_subst (* The defined and undefined variables *) -> LSet.t (* univ variables that can be substituted by algebraics *) -> UPairSet.t (* weak equality constraints *) -> diff --git a/engine/univops.mli b/engine/univops.mli index 6cc7868a38..1f1edbed16 100644 --- a/engine/univops.mli +++ b/engine/univops.mli @@ -15,5 +15,5 @@ open Univ val universes_of_constr : constr -> LSet.t [@@ocaml.deprecated "Use [Vars.universes_of_constr]"] -val restrict_universe_context : ContextSet.t -> LSet.t -> ContextSet.t +val restrict_universe_context : lbound:Univ.Level.t -> ContextSet.t -> LSet.t -> ContextSet.t [@@ocaml.deprecated "Use [UState.restrict_universe_context]"] diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index f86cb0f6f2..ff0b90dcff 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -10,6 +10,9 @@ open Util module type GLexerType = Plexing.Lexer +type ty_norec = TyNoRec +type ty_mayrec = TyMayRec + module type S = sig type te @@ -27,8 +30,6 @@ module type S = val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit end - type ty_norec = TyNoRec - type ty_mayrec = TyMayRec type ('self, 'trec, 'a) ty_symbol type ('self, 'trec, 'f, 'r) ty_rule type 'a ty_rules @@ -92,9 +93,6 @@ let tokens con = egram.gtokens; !list -type ty_norec = TyNoRec -type ty_mayrec = TyMayRec - type ('a, 'b, 'c) ty_and_rec = | NoRec2 : (ty_norec, ty_norec, ty_norec) ty_and_rec | MayRec2 : ('a, 'b, ty_mayrec) ty_and_rec diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli index 658baf1de9..9e48460206 100644 --- a/gramlib/grammar.mli +++ b/gramlib/grammar.mli @@ -19,6 +19,9 @@ module type GLexerType = Plexing.Lexer (** The input signature for the functor [Grammar.GMake]: [te] is the type of the tokens. *) +type ty_norec = TyNoRec +type ty_mayrec = TyMayRec + module type S = sig type te @@ -36,8 +39,6 @@ module type S = val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit end - type ty_norec = TyNoRec - type ty_mayrec = TyMayRec type ('self, 'trec, 'a) ty_symbol type ('self, 'trec, 'f, 'r) ty_rule type 'a ty_rules diff --git a/ide/MacOS/default_accel_map b/ide/MacOS/default_accel_map deleted file mode 100644 index 6bcf3b438f..0000000000 --- a/ide/MacOS/default_accel_map +++ /dev/null @@ -1,366 +0,0 @@ -; coqide GtkAccelMap rc-file -*- scheme -*- -; this file is an automated accelerator map dump -; -; (gtk_accel_path "<Actions>/Templates/Template Read Module" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic pattern" "") -(gtk_accel_path "<Actions>/Templates/Definition" "<Shift><Primary>d") -; (gtk_accel_path "<Actions>/Templates/Template Program Lemma" "") -(gtk_accel_path "<Actions>/Templates/Lemma" "<Shift><Primary>l") -; (gtk_accel_path "<Actions>/Templates/Template Fact" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic fold" "") -; (gtk_accel_path "<Actions>/Help/About Coq" "") -; (gtk_accel_path "<Actions>/Templates/Template Add Ring A Aplus Amult Aone Azero Ainv Aeq T [ c1 ... cn ]. " "") -; (gtk_accel_path "<Actions>/Templates/Template Hypothesis" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic repeat" "") -; (gtk_accel_path "<Actions>/Templates/Template Unset Extraction Optimize" "") -; (gtk_accel_path "<Actions>/Templates/Template Add Printing Constructor" "") -; (gtk_accel_path "<Actions>/Windows/Detach View" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic inversion" "") -; (gtk_accel_path "<Actions>/Templates/Template Write State" "") -; (gtk_accel_path "<Actions>/Export/Export to" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic inversion--clear" "") -; (gtk_accel_path "<Actions>/Templates/Template Implicit Arguments" "") -; (gtk_accel_path "<Actions>/Edit/Copy" "<Primary>c") -; (gtk_accel_path "<Actions>/Tactics/Tactic inversion -- using" "") -; (gtk_accel_path "<Actions>/View/Previous tab" "<Shift>Left") -; (gtk_accel_path "<Actions>/Tactics/Tactic change -- in" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic jp" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic red" "") -; (gtk_accel_path "<Actions>/Templates/Template Coercion" "") -; (gtk_accel_path "<Actions>/Templates/Template CoFixpoint" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic intros until" "") -; (gtk_accel_path "<Actions>/Templates/Template Derive Dependent Inversion" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic eapply" "") -; (gtk_accel_path "<Actions>/View/View" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic change" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic firstorder using" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic decompose sum" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic cut" "") -; (gtk_accel_path "<Actions>/Templates/Template Remove Printing Let" "") -; (gtk_accel_path "<Actions>/Templates/Template Structure" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic compute in" "") -; (gtk_accel_path "<Actions>/Queries/Locate" "") -; (gtk_accel_path "<Actions>/Templates/Template Save." "") -; (gtk_accel_path "<Actions>/Templates/Template Canonical Structure" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic compare" "") -; (gtk_accel_path "<Actions>/Templates/Template Next Obligation" "") -(gtk_accel_path "<Actions>/View/Display notations" "<Shift><Control>n") -; (gtk_accel_path "<Actions>/Tactics/Tactic fail" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic left" "") -(gtk_accel_path "<Actions>/Edit/Undo" "<Primary>u") -; (gtk_accel_path "<Actions>/Templates/Template Infix" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic functional induction" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic clear" "") -; (gtk_accel_path "<Actions>/Templates/Template End Silent." "") -; (gtk_accel_path "<Actions>/Tactics/Tactic intros" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic constructor -- with" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic destruct" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic intro after" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic abstract" "") -; (gtk_accel_path "<Actions>/Compile/Compile buffer" "") -; (gtk_accel_path "<Actions>/Queries/About" "F5") -; (gtk_accel_path "<Actions>/Templates/Template CoInductive" "") -; (gtk_accel_path "<Actions>/Templates/Template Test Printing Wildcard" "") -; (gtk_accel_path "<Actions>/Templates/Template Unset Hyps--limit" "") -; (gtk_accel_path "<Actions>/Templates/Template Transparent" "") -; (gtk_accel_path "<Actions>/Export/Ps" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic elim" "") -; (gtk_accel_path "<Actions>/Templates/Template Extract Constant" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic assert (--:--)" "") -; (gtk_accel_path "<Actions>/Templates/Template Add Rec LoadPath" "") -; (gtk_accel_path "<Actions>/Edit/Redo" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic compute" "") -; (gtk_accel_path "<Actions>/Compile/Next error" "F7") -; (gtk_accel_path "<Actions>/Templates/Template Add ML Path" "") -; (gtk_accel_path "<Actions>/Templates/Template Test Printing If" "") -; (gtk_accel_path "<Actions>/Templates/Template Load Verbose" "") -; (gtk_accel_path "<Actions>/Templates/Template Reset Extraction Inline" "") -; (gtk_accel_path "<Actions>/Templates/Template Set Implicit Arguments" "") -; (gtk_accel_path "<Actions>/Templates/Template Test Printing Let" "") -; (gtk_accel_path "<Actions>/Windows/Windows" "") -; (gtk_accel_path "<Actions>/Templates/Template Defined." "") -(gtk_accel_path "<Actions>/Templates/match" "<Shift><Primary>c") -; (gtk_accel_path "<Actions>/Tactics/Tactic set (--:=--)" "") -; (gtk_accel_path "<Actions>/Templates/Template Proof." "") -; (gtk_accel_path "<Actions>/Compile/Make" "F6") -; (gtk_accel_path "<Actions>/Templates/Template Module Type" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic apply -- with" "") -; (gtk_accel_path "<Actions>/File/Save as" "") -; (gtk_accel_path "<Actions>/Templates/Template Set Hyps--limit" "") -; (gtk_accel_path "<Actions>/Templates/Template Global Variable" "") -; (gtk_accel_path "<Actions>/Templates/Template Remove Printing Constructor" "") -; (gtk_accel_path "<Actions>/Templates/Template Add Setoid" "") -; (gtk_accel_path "<Actions>/Edit/Find Next" "F3") -; (gtk_accel_path "<Actions>/Edit/Find" "<Primary>f") -; (gtk_accel_path "<Actions>/Templates/Template Add Relation" "") -; (gtk_accel_path "<Actions>/Queries/Print" "F4") -; (gtk_accel_path "<Actions>/Templates/Template Obligations Tactic" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic trivial" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic first" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic case" "") -; (gtk_accel_path "<Actions>/Templates/Template Hint Constructors" "") -; (gtk_accel_path "<Actions>/Templates/Template Add Abstract Ring A Aplus Amult Aone Azero Ainv Aeq T." "") -; (gtk_accel_path "<Actions>/Templates/Template Coercion Local" "") -(gtk_accel_path "<Actions>/View/Show Query Pane" "<Control>Escape") -; (gtk_accel_path "<Actions>/Tactics/Tactic cbv" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic inversion--clear -- in" "") -; (gtk_accel_path "<Actions>/Templates/Template Add Rec ML Path" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic apply" "") -; (gtk_accel_path "<Actions>/Export/Latex" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic inversion -- using -- in" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic generalize" "") -(gtk_accel_path "<Actions>/Navigation/Backward" "<Primary><Control>Up") -; (gtk_accel_path "<Actions>/Tactics/Tactic p" "") -(gtk_accel_path "<Actions>/Navigation/Hide" "<Primary><Control>h") -; (gtk_accel_path "<Actions>/File/Close buffer" "<Primary>w") -; (gtk_accel_path "<Actions>/Tactics/Tactic induction" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic eauto with" "") -(gtk_accel_path "<Actions>/View/Display raw matching expressions" "<Shift><Control>m") -; (gtk_accel_path "<Actions>/Tactics/Tactic d" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic u" "") -; (gtk_accel_path "<Actions>/Templates/Templates" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic s" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic lapply" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic t" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic r" "") -; (gtk_accel_path "<Actions>/Edit/Replace" "<Primary>r") -; (gtk_accel_path "<Actions>/Tactics/Tactic case -- with" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic eexact" "") -; (gtk_accel_path "<Actions>/Queries/Check" "F3") -; (gtk_accel_path "<Actions>/Tactics/Tactic omega" "") -; (gtk_accel_path "<Actions>/File/New" "<Primary>n") -; (gtk_accel_path "<Actions>/Tactics/Tactic l" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic intro" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic j" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic i" "") -; (gtk_accel_path "<Actions>/Templates/Template Definition" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic g" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic f" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic e" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic c" "") -(gtk_accel_path "<Actions>/File/Rehighlight" "<Primary>l") -; (gtk_accel_path "<Actions>/Tactics/Tactic simple inversion" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic a" "") -; (gtk_accel_path "<Actions>/Templates/Template Mutual Inductive" "") -; (gtk_accel_path "<Actions>/Templates/Template Extraction NoInline" "") -(gtk_accel_path "<Actions>/Templates/Theorem" "<Shift><Primary>t") -; (gtk_accel_path "<Actions>/Templates/Template Derive Dependent Inversion--clear" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic unfold" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic red in" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite <- -- in" "") -; (gtk_accel_path "<Actions>/Templates/Template Hint Extern" "") -; (gtk_accel_path "<Actions>/Templates/Template Unfocus" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic dependent inversion--clear" "") -; (gtk_accel_path "<Actions>/Help/Browse Coq Library" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic lazy" "") -; (gtk_accel_path "<Actions>/Templates/Template Scheme" "") -(gtk_accel_path "<Actions>/Tactics/tauto" "<Primary><Control>p") -; (gtk_accel_path "<Actions>/Tactics/Tactic cutrewrite" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic contradiction" "") -; (gtk_accel_path "<Actions>/Templates/Template Set Printing Wildcard" "") -; (gtk_accel_path "<Actions>/Templates/Template Add LoadPath" "") -(gtk_accel_path "<Actions>/Navigation/Previous" "<Primary><Control>less") -; (gtk_accel_path "<Actions>/Templates/Template Require" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic simpl" "") -; (gtk_accel_path "<Actions>/Templates/Template Require Import" "") -; (gtk_accel_path "<Actions>/Templates/Template Add Abstract Semi Ring A Aplus Amult Aone Azero Aeq T." "") -(gtk_accel_path "<Actions>/Navigation/Forward" "<Primary><Control>Down") -; (gtk_accel_path "<Actions>/Tactics/Tactic rename -- into" "") -; (gtk_accel_path "<Actions>/Compile/Compile" "") -; (gtk_accel_path "<Actions>/File/Save all" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic fix" "") -; (gtk_accel_path "<Actions>/Templates/Template Parameter" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic assert" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic do" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic ring" "") -; (gtk_accel_path "<Actions>/Export/Pdf" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic quote" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic symmetry in" "") -; (gtk_accel_path "<Actions>/Help/Help" "") -(gtk_accel_path "<Actions>/Templates/Inductive" "<Shift><Primary>i") -; (gtk_accel_path "<Actions>/Tactics/Tactic idtac" "") -; (gtk_accel_path "<Actions>/Templates/Template Syntax" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic intro -- after" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic fold -- in" "") -; (gtk_accel_path "<Actions>/Templates/Template Program Definition" "") -; (gtk_accel_path "<Actions>/Templates/Template Hint Resolve" "") -; (gtk_accel_path "<Actions>/Templates/Template Set Extraction Optimize" "") -; (gtk_accel_path "<Actions>/File/Revert all buffers" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic subst" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic autorewrite" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic pose" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic simplify--eq" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic clearbody" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic eauto" "") -; (gtk_accel_path "<Actions>/Templates/Template Grammar" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic exact" "") -; (gtk_accel_path "<Actions>/Templates/Template Unset Implicit Arguments" "") -; (gtk_accel_path "<Actions>/Templates/Template Extract Inductive" "") -(gtk_accel_path "<Actions>/View/Display implicit arguments" "<Shift><Control>i") -; (gtk_accel_path "<Actions>/Tactics/Tactic symmetry" "") -; (gtk_accel_path "<Actions>/Templates/Template Add Printing Let" "") -; (gtk_accel_path "<Actions>/Help/Help for keyword" "<Primary>h") -; (gtk_accel_path "<Actions>/File/Save" "<Primary>s") -; (gtk_accel_path "<Actions>/Compile/Make makefile" "") -; (gtk_accel_path "<Actions>/Templates/Template Remove LoadPath" "") -(gtk_accel_path "<Actions>/Navigation/Interrupt" "<Primary><Control>Break") -(gtk_accel_path "<Actions>/Navigation/End" "<Primary><Control>End") -; (gtk_accel_path "<Actions>/Templates/Template Add Morphism" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic field" "") -; (gtk_accel_path "<Actions>/Templates/Template Axiom" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic solve" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic casetype" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic cbv in" "") -; (gtk_accel_path "<Actions>/Templates/Template Load" "") -; (gtk_accel_path "<Actions>/Templates/Template Goal" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic exists" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic decompose record" "") -(gtk_accel_path "<Actions>/Navigation/Go to" "<Primary><Control>Right") -; (gtk_accel_path "<Actions>/Templates/Template Remark" "") -; (gtk_accel_path "<Actions>/Templates/Template Set Undo" "") -; (gtk_accel_path "<Actions>/Templates/Template Inductive" "") -(gtk_accel_path "<Actions>/Edit/Preferences" "<Primary>VoidSymbol") -; (gtk_accel_path "<Actions>/Export/Html" "") -; (gtk_accel_path "<Actions>/Templates/Template Extraction Inline" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic absurd" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic simple induction" "") -; (gtk_accel_path "<Actions>/Queries/Queries" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite -- in" "") -; (gtk_accel_path "<Actions>/Templates/Template Hint Rewrite" "") -; (gtk_accel_path "<Actions>/Templates/Template Add Semi Ring A Aplus Amult Aone Azero Aeq T [ c1 ... cn ]." "") -; (gtk_accel_path "<Actions>/Navigation/Navigation" "") -; (gtk_accel_path "<Actions>/Help/Browse Coq Manual" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic transitivity" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic auto" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic dependent inversion -- with" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic assumption" "") -; (gtk_accel_path "<Actions>/Templates/Template Notation" "") -; (gtk_accel_path "<Actions>/Edit/Cut" "<Primary>x") -; (gtk_accel_path "<Actions>/Templates/Template Theorem" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic constructor" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic elim -- with" "") -; (gtk_accel_path "<Actions>/Templates/Template Identity Coercion" "") -(gtk_accel_path "<Actions>/View/Display all low-level contents" "<Shift><Control>l") -; (gtk_accel_path "<Actions>/Tactics/Tactic right" "") -; (gtk_accel_path "<Actions>/Edit/Find Previous" "<Shift>F3") -; (gtk_accel_path "<Actions>/Tactics/Tactic cofix" "") -; (gtk_accel_path "<Actions>/Templates/Template Restore State" "") -; (gtk_accel_path "<Actions>/Templates/Template Lemma" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic refine" "") -; (gtk_accel_path "<Actions>/Templates/Template Section" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic assert (--:=--)" "") -; (gtk_accel_path "<Actions>/Templates/Template Unset Printing Wildcard" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic progress" "") -; (gtk_accel_path "<Actions>/Templates/Template Add Printing If" "") -; (gtk_accel_path "<Actions>/Templates/Template Chapter" "") -(gtk_accel_path "<Actions>/File/Print..." "<Primary>p") -; (gtk_accel_path "<Actions>/Templates/Template Record" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic info" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic firstorder with" "") -; (gtk_accel_path "<Actions>/Templates/Template Hint Unfold" "") -; (gtk_accel_path "<Actions>/Templates/Template Set Silent." "") -; (gtk_accel_path "<Actions>/Templates/Template Program Theorem" "") -; (gtk_accel_path "<Actions>/Templates/Template Declare ML Module" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic lazy in" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic unfold -- in" "") -; (gtk_accel_path "<Actions>/Edit/Paste" "<Primary>v") -; (gtk_accel_path "<Actions>/Templates/Template Remove Printing If" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic intuition" "") -; (gtk_accel_path "<Actions>/Queries/SearchAbout" "F2") -; (gtk_accel_path "<Actions>/Tactics/Tactic dependent rewrite ->" "") -; (gtk_accel_path "<Actions>/Templates/Template Module" "") -; (gtk_accel_path "<Actions>/Templates/Template Unset Extraction AutoInline" "") -(gtk_accel_path "<Actions>/Templates/Scheme" "<Shift><Primary>s") -; (gtk_accel_path "<Actions>/Templates/Template V" "") -; (gtk_accel_path "<Actions>/Templates/Template Variable" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic decide equality" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic instantiate (--:=--)" "") -; (gtk_accel_path "<Actions>/Templates/Template Syntactic Definition" "") -; (gtk_accel_path "<Actions>/Templates/Template Set Extraction AutoInline" "") -; (gtk_accel_path "<Actions>/Templates/Template Unset Undo" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic dependent inversion" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic setoid--rewrite" "") -; (gtk_accel_path "<Actions>/Templates/Template Add Field" "") -; (gtk_accel_path "<Actions>/Templates/Template Require Export" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite <-" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic split" "") -; (gtk_accel_path "<Actions>/File/Quit" "<Primary>q") -(gtk_accel_path "<Actions>/View/Display existential variable instances" "<Shift><Control>e") -(gtk_accel_path "<Actions>/Navigation/Start" "<Primary><Control>Home") -; (gtk_accel_path "<Actions>/Tactics/Tactic dependent rewrite <-" "") -; (gtk_accel_path "<Actions>/Templates/Template U" "") -; (gtk_accel_path "<Actions>/Templates/Template Variables" "") -; (gtk_accel_path "<Actions>/Templates/Template S" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic move -- after" "") -; (gtk_accel_path "<Actions>/Templates/Template Unset Silent." "") -; (gtk_accel_path "<Actions>/Templates/Template Local" "") -; (gtk_accel_path "<Actions>/Templates/Template T" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic reflexivity" "") -; (gtk_accel_path "<Actions>/Templates/Template R" "") -; (gtk_accel_path "<Actions>/Templates/Template Time" "") -; (gtk_accel_path "<Actions>/Templates/Template P" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic decompose" "") -; (gtk_accel_path "<Actions>/Templates/Template N" "") -; (gtk_accel_path "<Actions>/Templates/Template Eval" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic congruence" "") -; (gtk_accel_path "<Actions>/Templates/Template O" "") -; (gtk_accel_path "<Actions>/Templates/Template E" "") -; (gtk_accel_path "<Actions>/Templates/Template I" "") -; (gtk_accel_path "<Actions>/Templates/Template H" "") -; (gtk_accel_path "<Actions>/Templates/Template Extraction Language" "") -; (gtk_accel_path "<Actions>/Templates/Template M" "") -; (gtk_accel_path "<Actions>/Templates/Template Derive Inversion" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic double induction" "") -; (gtk_accel_path "<Actions>/Templates/Template L" "") -; (gtk_accel_path "<Actions>/Templates/Template Derive Inversion--clear" "") -(gtk_accel_path "<Actions>/View/Display universe levels" "<Shift><Control>u") -; (gtk_accel_path "<Actions>/Templates/Template G" "") -; (gtk_accel_path "<Actions>/Templates/Template F" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic dependent inversion--clear -- with" "") -; (gtk_accel_path "<Actions>/Templates/Template D" "") -; (gtk_accel_path "<Actions>/Edit/Edit" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic firstorder" "") -; (gtk_accel_path "<Actions>/Templates/Template C" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic replace -- with" "") -; (gtk_accel_path "<Actions>/Templates/Template A" "") -; (gtk_accel_path "<Actions>/Templates/Template Remove Printing Record" "") -; (gtk_accel_path "<Actions>/Templates/Template Qed." "") -; (gtk_accel_path "<Actions>/Templates/Template Program Fixpoint" "") -(gtk_accel_path "<Actions>/View/Display coercions" "<Shift><Control>c") -; (gtk_accel_path "<Actions>/Tactics/Tactic hnf" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic injection" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite" "") -; (gtk_accel_path "<Actions>/Templates/Template Opaque" "") -; (gtk_accel_path "<Actions>/Templates/Template Focus" "") -; (gtk_accel_path "<Actions>/Templates/Template Ltac" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic simple destruct" "") -(gtk_accel_path "<Actions>/View/Display all basic low-level contents" "<Shift><Control>a") -; (gtk_accel_path "<Actions>/Tactics/Tactic jp <n>" "") -; (gtk_accel_path "<Actions>/Templates/Template Test Printing Synth" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic set" "") -; (gtk_accel_path "<Actions>/Edit/External editor" "") -; (gtk_accel_path "<Actions>/View/Show Toolbar" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic try" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic discriminate" "") -(gtk_accel_path "<Actions>/Templates/Fixpoint" "<Shift><Primary>f") -(gtk_accel_path "<Actions>/Edit/Complete Word" "<Primary>slash") -(gtk_accel_path "<Actions>/Navigation/Next" "<Primary><Control>greater") -; (gtk_accel_path "<Actions>/Tactics/Tactic elimtype" "") -; (gtk_accel_path "<Actions>/Templates/Template End" "") -; (gtk_accel_path "<Actions>/Templates/Template Fixpoint" "") -; (gtk_accel_path "<Actions>/View/Next tab" "<Shift>Right") -; (gtk_accel_path "<Actions>/File/File" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic setoid--replace" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic generalize dependent" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic fix -- with" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic pose --:=--)" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic auto with" "") -; (gtk_accel_path "<Actions>/Templates/Template Add Printing Record" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic inversion -- in" "") -; (gtk_accel_path "<Actions>/File/Open" "<Primary>o") -; (gtk_accel_path "<Actions>/Tactics/Tactic elim -- using" "") -; (gtk_accel_path "<Actions>/Templates/Template Hint" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic tauto" "") -; (gtk_accel_path "<Actions>/Export/Dvi" "") -; (gtk_accel_path "<Actions>/Tactics/Tactic simpl -- in" "") -; (gtk_accel_path "<Actions>/Templates/Template Hint Immediate" "") diff --git a/ide/coqide.ml b/ide/coqide.ml index 9cdfd0dc21..70fa61b208 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -1016,7 +1016,7 @@ let build_ui () = menu edit_menu [ item "Edit" ~label:"_Edit"; - item "Undo" ~accel:"<Ctrl>u" ~stock:`UNDO + item "Undo" ~accel:"<Primary>u" ~stock:`UNDO ~callback:(cb_on_current_term (fun t -> t.script#undo ())); item "Redo" ~stock:`REDO ~callback:(cb_on_current_term (fun t -> t.script#redo ())); @@ -1035,7 +1035,7 @@ let build_ui () = ~callback:(cb_on_current_term (fun t -> t.finder#find_backward ())); item "External editor" ~label:"External editor" ~stock:`EDIT ~callback:(External.editor ~parent:w); - item "Preferences" ~accel:"<Ctrl>comma" ~stock:`PREFERENCES + item "Preferences" ~accel:"<Primary>comma" ~stock:`PREFERENCES ~callback:(fun _ -> begin try Preferences.configure ~apply:refresh_notebook_pos w @@ -1053,19 +1053,19 @@ let build_ui () = item "Next tab" ~label:"_Next tab" ~accel:"<Alt>Right" ~stock:`GO_FORWARD ~callback:(fun _ -> notebook#next_page ()); - item "Zoom in" ~label:"_Zoom in" ~accel:("<Control>plus") + item "Zoom in" ~label:"_Zoom in" ~accel:("<Primary>plus") ~stock:`ZOOM_IN ~callback:(fun _ -> let ft = Pango.Font.from_string text_font#get in Pango.Font.set_size ft (Pango.Font.get_size ft + Pango.scale); text_font#set (Pango.Font.to_string ft); save_pref ()); - item "Zoom out" ~label:"_Zoom out" ~accel:("<Control>minus") + item "Zoom out" ~label:"_Zoom out" ~accel:("<Primary>minus") ~stock:`ZOOM_OUT ~callback:(fun _ -> let ft = Pango.Font.from_string text_font#get in Pango.Font.set_size ft (Pango.Font.get_size ft - Pango.scale); text_font#set (Pango.Font.to_string ft); save_pref ()); - item "Zoom fit" ~label:"_Zoom fit" ~accel:("<Control>0") + item "Zoom fit" ~label:"_Zoom fit" ~accel:("<Primary>0") ~stock:`ZOOM_FIT ~callback:(cb_on_current_term MiscMenu.zoom_fit); toggle_item "Show Toolbar" ~label:"Show _Toolbar" ~active:(show_toolbar#get) @@ -1247,7 +1247,6 @@ let build_ui () = let () = refresh_notebook_pos () in let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in let () = lower_hbox#pack ~expand:true status#coerce in - let () = push_info ("Ready"^ if microPG#get then ", [μPG]" else "") in (* Location display *) let l = GMisc.label @@ -1372,7 +1371,7 @@ let read_coqide_args argv = |"-coqtop-flags" :: flags :: args-> Coq.ideslave_coqtop_flags := Some flags; filter_coqtop coqtop project_files bindings_files out args - |arg::args when out = [] && Minilib.is_prefix_of "-psn_" arg -> + |arg::args when out = [] && CString.is_prefix "-psn_" arg -> (* argument added by MacOS during .app launch *) filter_coqtop coqtop project_files bindings_files out args |arg::args -> filter_coqtop coqtop project_files bindings_files (arg::out) args diff --git a/ide/coqide_main.ml b/ide/coqide_main.ml index f2ce2e8bd9..1e04d269f6 100644 --- a/ide/coqide_main.ml +++ b/ide/coqide_main.ml @@ -49,11 +49,10 @@ let catch_gtk_messages () = let () = catch_gtk_messages () let load_prefs () = - try Preferences.load_pref () - with e -> Ideutils.flash_info - ("Could not load preferences ("^Printexc.to_string e^").") + Preferences.load_pref ~warn:(fun ~delay -> Ideutils.flash_info ~delay) let () = + Ideutils.push_info ("Ready"^ if Preferences.microPG#get then ", [μPG]" else ""); load_prefs (); let argl = List.tl (Array.to_list Sys.argv) in let argl = Coqide.read_coqide_args argl in diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 246254c6a5..4b156065f3 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -34,9 +34,38 @@ let push_info,pop_info,clear_info = (fun () -> decr size; status_context#pop ()), (fun () -> for _i = 1 to !size do status_context#pop () done; size := 0) +type 'a mlist = Nil | Cons of { hd : 'a ; mutable tl : 'a mlist } + +let enqueue a x = + let rec aux x = match x with + | Nil -> assert false + | Cons p -> + match p.tl with + | Nil -> p.tl <- Cons { hd = a ; tl = Nil } + | _ -> aux p.tl in + match !x with + | Nil -> x := Cons { hd = a ; tl = Nil } + | _ -> aux !x + +let pop = function + | Cons p -> p.tl + | Nil -> assert false + let flash_info = + let queue = ref Nil in let flash_context = status#new_context ~name:"Flash" in - (fun ?(delay=5000) s -> flash_context#flash ~delay s) + let rec process () = match !queue with + | Cons { hd = (delay,text) } -> + let msg = flash_context#push text in + ignore (Glib.Timeout.add ~ms:delay ~callback:(fun () -> + flash_context#remove msg; + queue := pop !queue; + process (); false)) + | Nil -> () in + fun ?(delay=5000) text -> + let processing = !queue <> Nil in + enqueue (delay,text) queue; + if not processing then process () (* Note: Setting the same attribute with two separate tags appears to use the first value applied and not the second. I saw this trying to set the background diff --git a/ide/minilib.ml b/ide/minilib.ml index 09a7112098..926ad27abc 100644 --- a/ide/minilib.ml +++ b/ide/minilib.ml @@ -58,17 +58,13 @@ let coqide_data_dirs () = :: List.map coqify (Glib.get_system_data_dirs ()) @ [Envars.datadir ()] -let coqide_config_dirs () = - coqide_config_home () - :: List.map coqify (Glib.get_system_config_dirs ()) - @ [Envars.configdir ()] +let coqide_system_config_dirs () = + List.map coqify (Glib.get_system_config_dirs ()) -let is_prefix_of pre s = - let i = ref 0 in - let () = while (!i < (String.length pre) - && !i < (String.length s) - && pre.[!i] = s.[!i]) do - incr i - done - in !i = String.length pre +let coqide_default_config_dir () = + Envars.configdir () +let coqide_config_dirs () = + coqide_config_home () :: + coqide_system_config_dirs () @ + [coqide_default_config_dir ()] diff --git a/ide/minilib.mli b/ide/minilib.mli index c5849cc2c9..a9d26ee7d2 100644 --- a/ide/minilib.mli +++ b/ide/minilib.mli @@ -27,7 +27,19 @@ val debug : bool ref val log_pp : ?level:level -> Pp.t -> unit val log : ?level:level -> string -> unit +(* The directory where user config files are conventionally *) +(* installed on the current platform (as given by Glib) *) val coqide_config_home : unit -> string + +(* The directories where system-wide config files are conventionally *) +(* installed on the current platform (as given by Glib) *) +val coqide_system_config_dirs : unit -> string list + +(* The directory where default config files are installed at installation time *) +val coqide_default_config_dir : unit -> string + +(* The ordered list of directories where a config file is searched by default *) val coqide_config_dirs : unit -> string list + +(* The ordered list of directories where a data file is searched by default *) val coqide_data_dirs : unit -> string list -val is_prefix_of : string -> string -> bool diff --git a/ide/preferences.ml b/ide/preferences.ml index bf9fe8922a..7b667027fc 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -10,8 +10,6 @@ open Configwin -let pref_file = Filename.concat (Minilib.coqide_config_home ()) "coqiderc" -let accel_file = Filename.concat (Minilib.coqide_config_home ()) "coqide.keys" let lang_manager = GSourceView3.source_language_manager ~default:true let () = lang_manager#set_search_path ((Minilib.coqide_data_dirs ())@lang_manager#search_path) @@ -235,22 +233,13 @@ end end -let get_config_file name = +let get_config_file dirs name = let find_config dir = Sys.file_exists (Filename.concat dir name) in - let config_dir = List.find find_config (Minilib.coqide_config_dirs ()) in + let config_dir = List.find find_config dirs in Filename.concat config_dir name -(* Small hack to handle v8.3 to v8.4 change in configuration file *) -let loaded_pref_file = - try get_config_file "coqiderc" - with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqiderc" - -let loaded_accel_file = - try get_config_file "coqide.keys" - with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqide.keys" - let get_unicode_bindings_local_file () = - try Some (get_config_file "coqide.bindings") + try Some (get_config_file [Minilib.coqide_config_home ()] "coqide.bindings") with Not_found -> None let get_unicode_bindings_default_file () = @@ -332,26 +321,36 @@ let attach_modifiers (pref : string preference) prefix = in pref#connect#changed ~callback:cb +let select_arch m m_osx = + if Coq_config.arch = "Darwin" then m_osx else m + let modifier_for_navigation = - new preference ~name:["modifier_for_navigation"] ~init:"<Control>" ~repr:Repr.(string) + new preference ~name:["modifier_for_navigation"] + ~init:(select_arch "<Control>" "<Control><Primary>") ~repr:Repr.(string) let modifier_for_templates = new preference ~name:["modifier_for_templates"] ~init:"<Control><Shift>" ~repr:Repr.(string) let modifier_for_tactics = - new preference ~name:["modifier_for_tactics"] ~init:"<Control><Alt>" ~repr:Repr.(string) + new preference ~name:["modifier_for_tactics"] + ~init:(select_arch "<Control><Alt>" "<Control><Primary>") ~repr:Repr.(string) let modifier_for_display = - new preference ~name:["modifier_for_display"] ~init:"<Alt><Shift>" ~repr:Repr.(string) + new preference ~name:["modifier_for_display"] + ~init:(select_arch "<Alt><Shift>" "<Primary><Shift>")~repr:Repr.(string) let modifier_for_queries = new preference ~name:["modifier_for_queries"] ~init:"<Control><Shift>" ~repr:Repr.(string) -let _ = attach_modifiers modifier_for_navigation "<Actions>/Navigation/" -let _ = attach_modifiers modifier_for_templates "<Actions>/Templates/" -let _ = attach_modifiers modifier_for_tactics "<Actions>/Tactics/" -let _ = attach_modifiers modifier_for_display "<Actions>/View/" -let _ = attach_modifiers modifier_for_queries "<Actions>/Queries/" +let attach_modifiers_callback () = + (* Tell to propagate changes done in preference menu to accel map *) + (* To be done after the preferences are loaded *) + let _ = attach_modifiers modifier_for_navigation "<Actions>/Navigation/" in + let _ = attach_modifiers modifier_for_templates "<Actions>/Templates/" in + let _ = attach_modifiers modifier_for_tactics "<Actions>/Tactics/" in + let _ = attach_modifiers modifier_for_display "<Actions>/View/" in + let _ = attach_modifiers modifier_for_queries "<Actions>/Queries/" in + () let modifiers_valid = new preference ~name:["modifiers_valid"] ~init:"<Alt><Control><Shift>" ~repr:Repr.(string) @@ -380,9 +379,6 @@ let text_font = let show_toolbar = new preference ~name:["show_toolbar"] ~init:true ~repr:Repr.(bool) -let contextual_menus_on_goal = - new preference ~name:["contextual_menus_on_goal"] ~init:true ~repr:Repr.(bool) - let window_width = new preference ~name:["window_width"] ~init:800 ~repr:Repr.(int) @@ -644,29 +640,73 @@ let tag_button () = let box = GPack.hbox () in new tag_button (Gobject.unsafe_cast box#as_widget) -let save_pref () = +(** Loading/saving preferences *) + +let pref_file = Filename.concat (Minilib.coqide_config_home ()) "coqiderc" +let accel_file = Filename.concat (Minilib.coqide_config_home ()) "coqide.keys" + +let save_accel_pref () = + if not (Sys.file_exists (Minilib.coqide_config_home ())) + then Unix.mkdir (Minilib.coqide_config_home ()) 0o700; + GtkData.AccelMap.save accel_file + +let save_rc_pref () = if not (Sys.file_exists (Minilib.coqide_config_home ())) then Unix.mkdir (Minilib.coqide_config_home ()) 0o700; - let () = try GtkData.AccelMap.save accel_file with _ -> () in let add = Util.String.Map.add in let fold key obj accu = add key (obj.get ()) accu in let prefs = Util.String.Map.fold fold !preferences Util.String.Map.empty in let prefs = Util.String.Map.fold Util.String.Map.add !unknown_preferences prefs in Config_lexer.print_file pref_file prefs -let load_pref () = - (* Load main preference file *) - let () = - let m = Config_lexer.load_file loaded_pref_file in +let save_pref () = + save_accel_pref (); + save_rc_pref () + +let try_load_pref_file loader warn file = + try + loader file + with + e -> warn ~delay:5000 ("Could not load " ^ file ^ " ("^Printexc.to_string e^")") + +let load_pref_file loader warn name = + try + let user_file = get_config_file [Minilib.coqide_config_home ()] name in + warn ~delay:2000 ("Loading " ^ user_file); + try_load_pref_file loader warn user_file + with Not_found -> + try + let system_wide_file = get_config_file (Minilib.coqide_system_config_dirs ()) name in + warn ~delay:5000 ("No user " ^ name ^ ", using system wide configuration"); + try_load_pref_file loader warn system_wide_file + with Not_found -> + (* Compatibility with oldest versions of CoqIDE (<= 8.4) *) + try + let old_user_file = get_config_file [Option.default "" (Glib.get_home_dir ())] ("."^name) in + warn ~delay:5000 ("No " ^ name ^ ", trying to recover from an older version of CoqIDE"); + try_load_pref_file loader warn old_user_file + with Not_found -> + (* Built-in configuration *) + warn ~delay:5000 ("No " ^ name ^ ", using default internal configuration") + +let load_accel_pref ~warn = + load_pref_file GtkData.AccelMap.load warn "coqide.keys" + +let load_rc_pref ~warn = + let loader file = + let m = Config_lexer.load_file file in let iter name v = if Util.String.Map.mem name !preferences then try (Util.String.Map.find name !preferences).set v with _ -> () else unknown_preferences := Util.String.Map.add name v !unknown_preferences in Util.String.Map.iter iter m in - (* Load file for bindings *) - let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in - () + load_pref_file loader warn "coqiderc"; + attach_modifiers_callback () + +let load_pref ~warn = + load_rc_pref ~warn; + load_accel_pref ~warn let pstring name p = string ~f:p#set name p#get let pbool name p = bool ~f:p#set name p#get @@ -893,19 +933,19 @@ let configure ?(apply=(fun () -> ())) parent = in let project_file_name = pstring "Default name for project file" project_file_name in let modifier_for_tactics = - pmodifiers "Modifiers for Tactics Menu" modifier_for_tactics + pmodifiers "Global change of modifiers for Tactics Menu" modifier_for_tactics in let modifier_for_templates = - pmodifiers "Modifiers for Templates Menu" modifier_for_templates + pmodifiers "Global change of modifiers for Templates Menu" modifier_for_templates in let modifier_for_navigation = - pmodifiers "Modifiers for Navigation Menu" modifier_for_navigation + pmodifiers "Global change of modifiers for Navigation Menu" modifier_for_navigation in let modifier_for_display = - pmodifiers "Modifiers for View Menu" modifier_for_display + pmodifiers "Global change of modifiers for View Menu" modifier_for_display in let modifier_for_queries = - pmodifiers "Modifiers for Queries Menu" modifier_for_queries + pmodifiers "Global change of modifiers for Queries Menu" modifier_for_queries in let modifiers_valid = pmodifiers ~all:true "Allowed modifiers" modifiers_valid @@ -939,9 +979,7 @@ let configure ?(apply=(fun () -> ())) parent = cmd_browse#get in - let contextual_menus_on_goal = pbool "Contextual menus on goal" contextual_menus_on_goal in - - let misc = [contextual_menus_on_goal;stop_before;reset_on_tab_switch; + let misc = [stop_before;reset_on_tab_switch; vertical_tabs;opposite_tabs] in (* diff --git a/ide/preferences.mli b/ide/preferences.mli index 490756d4f2..4b04326cec 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -79,7 +79,6 @@ val cmd_browse : string preference val cmd_editor : string preference val text_font : string preference val show_toolbar : bool preference -val contextual_menus_on_goal : bool preference val window_width : int preference val window_height : int preference val auto_complete : bool preference @@ -107,7 +106,7 @@ val user_queries : (string * string) list preference val diffs : string preference val save_pref : unit -> unit -val load_pref : unit -> unit +val load_pref : warn:(delay:int -> string -> unit) -> unit val configure : ?apply:(unit -> unit) -> GWindow.window -> unit diff --git a/ide/session.ml b/ide/session.ml index a9c106a765..38fdd0ef2a 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -502,19 +502,25 @@ let build_layout (sn:session) = ~callback:(fun () -> if sn.buffer#modified then img#set_stock `SAVE else img#set_stock `YES) in - let _ = - eval_paned#misc#connect#size_allocate - ~callback: - (let b = ref true in - fun {Gtk.width=paned_width;Gtk.height=paned_height} -> - if !b then begin - eval_paned#set_position - (paned_width / 2); - state_paned#set_position - (paned_height / 2); - b := false - end) - in + (* There was an issue in the previous implementation for setting the + position of the handle. It was using the size_allocate event but + there is an issue with size_allocate. G. Melquiond analyzed that + at starting time, the size_allocate event is only issued in + Layout phase of the gtk loop so that it is actually processed + only in the next iteration of the event-update-layout-paint loop, + after the user does something and trigger an effective new event + (see #10578). So we preventively enforce an estimated position + for the handles to be used in the very first initializing + iteration of the loop *) + let () = + (* 14 is the estimated size for vertical borders *) + let estimated_vertical_handle_position = (window_width#get - 14) / 2 in + (* 169 is the estimated size for menus, command line, horizontal border *) + let estimated_horizontal_handle_position = (window_height#get - 169) / 2 in + if estimated_vertical_handle_position > 0 then + eval_paned#set_position estimated_vertical_handle_position; + if estimated_horizontal_handle_position > 0 then + state_paned#set_position estimated_horizontal_handle_position in session_box#pack sn.finder#coerce; session_box#pack sn.segment#coerce; sn.command#pack_in (session_paned#pack2 ~shrink:false ~resize:false); @@ -538,8 +544,6 @@ let build_layout (sn:session) = else (label#set_text (red txt);label#set_use_markup true)); session_tab#pack sn.tab_label#coerce; img#set_stock `YES; - eval_paned#set_position 1; - state_paned#set_position 1; let control = object method detach () = proof_detachable#detach () diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 3f216b0d63..b4798127f9 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -625,7 +625,8 @@ let interp_univ_constraints env evd cstrs = let interp_univ_decl env decl = let open UState in let pl : lident list = decl.univdecl_instance in - let evd = Evd.from_ctx (UState.make_with_initial_binders (Environ.universes env) pl) in + let evd = Evd.from_ctx (UState.make_with_initial_binders ~lbound:(Environ.universes_lbound env) + (Environ.universes env) pl) in let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in let decl = { univdecl_instance = pl; univdecl_extensible_instance = decl.univdecl_extensible_instance; diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index 8d6a266c30..41d1da9694 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -20,31 +20,21 @@ let open_glob_file f = let close_glob_file () = close_out !glob_file -type glob_output_t = - | NoGlob - | StdOut - | MultFiles - | Feedback - | File of string +type glob_output = + | NoGlob + | Feedback + | MultFiles + | File of string let glob_output = ref NoGlob -let dump () = !glob_output != NoGlob +let dump () = !glob_output <> NoGlob -let noglob () = glob_output := NoGlob - -let dump_to_dotglob () = glob_output := MultFiles - -let dump_into_file f = - if String.equal f "stdout" then - (glob_output := StdOut; glob_file := stdout) - else - (glob_output := File f; open_glob_file f) - -let feedback_glob () = glob_output := Feedback +let set_glob_output mode = + glob_output := mode let dump_string s = - if dump () && !glob_output != Feedback then + if dump () && !glob_output != Feedback then output_string !glob_file s let start_dump_glob ~vfile ~vofile = @@ -57,13 +47,13 @@ let start_dump_glob ~vfile ~vofile = | File f -> open_glob_file f; output_string !glob_file "DIGEST NO\n" - | NoGlob | Feedback | StdOut -> + | NoGlob | Feedback -> () let end_dump_glob () = match !glob_output with | MultFiles | File _ -> close_glob_file () - | NoGlob | Feedback | StdOut -> () + | NoGlob | Feedback -> () let previous_state = ref MultFiles let pause () = previous_state := !glob_output; glob_output := NoGlob diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index 60d62a1cb2..2b6a116a01 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -8,19 +8,19 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val open_glob_file : string -> unit -val close_glob_file : unit -> unit - val start_dump_glob : vfile:string -> vofile:string -> unit val end_dump_glob : unit -> unit val dump : unit -> bool -val noglob : unit -> unit -val dump_into_file : string -> unit (** special handling of "stdout" *) +type glob_output = + | NoGlob + | Feedback + | MultFiles (* one glob file per .v file *) + | File of string (* Single file for all coqc arguments *) -val dump_to_dotglob : unit -> unit -val feedback_glob : unit -> unit +(* Default "NoGlob" *) +val set_glob_output : glob_output -> unit val pause : unit -> unit val continue : unit -> unit diff --git a/interp/notation.ml b/interp/notation.ml index a78bc60e83..ea2173860d 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1205,7 +1205,7 @@ let interp_notation ?loc ntn local_scopes = let scopes = make_current_scopes local_scopes in try let (n,sc) = find_interpretation ntn (find_notation ntn) scopes in - Option.iter (fun d -> warn_deprecated_notation (ntn,d)) n.not_deprecation; + Option.iter (fun d -> warn_deprecated_notation ?loc (ntn,d)) n.not_deprecation; n.not_interp, (n.not_location, sc) with Not_found -> user_err ?loc diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index 302bb6ece2..9dded8656c 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -100,7 +100,7 @@ let warn_deprecated_syntactic_definition = let search_syntactic_definition ?loc kn = let syndef = KNmap.find kn !syntax_table in let def = out_pat syndef.syndef_pattern in - Option.iter (fun d -> warn_deprecated_syntactic_definition (kn,d)) syndef.syndef_deprecation; + Option.iter (fun d -> warn_deprecated_syntactic_definition ?loc (kn,d)) syndef.syndef_deprecation; def let search_filtered_syntactic_definition ?loc filter kn = @@ -108,5 +108,5 @@ let search_filtered_syntactic_definition ?loc filter kn = let def = out_pat syndef.syndef_pattern in let res = filter def in if Option.has_some res then - Option.iter (fun d -> warn_deprecated_syntactic_definition (kn,d)) syndef.syndef_deprecation; + Option.iter (fun d -> warn_deprecated_syntactic_definition ?loc (kn,d)) syndef.syndef_deprecation; res diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 8d32684b09..44676c9da5 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -87,6 +87,11 @@ type typing_flags = { indices_matter: bool; (** The universe of an inductive type must be above that of its indices. *) + + check_template : bool; + (* If [false] then we don't check that the universes template-polymorphic + inductive parameterize on are necessarily local and unbounded from below. + This potentially introduces inconsistencies. *) } (* some contraints are in constant_constraints, some other may be in diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 391b139496..7225671a1e 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -26,6 +26,7 @@ let safe_flags oracle = { enable_VM = true; enable_native_compiler = true; indices_matter = true; + check_template = true; } (** {6 Arities } *) diff --git a/kernel/dune b/kernel/dune index 4038bf5638..5f7502ef6b 100644 --- a/kernel/dune +++ b/kernel/dune @@ -3,7 +3,7 @@ (synopsis "The Coq Kernel") (public_name coq.kernel) (wrapped false) - (modules (:standard \ genOpcodeFiles uint63_i386_31 uint63_amd64_63 write_uint63)) + (modules (:standard \ genOpcodeFiles uint63_31 uint63_63)) (libraries lib byterun dynlink)) (executable @@ -16,7 +16,7 @@ (rule (targets uint63.ml) - (deps (:gen-file uint63_%{ocaml-config:architecture}_%{ocaml-config:int_size}.ml)) + (deps (:gen-file uint63_%{ocaml-config:int_size}.ml)) (action (copy# %{gen-file} %{targets}))) (documentation diff --git a/kernel/environ.ml b/kernel/environ.ml index 655094e88b..4a2aeea22d 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -59,8 +59,9 @@ type globals = { type stratification = { env_universes : UGraph.t; - env_engagement : engagement; env_sprop_allowed : bool; + env_universes_lbound : Univ.Level.t; + env_engagement : engagement } type val_kind = @@ -119,9 +120,9 @@ let empty_env = { env_nb_rel = 0; env_stratification = { env_universes = UGraph.initial_universes; - env_engagement = PredicativeSet; env_sprop_allowed = false; - }; + env_universes_lbound = Univ.Level.set; + env_engagement = PredicativeSet }; env_typing_flags = Declareops.safe_flags Conv_oracle.empty; retroknowledge = Retroknowledge.empty; indirect_pterms = Opaqueproof.empty_opaquetab; @@ -262,8 +263,15 @@ 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 check_template env = env.env_typing_flags.check_template let universes env = env.env_stratification.env_universes +let universes_lbound env = env.env_stratification.env_universes_lbound + +let set_universes_lbound env lbound = + let env_stratification = { env.env_stratification with env_universes_lbound = lbound } in + { env with env_stratification } + let named_context env = env.env_named_context.env_named_ctx let named_context_val env = env.env_named_context let rel_context env = env.env_rel_context.env_rel_ctx @@ -382,29 +390,30 @@ let check_constraints c env = let push_constraints_to_env (_,univs) env = add_constraints univs env -let add_universes strict ctx g = +let add_universes ~lbound ~strict ctx g = let g = Array.fold_left - (fun g v -> UGraph.add_universe v strict g) + (fun g v -> UGraph.add_universe ~lbound ~strict v g) g (Univ.Instance.to_array (Univ.UContext.instance ctx)) in UGraph.merge_constraints (Univ.UContext.constraints ctx) g let push_context ?(strict=false) ctx env = - map_universes (add_universes strict ctx) env + map_universes (add_universes ~lbound:(universes_lbound env) ~strict ctx) env -let add_universes_set strict ctx g = +let add_universes_set ~lbound ~strict ctx g = let g = Univ.LSet.fold (* Be lenient, module typing reintroduces universes and constraints due to includes *) - (fun v g -> try UGraph.add_universe v strict g with UGraph.AlreadyDeclared -> g) + (fun v g -> try UGraph.add_universe ~lbound ~strict v g with UGraph.AlreadyDeclared -> g) (Univ.ContextSet.levels ctx) g in UGraph.merge_constraints (Univ.ContextSet.constraints ctx) g let push_context_set ?(strict=false) ctx env = - map_universes (add_universes_set strict ctx) env + map_universes (add_universes_set ~lbound:(universes_lbound env) ~strict ctx) env let push_subgraph (levels,csts) env = + let lbound = universes_lbound env in let add_subgraph g = - let newg = Univ.LSet.fold (fun v g -> UGraph.add_universe v false g) levels g in + let newg = Univ.LSet.fold (fun v g -> UGraph.add_universe ~lbound ~strict:false v 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 @@ -428,6 +437,7 @@ let same_flags { share_reduction; enable_VM; enable_native_compiler; + check_template; } alt = check_guarded == alt.check_guarded && check_positive == alt.check_positive && @@ -436,7 +446,8 @@ let same_flags { indices_matter == alt.indices_matter && share_reduction == alt.share_reduction && enable_VM == alt.enable_VM && - enable_native_compiler == alt.enable_native_compiler + enable_native_compiler == alt.enable_native_compiler && + check_template == alt.check_template [@warning "+9"] let set_typing_flags c env = (* Unsafe *) @@ -568,11 +579,20 @@ let polymorphic_pind (ind,u) env = let type_in_type_ind (mind,_i) env = not (lookup_mind mind env).mind_typing_flags.check_universes +let template_checked_ind (mind,_i) env = + (lookup_mind mind env).mind_typing_flags.check_template + let template_polymorphic_ind (mind,i) env = match (lookup_mind mind env).mind_packets.(i).mind_arity with | TemplateArity _ -> true | RegularArity _ -> false +let template_polymorphic_variables (mind,i) env = + match (lookup_mind mind env).mind_packets.(i).mind_arity with + | TemplateArity { Declarations.template_param_levels = l; _ } -> + List.map_filter (fun level -> level) l + | RegularArity _ -> [] + let template_polymorphic_pind (ind,u) env = if not (Univ.Instance.is_empty u) then false else template_polymorphic_ind ind env @@ -762,6 +782,22 @@ let is_template_polymorphic env r = | IndRef ind -> template_polymorphic_ind ind env | ConstructRef cstr -> template_polymorphic_ind (inductive_of_constructor cstr) env +let get_template_polymorphic_variables env r = + let open Names.GlobRef in + match r with + | VarRef _id -> [] + | ConstRef _c -> [] + | IndRef ind -> template_polymorphic_variables ind env + | ConstructRef cstr -> template_polymorphic_variables (inductive_of_constructor cstr) env + +let is_template_checked env r = + let open Names.GlobRef in + match r with + | VarRef _id -> false + | ConstRef _c -> false + | IndRef ind -> template_checked_ind ind env + | ConstructRef cstr -> template_checked_ind (inductive_of_constructor cstr) env + let is_type_in_type env r = let open Names.GlobRef in match r with diff --git a/kernel/environ.mli b/kernel/environ.mli index e6d814ac7d..f7de98dcfb 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -51,8 +51,9 @@ type globals type stratification = { env_universes : UGraph.t; - env_engagement : engagement; env_sprop_allowed : bool; + env_universes_lbound : Univ.Level.t; + env_engagement : engagement } type named_context_val = private { @@ -85,6 +86,8 @@ val eq_named_context_val : named_context_val -> named_context_val -> bool val empty_env : env val universes : env -> UGraph.t +val universes_lbound : env -> Univ.Level.t +val set_universes_lbound : env -> Univ.Level.t -> env val rel_context : env -> Constr.rel_context val named_context : env -> Constr.named_context val named_context_val : env -> named_context_val @@ -99,6 +102,7 @@ val is_impredicative_set : env -> bool val type_in_type : env -> bool val deactivated_guard : env -> bool val indices_matter : env -> bool +val check_template : env -> bool val is_impredicative_sort : env -> Sorts.t -> bool val is_impredicative_univ : env -> Univ.Universe.t -> bool @@ -254,7 +258,9 @@ val type_in_type_ind : inductive -> env -> bool (** Old-style polymorphism *) val template_polymorphic_ind : inductive -> env -> bool +val template_polymorphic_variables : inductive -> env -> Univ.Level.t list val template_polymorphic_pind : pinductive -> env -> bool +val template_checked_ind : inductive -> env -> bool (** {5 Modules } *) @@ -346,6 +352,8 @@ val remove_hyps : Id.Set.t -> (Constr.named_declaration -> Constr.named_declarat val is_polymorphic : env -> Names.GlobRef.t -> bool val is_template_polymorphic : env -> GlobRef.t -> bool +val get_template_polymorphic_variables : env -> GlobRef.t -> Univ.Level.t list +val is_template_checked : env -> GlobRef.t -> bool val is_type_in_type : env -> GlobRef.t -> bool (** Native compiler *) diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml index c8e04b9fee..06d2e1bb21 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -236,22 +236,53 @@ let allowed_sorts {ind_squashed;ind_univ;ind_min_univ=_;ind_has_relevant_arg=_} if not ind_squashed then InType else Sorts.family (Sorts.sort_of_univ ind_univ) +(* For a level to be template polymorphic, it must be introduced + by the definition (so have no constraint except lbound <= l) + and not to be constrained from below, so any universe l' <= l + can be used as an instance of l. All bounds from above, i.e. + l <=/< r will be valid for any l' <= l. *) +let unbounded_from_below u cstrs = + Univ.Constraint.for_all (fun (l, d, r) -> + match d with + | Eq -> not (Univ.Level.equal l u) && not (Univ.Level.equal r u) + | Lt | Le -> not (Univ.Level.equal r u)) + cstrs + (* Returns the list [x_1, ..., x_n] of levels contributing to template - polymorphism. The elements x_k is None if the k-th parameter (starting - from the most recent and ignoring let-definitions) is not contributing - or is Some u_k if its level is u_k and is contributing. *) -let param_ccls paramsctxt = + polymorphism. The elements x_k is None if the k-th parameter + (starting from the most recent and ignoring let-definitions) is not + contributing to the inductive type's sort or is Some u_k if its level + is u_k and is contributing. *) +let template_polymorphic_univs ~template_check uctx paramsctxt concl = + let check_level l = + if Univ.LSet.mem l (Univ.ContextSet.levels uctx) && + unbounded_from_below l (Univ.ContextSet.constraints uctx) then + Some l + else None + in + let univs = Univ.Universe.levels concl in + let univs = + if template_check then + Univ.LSet.filter (fun l -> Option.has_some (check_level l) || Univ.Level.is_prop l) univs + else univs (* Doesn't check the universes can be generalized *) + in let fold acc = function | (LocalAssum (_, p)) -> (let c = Term.strip_prod_assum p in match kind c with - | Sort (Type u) -> Univ.Universe.level u + | Sort (Type u) -> + if template_check then + (match Univ.Universe.level u with + | Some l -> if Univ.LSet.mem l univs && not (Univ.Level.is_prop l) then Some l else None + | None -> None) + else Univ.Universe.level u | _ -> None) :: acc | LocalDef _ -> acc in - List.fold_left fold [] paramsctxt + let params = List.fold_left fold [] paramsctxt in + params, univs -let abstract_packets univs usubst params ((arity,lc),(indices,splayed_lc),univ_info) = +let abstract_packets ~template_check univs usubst params ((arity,lc),(indices,splayed_lc),univ_info) = let arity = Vars.subst_univs_level_constr usubst arity in let lc = Array.map (Vars.subst_univs_level_constr usubst) lc in let indices = Vars.subst_univs_level_context usubst indices in @@ -264,14 +295,20 @@ let abstract_packets univs usubst params ((arity,lc),(indices,splayed_lc),univ_i let ind_univ = Univ.subst_univs_level_universe usubst univ_info.ind_univ in let arity = match univ_info.ind_min_univ with - | None -> RegularArity {mind_user_arity=arity;mind_sort=Sorts.sort_of_univ ind_univ} + | None -> RegularArity {mind_user_arity = arity; mind_sort = Sorts.sort_of_univ ind_univ} | Some min_univ -> - ((match univs with - | Monomorphic _ -> () + let ctx = match univs with + | Monomorphic ctx -> ctx | Polymorphic _ -> CErrors.anomaly ~label:"polymorphic_template_ind" - Pp.(strbrk "Template polymorphism and full polymorphism are incompatible.")); - TemplateArity {template_param_levels=param_ccls params; template_level=min_univ}) + Pp.(strbrk "Template polymorphism and full polymorphism are incompatible.") in + let param_levels, concl_levels = template_polymorphic_univs ~template_check ctx params min_univ in + if template_check && List.for_all (fun x -> Option.is_empty x) param_levels + && Univ.LSet.is_empty concl_levels then + CErrors.anomaly ~label:"polymorphic_template_ind" + Pp.(strbrk "Ill-formed template inductive declaration: not polymorphic on any universe.") + else + TemplateArity {template_param_levels = param_levels; template_level = min_univ} in let kelim = allowed_sorts univ_info in @@ -286,10 +323,14 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = mind_check_names mie; assert (List.is_empty (Environ.rel_context env)); + let has_template_poly = List.exists (fun oie -> oie.mind_entry_template) mie.mind_entry_inds in + (* universes *) let env_univs = match mie.mind_entry_universes with - | Monomorphic_entry ctx -> push_context_set ctx env + | Monomorphic_entry ctx -> + let env = if has_template_poly then set_universes_lbound env Univ.Level.prop else env in + push_context_set ctx env | Polymorphic_entry (_, ctx) -> push_context ctx env in @@ -335,7 +376,8 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = (* Abstract universes *) let usubst, univs = Declareops.abstract_universes mie.mind_entry_universes in let params = Vars.subst_univs_level_context usubst params in - let data = List.map (abstract_packets univs usubst params) data in + let template_check = Environ.check_template env in + let data = List.map (abstract_packets ~template_check univs usubst params) data in let env_ar_par = let ctx = Environ.rel_context env_ar_par in diff --git a/kernel/indTyping.mli b/kernel/indTyping.mli index aaa0d6a149..8da4e2885c 100644 --- a/kernel/indTyping.mli +++ b/kernel/indTyping.mli @@ -33,3 +33,12 @@ val typecheck_inductive : env -> mutual_inductive_entry -> (Constr.rel_context * (Constr.rel_context * Constr.types) array) * Sorts.family) array + +(* Utility function to compute the actual universe parameters + of a template polymorphic inductive *) +val template_polymorphic_univs : + template_check:bool -> + Univ.ContextSet.t -> + Constr.rel_context -> + Univ.Universe.t -> + Univ.Level.t option list * Univ.LSet.t diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 9305a91731..ccc218771a 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -94,7 +94,8 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = c', Monomorphic Univ.ContextSet.empty, cst | Polymorphic uctx, Some ctx -> let () = - if not (UGraph.check_subtype (Environ.universes env) uctx ctx) then + if not (UGraph.check_subtype ~lbound:(Environ.universes_lbound env) + (Environ.universes env) uctx ctx) then error_incorrect_with_constraint lab in (** Terms are compared in a context with De Bruijn universe indices *) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 53f228c618..327cb2efeb 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -777,7 +777,7 @@ let infer_cmp_universes env pb s0 s1 univs = | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible else univs | Set, Prop -> raise NotConvertible | Set, Type u -> infer_pb Univ.type0_univ u - | Type _u, Prop -> raise NotConvertible + | Type u, Prop -> infer_pb u Univ.type0m_univ | Type u, Set -> infer_pb u Univ.type0_univ | Type u0, Type u1 -> infer_pb u0 u1 diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index d47dc0c6e1..d22ec3b7ca 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -97,7 +97,8 @@ let check_universes error env u1 u2 = match u1, u2 with | Monomorphic _, Monomorphic _ -> env | Polymorphic auctx1, Polymorphic auctx2 -> - if not (UGraph.check_subtype (Environ.universes env) auctx2 auctx1) then + let lbound = Environ.universes_lbound env in + if not (UGraph.check_subtype ~lbound (Environ.universes env) auctx2 auctx1) then error (IncompatibleConstraints { got = auctx1; expect = auctx2; } ) else Environ.push_context ~strict:false (Univ.AUContext.repr auctx2) env diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 6fde6e9c5f..33336079bb 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -149,10 +149,10 @@ let enforce_leq_alg u v g = cg exception AlreadyDeclared = G.AlreadyDeclared -let add_universe u strict g = +let add_universe u ~lbound ~strict g = let graph = G.add u g.graph in let d = if strict then Lt else Le in - enforce_constraint (Level.set,d,u) {g with graph} + enforce_constraint (lbound,d,u) {g with graph} let add_universe_unconstrained u g = {g with graph=G.add u g.graph} @@ -164,11 +164,11 @@ let constraints_for ~kept g = G.constraints_for ~kept:(LSet.remove Level.sprop k (** Subtyping of polymorphic contexts *) -let check_subtype univs ctxT ctx = +let check_subtype ~lbound univs ctxT ctx = if AUContext.size ctxT == AUContext.size ctx then let (inst, cst) = UContext.dest (AUContext.repr ctx) in let cstT = UContext.constraints (AUContext.repr ctxT) in - let push accu v = add_universe v false accu in + let push accu v = add_universe v ~lbound ~strict:false accu in let univs = Array.fold_left push univs (Instance.to_array inst) in let univs = merge_constraints cstT univs in check_constraints cst univs diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index e1b5868d55..d90f01d8d1 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -48,7 +48,7 @@ val enforce_leq_alg : Universe.t -> Universe.t -> t -> Constraint.t * t exception AlreadyDeclared -val add_universe : Level.t -> bool -> t -> t +val add_universe : Level.t -> lbound:Level.t -> strict:bool -> t -> t (** Add a universe without (Prop,Set) <= u *) val add_universe_unconstrained : Level.t -> t -> t @@ -86,7 +86,7 @@ val constraints_for : kept:LSet.t -> t -> Constraint.t val domain : t -> LSet.t (** Known universes *) -val check_subtype : AUContext.t check_function +val check_subtype : lbound:Level.t -> AUContext.t check_function (** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of [ctx1]. *) diff --git a/kernel/uint63.mli b/kernel/uint63.mli index 5542716af2..d22ba3468f 100644 --- a/kernel/uint63.mli +++ b/kernel/uint63.mli @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + type t val uint_size : int diff --git a/kernel/uint63_i386_31.ml b/kernel/uint63_31.ml index b8eccd19fb..b8eccd19fb 100644 --- a/kernel/uint63_i386_31.ml +++ b/kernel/uint63_31.ml diff --git a/kernel/uint63_amd64_63.ml b/kernel/uint63_63.ml index 5c4028e1c8..5c4028e1c8 100644 --- a/kernel/uint63_amd64_63.ml +++ b/kernel/uint63_63.ml diff --git a/kernel/write_uint63.ml b/kernel/write_uint63.ml deleted file mode 100644 index 57a170c8f5..0000000000 --- a/kernel/write_uint63.ml +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Equivalent of rm -f *) -let safe_remove f = - try Unix.chmod f 0o644; Sys.remove f with _ -> () - -(** * Generate an implementation of 63-bit arithmetic *) -let ml_file_copy input output = - safe_remove output; - let i = open_in input in - let o = open_out output in - let pr s = Printf.fprintf o s in - pr "(* DO NOT EDIT THIS FILE: automatically generated by ./write_uint63.ml *)\n"; - pr "(* see uint63_amd64.ml and uint63_x86.ml *)\n"; - try - while true do - output_string o (input_line i); output_char o '\n' - done - with End_of_file -> - close_in i; - close_out o; - Unix.chmod output 0o444 - -let write_uint63 () = - ml_file_copy - (if max_int = 1073741823 (* 32-bits *) then "uint63_i386_31.ml" - else (* 64 bits *) "uint63_amd64_63.ml") - "uint63.ml" - -let () = write_uint63 () diff --git a/lib/aux_file.mli b/lib/aux_file.mli index 60c8fb4449..b241fdc6cc 100644 --- a/lib/aux_file.mli +++ b/lib/aux_file.mli @@ -21,7 +21,7 @@ val contents : aux_file -> string M.t H.t val aux_file_name_for : string -> string val start_aux_file : aux_file:string -> v_file:string -> unit -val stop_aux_file : unit -> unit +val stop_aux_file : unit -> unit val recording : unit -> bool val record_in_aux_at : ?loc:Loc.t -> string -> string -> unit diff --git a/lib/feedback.mli b/lib/feedback.mli index dc8449ed71..5375d97d57 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -74,13 +74,8 @@ val feedback : ?did:doc_id -> ?id:Stateid.t -> ?route:route_id -> feedback_conte (** [set_id_for_feedback route id] Set the defaults for feedback *) val set_id_for_feedback : ?route:route_id -> doc_id -> Stateid.t -> unit -(** {6 output functions} +(** {6 output functions} *) -[msg_notice] do not put any decoration on output by default. If -possible don't mix it with goal output (prefer msg_info or -msg_warning) so that interfaces can dispatch outputs easily. Once all -interfaces use the xml-like protocol this constraint can be -relaxed. *) (* Should we advertise these functions more? Should they be the ONLY allowed way to output something? *) diff --git a/lib/flags.ml b/lib/flags.ml index 190de5853d..f09dc48f5d 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -41,8 +41,6 @@ let with_options ol f x = let () = List.iter2 (:=) ol vl in Exninfo.iraise reraise -let record_aux_file = ref false - let async_proofs_worker_id = ref "master" let async_proofs_is_worker () = !async_proofs_worker_id <> "master" diff --git a/lib/flags.mli b/lib/flags.mli index 1c96796220..185a5f8425 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -31,10 +31,6 @@ (** Command-line flags *) -(** Set by coqtop to tell the kernel to output to the aux file; will - be eventually removed by cleanups such as PR#1103 *) -val record_aux_file : bool ref - (** Async-related flags *) val async_proofs_worker_id : string ref val async_proofs_is_worker : unit -> bool diff --git a/lib/future.ml b/lib/future.ml index 01fb7d0297..d3ea538549 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -98,7 +98,6 @@ let peek_val kx = let _, _, _, x = get kx in match !x with let uuid kx = let _, id, _, _ = get kx in id let from_val ?(fix_exn=id) v = create fix_exn (Val v) -let from_here ?(fix_exn=id) v = create fix_exn (Val v) let fix_exn_of ck = let _, _, fix_exn, _ = get ck in fix_exn @@ -168,8 +167,6 @@ let join kx = kx := Finished v; v -let sink kx = if is_val kx then ignore(join kx) - let split2 x = chain x (fun x -> fst x), chain x (fun x -> snd x) diff --git a/lib/future.mli b/lib/future.mli index 8e5f704837..c0fc91bcc3 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -55,10 +55,6 @@ val create : fix_exn -> (unit -> 'a) -> 'a computation argument should really be given *) val from_val : ?fix_exn:fix_exn -> 'a -> 'a computation -(* Like from_val, but also takes a snapshot of the global state. Morally - the value is not just the 'a but also the global system state *) -val from_here : ?fix_exn:fix_exn -> 'a -> 'a computation - (* To get the fix_exn of a computation and build a Lemmas.declaration_hook. * When a future enters the environment a corresponding hook is run to perform * some work. If this fails, then its failure has to be annotated with the @@ -100,9 +96,6 @@ val compute : 'a computation -> 'a value * in a computation obtained by chaining on a joined future. *) val join : 'a computation -> 'a -(* Call this before stocking the future. If it is_val then it is joined *) -val sink : 'a computation -> unit - (*** Utility functions ************************************************* ***) val split2 : ('a * 'b) computation -> 'a computation * 'b computation diff --git a/lib/system.ml b/lib/system.ml index b1a9efccfc..8c333ec267 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -300,13 +300,13 @@ let with_time ~batch ~header f x = let y = f x in let tend = get_time() in let msg2 = if batch then "" else " (successful)" in - Feedback.msg_info (header ++ str msg ++ fmt_time_difference tstart tend ++ str msg2); + Feedback.msg_notice (header ++ str msg ++ fmt_time_difference tstart tend ++ str msg2); y with e -> let tend = get_time() in let msg = if batch then "" else "Finished failing transaction in " in let msg2 = if batch then "" else " (failure)" in - Feedback.msg_info (header ++ str msg ++ fmt_time_difference tstart tend ++ str msg2); + Feedback.msg_notice (header ++ str msg ++ fmt_time_difference tstart tend ++ str msg2); raise e (* We use argv.[0] as we don't want to resolve symlinks *) diff --git a/library/coqlib.ml b/library/coqlib.ml index b1e4ef2b00..11d053624c 100644 --- a/library/coqlib.ml +++ b/library/coqlib.ml @@ -104,8 +104,10 @@ let gen_reference_in_modules locstr dirs s = let check_required_library d = let dir = make_dir d in - if Library.library_is_loaded dir then () - else + try + let _ : Declarations.module_body = Global.lookup_module (ModPath.MPfile dir) in + () + with Not_found -> let in_current_dir = match Lib.current_mp () with | MPfile dp -> DirPath.equal dir dp | _ -> false diff --git a/library/declaremods.ml b/library/declaremods.ml index eea129eae7..b4dc42bdfe 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -110,9 +110,9 @@ and subst_objects subst seg = | IncludeObject aobjs -> let aobjs' = subst_aobjs subst aobjs in if aobjs' == aobjs then node else (id, IncludeObject aobjs') - | ImportObject { export; mp } -> - let mp' = subst_mp subst mp in - if mp'==mp then node else (id, ImportObject { export; mp = mp' }) + | ExportObject { mpl } -> + let mpl' = List.map (subst_mp subst) mpl in + if mpl'==mpl then node else (id, ExportObject { mpl = mpl' }) | KeepObject _ -> assert false in List.Smart.map subst_one seg @@ -151,7 +151,11 @@ let expand_sobjs (_,aobjs) = expand_aobjs aobjs Module M:SIG. ... End M. have the keep list empty. *) -type module_objects = Nametab.object_prefix * Lib.lib_objects * Lib.lib_objects +type module_objects = + { module_prefix : Nametab.object_prefix; + module_substituted_objects : Lib.lib_objects; + module_keep_objects : Lib.lib_objects; + } module ModObjs : sig @@ -217,7 +221,13 @@ let do_module exists iter_objects i obj_dir obj_mp sobjs kobjs = (* If we're not a functor, let's iter on the internal components *) if sobjs_no_functor sobjs then begin let objs = expand_sobjs sobjs in - ModObjs.set obj_mp (prefix,objs,kobjs); + let module_objects = + { module_prefix = prefix; + module_substituted_objects = objs; + module_keep_objects = kobjs; + } + in + ModObjs.set obj_mp module_objects; iter_objects (i+1) prefix objs; iter_objects (i+1) prefix kobjs end @@ -233,7 +243,7 @@ let do_module' exists iter_objects i ((sp,kn),sobjs) = (** Nota: Interactive modules and module types cannot be recached! This used to be checked more properly here. *) -let do_modtype i sp mp sobjs = +let load_modtype i sp mp sobjs = if Nametab.exists_modtype sp then anomaly (pr_path sp ++ str " already exists."); Nametab.push_modtype (Nametab.Until i) sp mp; @@ -247,9 +257,9 @@ let rec load_object i (name, obj) = | ModuleObject sobjs -> do_module' false load_objects i (name, sobjs) | ModuleTypeObject sobjs -> let (sp,kn) = name in - do_modtype i sp (mp_of_kn kn) sobjs + load_modtype i sp (mp_of_kn kn) sobjs | IncludeObject aobjs -> load_include i (name, aobjs) - | ImportObject _ -> () + | ExportObject _ -> () | KeepObject objs -> load_keep i (name, objs) and load_objects i prefix objs = @@ -266,32 +276,69 @@ and load_keep i ((sp,kn),kobjs) = (* Invariant : seg isn't empty *) let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in let prefix = Nametab.{ obj_dir ; obj_mp; obj_sec = DirPath.empty } in - let prefix',sobjs,kobjs0 = + let modobjs = try ModObjs.get obj_mp with Not_found -> assert false (* a substobjs should already be loaded *) in - assert Nametab.(eq_op prefix' prefix); - assert (List.is_empty kobjs0); - ModObjs.set obj_mp (prefix,sobjs,kobjs); + assert Nametab.(eq_op modobjs.module_prefix prefix); + assert (List.is_empty modobjs.module_keep_objects); + ModObjs.set obj_mp { modobjs with module_keep_objects = kobjs }; load_objects i prefix kobjs (** {6 Implementation of Import and Export commands} *) -let rec really_import_module mp = +let mark_object obj (exports,acc) = + (exports, obj::acc) + +let rec collect_module_objects mp acc = (* May raise Not_found for unknown module and for functors *) - let prefix,sobjs,keepobjs = ModObjs.get mp in - open_objects 1 prefix sobjs; - open_objects 1 prefix keepobjs + let modobjs = ModObjs.get mp in + let prefix = modobjs.module_prefix in + let acc = collect_objects 1 prefix modobjs.module_keep_objects acc in + collect_objects 1 prefix modobjs.module_substituted_objects acc + +and collect_object i (name, obj as o) acc = + match obj with + | ExportObject { mpl; _ } -> collect_export i mpl acc + | AtomicObject _ | IncludeObject _ | KeepObject _ + | ModuleObject _ | ModuleTypeObject _ -> mark_object o acc + +and collect_objects i prefix objs acc = + List.fold_right (fun (id, obj) acc -> collect_object i (Lib.make_oname prefix id, obj) acc) objs acc + +and collect_one_export mp (exports,objs as acc) = + if not (MPset.mem mp exports) then + collect_module_objects mp (MPset.add mp exports, objs) + else acc + +and collect_export i mpl acc = + if Int.equal i 1 then + List.fold_right collect_one_export mpl acc + else acc -and open_object i (name, obj) = +let rec open_object i (name, obj) = match obj with | AtomicObject o -> Libobject.open_object i (name, o) - | ModuleObject sobjs -> do_module' true open_objects i (name, sobjs) + | ModuleObject sobjs -> + let dir = dir_of_sp (fst name) in + let mp = mp_of_kn (snd name) in + open_module i dir mp sobjs | ModuleTypeObject sobjs -> open_modtype i (name, sobjs) | IncludeObject aobjs -> open_include i (name, aobjs) - | ImportObject { mp; _ } -> open_import i mp + | ExportObject { mpl; _ } -> open_export i mpl | KeepObject objs -> open_keep i (name, objs) +and open_module i obj_dir obj_mp sobjs = + let prefix = Nametab.{ obj_dir ; obj_mp; obj_sec = DirPath.empty } in + let dirinfo = Nametab.GlobDirRef.DirModule prefix in + consistency_checks true obj_dir dirinfo; + Nametab.push_dir (Nametab.Exactly i) obj_dir dirinfo; + (* If we're not a functor, let's iter on the internal components *) + if sobjs_no_functor sobjs then begin + let modobjs = ModObjs.get obj_mp in + open_objects (i+1) modobjs.module_prefix modobjs.module_substituted_objects + end + and open_objects i prefix objs = List.iter (fun (id, obj) -> open_object i (Lib.make_oname prefix id, obj)) objs @@ -312,8 +359,9 @@ and open_include i ((sp,kn), aobjs) = let o = expand_aobjs aobjs in open_objects i prefix o -and open_import i mp = - if Int.equal i 1 then really_import_module mp +and open_export i mpl = + let _,objs = collect_export i mpl (MPset.empty, []) in + List.iter (open_object 1) objs and open_keep i ((sp,kn),kobjs) = let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in @@ -326,9 +374,9 @@ let rec cache_object (name, obj) = | ModuleObject sobjs -> do_module' false load_objects 1 (name, sobjs) | ModuleTypeObject sobjs -> let (sp,kn) = name in - do_modtype 1 sp (mp_of_kn kn) sobjs + load_modtype 0 sp (mp_of_kn kn) sobjs | IncludeObject aobjs -> cache_include (name, aobjs) - | ImportObject { mp } -> really_import_module mp + | ExportObject { mpl } -> anomaly Pp.(str "Export should not be cached") | KeepObject objs -> cache_keep (name, objs) and cache_include ((sp,kn), aobjs) = @@ -975,9 +1023,13 @@ let end_library ?except ~output_native_objects dir = let substitute, keep, _ = Lib.classify_segment lib_stack in cenv,(substitute,keep),ast -let import_module export mp = - really_import_module mp; - Lib.add_anonymous_entry (Lib.Leaf (ImportObject { export; mp })) +let import_modules ~export mpl = + let _,objs = List.fold_right collect_module_objects mpl (MPset.empty, []) in + List.iter (open_object 1) objs; + if export then Lib.add_anonymous_entry (Lib.Leaf (ExportObject { mpl })) + +let import_module ~export mp = + import_modules ~export [mp] (** {6 Iterators} *) @@ -988,9 +1040,10 @@ let iter_all_segments f = List.iter (apply_obj prefix) objs | _ -> f (Lib.make_oname prefix id) obj in - let apply_mod_obj _ (prefix,substobjs,keepobjs) = - List.iter (apply_obj prefix) substobjs; - List.iter (apply_obj prefix) keepobjs + let apply_mod_obj _ modobjs = + let prefix = modobjs.module_prefix in + List.iter (apply_obj prefix) modobjs.module_substituted_objects; + List.iter (apply_obj prefix) modobjs.module_keep_objects in let apply_node = function | sp, Lib.Leaf o -> f sp o @@ -1016,9 +1069,10 @@ let debug_print_modtab _ = | [] -> str "[]" | l -> str "[." ++ int (List.length l) ++ str ".]" in - let pr_modinfo mp (prefix,substobjs,keepobjs) s = + let pr_modinfo mp modobjs s = + let objs = modobjs.module_substituted_objects @ modobjs.module_keep_objects in s ++ str (ModPath.to_string mp) ++ (spc ()) - ++ (pr_seg (Lib.segment_of_objects prefix (substobjs@keepobjs))) + ++ (pr_seg (Lib.segment_of_objects modobjs.module_prefix objs)) in let modules = MPmap.fold pr_modinfo (ModObjs.all ()) (mt ()) in hov 0 modules diff --git a/library/declaremods.mli b/library/declaremods.mli index ada53dbff0..b7c7cd1dba 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -103,18 +103,17 @@ val end_library : (** append a function to be executed at end_library *) val append_end_library_hook : (unit -> unit) -> unit -(** [really_import_module mp] opens the module [mp] (in a Caml sense). +(** [import_module export mp] imports the module [mp]. It modifies Nametab and performs the [open_object] function for every object of the module. Raises [Not_found] when [mp] is unknown - or when [mp] corresponds to a functor. *) - -val really_import_module : ModPath.t -> unit - -(** [import_module export mp] is a synchronous version of - [really_import_module]. If [export] is [true], the module is also + or when [mp] corresponds to a functor. If [export] is [true], the module is also opened every time the module containing it is. *) -val import_module : bool -> ModPath.t -> unit +val import_module : export:bool -> ModPath.t -> unit + +(** Same as [import_module] but for multiple modules, and more optimized than + iterating [import_module]. *) +val import_modules : export:bool -> ModPath.t list -> unit (** Include *) diff --git a/library/global.ml b/library/global.ml index 0fc9e11364..6bb4614aa4 100644 --- a/library/global.ml +++ b/library/global.ml @@ -119,6 +119,7 @@ let add_module_parameter mbid mte inl = (** Queries on the global environment *) let universes () = universes (env()) +let universes_lbound () = universes_lbound (env()) let named_context () = named_context (env()) let named_context_val () = named_context_val (env()) @@ -181,6 +182,10 @@ let is_polymorphic r = Environ.is_polymorphic (env()) r let is_template_polymorphic r = is_template_polymorphic (env ()) r +let is_template_checked r = is_template_checked (env ()) r + +let get_template_polymorphic_variables r = get_template_polymorphic_variables (env ()) r + let is_type_in_type r = is_type_in_type (env ()) r let current_modpath () = diff --git a/library/global.mli b/library/global.mli index b089b7dd80..d0bd556d70 100644 --- a/library/global.mli +++ b/library/global.mli @@ -22,6 +22,7 @@ val env : unit -> Environ.env val env_is_initial : unit -> bool val universes : unit -> UGraph.t +val universes_lbound : unit -> Univ.Level.t val named_context_val : unit -> Environ.named_context_val val named_context : unit -> Constr.named_context @@ -136,6 +137,8 @@ val is_joined_environment : unit -> bool val is_polymorphic : GlobRef.t -> bool val is_template_polymorphic : GlobRef.t -> bool +val is_template_checked : GlobRef.t -> bool +val get_template_polymorphic_variables : GlobRef.t -> Univ.Level.t list val is_type_in_type : GlobRef.t -> bool (** {6 Retroknowledge } *) diff --git a/library/goptions.ml b/library/goptions.ml index c7024ca81d..0973944fb5 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -398,9 +398,9 @@ let print_option_value key = let s = read () in match s with | BoolValue b -> - Feedback.msg_info (str "The " ++ str name ++ str " mode is " ++ str (if b then "on" else "off")) + Feedback.msg_notice (str "The " ++ str name ++ str " mode is " ++ str (if b then "on" else "off")) | _ -> - Feedback.msg_info (str "Current value of " ++ str name ++ str " is " ++ msg_option_value (name, s)) + Feedback.msg_notice (str "Current value of " ++ str name ++ str " is " ++ msg_option_value (name, s)) let get_tables () = let tables = !value_tab in diff --git a/library/lib.ml b/library/lib.ml index 3f51826315..851f086961 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -73,11 +73,8 @@ let classify_segment seg = clean ((id,o)::substl, keepl, anticipl) stk | KeepObject _ -> clean (substl, (id,o)::keepl, anticipl) stk - | ImportObject { export } -> - if export then - clean ((id,o)::substl, keepl, anticipl) stk - else - clean acc stk + | ExportObject _ -> + clean ((id,o)::substl, keepl, anticipl) stk | AtomicObject obj -> begin match classify_object obj with | Dispose -> clean acc stk @@ -615,7 +612,7 @@ let discharge_item ((sp,_ as oname),e) = | Leaf lobj -> begin match lobj with | ModuleObject _ | ModuleTypeObject _ | IncludeObject _ | KeepObject _ - | ImportObject _ -> None + | ExportObject _ -> None | AtomicObject obj -> Option.map (fun o -> (basename sp,o)) (discharge_object (oname,obj)) end diff --git a/library/libobject.ml b/library/libobject.ml index 27e7810e6c..932f065f73 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -75,7 +75,7 @@ and t = | ModuleTypeObject of substitutive_objects | IncludeObject of algebraic_objects | KeepObject of objects - | ImportObject of { export : bool; mp : ModPath.t } + | ExportObject of { mpl : ModPath.t list } | AtomicObject of obj and objects = (Names.Id.t * t) list diff --git a/library/libobject.mli b/library/libobject.mli index 3b37db4a6f..146ccc293f 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -112,7 +112,7 @@ and t = | ModuleTypeObject of substitutive_objects | IncludeObject of algebraic_objects | KeepObject of objects - | ImportObject of { export : bool; mp : Names.ModPath.t } + | ExportObject of { mpl : Names.ModPath.t list } | AtomicObject of obj and objects = (Names.Id.t * t) list diff --git a/library/library.mllib b/library/library.mllib index 3b75438ccd..c34d8911e8 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -6,7 +6,6 @@ Nametab Global Lib Declaremods -Library States Kindops Goptions diff --git a/library/states.ml b/library/states.ml index a73f16957d..0be153d96a 100644 --- a/library/states.ml +++ b/library/states.ml @@ -9,7 +9,6 @@ (************************************************************************) open Util -open System type state = Lib.frozen * Summary.frozen @@ -25,13 +24,6 @@ let unfreeze (fl,fs) = Lib.unfreeze fl; Summary.unfreeze_summaries fs -let extern_state s = - System.extern_state Coq_config.state_magic_number s (freeze ~marshallable:true) - -let intern_state s = - unfreeze (with_magic_number_check (System.intern_state Coq_config.state_magic_number) s); - Library.overwrite_library_filenames s - (* Rollback. *) let with_state_protection f x = diff --git a/library/states.mli b/library/states.mli index c4f3eae49d..4870f48fc3 100644 --- a/library/states.mli +++ b/library/states.mli @@ -15,9 +15,6 @@ freezing the states of both [Lib] and [Summary]. We provide functions to write and restore state to and from a given file. *) -val intern_state : string -> unit -val extern_state : string -> unit - type state val freeze : marshallable:bool -> state val unfreeze : state -> unit diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index de23f05a9e..7f0d768d3f 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -436,7 +436,7 @@ let comment_stop ep = let bp = match !comment_begin with Some bp -> bp | None -> - Feedback.msg_notice + Feedback.msg_debug (str "No begin location for comment '" ++ str current_s ++str"' ending at " ++ int ep); diff --git a/parsing/extend.ml b/parsing/extend.ml index 63e121c0d1..ed6ebe5aed 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -79,8 +79,10 @@ type ('a,'b,'c) ty_user_symbol = (** {5 Type-safe grammar extension} *) -type norec = NoRec (* just two *) -type mayrec = MayRec (* incompatible types *) +(* Should be merged with gramlib's implementation *) + +type norec = Gramlib.Grammar.ty_norec +type mayrec = Gramlib.Grammar.ty_mayrec type ('self, 'trec, 'a) symbol = | Atoken : 'c Tok.p -> ('self, norec, 'c) symbol @@ -107,15 +109,3 @@ and 'a rules = type 'a production_rule = | Rule : ('a, _, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule - -type 'a single_extend_statement = - string option * - (* Level *) - Gramlib.Gramext.g_assoc option * - (* Associativity *) - 'a production_rule list - (* Symbol list with the interpretation function *) - -type 'a extend_statement = - Gramlib.Gramext.position option * - 'a single_extend_statement list diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 3aaba27579..e0d63a723e 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -131,73 +131,57 @@ end (** Binding general entry keys to symbol *) -type ('s, 'trec, 'a, 'r) casted_rule = -| CastedRNo : ('s, G.ty_norec, 'b, 'r) G.ty_rule * ('a -> 'b) -> ('s, norec, 'a, 'r) casted_rule -| CastedRMay : ('s, G.ty_mayrec, 'b, 'r) G.ty_rule * ('a -> 'b) -> ('s, mayrec, 'a, 'r) casted_rule - -type ('s, 'trec, 'a) casted_symbol = -| CastedSNo : ('s, G.ty_norec, 'a) G.ty_symbol -> ('s, norec, 'a) casted_symbol -| CastedSMay : ('s, G.ty_mayrec, 'a) G.ty_symbol -> ('s, mayrec, 'a) casted_symbol - -let rec symbol_of_prod_entry_key : type s tr a. (s, tr, a) symbol -> (s, tr, a) casted_symbol = +let rec symbol_of_prod_entry_key : type s tr a. (s, tr, a) symbol -> (s, tr, a) G.ty_symbol = function -| Atoken t -> CastedSNo (G.s_token t) +| Atoken t -> G.s_token t | Alist1 s -> - begin match symbol_of_prod_entry_key s with - | CastedSNo s -> CastedSNo (G.s_list1 s) - | CastedSMay s -> CastedSMay (G.s_list1 s) end + let s = symbol_of_prod_entry_key s in + G.s_list1 s | Alist1sep (s,sep) -> - let CastedSNo sep = symbol_of_prod_entry_key sep in - begin match symbol_of_prod_entry_key s with - | CastedSNo s -> CastedSNo (G.s_list1sep s sep false) - | CastedSMay s -> CastedSMay (G.s_list1sep s sep false) end + let s = symbol_of_prod_entry_key s in + let sep = symbol_of_prod_entry_key sep in + G.s_list1sep s sep false | Alist0 s -> - begin match symbol_of_prod_entry_key s with - | CastedSNo s -> CastedSNo (G.s_list0 s) - | CastedSMay s -> CastedSMay (G.s_list0 s) end + let s = symbol_of_prod_entry_key s in + G.s_list0 s | Alist0sep (s,sep) -> - let CastedSNo sep = symbol_of_prod_entry_key sep in - begin match symbol_of_prod_entry_key s with - | CastedSNo s -> CastedSNo (G.s_list0sep s sep false) - | CastedSMay s -> CastedSMay (G.s_list0sep s sep false) end + let s = symbol_of_prod_entry_key s in + let sep = symbol_of_prod_entry_key sep in + G.s_list0sep s sep false | Aopt s -> - begin match symbol_of_prod_entry_key s with - | CastedSNo s -> CastedSNo (G.s_opt s) - | CastedSMay s -> CastedSMay (G.s_opt s) end -| Aself -> CastedSMay G.s_self -| Anext -> CastedSMay G.s_next -| Aentry e -> CastedSNo (G.s_nterm e) -| Aentryl (e, n) -> CastedSNo (G.s_nterml e n) + let s = symbol_of_prod_entry_key s in + G.s_opt 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 - CastedSNo (G.s_rules ~warning:(Some warning) (List.map symbol_of_rules rs)) + G.s_rules ~warning:(Some warning) (List.map symbol_of_rules rs) -and symbol_of_rule : type s tr a r. (s, tr, a, Loc.t -> r) Extend.rule -> (s, tr, a, Loc.t -> r) casted_rule = function -| Stop -> CastedRNo (G.r_stop, fun act loc -> act loc) +and symbol_of_rule : type s tr a r. (s, tr, a, Loc.t -> r) Extend.rule -> (s, tr, a, Loc.t -> r) G.ty_rule = function +| Stop -> + G.r_stop | Next (r, s) -> - begin match symbol_of_rule r, symbol_of_prod_entry_key s with - | CastedRNo (r, cast), CastedSNo s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) - | CastedRNo (r, cast), CastedSMay s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) - | CastedRMay (r, cast), CastedSNo s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) - | CastedRMay (r, cast), CastedSMay s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) end + let r = symbol_of_rule r in + let s = symbol_of_prod_entry_key s in + G.r_next r s | NextNoRec (r, s) -> - let CastedRNo (r, cast) = symbol_of_rule r in - let CastedSNo s = symbol_of_prod_entry_key s in - CastedRNo (G.r_next_norec r s, (fun act x -> cast (act x))) + let r = symbol_of_rule r in + let s = symbol_of_prod_entry_key s in + G.r_next_norec r s and symbol_of_rules : type a. a Extend.rules -> a G.ty_rules = function | Rules (r, act) -> - let CastedRNo (symb, cast) = symbol_of_rule r in - G.rules (symb, cast act) + let symb = symbol_of_rule r in + G.rules (symb,act) (** FIXME: This is a hack around a deficient camlp5 API *) type 'a any_production = AnyProduction : ('a, 'tr, 'f, Loc.t -> 'a) G.ty_rule * 'f -> 'a any_production let of_coq_production_rule : type a. a Extend.production_rule -> a any_production = function | Rule (toks, act) -> - match symbol_of_rule toks with - | CastedRNo (symb, cast) -> AnyProduction (symb, cast act) - | CastedRMay (symb, cast) -> AnyProduction (symb, cast act) + AnyProduction (symbol_of_rule toks, act) let of_coq_single_extend_statement (lvl, assoc, rule) = (lvl, assoc, List.map of_coq_production_rule rule) @@ -215,6 +199,18 @@ let fix_extend_statement (pos, st) = (** Type of reinitialization data *) type gram_reinit = Gramlib.Gramext.g_assoc * Gramlib.Gramext.position +type 'a single_extend_statement = + string option * + (* Level *) + Gramlib.Gramext.g_assoc option * + (* Associativity *) + 'a production_rule list + (* Symbol list with the interpretation function *) + +type 'a extend_statement = + Gramlib.Gramext.position option * + 'a single_extend_statement list + type extend_rule = | ExtendRule : 'a G.Entry.e * gram_reinit option * 'a extend_statement -> extend_rule @@ -462,11 +458,10 @@ module Module = let module_expr = Entry.create "module_expr" let module_type = Entry.create "module_type" end + let epsilon_value (type s tr a) f (e : (s, tr, a) symbol) = - let r = - match symbol_of_prod_entry_key e with - | CastedSNo s -> G.production (G.r_next G.r_stop s, (fun x _ -> f x)) - | CastedSMay s -> G.production (G.r_next G.r_stop s, (fun x _ -> f x)) in + let s = symbol_of_prod_entry_key e in + let r = G.production (G.r_next G.r_stop s, (fun x _ -> f x)) in let ext = [None, None, [r]] in let entry = Gram.entry_create "epsilon" in let warning msg = Feedback.msg_warning Pp.(str msg) in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 7efeab6ba0..10f78a5a72 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -212,8 +212,19 @@ val epsilon_value : ('a -> 'self) -> ('self, _, 'a) Extend.symbol -> 'self optio type gram_reinit = Gramlib.Gramext.g_assoc * Gramlib.Gramext.position (** Type of reinitialization data *) -val grammar_extend : 'a Entry.t -> gram_reinit option -> - 'a Extend.extend_statement -> unit +type 'a single_extend_statement = + string option * + (* Level *) + Gramlib.Gramext.g_assoc option * + (* Associativity *) + 'a production_rule list + (* Symbol list with the interpretation function *) + +type 'a extend_statement = + Gramlib.Gramext.position option * + 'a single_extend_statement list + +val grammar_extend : 'a Entry.t -> gram_reinit option -> 'a extend_statement -> unit (** Extend the grammar of Coq, without synchronizing it with the backtracking mechanism. This means that grammar extensions defined this way will survive an undo. *) diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v index 638a4cef21..3ad5bc9f2d 100644 --- a/plugins/btauto/Algebra.v +++ b/plugins/btauto/Algebra.v @@ -1,4 +1,4 @@ -Require Import Bool PArith DecidableClass Omega Lia. +Require Import Bool PArith DecidableClass Ring Omega Lia. Ltac bool := repeat match goal with diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 3ed843649e..b5be1cdd89 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -437,30 +437,25 @@ let cc_tactic depth additionnal_terms = let cstr=(get_constructor_info uf ipac.cnode).ci_constr in discriminate_tac cstr p | Incomplete -> - let open Glob_term in - let env = Proofview.Goal.env gl in - let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in - let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) in - let pr_missing (c, missing) = - let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in - let holes = List.init missing (fun _ -> hole) in - Printer.pr_glob_constr_env env (DAst.make @@ GApp (c, holes)) - in - Feedback.msg_info - (Pp.str "Goal is solvable by congruence but some arguments are missing."); - Feedback.msg_info - (Pp.str " Try " ++ - hov 8 - begin - str "\"congruence with (" ++ - prlist_with_sep - (fun () -> str ")" ++ spc () ++ str "(") - pr_missing - terms_to_complete ++ - str ")\"," - end ++ - Pp.str " replacing metavariables by arbitrary terms."); - Tacticals.New.tclFAIL 0 (str "Incomplete") + let open Glob_term in + let env = Proofview.Goal.env gl in + let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in + let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) in + let pr_missing (c, missing) = + let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in + let holes = List.init missing (fun _ -> hole) in + Printer.pr_glob_constr_env env (DAst.make @@ GApp (c, holes)) + in + let msg = Pp.(str "Goal is solvable by congruence but some arguments are missing." + ++ fnl () ++ + str " Try " ++ + hov 8 + begin + str "\"congruence with (" ++ prlist_with_sep (fun () -> str ")" ++ spc () ++ str "(") + pr_missing terms_to_complete ++ str ")\"," + end ++ + str " replacing metavariables by arbitrary terms.") in + Tacticals.New.tclFAIL 0 msg | Contradiction dis -> let env = Proofview.Goal.env gl in let p=build_proof env sigma uf (`Prove (dis.lhs,dis.rhs)) in diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 78c6255c1e..cca212f332 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -754,18 +754,6 @@ and extract_cst_app env sg mle mlt kn args = let la = List.length args in (* The ml arguments, already expunged from known logical ones *) let mla = make_mlargs env sg mle s args metas in - let mla = - if magic1 || lang () != Ocaml then mla - else - try - (* for better optimisations later, we discard dependent args - of projections and replace them by fake args that will be - removed during final pretty-print. *) - let l,l' = List.chop (projection_arity (GlobRef.ConstRef kn)) mla in - if not (List.is_empty l') then (List.map (fun _ -> MLexn "Proj Args") l) @ l' - else mla - with e when CErrors.noncritical e -> mla - in (* For strict languages, purely logical signatures lead to a dummy lam (except when [Kill Ktype] everywhere). So a [MLdummy] is left accordingly. *) diff --git a/plugins/extraction/g_extraction.mlg b/plugins/extraction/g_extraction.mlg index e222fbc808..4f077b08b6 100644 --- a/plugins/extraction/g_extraction.mlg +++ b/plugins/extraction/g_extraction.mlg @@ -128,7 +128,7 @@ END VERNAC COMMAND EXTEND PrintExtractionInline CLASSIFIED AS QUERY | [ "Print" "Extraction" "Inline" ] - -> {Feedback. msg_info (print_extraction_inline ()) } + -> {Feedback.msg_notice (print_extraction_inline ()) } END VERNAC COMMAND EXTEND ResetExtractionInline CLASSIFIED AS SIDEFF @@ -150,7 +150,7 @@ END VERNAC COMMAND EXTEND PrintExtractionBlacklist CLASSIFIED AS QUERY | [ "Print" "Extraction" "Blacklist" ] - -> { Feedback.msg_info (print_extraction_blacklist ()) } + -> { Feedback.msg_notice (print_extraction_blacklist ()) } END VERNAC COMMAND EXTEND ResetExtractionBlacklist CLASSIFIED AS SIDEFF diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 2d5872718f..000df26858 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -779,7 +779,7 @@ let eta_red e = else e | _ -> e -(* Performs an eta-reduction when the core is atomic, +(* Performs an eta-reduction when the core is atomic and value, or otherwise returns None *) let atomic_eta_red e = @@ -789,7 +789,7 @@ let atomic_eta_red e = | MLapp (f,a) when test_eta_args_lift 0 n a -> (match f with | MLrel k when k>n -> Some (MLrel (k-n)) - | MLglob _ | MLexn _ | MLdummy _ -> Some f + | MLglob _ | MLdummy _ -> Some f | _ -> None) | _ -> None @@ -1547,6 +1547,7 @@ let inline r t = not (to_keep r) (* The user DOES want to keep it *) && not (is_inline_custom r) && (to_inline r (* The user DOES want to inline it *) - || (lang () != Haskell && not (is_projection r) && - (is_recursor r || manual_inline r || inline_test r t))) + || (lang () != Haskell && + (is_projection r || is_recursor r || + manual_inline r || inline_test r t))) diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 75fb35192b..e7004fe9af 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -229,12 +229,7 @@ let rec pp_expr par env args = and pp_a1 = pp_expr false env [] a1 and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in hv 0 (apply2 (pp_letin pp_id pp_a1 pp_a2)) - | MLglob r -> - (try - let args = List.skipn (projection_arity r) args in - let record = List.hd args in - pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args) - with e when CErrors.noncritical e -> apply (pp_global Term r)) + | MLglob r -> apply (pp_global Term r) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix par env' i (Array.of_list (List.rev ids'),defs) args @@ -324,10 +319,14 @@ and pp_record_proj par env typ t pv args = let n = List.length ids in let no_patvar a = not (List.exists (ast_occurs_itvl 1 n) a) in let rel_i,a = match body with - | MLrel i when i <= n -> i,[] - | MLapp(MLrel i, a) when i<=n && no_patvar a -> i,a + | MLrel i | MLmagic(MLrel i) when i <= n -> i,[] + | MLapp(MLrel i, a) | MLmagic(MLapp(MLrel i, a)) + | MLapp(MLmagic(MLrel i), a) when i<=n && no_patvar a -> i,a | _ -> raise Impossible in + let magic = + match body with MLmagic _ | MLapp(MLmagic _, _) -> true | _ -> false + in let rec lookup_rel i idx = function | Prel j :: l -> if Int.equal i j then idx else lookup_rel i (idx+1) l | Pwild :: l -> lookup_rel i (idx+1) l @@ -343,7 +342,10 @@ and pp_record_proj par env typ t pv args = let pp_args = (List.map (pp_expr true env' []) a) @ args in let pp_head = pp_expr true env [] t ++ str "." ++ pp_field r fields idx in - pp_apply pp_head par pp_args + if magic then + pp_apply (str "Obj.magic") par (pp_head :: pp_args) + else + pp_apply pp_head par pp_args and pp_record_pat (fields, args) = str "{ " ++ @@ -579,14 +581,10 @@ let pp_decl = function | Dterm (r, a, t) -> let def = if is_custom r then str (" = " ^ find_custom r) - else if is_projection r then - (prvect str (Array.make (projection_arity r) " _")) ++ - str " x = x." else pp_function (empty_env ()) a in let name = pp_global Term r in - let postdef = if is_projection r then name else mt () in - pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ postdef) + pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ mt ()) | Dfix (rv,defs,typs) -> pp_Dfix (rv,defs,typs) diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index 8a5c32b8b5..35cd10a1ff 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -83,7 +83,7 @@ END VERNAC COMMAND EXTEND Firstorder_Print_Solver CLASSIFIED AS QUERY | [ "Print" "Firstorder" "Solver" ] -> { - Feedback.msg_info + Feedback.msg_notice (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) } END diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 5a939b4adf..ca33e4e757 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -941,7 +941,11 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = let equation_lemma = try - let finfos = find_Function_infos (fst (destConst !evd f)) (*FIXME*) in + let finfos = + match find_Function_infos (fst (destConst !evd f)) (*FIXME*) with + | None -> raise Not_found + | Some finfos -> finfos + in mkConst (Option.get finfos.equation_lemma) with (Not_found | Option.IsNone as e) -> let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in @@ -953,14 +957,18 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a let _ = match e with | Option.IsNone -> - let finfos = find_Function_infos (fst (destConst !evd f)) in - update_Function - {finfos with - equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with - GlobRef.ConstRef c -> c - | _ -> CErrors.anomaly (Pp.str "Not a constant.") - ) - } + let finfos = match find_Function_infos (fst (destConst !evd f)) with + | None -> raise Not_found + | Some finfos -> finfos + in + update_Function + {finfos with + equation_lemma = Some ( + match Nametab.locate (qualid_of_ident equation_lemma_id) with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly (Pp.str "Not a constant.") + ) + } | _ -> () in (* let res = Constrintern.construct_reference (pf_hyps g) equation_lemma_id in *) diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 92a93489f4..2b990400e3 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -91,7 +91,7 @@ END { let functional_induction b c x pat = - Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat)) + functional_induction true c x (Option.map out_disjunctive pat) } diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index a836335d4d..570b72136c 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -164,7 +164,7 @@ let prepare_body { Vernacexpr.binders } rt = let fun_args,rt' = chop_rlambda_n n rt in (fun_args,rt') -let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook = +let build_functional_principle ?(opaque=Proof_global.Transparent) (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook = (* First we get the type of the old graph principle *) let mutr_nparams = (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)).Tactics.nparams in (* let time1 = System.get_time () in *) @@ -199,10 +199,10 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin (* end; *) let open Proof_global in - let { name; entries } = Lemmas.pf_fold (close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x)) lemma in + let { name; entries } = Lemmas.pf_fold (close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x)) lemma in match entries with | [entry] -> - name, entry, hook + entry, hook | _ -> CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") @@ -234,6 +234,23 @@ let change_property_sort evd toSort princ princName = ) (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.Tactics.params) +(* XXX: To be cleaned up soon in favor of common save path. *) +let save name const ?hook uctx scope kind = + let open Declare in + let open DeclareDef in + let fix_exn = Future.fix_exn_of const.Declare.proof_entry_body in + let r = match scope with + | Discharge -> + let c = SectionLocalDef const in + let () = declare_variable ~name ~kind c in + GlobRef.VarRef name + | Global local -> + let kn = declare_constant ~name ~kind ~local (DefinitionEntry const) in + GlobRef.ConstRef kn + in + DeclareDef.Hook.(call ?hook ~fix_exn { S.uctx; obls = []; scope; dref = r }); + definition_message name + let generate_functional_principle (evd: Evd.evar_map ref) interactive_proof old_princ_type sorts new_princ_name funs i proof_tac @@ -282,7 +299,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) register_with_sort Sorts.InProp; register_with_sort Sorts.InSet in - let id,entry,hook = + let entry, hook = build_functional_principle evd interactive_proof old_princ_type new_sorts funs i proof_tac hook in @@ -495,14 +512,17 @@ let find_induction_principle evd f = | Constr.Const c' -> c' | _ -> CErrors.user_err Pp.(str "Must be used with a function") in - let infos = find_Function_infos f_as_constant in - match infos.rect_lemma with - | None -> raise Not_found - | Some rect_lemma -> - let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) in - let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in - evd:=evd'; - rect_lemma,typ + match find_Function_infos f_as_constant with + | None -> + raise Not_found + | Some infos -> + match infos.rect_lemma with + | None -> raise Not_found + | Some rect_lemma -> + let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) in + let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in + evd:=evd'; + rect_lemma,typ (* [prove_fun_correct funs_constr graphs_constr schemes lemmas_types_infos i ] is the tactic used to prove correctness lemma. @@ -1016,12 +1036,12 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) let rewrite_tac j ids : Tacmach.tactic = let graph_def = graphs.(j) in - let infos = - try find_Function_infos (fst (destConst (project g) funcs.(j))) - with Not_found -> CErrors.user_err Pp.(str "No graph found") + let infos = match find_Function_infos (fst (destConst (project g) funcs.(j))) with + | None -> + CErrors.user_err Pp.(str "No graph found") + | Some infos -> infos in - if infos.is_general - || Rtree.is_infinite Declareops.eq_recarg graph_def.Declarations.mind_recargs + if infos.is_general || Rtree.is_infinite Declareops.eq_recarg graph_def.Declarations.mind_recargs then let eq_lemma = try Option.get (infos).equation_lemma @@ -1167,16 +1187,16 @@ let get_funs_constant mp = in l_const -let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_effects Proof_global.proof_entry list = +let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_effects Declare.proof_entry list = let exception Found_type of int in let env = Global.env () in let funs = List.map fst fas in let first_fun = List.hd funs in let funs_mp = KerName.modpath (Constant.canonical (fst first_fun)) in let first_fun_kn = - try - fst (find_Function_infos (fst first_fun)).graph_ind - with Not_found -> raise No_graph_found + match find_Function_infos (fst first_fun) with + | None -> raise No_graph_found + | Some finfos -> fst finfos.graph_ind in let this_block_funs_indexes = get_funs_constant funs_mp (fst first_fun) in let this_block_funs = Array.map (fun (c,_) -> (c,snd first_fun)) this_block_funs_indexes in @@ -1216,9 +1236,21 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef s::l_schemes -> s,l_schemes | _ -> CErrors.anomaly (Pp.str "") in - let _,const,_ = + let opaque = + let finfos = + match find_Function_infos (fst first_fun) with + | None -> raise Not_found + | Some finfos -> finfos + in + let open Proof_global in + match finfos.equation_lemma with + | None -> Transparent (* non recursive definition *) + | Some equation -> + if Declareops.is_opaque (Global.lookup_constant equation) then Opaque else Transparent + in + let entry, _hook = try - build_functional_principle evd false + build_functional_principle ~opaque evd false first_type (Array.of_list sorts) this_block_funs @@ -1230,27 +1262,16 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef in incr i; - let opacity = - let finfos = find_Function_infos (fst first_fun) in - try - let equation = Option.get finfos.equation_lemma in - Declareops.is_opaque (Global.lookup_constant equation) - with Option.IsNone -> (* non recursive definition *) - false - in - let const = {const with Proof_global.proof_entry_opaque = opacity } in (* The others are just deduced *) if List.is_empty other_princ_types - then - [const] + then [entry] else let other_fun_princ_types = let funs = Array.map Constr.mkConstU this_block_funs in let sorts = Array.of_list sorts in List.map (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) other_princ_types in - let open Proof_global in - let first_princ_body,first_princ_type = const.proof_entry_body, const.proof_entry_type in + let first_princ_body,first_princ_type = Declare.(entry.proof_entry_body, entry.proof_entry_type) in let ctxt,fix = Term.decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) let (idxs,_),(_,ta,_ as decl) = Constr.destFix fix in let other_result = @@ -1277,7 +1298,7 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef (* If we reach this point, the two principle are not mutually recursive We fall back to the previous method *) - let _,const,_ = + let entry, _hook = build_functional_principle evd false @@ -1288,20 +1309,16 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef (Functional_principles_proofs.prove_princ_for_struct evd false !i (Array.of_list (List.map fst funs))) (fun _ _ -> ()) in - const + entry with Found_type i -> let princ_body = Termops.it_mkLambda_or_LetIn (Constr.mkFix((idxs,i),decl)) ctxt in - {const with - proof_entry_body = - (Future.from_val ((princ_body, Univ.ContextSet.empty), Evd.empty_side_effects)); - proof_entry_type = Some scheme_type - } + Declare.definition_entry ~types:scheme_type princ_body ) other_fun_princ_types in - const::other_result + entry::other_result (* [derive_correctness funs graphs] create correctness and completeness lemmas for each function in [funs] w.r.t. [graphs] @@ -1352,7 +1369,8 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = Array.of_list (List.map (fun entry -> - (EConstr.of_constr (fst (fst(Future.force entry.Proof_global.proof_entry_body))), EConstr.of_constr (Option.get entry.Proof_global.proof_entry_type )) + (EConstr.of_constr (fst (fst (Future.force entry.Declare.proof_entry_body))), + EConstr.of_constr (Option.get entry.Declare.proof_entry_type )) ) (make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs)) ) @@ -1381,7 +1399,11 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = let lemma = fst @@ Lemmas.by (Proofview.V82.tactic (proving_tac i)) lemma in let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = find_Function_infos (fst f_as_constant) in + let finfo = + match find_Function_infos (fst f_as_constant) with + | None -> raise Not_found + | Some finfo -> finfo + in (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in @@ -1443,7 +1465,11 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") (proving_tac i))) lemma) in let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = find_Function_infos (fst f_as_constant) in + let finfo = + match find_Function_infos (fst f_as_constant) with + | None -> raise Not_found + | Some finfo -> finfo + in let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in let (lem_cst,_) = destConst !evd lem_cst_constr in @@ -2028,7 +2054,11 @@ let build_case_scheme fa = let sigma, (_,u) = Evd.fresh_constant_instance env sigma funs in let first_fun = funs in let funs_mp = Constant.modpath first_fun in - let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in + let first_fun_kn = + match find_Function_infos first_fun with + | None -> raise No_graph_found + | Some finfos -> fst finfos.graph_ind + in let this_block_funs_indexes = get_funs_constant funs_mp first_fun in let this_block_funs = Array.map (fun (c,_) -> (c,u)) this_block_funs_indexes in let prop_sort = Sorts.InProp in diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index ddd6ecfb5c..7c17ecdba0 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1252,7 +1252,7 @@ let rec compute_cst_params relnames params gt = DAst.with_val (function | GSort _ -> params | GHole _ -> params | GIf _ | GRec _ | GCast _ -> - raise (UserError(Some "compute_cst_params", str "Not handled case")) + CErrors.user_err ~hdr:"compute_cst_params" (str "Not handled case") ) gt and compute_cst_params_from_app acc (params,rtl) = let is_gid id c = match DAst.get c with GVar id' -> Id.equal id id' | _ -> false in diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index fbf63c69dd..8abccabae6 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -1,4 +1,13 @@ -open Pp +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + open Constr open Glob_term open CErrors @@ -433,7 +442,8 @@ let replace_var_by_term x_id term = replace_var_by_pattern lhs, replace_var_by_pattern rhs ) - | GRec _ -> raise (UserError(None,str "Not handled GRec")) + | GRec _ -> + CErrors.user_err (Pp.str "Not handled GRec") | GSort _ | GHole _ as rt -> rt | GInt _ as rt -> rt diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 24b3690138..70211a1860 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + open Names open Glob_term diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index eeb2f246c2..a205c0744a 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -8,15 +8,19 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open CErrors -open Sorts +open Pp open Util +open CErrors open Names +open Sorts open Constr open EConstr -open Pp + +open Tacmach.New +open Tacticals.New +open Tactics + open Indfun_common -open Tactypes module RelDecl = Context.Rel.Declaration @@ -37,111 +41,107 @@ let choose_dest_or_ind scheme_info args = Tactics.induction_destruct (is_rec_info sigma scheme_info) false args) let functional_induction with_clean c princl pat = - let res = - fun g -> - let sigma = Tacmach.project g in + let open Proofview.Notations in + Proofview.Goal.enter_one (fun gl -> + let sigma = project gl in let f,args = decompose_app sigma c in - let princ,bindings, princ_type,g' = - match princl with - | None -> (* No principle is given let's find the good one *) - begin - match EConstr.kind sigma f with - | Const (c',u) -> - let princ_option = - let finfo = (* we first try to find out a graph on f *) - try find_Function_infos c' - with Not_found -> - user_err (str "Cannot find induction information on "++ - Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) - in - match Tacticals.elimination_sort_of_goal g with - | InSProp -> finfo.sprop_lemma - | InProp -> finfo.prop_lemma - | InSet -> finfo.rec_lemma - | InType -> finfo.rect_lemma + match princl with + | None -> (* No principle is given let's find the good one *) + begin + match EConstr.kind sigma f with + | Const (c',u) -> + let princ_option = + let finfo = (* we first try to find out a graph on f *) + match find_Function_infos c' with + | Some finfo -> finfo + | None -> + user_err (str "Cannot find induction information on "++ + Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) + in + match elimination_sort_of_goal gl with + | InSProp -> finfo.sprop_lemma + | InProp -> finfo.prop_lemma + | InSet -> finfo.rec_lemma + | InType -> finfo.rect_lemma + in + let princ = (* then we get the principle *) + match princ_option with + | Some princ -> + let sigma, princ = Evd.fresh_global (pf_env gl) (project gl) (GlobRef.ConstRef princ) in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT princ + | None -> + (*i If there is not default lemma defined then, + we cross our finger and try to find a lemma named f_ind + (or f_rec, f_rect) i*) + let princ_name = + Indrec.make_elimination_ident + (Label.to_id (Constant.label c')) + (elimination_sort_of_goal gl) in - let princ,g' = (* then we get the principle *) + let princ_ref = try - let g',princ = - Tacmach.pf_eapply (Evd.fresh_global) g (GlobRef.ConstRef (Option.get princ_option )) in - princ,g' - with Option.IsNone -> - (*i If there is not default lemma defined then, - we cross our finger and try to find a lemma named f_ind - (or f_rec, f_rect) i*) - let princ_name = - Indrec.make_elimination_ident - (Label.to_id (Constant.label c')) - (Tacticals.elimination_sort_of_goal g) - in - try - let princ_ref = const_of_id princ_name in - let (a,b) = Tacmach.pf_eapply (Evd.fresh_global) g princ_ref in - (b,a) - (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *) - with Not_found -> (* This one is neither defined ! *) - user_err (str "Cannot find induction principle for " - ++ Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) + Constrintern.locate_reference (Libnames.qualid_of_ident princ_name) + with + | Not_found -> + user_err (str "Cannot find induction principle for " + ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) in - (princ,NoBindings,Tacmach.pf_unsafe_type_of g' princ,g') - | _ -> raise (UserError(None,str "functional induction must be used with a function" )) - end - | Some ((princ,binding)) -> - princ,binding,Tacmach.pf_unsafe_type_of g princ,g - in - let sigma = Tacmach.project g' in - let princ_infos = Tactics.compute_elim_sig (Tacmach.project g') princ_type in - let args_as_induction_constr = - let c_list = - if princ_infos.Tactics.farg_in_concl - then [c] else [] - in - if List.length args + List.length c_list = 0 - then user_err Pp.(str "Cannot recognize a valid functional scheme" ); - let encoded_pat_as_patlist = - List.make (List.length args + List.length c_list - 1) None @ [pat] - in - List.map2 - (fun c pat -> - ((None, - Tactics.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))), - (None,pat), - None)) - (args@c_list) - encoded_pat_as_patlist - in - let princ' = Some (princ,bindings) in - let princ_vars = - List.fold_right - (fun a acc -> try Id.Set.add (destVar sigma a) acc with DestKO -> acc) - args - Id.Set.empty + let sigma, princ = Evd.fresh_global (pf_env gl) (project gl) princ_ref in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT princ + in + princ >>= fun princ -> + (* We need to refresh gl due to the updated evar_map in princ *) + Proofview.Goal.enter_one (fun gl -> + Proofview.tclUNIT (princ, Tactypes.NoBindings, pf_unsafe_type_of gl princ, args)) + | _ -> + CErrors.user_err (str "functional induction must be used with a function" ) + end + | Some ((princ,binding)) -> + Proofview.tclUNIT (princ, binding, pf_unsafe_type_of gl princ, args) + ) >>= fun (princ, bindings, princ_type, args) -> + Proofview.Goal.enter (fun gl -> + let sigma = project gl in + let princ_infos = compute_elim_sig (project gl) princ_type in + let args_as_induction_constr = + let c_list = + if princ_infos.Tactics.farg_in_concl + then [c] else [] in - let old_idl = List.fold_right Id.Set.add (Tacmach.pf_ids_of_hyps g) Id.Set.empty in - let old_idl = Id.Set.diff old_idl princ_vars in - let subst_and_reduce g = - if with_clean - then - let idl = - List.filter (fun id -> not (Id.Set.mem id old_idl)) - (Tacmach.pf_ids_of_hyps g) - in - let flag = - Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - } - in - Tacticals.tclTHEN - (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Proofview.V82.of_tactic (Equality.subst_gen (do_rewrite_dependent ()) [id]))) idl ) - (Proofview.V82.of_tactic (Tactics.reduce flag Locusops.allHypsAndConcl)) - g - else Tacticals.tclIDTAC g + if List.length args + List.length c_list = 0 + then user_err Pp.(str "Cannot recognize a valid functional scheme" ); + let encoded_pat_as_patlist = + List.make (List.length args + List.length c_list - 1) None @ [pat] in - Tacticals.tclTHEN - (Proofview.V82.of_tactic (choose_dest_or_ind - princ_infos - (args_as_induction_constr,princ'))) - subst_and_reduce - g' - in res + List.map2 + (fun c pat -> + ((None, ElimOnConstr (fun env sigma -> (sigma,(c,Tactypes.NoBindings)))), + (None,pat), None)) + (args@c_list) + encoded_pat_as_patlist + in + let princ' = Some (princ,bindings) in + let princ_vars = + List.fold_right + (fun a acc -> try Id.Set.add (destVar sigma a) acc with DestKO -> acc) + args + Id.Set.empty + in + let old_idl = List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty in + let old_idl = Id.Set.diff old_idl princ_vars in + let subst_and_reduce gl = + if with_clean + then + let idl = List.filter (fun id -> not (Id.Set.mem id old_idl))(pf_ids_of_hyps gl) in + let flag = Genredexpr.Cbv { Redops.all_flags with Genredexpr.rDelta = false } in + tclTHEN + (tclMAP (fun id -> tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) idl) + (reduce flag Locusops.allHypsAndConcl) + else tclIDTAC + in + tclTHEN + (choose_dest_or_ind + princ_infos + (args_as_induction_constr,princ')) + (Proofview.Goal.enter subst_and_reduce)) diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index 97a840e950..476d74b3f8 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -8,9 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val functional_induction : - bool -> - EConstr.constr -> - (EConstr.constr * EConstr.constr Tactypes.bindings) option -> - Ltac_plugin.Tacexpr.or_and_intro_pattern option -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma +val functional_induction + : bool + -> EConstr.constr + -> (EConstr.constr * EConstr.constr Tactypes.bindings) option + -> Ltac_plugin.Tacexpr.or_and_intro_pattern option + -> unit Proofview.tactic diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 52a29fb559..80fc64fe65 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -40,7 +40,9 @@ let locate_constant ref = let locate_with_msg msg f x = try f x - with Not_found -> raise (CErrors.UserError(None, msg)) + with + | Not_found -> + CErrors.user_err msg let filter_map filter f = @@ -64,8 +66,7 @@ let chop_rlambda_n = | Glob_term.GLambda(name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b | Glob_term.GLetIn(name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b | _ -> - raise (CErrors.UserError(Some "chop_rlambda_n", - str "chop_rlambda_n: Not enough Lambdas")) + CErrors.user_err ~hdr:"chop_rlambda_n" (str "chop_rlambda_n: Not enough Lambdas") in chop_lambda_n [] @@ -76,7 +77,8 @@ let chop_rprod_n = else match DAst.get rt with | Glob_term.GProd(name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b - | _ -> raise (CErrors.UserError(Some "chop_rprod_n",str "chop_rprod_n: Not enough products")) + | _ -> + CErrors.user_err ~hdr:"chop_rprod_n" (str "chop_rprod_n: Not enough products") in chop_prod_n [] @@ -92,13 +94,6 @@ let list_union_eq eq_fun l1 l2 = let list_add_set_eq eq_fun x l = if List.exists (eq_fun x) l then l else x::l -let const_of_id id = - let princ_ref = qualid_of_ident id in - try Constrintern.locate_reference princ_ref - with Not_found -> - CErrors.user_err ~hdr:"IndFun.const_of_id" - (str "cannot find " ++ Id.print id) - [@@@ocaml.warning "-3"] let coq_constant s = UnivGen.constr_of_monomorphic_global @@ @@ -112,29 +107,6 @@ let find_reference sl s = let eq = lazy(EConstr.of_constr (coq_constant "eq")) let refl_equal = lazy(EConstr.of_constr (coq_constant "eq_refl")) -(*****************************************************************) -(* Copy of the standard save mechanism but without the much too *) -(* slow reduction function *) -(*****************************************************************) -open Declare -open DeclareDef - -let definition_message = Declare.definition_message - -let save name const ?hook uctx scope kind = - let fix_exn = Future.fix_exn_of const.Proof_global.proof_entry_body in - let r = match scope with - | Discharge -> - let c = SectionLocalDef const in - let () = declare_variable ~name ~kind c in - GlobRef.VarRef name - | Global local -> - let kn = declare_constant ~name ~kind ~local (DefinitionEntry const) in - GlobRef.ConstRef kn - in - DeclareDef.Hook.(call ?hook ~fix_exn { S.uctx; obls = []; scope; dref = r }); - definition_message name - let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () @@ -301,20 +273,16 @@ let find_or_none id = ) with Not_found -> None - - let find_Function_infos f = - Cmap_env.find f !from_function - + Cmap_env.find_opt f !from_function let find_Function_of_graph ind = - Indmap.find ind !from_graph + Indmap.find_opt ind !from_graph let update_Function finfo = (* Pp.msgnl (pr_info finfo); *) Lib.add_anonymous_leaf (in_Function finfo) - let add_Function is_general f = let f_id = Label.to_id (Constant.label f) in let equation_lemma = find_or_none (mk_equation_id f_id) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index fff4711044..cd5202a6c7 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -38,20 +38,10 @@ val chop_rprod_n : int -> Glob_term.glob_constr -> val eq : EConstr.constr Lazy.t val refl_equal : EConstr.constr Lazy.t -val const_of_id: Id.t -> GlobRef.t(* constantyes *) val jmeq : unit -> EConstr.constr val jmeq_refl : unit -> EConstr.constr val make_eq : unit -> EConstr.constr -val save - : Id.t - -> Evd.side_effects Proof_global.proof_entry - -> ?hook:DeclareDef.Hook.t - -> UState.t - -> DeclareDef.locality - -> Decls.logical_kind - -> unit - (* [with_full_print f a] applies [f] to [a] in full printing environment. This function preserves the print settings @@ -75,8 +65,8 @@ type function_info = is_general : bool; } -val find_Function_infos : Constant.t -> function_info -val find_Function_of_graph : inductive -> function_info +val find_Function_infos : Constant.t -> function_info option +val find_Function_of_graph : inductive -> function_info option (* WARNING: To be used just after the graph definition !!! *) val add_Function : bool -> Constant.t -> unit val update_Function : function_info -> unit diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 38fdd789a3..d72319d078 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -34,9 +34,10 @@ let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> let ((kn',num) as ind'),u = destInd sigma i in if MutInd.equal kn kn' then (* We have generated a graph hypothesis so that we must change it if we can *) - let info = - try find_Function_of_graph ind' - with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) + let info = match find_Function_of_graph ind' with + | Some info -> info + | None -> + (* The graphs are mutually recursive but we cannot find one of them !*) CErrors.anomaly (Pp.str "Cannot retrieve infos about a mutual block.") in (* if we can find a completeness lemma for this function @@ -108,18 +109,20 @@ let invfun qhyp f = | _ -> CErrors.user_err Pp.(str "Not a function") in - try - let finfos = find_Function_infos f in - let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind in - Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp - with - | Not_found -> CErrors.user_err (Pp.str "No graph found") - | Option.IsNone -> CErrors.user_err (Pp.str "Cannot use equivalence with graph!") - -exception NoFunction + match find_Function_infos f with + | None -> + CErrors.user_err (Pp.str "No graph found") + | Some finfos -> + match finfos.correctness_lemma with + | None -> + CErrors.user_err (Pp.str "Cannot use equivalence with graph!") + | Some f_correct -> + let f_correct = mkConst f_correct + and kn = fst finfos.graph_ind in + Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp let invfun qhyp f = + let exception NoFunction in match f with | Some f -> invfun qhyp f | None -> @@ -132,31 +135,33 @@ let invfun qhyp f = let f1,_ = decompose_app sigma args.(1) in try if not (isConst sigma f1) then raise NoFunction; - let finfos = find_Function_infos (fst (destConst sigma f1)) in + let finfos = Option.get (find_Function_infos (fst (destConst sigma f1))) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in functional_inversion kn hid f1 f_correct - with | NoFunction | Option.IsNone | Not_found -> - try - let f2,_ = decompose_app sigma args.(2) in - if not (isConst sigma f2) then raise NoFunction; - let finfos = find_Function_infos (fst (destConst sigma f2)) in - let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind - in - functional_inversion kn hid f2 f_correct with - | NoFunction -> - CErrors.user_err Pp.(str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") - | Option.IsNone -> - if do_observe () - then CErrors.user_err (Pp.str "Cannot use equivalence with graph for any side of the equality") - else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Not_found -> - if do_observe () - then CErrors.user_err (Pp.str "No graph found for any side of equality") - else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + | NoFunction | Option.IsNone -> + let f2,_ = decompose_app sigma args.(2) in + if isConst sigma f2 then + match find_Function_infos (fst (destConst sigma f2)) with + | None -> + if do_observe () + then CErrors.user_err (Pp.str "No graph found for any side of equality") + else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + | Some finfos -> + match finfos.correctness_lemma with + | None -> + if do_observe () + then CErrors.user_err (Pp.str "Cannot use equivalence with graph for any side of the equality") + else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + | Some f_correct -> + let f_correct = mkConst f_correct + and kn = fst finfos.graph_ind + in + functional_inversion kn hid f2 f_correct + else (* NoFunction *) + CErrors.user_err Pp.(str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") end | _ -> CErrors.user_err Pp.(Ppconstr.pr_id hid ++ str " must be an equality ") in diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 21d61d1f97..f7215a9d13 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -1100,7 +1100,7 @@ VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF END VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY -| [ "Print" "Equivalent" "Keys" ] -> { Feedback.msg_info (Keys.pr_keys Printer.pr_global) } +| [ "Print" "Equivalent" "Keys" ] -> { Feedback.msg_notice (Keys.pr_keys Printer.pr_global) } END diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index 455c8ab003..61cc77c42a 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -145,7 +145,7 @@ open Pp VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY | [ "Show" "Obligation" "Tactic" ] -> { - Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) } + Feedback.msg_notice (str"Program obligation tactic is " ++ print_default_tactic ()) } END VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY @@ -154,8 +154,8 @@ VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY END VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY -| [ "Preterm" "of" ident(name) ] -> { Feedback.msg_info (show_term (Some name)) } -| [ "Preterm" ] -> { Feedback.msg_info (show_term None) } +| [ "Preterm" "of" ident(name) ] -> { Feedback.msg_notice (show_term (Some name)) } +| [ "Preterm" ] -> { Feedback.msg_notice (show_term None) } END { diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 9d46bbc74e..fe5ebf1172 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -417,7 +417,7 @@ let get_timer name = let finish_timing ~prefix name = let tend = System.get_time () in let tstart = get_timer name in - Feedback.msg_info(str prefix ++ pr_opt str name ++ str " ran for " ++ + Feedback.msg_notice(str prefix ++ pr_opt str name ++ str " ran for " ++ System.fmt_time_difference tstart tend) (* ******************** *) @@ -431,7 +431,7 @@ let print_results_filter ~cutoff ~filter = let results = SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in let results = merge_roots results Local.(CList.last !stack) in - Feedback.msg_info (to_string ~cutoff ~filter results) + Feedback.msg_notice (to_string ~cutoff ~filter results) ;; let print_results ~cutoff = diff --git a/plugins/ltac/tacarg.ml b/plugins/ltac/tacarg.ml index 9e8e86d4fc..252c15478d 100644 --- a/plugins/ltac/tacarg.ml +++ b/plugins/ltac/tacarg.ml @@ -20,7 +20,7 @@ let make0 ?dyn name = wit let wit_intropattern = make0 "intropattern" (* To keep after deprecation phase but it will get a different parsing semantics (Tactic Notation and TACTIC EXTEND) in pltac.ml *) -let wit_simple_intropattern = make0 "simple_intropattern" +let wit_simple_intropattern = make0 ~dyn:(val_tag (topwit wit_intropattern)) "simple_intropattern" let wit_quant_hyp = make0 "quant_hyp" let wit_constr_with_bindings = make0 "constr_with_bindings" let wit_open_constr_with_bindings = make0 "open_constr_with_bindings" diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index e64129d204..da89a027e2 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -145,11 +145,8 @@ let coerce_to_constr_context v = else raise (CannotCoerceTo "a term context") let is_intro_pattern v = - if has_type v (topwit wit_intropattern [@warning "-3"]) then - Some (out_gen (topwit wit_intropattern [@warning "-3"]) v).CAst.v - else - if has_type v (topwit wit_simple_intropattern) then - Some (out_gen (topwit wit_simple_intropattern) v).CAst.v + if has_type v (topwit wit_intro_pattern) then + Some (out_gen (topwit wit_intro_pattern) v).CAst.v else None diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 94af4a3151..ba759441e5 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -189,31 +189,32 @@ let flatten_contravariant_disj _ ist = tclTHEN (tclTHENLIST tacs) tac0 | _ -> fail -let make_unfold name = - let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in - let const = Constant.make2 (ModPath.MPfile dir) (Label.make name) in - Locus.(AllOccurrences, ArgArg (EvalConstRef const, None)) +let evalglobref_of_globref = + function + | GlobRef.VarRef v -> EvalVarRef v + | GlobRef.ConstRef c -> EvalConstRef c + | GlobRef.IndRef _ | GlobRef.ConstructRef _ -> assert false -let u_not = make_unfold "not" +let make_unfold name = + let const = evalglobref_of_globref (Coqlib.lib_ref name) in + Locus.(AllOccurrences, ArgArg (const, None)) let reduction_not_iff _ ist = let make_reduce c = TacAtom (CAst.make @@ TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in let tac = match !negation_unfolding with - | true -> make_reduce [u_not] + | true -> make_reduce [make_unfold "core.not.type"] | false -> TacId [] in eval_tactic_ist ist tac -let coq_nnpp_path = - let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in - Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP") - let apply_nnpp _ ist = + let nnpp = "core.nnpp.type" in Proofview.tclBIND (Proofview.tclUNIT ()) - begin fun () -> try - Tacticals.New.pf_constr_of_global (Nametab.global_of_path coq_nnpp_path) >>= apply - with Not_found -> tclFAIL 0 (Pp.mt ()) + begin fun () -> + if Coqlib.has_ref nnpp + then Tacticals.New.pf_constr_of_global (Coqlib.lib_ref nnpp) >>= apply + else tclFAIL 0 (Pp.mt ()) end (* This is the uniform mode dealing with ->, not, iff and types isomorphic to diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index 78bfe480b3..2762bb6b32 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -19,6 +19,47 @@ Require Export Ring_theory. Local Open Scope positive_scope. Import RingSyntax. +(** Definition of polynomial expressions *) +#[universes(template)] +Inductive PExpr {C} : Type := +| PEc : C -> PExpr +| PEX : positive -> PExpr +| PEadd : PExpr -> PExpr -> PExpr +| PEsub : PExpr -> PExpr -> PExpr +| PEmul : PExpr -> PExpr -> PExpr +| PEopp : PExpr -> PExpr +| PEpow : PExpr -> N -> PExpr. +Arguments PExpr : clear implicits. + + (* Definition of multivariable polynomials with coefficients in C : + Type [Pol] represents [X1 ... Xn]. + The representation is Horner's where a [n] variable polynomial + (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients + are polynomials with [n-1] variables (C[X2..Xn]). + There are several optimisations to make the repr compacter: + - [Pc c] is the constant polynomial of value c + == c*X1^0*..*Xn^0 + - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. + variable indices are shifted of j in Q. + == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} + - [PX P i Q] is an optimised Horner form of P*X^i + Q + with P not the null polynomial + == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} + + In addition: + - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden + since they can be represented by the simpler form (PX P (i+j) Q) + - (Pinj i (Pinj j P)) is (Pinj (i+j) P) + - (Pinj i (Pc c)) is (Pc c) + *) + +#[universes(template)] +Inductive Pol {C} : Type := +| Pc : C -> Pol +| Pinj : positive -> Pol -> Pol +| PX : Pol -> positive -> Pol -> Pol. +Arguments Pol : clear implicits. + Section MakeRingPol. (* Ring elements *) @@ -96,33 +137,11 @@ Section MakeRingPol. match goal with |- ?t == _ => mul_permut_rec t end). - (* Definition of multivariable polynomials with coefficients in C : - Type [Pol] represents [X1 ... Xn]. - The representation is Horner's where a [n] variable polynomial - (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients - are polynomials with [n-1] variables (C[X2..Xn]). - There are several optimisations to make the repr compacter: - - [Pc c] is the constant polynomial of value c - == c*X1^0*..*Xn^0 - - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. - variable indices are shifted of j in Q. - == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} - - [PX P i Q] is an optimised Horner form of P*X^i + Q - with P not the null polynomial - == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} + Notation PExpr := (PExpr C). + Notation Pol := (Pol C). - In addition: - - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden - since they can be represented by the simpler form (PX P (i+j) Q) - - (Pinj i (Pinj j P)) is (Pinj (i+j) P) - - (Pinj i (Pc c)) is (Pc c) - *) - - #[universes(template)] - Inductive Pol : Type := - | Pc : C -> Pol - | Pinj : positive -> Pol -> Pol - | PX : Pol -> positive -> Pol -> Pol. + Implicit Types pe : PExpr. + Implicit Types P : Pol. Definition P0 := Pc cO. Definition P1 := Pc cI. @@ -152,7 +171,7 @@ Section MakeRingPol. | _ => Pinj j P end. - Definition mkPinj_pred j P:= + Definition mkPinj_pred j P := match j with | xH => P | xO j => Pinj (Pos.pred_double j) P @@ -938,18 +957,6 @@ Qed. rewrite <- IHm; auto. Qed. - (** Definition of polynomial expressions *) - - #[universes(template)] - Inductive PExpr : Type := - | PEc : C -> PExpr - | PEX : positive -> PExpr - | PEadd : PExpr -> PExpr -> PExpr - | PEsub : PExpr -> PExpr -> PExpr - | PEmul : PExpr -> PExpr -> PExpr - | PEopp : PExpr -> PExpr - | PEpow : PExpr -> N -> PExpr. - (** evaluation of polynomial expressions towards R *) Definition mk_X j := mkPinj_pred j mkX. diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index 8c7b601aba..7e04fe0220 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -23,9 +23,6 @@ Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". -Ltac preprocess := - zify ; unfold Z.succ in * ; unfold Z.pred in *. - Ltac zchange checker := intros __wit __varmap __ff ; change (@Tauto.eval_bf _ (Zeval_formula (@find Z Z0 __varmap)) __ff) ; @@ -39,11 +36,17 @@ Ltac zchecker_abstract checker := Ltac zchecker := zchecker_no_abstract ZTautoChecker_sound. -Ltac zchecker_ext := zchecker_no_abstract ZTautoCheckerExt_sound. +(*Ltac zchecker_ext := zchecker_no_abstract ZTautoCheckerExt_sound.*) + +Ltac zchecker_ext := + intros __wit __varmap __ff ; + exact (ZTautoCheckerExt_sound __ff __wit + (@eq_refl bool true <: @eq bool (ZTautoCheckerExt __ff __wit) true) + (@find Z Z0 __varmap)). -Ltac lia := preprocess; xlia zchecker_ext. +Ltac lia := zify; xlia zchecker_ext. -Ltac nia := preprocess; xnlia zchecker. +Ltac nia := zify; xnlia zchecker. (* Local Variables: *) diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 1050bae303..80e0f3a536 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -55,7 +55,8 @@ Extract Constant Rinv => "fun x -> 1 / x". extraction is only performed as a test in the test suite. *) (*Extraction "micromega.ml" Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula - ZMicromega.cnfZ ZMicromega.Zeval_const ZMicromega.bound_problem_fr QMicromega.cnfQ + Tauto.abst_form + ZMicromega.cnfZ ZMicromega.bound_problem_fr ZMicromega.Zeval_const QMicromega.cnfQ List.map simpl_cone (*map_cone indexes*) denorm Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index a99f21ad47..4a02d1d01e 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -68,7 +68,7 @@ Require Import EnvRing. Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q := match e with | PEc c => c - | PEX _ j => env j + | PEX j => env j | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) @@ -80,7 +80,7 @@ Lemma Qeval_expr_simpl : forall env e, Qeval_expr env e = match e with | PEc c => c - | PEX _ j => env j + | PEX j => env j | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) @@ -172,9 +172,9 @@ Qed. Require Import Coq.micromega.Tauto. -Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. +Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. -Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. +Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool. @@ -204,7 +204,7 @@ Proof. unfold eval_nformula. unfold RingMicromega.eval_nformula. destruct t. apply (check_inconsistent_sound Qsor QSORaddon) ; auto. - - unfold qdeduce. apply (nformula_plus_nformula_correct Qsor QSORaddon). + - unfold qdeduce. intros. revert H. apply (nformula_plus_nformula_correct Qsor QSORaddon);auto. - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now eapply (cnf_normalise_correct Qsor QSORaddon);eauto. - intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now eapply (cnf_negate_correct Qsor QSORaddon);eauto. - intros t w0. diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index 30bbac44d0..d8282a1127 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -432,8 +432,8 @@ Qed. Require Import Coq.micromega.Tauto. -Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool. -Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool. +Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. +Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool Qle_bool. Definition runsat := check_inconsistent 0%Q Qeq_bool Qle_bool. @@ -467,7 +467,9 @@ Proof. apply Reval_nformula_dec. - destruct t. apply (check_inconsistent_sound Rsor QSORaddon) ; auto. - - unfold rdeduce. apply (nformula_plus_nformula_correct Rsor QSORaddon). + - unfold rdeduce. + intros. revert H. + eapply (nformula_plus_nformula_correct Rsor QSORaddon); eauto. - now apply (cnf_normalise_correct Rsor QSORaddon). - intros. now eapply (cnf_negate_correct Rsor QSORaddon); eauto. - intros t w0. diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v index 63b4d5e8f8..cd759029fa 100644 --- a/plugins/micromega/Refl.v +++ b/plugins/micromega/Refl.v @@ -99,8 +99,6 @@ Proof. apply IHl; auto. Qed. - - Lemma make_conj_app : forall A eval l1 l2, @make_conj A eval (l1 ++ l2) <-> @make_conj A eval l1 /\ @make_conj A eval l2. Proof. induction l1. @@ -114,34 +112,41 @@ Proof. tauto. Qed. +Infix "+++" := rev_append (right associativity, at level 60) : list_scope. + +Lemma make_conj_rapp : forall A eval l1 l2, @make_conj A eval (l1 +++ l2) <-> @make_conj A eval (l1++l2). +Proof. + induction l1. + - simpl. tauto. + - intros. + simpl rev_append at 1. + rewrite IHl1. + rewrite make_conj_app. + rewrite make_conj_cons. + simpl app. + rewrite make_conj_cons. + rewrite make_conj_app. + tauto. +Qed. + Lemma not_make_conj_cons : forall (A:Type) (t:A) a eval (no_middle_eval : (eval t) \/ ~ (eval t)), - ~ make_conj eval (t ::a) -> ~ (eval t) \/ (~ make_conj eval a). + ~ make_conj eval (t ::a) <-> ~ (eval t) \/ (~ make_conj eval a). Proof. intros. - simpl in H. - destruct a. - tauto. + rewrite make_conj_cons. tauto. Qed. Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval (no_middle_eval : forall d, eval d \/ ~ eval d) , - ~ make_conj eval (t ++ a) -> (~ make_conj eval t) \/ (~ make_conj eval a). + ~ make_conj eval (t ++ a) <-> (~ make_conj eval t) \/ (~ make_conj eval a). Proof. induction t. - simpl. - tauto. - intros. - simpl ((a::t)++a0)in H. - destruct (@not_make_conj_cons _ _ _ _ (no_middle_eval a) H). - left ; red ; intros. - apply H0. - rewrite make_conj_cons in H1. - tauto. - destruct (IHt _ _ no_middle_eval H0). - left ; red ; intros. - apply H1. - rewrite make_conj_cons in H2. - tauto. - right ; auto. + - simpl. + tauto. + - intros. + simpl ((a::t)++a0). + rewrite !not_make_conj_cons by auto. + rewrite IHt by auto. + tauto. Qed. diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index 75801162a7..c1edf579cf 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -289,7 +289,6 @@ destruct o' ; rewrite H1 ; now rewrite (Rplus_0_l sor). now apply (Rplus_nonneg_nonneg sor). Qed. -#[universes(template)] Inductive Psatz : Type := | PsatzIn : nat -> Psatz | PsatzSquare : PolC -> Psatz @@ -708,6 +707,8 @@ Definition padd := Padd cO cplus ceqb. Definition pmul := Pmul cO cI cplus ctimes ceqb. +Definition popp := Popp copp. + Definition normalise (f : Formula C) : NFormula := let (lhs, op, rhs) := f in let lhs := norm lhs in @@ -734,7 +735,6 @@ let (lhs, op, rhs) := f in | OpLt => (psub lhs rhs, NonStrict) end. - Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) == eval_pol env lhs - eval_pol env rhs. Proof. intros. @@ -756,6 +756,12 @@ Proof. (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). Qed. +Lemma eval_pol_opp : forall env e, eval_pol env (popp e) == - eval_pol env e. +Proof. + intros. + apply (Popp_ok (SORsetoid sor) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor)) (SORrm addon)). +Qed. Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env (norm lhs). @@ -767,16 +773,18 @@ Qed. Theorem normalise_sound : forall (env : PolEnv) (f : Formula C), - eval_formula env f -> eval_nformula env (normalise f). + eval_formula env f <-> eval_nformula env (normalise f). Proof. -intros env f H; destruct f as [lhs op rhs]; simpl in *. +intros env f; destruct f as [lhs op rhs]; simpl in *. destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm. -now apply <- (Rminus_eq_0 sor). -intros H1. apply -> (Rminus_eq_0 sor) in H1. now apply H. -now apply -> (Rle_le_minus sor). -now apply -> (Rle_le_minus sor). -now apply -> (Rlt_lt_minus sor). -now apply -> (Rlt_lt_minus sor). +- symmetry. + now apply (Rminus_eq_0 sor). +- rewrite (Rminus_eq_0 sor). + tauto. +- now apply (Rle_le_minus sor). +- now apply (Rle_le_minus sor). +- now apply (Rlt_lt_minus sor). +- now apply (Rlt_lt_minus sor). Qed. Theorem negate_correct : @@ -785,92 +793,173 @@ Theorem negate_correct : Proof. intros env f; destruct f as [lhs op rhs]; simpl. destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm. -symmetry. rewrite (Rminus_eq_0 sor). +- symmetry. rewrite (Rminus_eq_0 sor). split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)]. -rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor). -rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). -rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). -rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). -rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). +- rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor). +- rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). +- rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor). +- rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). +- rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). Qed. (** Another normalisation - this is used for cnf conversion **) -Definition xnormalise (t:Formula C) : list (NFormula) := - let (lhs,o,rhs) := t in - let lhs := norm lhs in - let rhs := norm rhs in +Definition xnormalise (f:NFormula) : list (NFormula) := + let (e,o) := f in + match o with + | Equal => (e , Strict) :: (popp e, Strict) :: nil + | NonEqual => (e , Equal) :: nil + | Strict => (popp e, NonStrict) :: nil + | NonStrict => (popp e, Strict) :: nil + end. + +Definition xnegate (t:NFormula) : list (NFormula) := + let (e,o) := t in match o with - | OpEq => - (psub lhs rhs, Strict)::(psub rhs lhs , Strict)::nil - | OpNEq => (psub lhs rhs,Equal) :: nil - | OpGt => (psub rhs lhs,NonStrict) :: nil - | OpLt => (psub lhs rhs,NonStrict) :: nil - | OpGe => (psub rhs lhs , Strict) :: nil - | OpLe => (psub lhs rhs ,Strict) :: nil + | Equal => (e,Equal) :: nil + | NonEqual => (e,Strict)::(popp e,Strict)::nil + | Strict => (e,Strict) :: nil + | NonStrict => (e,NonStrict) :: nil end. -Import Coq.micromega.Tauto. -Definition cnf_normalise {T : Type} (t:Formula C) (tg : T) : cnf NFormula T := - List.map (fun x => (x,tg)::nil) (xnormalise t). +Import Coq.micromega.Tauto. +Definition cnf_of_list {T : Type} (l:list NFormula) (tg : T) : cnf NFormula T := + List.fold_right (fun x acc => + if check_inconsistent x then acc else ((x,tg)::nil)::acc) + (cnf_tt _ _) l. Add Ring SORRing : (SORrt sor). -Lemma cnf_normalise_correct : forall (T : Type) env t tg, eval_cnf (Annot:=T) eval_nformula env (cnf_normalise t tg) -> eval_formula env t. +Lemma cnf_of_list_correct : + forall (T : Type) env l tg, + eval_cnf (Annot:=T) eval_nformula env (cnf_of_list l tg) <-> + make_conj (fun x : NFormula => eval_nformula env x -> False) l. Proof. - unfold cnf_normalise, xnormalise ; simpl ; intros T env t tg. - unfold eval_cnf, eval_clause. - destruct t as [lhs o rhs]; case_eq o ; unfold eval_tt; - simpl; - repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; - generalize (eval_pexpr env lhs); - generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros. - - apply (SORle_antisymm sor). - + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - - now rewrite <- (Rminus_eq_0 sor). - - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. - - rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto. - - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. - - rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. + unfold cnf_of_list. + intros T env l tg. + set (F := (fun (x : NFormula) (acc : list (list (NFormula * T))) => + if check_inconsistent x then acc else ((x, tg) :: nil) :: acc)). + set (G := ((fun x : NFormula => eval_nformula env x -> False))). + induction l. + - compute. + tauto. + - rewrite make_conj_cons. + simpl. + unfold F at 1. + destruct (check_inconsistent a) eqn:EQ. + + rewrite IHl. + unfold G. + destruct a. + specialize (check_inconsistent_sound _ _ EQ env). + simpl. + tauto. + + + rewrite <- eval_cnf_cons_iff with (1:= fun env (term:Formula Z) => True) . + simpl. + unfold eval_tt. simpl. + rewrite IHl. + unfold G at 2. + tauto. Qed. -Definition xnegate (t:Formula C) : list (NFormula) := - let (lhs,o,rhs) := t in - let lhs := norm lhs in - let rhs := norm rhs in - match o with - | OpEq => (psub lhs rhs,Equal) :: nil - | OpNEq => (psub lhs rhs ,Strict)::(psub rhs lhs,Strict)::nil - | OpGt => (psub lhs rhs,Strict) :: nil - | OpLt => (psub rhs lhs,Strict) :: nil - | OpGe => (psub lhs rhs,NonStrict) :: nil - | OpLe => (psub rhs lhs,NonStrict) :: nil - end. +Definition cnf_normalise {T: Type} (t: Formula C) (tg: T) : cnf NFormula T := + let f := normalise t in + if check_inconsistent f then cnf_ff _ _ + else cnf_of_list (xnormalise f) tg. + +Definition cnf_negate {T: Type} (t: Formula C) (tg: T) : cnf NFormula T := + let f := normalise t in + if check_inconsistent f then cnf_tt _ _ + else cnf_of_list (xnegate f) tg. + +Lemma eq0_cnf : forall x, + (0 < x -> False) /\ (0 < - x -> False) <-> x == 0. +Proof. + split ; intros. + + apply (SORle_antisymm sor). + * now rewrite (Rle_ngt sor). + * rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). + setoid_replace (0 - x) with (-x) by ring. + tauto. + + split; intro. + * rewrite (SORlt_le_neq sor) in H0. + apply (proj2 H0). + now rewrite H. + * rewrite (SORlt_le_neq sor) in H0. + apply (proj2 H0). + rewrite H. ring. +Qed. + +Lemma xnormalise_correct : forall env f, + (make_conj (fun x => eval_nformula env x -> False) (xnormalise f)) <-> eval_nformula env f. +Proof. + intros env f. + destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; + repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; + repeat rewrite eval_pol_opp; + generalize (eval_pol env e) as x; intro. + - apply eq0_cnf. + - unfold not. tauto. + - symmetry. rewrite (Rlt_nge sor). + rewrite (Rle_le_minus sor). + setoid_replace (0 - x) with (-x) by ring. + tauto. + - rewrite (Rle_ngt sor). + symmetry. + rewrite (Rlt_lt_minus sor). + setoid_replace (0 - x) with (-x) by ring. + tauto. +Qed. -Definition cnf_negate {T : Type} (t:Formula C) (tg:T) : cnf NFormula T := - List.map (fun x => (x,tg)::nil) (xnegate t). -Lemma cnf_negate_correct : forall (T : Type) env t (tg:T), eval_cnf eval_nformula env (cnf_negate t tg) -> ~ eval_formula env t. +Lemma xnegate_correct : forall env f, + (make_conj (fun x => eval_nformula env x -> False) (xnegate f)) <-> ~ eval_nformula env f. +Proof. + intros env f. + destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; + repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; + repeat rewrite eval_pol_opp; + generalize (eval_pol env e) as x; intro. + - tauto. + - rewrite eq0_cnf. + rewrite (Req_dne sor). + tauto. + - tauto. + - tauto. +Qed. + + +Lemma cnf_normalise_correct : forall (T : Type) env t tg, eval_cnf (Annot:=T) eval_nformula env (cnf_normalise t tg) <-> eval_formula env t. +Proof. + intros T env t tg. + unfold cnf_normalise. + rewrite normalise_sound. + generalize (normalise t) as f;intro. + destruct (check_inconsistent f) eqn:U. + - destruct f as [e op]. + assert (US := check_inconsistent_sound _ _ U env). + rewrite eval_cnf_ff with (1:= eval_nformula). + tauto. + - intros. rewrite cnf_of_list_correct. + now apply xnormalise_correct. +Qed. + +Lemma cnf_negate_correct : forall (T : Type) env t (tg:T), eval_cnf eval_nformula env (cnf_negate t tg) <-> ~ eval_formula env t. Proof. - unfold cnf_negate, xnegate ; simpl ; intros T env t tg. - unfold eval_cnf, eval_clause. - destruct t as [lhs o rhs]; case_eq o ; unfold eval_tt; simpl; - repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; - generalize (eval_pexpr env lhs); - generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; intuition. + intros T env t tg. + rewrite normalise_sound. + unfold cnf_negate. + generalize (normalise t) as f;intro. + destruct (check_inconsistent f) eqn:U. - - apply H0. - rewrite H1 ; ring. - - apply H1. apply (SORle_antisymm sor). - + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - + rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto. - - apply H0. now rewrite (Rle_le_minus sor) in H1. - - apply H0. now rewrite (Rle_le_minus sor) in H1. - - apply H0. now rewrite (Rlt_lt_minus sor) in H1. - - apply H0. now rewrite (Rlt_lt_minus sor) in H1. + destruct f as [e o]. + assert (US := check_inconsistent_sound _ _ U env). + rewrite eval_cnf_tt with (1:= eval_nformula). + tauto. + - rewrite cnf_of_list_correct. + apply xnegate_correct. Qed. Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). @@ -892,7 +981,7 @@ Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C := | Pc c => PEc c | Pinj j p => xdenorm (Pos.add j jmp ) p | PX p j q => PEadd - (PEmul (xdenorm jmp p) (PEpow (PEX _ jmp) (Npos j))) + (PEmul (xdenorm jmp p) (PEpow (PEX jmp) (Npos j))) (xdenorm (Pos.succ jmp) q) end. @@ -961,7 +1050,7 @@ Variable phi_C_of_S : forall c, phiS c = phi (C_of_S c). Fixpoint map_PExpr (e : PExpr S) : PExpr C := match e with | PEc c => PEc (C_of_S c) - | PEX _ p => PEX _ p + | PEX p => PEX p | PEadd e1 e2 => PEadd (map_PExpr e1) (map_PExpr e2) | PEsub e1 e2 => PEsub (map_PExpr e1) (map_PExpr e2) | PEmul e1 e2 => PEmul (map_PExpr e1) (map_PExpr e2) diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 56032befba..02dd29ef14 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -27,7 +27,6 @@ Section S. Context {AA : Type}. (* type of annotations for atoms *) Context {AF : Type}. (* type of formulae identifiers *) - #[universes(template)] Inductive GFormula : Type := | TT : GFormula | FF : GFormula @@ -224,32 +223,59 @@ Section S. end end. - (* Definition or_clause_cnf (t:clause) (f:cnf) : cnf := - List.map (fun x => (t++x)) f. *) - - Definition or_clause_cnf (t:clause) (f:cnf) : cnf := - List.fold_right (fun e acc => + Definition xor_clause_cnf (t:clause) (f:cnf) : cnf := + List.fold_left (fun acc e => match or_clause t e with | None => acc | Some cl => cl :: acc - end) nil f. + end) f nil . + + Definition or_clause_cnf (t: clause) (f:cnf) : cnf := + match t with + | nil => f + | _ => xor_clause_cnf t f + end. Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf := match f with | nil => cnf_tt - | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f') + | e :: rst => (or_cnf rst f') +++ (or_clause_cnf e f') end. Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf := - f1 ++ f2. + f1 +++ f2. (** TX is Prop in Coq and EConstr.constr in Ocaml. AF i s unit in Coq and Names.Id.t in Ocaml *) Definition TFormula (TX: Type) (AF: Type) := @GFormula Term TX Annot AF. + + Definition is_cnf_tt (c : cnf) : bool := + match c with + | nil => true + | _ => false + end. + + Definition is_cnf_ff (c : cnf) : bool := + match c with + | nil::nil => true + | _ => false + end. + + Definition and_cnf_opt (f1 : cnf) (f2 : cnf) : cnf := + if is_cnf_ff f1 || is_cnf_ff f2 + then cnf_ff + else and_cnf f1 f2. + + Definition or_cnf_opt (f1 : cnf) (f2 : cnf) : cnf := + if is_cnf_tt f1 || is_cnf_tt f2 + then cnf_tt + else if is_cnf_ff f2 + then f1 else or_cnf f1 f2. + Fixpoint xcnf {TX AF: Type} (pol : bool) (f : TFormula TX AF) {struct f}: cnf := match f with | TT => if pol then cnf_tt else cnf_ff @@ -258,9 +284,10 @@ Section S. | A x t => if pol then normalise x t else negate x t | N e => xcnf (negb pol) e | Cj e1 e2 => - (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) - | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) - | I e1 _ e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) + (if pol then and_cnf_opt else or_cnf_opt) (xcnf pol e1) (xcnf pol e2) + | D e1 e2 => (if pol then or_cnf_opt else and_cnf_opt) (xcnf pol e1) (xcnf pol e2) + | I e1 _ e2 + => (if pol then or_cnf_opt else and_cnf_opt) (xcnf (negb pol) e1) (xcnf pol e2) end. Section CNFAnnot. @@ -270,8 +297,6 @@ Section S. For efficiency, this is a separate function. *) - - Fixpoint radd_term (t : Term' * Annot) (cl : clause) : clause + list Annot := match cl with | nil => (* if t is unsat, the clause is empty BUT t is needed. *) @@ -302,56 +327,616 @@ Section S. end end. - Definition ror_clause_cnf t f := - List.fold_right (fun e '(acc,tg) => + Definition xror_clause_cnf t f := + List.fold_left (fun '(acc,tg) e => match ror_clause t e with | inl cl => (cl :: acc,tg) - | inr l => (acc,tg++l) - end) (nil,nil) f . + | inr l => (acc,tg+++l) + end) f (nil,nil). + + Definition ror_clause_cnf t f := + match t with + | nil => (f,nil) + | _ => xror_clause_cnf t f + end. - Fixpoint ror_cnf f f' := + Fixpoint ror_cnf (f f':list clause) := match f with | nil => (cnf_tt,nil) | e :: rst => let (rst_f',t) := ror_cnf rst f' in let (e_f', t') := ror_clause_cnf e f' in - (rst_f' ++ e_f', t ++ t') + (rst_f' +++ e_f', t +++ t') + end. + + Definition annot_of_clause (l : clause) : list Annot := + List.map snd l. + + Definition annot_of_cnf (f : cnf) : list Annot := + List.fold_left (fun acc e => annot_of_clause e +++ acc ) f nil. + + + Definition ror_cnf_opt f1 f2 := + if is_cnf_tt f1 + then (cnf_tt , nil) + else if is_cnf_tt f2 + then (cnf_tt, nil) + else if is_cnf_ff f2 + then (f1,nil) + else ror_cnf f1 f2. + + + Definition ocons {A : Type} (o : option A) (l : list A) : list A := + match o with + | None => l + | Some e => e ::l end. - Fixpoint rxcnf {TX AF: Type}(polarity : bool) (f : TFormula TX AF) := + Definition ratom (c : cnf) (a : Annot) : cnf * list Annot := + if is_cnf_ff c || is_cnf_tt c + then (c,a::nil) + else (c,nil). (* t is embedded in c *) + + Fixpoint rxcnf {TX AF: Type}(polarity : bool) (f : TFormula TX AF) : cnf * list Annot := match f with | TT => if polarity then (cnf_tt,nil) else (cnf_ff,nil) | FF => if polarity then (cnf_ff,nil) else (cnf_tt,nil) | X p => if polarity then (cnf_ff,nil) else (cnf_ff,nil) - | A x t => ((if polarity then normalise x t else negate x t),nil) + | A x t => ratom (if polarity then normalise x t else negate x t) t | N e => rxcnf (negb polarity) e | Cj e1 e2 => - let (e1,t1) := rxcnf polarity e1 in - let (e2,t2) := rxcnf polarity e2 in + let '(e1,t1) := rxcnf polarity e1 in + let '(e2,t2) := rxcnf polarity e2 in if polarity - then (e1 ++ e2, t1 ++ t2) - else let (f',t') := ror_cnf e1 e2 in - (f', t1 ++ t2 ++ t') + then (and_cnf_opt e1 e2, t1 +++ t2) + else let (f',t') := ror_cnf_opt e1 e2 in + (f', t1 +++ t2 +++ t') | D e1 e2 => - let (e1,t1) := rxcnf polarity e1 in - let (e2,t2) := rxcnf polarity e2 in + let '(e1,t1) := rxcnf polarity e1 in + let '(e2,t2) := rxcnf polarity e2 in if polarity - then let (f',t') := ror_cnf e1 e2 in - (f', t1 ++ t2 ++ t') - else (e1 ++ e2, t1 ++ t2) - | I e1 _ e2 => - let (e1 , t1) := (rxcnf (negb polarity) e1) in - let (e2 , t2) := (rxcnf polarity e2) in + then let (f',t') := ror_cnf_opt e1 e2 in + (f', t1 +++ t2 +++ t') + else (and_cnf_opt e1 e2, t1 +++ t2) + | I e1 a e2 => + let '(e1 , t1) := (rxcnf (negb polarity) e1) in if polarity - then let (f',t') := ror_cnf e1 e2 in - (f', t1 ++ t2 ++ t') - else (and_cnf e1 e2, t1 ++ t2) + then + if is_cnf_ff e1 + then + rxcnf polarity e2 + else (* compute disjunction *) + let '(e2 , t2) := (rxcnf polarity e2) in + let (f',t') := ror_cnf_opt e1 e2 in + (f', t1 +++ t2 +++ t') (* record the hypothesis *) + else + let '(e2 , t2) := (rxcnf polarity e2) in + (and_cnf_opt e1 e2, t1 +++ t2) end. + + Section Abstraction. + Variable TX : Type. + Variable AF : Type. + + Class to_constrT : Type := + { + mkTT : TX; + mkFF : TX; + mkA : Term -> Annot -> TX; + mkCj : TX -> TX -> TX; + mkD : TX -> TX -> TX; + mkI : TX -> TX -> TX; + mkN : TX -> TX + }. + + Context {to_constr : to_constrT}. + + Fixpoint aformula (f : TFormula TX AF) : TX := + match f with + | TT => mkTT + | FF => mkFF + | X p => p + | A x t => mkA x t + | Cj f1 f2 => mkCj (aformula f1) (aformula f2) + | D f1 f2 => mkD (aformula f1) (aformula f2) + | I f1 o f2 => mkI (aformula f1) (aformula f2) + | N f => mkN (aformula f) + end. + + + Definition is_X (f : TFormula TX AF) : option TX := + match f with + | X p => Some p + | _ => None + end. + + Definition is_X_inv : forall f x, + is_X f = Some x -> f = X x. + Proof. + destruct f ; simpl ; congruence. + Qed. + + + Variable needA : Annot -> bool. + + Definition abs_and (f1 f2 : TFormula TX AF) + (c : TFormula TX AF -> TFormula TX AF -> TFormula TX AF) := + match is_X f1 , is_X f2 with + | Some _ , _ | _ , Some _ => X (aformula (c f1 f2)) + | _ , _ => c f1 f2 + end. + + Definition abs_or (f1 f2 : TFormula TX AF) + (c : TFormula TX AF -> TFormula TX AF -> TFormula TX AF) := + match is_X f1 , is_X f2 with + | Some _ , Some _ => X (aformula (c f1 f2)) + | _ , _ => c f1 f2 + end. + + Definition mk_arrow (o : option AF) (f1 f2: TFormula TX AF) := + match o with + | None => I f1 None f2 + | Some _ => if is_X f1 then f2 else I f1 o f2 + end. + + + Fixpoint abst_form (pol : bool) (f : TFormula TX AF) := + match f with + | TT => if pol then TT else X mkTT + | FF => if pol then X mkFF else FF + | X p => X p + | A x t => if needA t then A x t else X (mkA x t) + | Cj f1 f2 => + let f1 := abst_form pol f1 in + let f2 := abst_form pol f2 in + if pol then abs_and f1 f2 Cj + else abs_or f1 f2 Cj + | D f1 f2 => + let f1 := abst_form pol f1 in + let f2 := abst_form pol f2 in + if pol then abs_or f1 f2 D + else abs_and f1 f2 D + | I f1 o f2 => + let f1 := abst_form (negb pol) f1 in + let f2 := abst_form pol f2 in + if pol + then abs_or f1 f2 (mk_arrow o) + else abs_and f1 f2 (mk_arrow o) + | N f => let f := abst_form (negb pol) f in + match is_X f with + | Some a => X (mkN a) + | _ => N f + end + end. + + + + + Lemma if_same : forall {A: Type} (b:bool) (t:A), + (if b then t else t) = t. + Proof. + destruct b ; reflexivity. + Qed. + + Lemma is_cnf_tt_cnf_ff : + is_cnf_tt cnf_ff = false. + Proof. + reflexivity. + Qed. + + Lemma is_cnf_ff_cnf_ff : + is_cnf_ff cnf_ff = true. + Proof. + reflexivity. + Qed. + + + Lemma is_cnf_tt_inv : forall f1, + is_cnf_tt f1 = true -> f1 = cnf_tt. + Proof. + unfold cnf_tt. + destruct f1 ; simpl ; try congruence. + Qed. + + Lemma is_cnf_ff_inv : forall f1, + is_cnf_ff f1 = true -> f1 = cnf_ff. + Proof. + unfold cnf_ff. + destruct f1 ; simpl ; try congruence. + destruct c ; simpl ; try congruence. + destruct f1 ; try congruence. + reflexivity. + Qed. + + + Lemma if_cnf_tt : forall f, (if is_cnf_tt f then cnf_tt else f) = f. + Proof. + intros. + destruct (is_cnf_tt f) eqn:EQ. + apply is_cnf_tt_inv in EQ;auto. + reflexivity. + Qed. + + Lemma or_cnf_opt_cnf_ff : forall f, + or_cnf_opt cnf_ff f = f. + Proof. + intros. + unfold or_cnf_opt. + rewrite is_cnf_tt_cnf_ff. + simpl. + destruct (is_cnf_tt f) eqn:EQ. + apply is_cnf_tt_inv in EQ. + congruence. + destruct (is_cnf_ff f) eqn:EQ1. + apply is_cnf_ff_inv in EQ1. + congruence. + reflexivity. + Qed. + + Lemma abs_and_pol : forall f1 f2 pol, + and_cnf_opt (xcnf pol f1) (xcnf pol f2) = + xcnf pol (abs_and f1 f2 (if pol then Cj else D)). + Proof. + unfold abs_and; intros. + destruct (is_X f1) eqn:EQ1. + apply is_X_inv in EQ1. + subst. + simpl. + rewrite if_same. reflexivity. + destruct (is_X f2) eqn:EQ2. + apply is_X_inv in EQ2. + subst. + simpl. + rewrite if_same. + unfold and_cnf_opt. + rewrite orb_comm. reflexivity. + destruct pol ; simpl; auto. + Qed. + + Lemma abs_or_pol : forall f1 f2 pol, + or_cnf_opt (xcnf pol f1) (xcnf pol f2) = + xcnf pol (abs_or f1 f2 (if pol then D else Cj)). + Proof. + unfold abs_or; intros. + destruct (is_X f1) eqn:EQ1. + apply is_X_inv in EQ1. + subst. + destruct (is_X f2) eqn:EQ2. + apply is_X_inv in EQ2. + subst. + simpl. + rewrite if_same. + reflexivity. + simpl. + rewrite if_same. + destruct pol ; simpl; auto. + destruct pol ; simpl ; auto. + Qed. + + Variable needA_all : forall a, needA a = true. + + Lemma xcnf_true_mk_arrow_l : forall o t f, + xcnf true (mk_arrow o (X t) f) = xcnf true f. + Proof. + destruct o ; simpl; auto. + intros. rewrite or_cnf_opt_cnf_ff. reflexivity. + Qed. + + Lemma or_cnf_opt_cnf_ff_r : forall f, + or_cnf_opt f cnf_ff = f. + Proof. + unfold or_cnf_opt. + intros. + rewrite is_cnf_tt_cnf_ff. + rewrite orb_comm. + simpl. + apply if_cnf_tt. + Qed. + + Lemma xcnf_true_mk_arrow_r : forall o t f, + xcnf true (mk_arrow o f (X t)) = xcnf false f. + Proof. + destruct o ; simpl; auto. + - intros. + destruct (is_X f) eqn:EQ. + apply is_X_inv in EQ. subst. reflexivity. + simpl. + apply or_cnf_opt_cnf_ff_r. + - intros. + apply or_cnf_opt_cnf_ff_r. + Qed. + + + + Lemma abst_form_correct : forall f pol, + xcnf pol f = xcnf pol (abst_form pol f). + Proof. + induction f;intros. + - simpl. destruct pol ; reflexivity. + - simpl. destruct pol ; reflexivity. + - simpl. reflexivity. + - simpl. rewrite needA_all. + reflexivity. + - simpl. + specialize (IHf1 pol). + specialize (IHf2 pol). + rewrite IHf1. + rewrite IHf2. + destruct pol. + + + apply abs_and_pol; auto. + + + apply abs_or_pol; auto. + - simpl. + specialize (IHf1 pol). + specialize (IHf2 pol). + rewrite IHf1. + rewrite IHf2. + destruct pol. + + + apply abs_or_pol; auto. + + + apply abs_and_pol; auto. + - simpl. + specialize (IHf (negb pol)). + destruct (is_X (abst_form (negb pol) f)) eqn:EQ1. + + apply is_X_inv in EQ1. + rewrite EQ1 in *. + simpl in *. + destruct pol ; auto. + + simpl. congruence. + - simpl. + specialize (IHf1 (negb pol)). + specialize (IHf2 pol). + destruct pol. + + + simpl in *. + unfold abs_or. + destruct (is_X (abst_form false f1)) eqn:EQ1; + destruct (is_X (abst_form true f2)) eqn:EQ2 ; simpl. + * apply is_X_inv in EQ1. + apply is_X_inv in EQ2. + rewrite EQ1 in *. + rewrite EQ2 in *. + rewrite IHf1. rewrite IHf2. + simpl. reflexivity. + * apply is_X_inv in EQ1. + rewrite EQ1 in *. + rewrite IHf1. + simpl. + rewrite xcnf_true_mk_arrow_l. + rewrite or_cnf_opt_cnf_ff. + congruence. + * apply is_X_inv in EQ2. + rewrite EQ2 in *. + rewrite IHf2. + simpl. + rewrite xcnf_true_mk_arrow_r. + rewrite or_cnf_opt_cnf_ff_r. + congruence. + * destruct o ; simpl ; try congruence. + rewrite EQ1. + simpl. congruence. + + simpl in *. + unfold abs_and. + destruct (is_X (abst_form true f1)) eqn:EQ1; + destruct (is_X (abst_form false f2)) eqn:EQ2 ; simpl. + * apply is_X_inv in EQ1. + apply is_X_inv in EQ2. + rewrite EQ1 in *. + rewrite EQ2 in *. + rewrite IHf1. rewrite IHf2. + simpl. reflexivity. + * apply is_X_inv in EQ1. + rewrite EQ1 in *. + rewrite IHf1. + simpl. reflexivity. + * apply is_X_inv in EQ2. + rewrite EQ2 in *. + rewrite IHf2. + simpl. unfold and_cnf_opt. + rewrite orb_comm. reflexivity. + * destruct o; simpl. + rewrite EQ1. simpl. + congruence. + congruence. + Qed. + + End Abstraction. + + End CNFAnnot. + Lemma radd_term_term : forall a' a cl, radd_term a a' = inl cl -> add_term a a' = Some cl. + Proof. + induction a' ; simpl. + - intros. + destruct (deduce (fst a) (fst a)). + destruct (unsat t). congruence. + inversion H. reflexivity. + inversion H ;reflexivity. + - intros. + destruct (deduce (fst a0) (fst a)). + destruct (unsat t). congruence. + destruct (radd_term a0 a') eqn:RADD; try congruence. + inversion H. subst. + apply IHa' in RADD. + rewrite RADD. + reflexivity. + destruct (radd_term a0 a') eqn:RADD; try congruence. + inversion H. subst. + apply IHa' in RADD. + rewrite RADD. + reflexivity. + Qed. + + Lemma radd_term_term' : forall a' a cl, add_term a a' = Some cl -> radd_term a a' = inl cl. + Proof. + induction a' ; simpl. + - intros. + destruct (deduce (fst a) (fst a)). + destruct (unsat t). congruence. + inversion H. reflexivity. + inversion H ;reflexivity. + - intros. + destruct (deduce (fst a0) (fst a)). + destruct (unsat t). congruence. + destruct (add_term a0 a') eqn:RADD; try congruence. + inversion H. subst. + apply IHa' in RADD. + rewrite RADD. + reflexivity. + destruct (add_term a0 a') eqn:RADD; try congruence. + inversion H. subst. + apply IHa' in RADD. + rewrite RADD. + reflexivity. + Qed. + + Lemma xror_clause_clause : forall a f, + fst (xror_clause_cnf a f) = xor_clause_cnf a f. + Proof. + unfold xror_clause_cnf. + unfold xor_clause_cnf. + assert (ACC: fst (@nil clause,@nil Annot) = nil). + reflexivity. + intros. + set (F1:= (fun '(acc, tg) (e : clause) => + match ror_clause a e with + | inl cl => (cl :: acc, tg) + | inr l => (acc, tg +++ l) + end)). + set (F2:= (fun (acc : list clause) (e : clause) => + match or_clause a e with + | Some cl => cl :: acc + | None => acc + end)). + revert ACC. + generalize (@nil clause,@nil Annot). + generalize (@nil clause). + induction f ; simpl ; auto. + intros. + apply IHf. + unfold F1 , F2. + destruct p ; simpl in * ; subst. + clear. + revert a0. + induction a; simpl; auto. + intros. + destruct (radd_term a a1) eqn:RADD. + apply radd_term_term in RADD. + rewrite RADD. + auto. + destruct (add_term a a1) eqn:RADD'. + apply radd_term_term' in RADD'. + congruence. + reflexivity. + Qed. + + Lemma ror_clause_clause : forall a f, + fst (ror_clause_cnf a f) = or_clause_cnf a f. + Proof. + unfold ror_clause_cnf,or_clause_cnf. + destruct a ; auto. + apply xror_clause_clause. + Qed. + + Lemma ror_cnf_cnf : forall f1 f2, fst (ror_cnf f1 f2) = or_cnf f1 f2. + Proof. + induction f1 ; simpl ; auto. + intros. + specialize (IHf1 f2). + destruct(ror_cnf f1 f2). + rewrite <- ror_clause_clause. + destruct(ror_clause_cnf a f2). + simpl. + rewrite <- IHf1. + reflexivity. + Qed. + + Lemma ror_opt_cnf_cnf : forall f1 f2, fst (ror_cnf_opt f1 f2) = or_cnf_opt f1 f2. + Proof. + unfold ror_cnf_opt, or_cnf_opt. + intros. + destruct (is_cnf_tt f1). + - simpl ; auto. + - simpl. destruct (is_cnf_tt f2) ; simpl ; auto. + destruct (is_cnf_ff f2) eqn:EQ. + reflexivity. + apply ror_cnf_cnf. + Qed. + + Lemma ratom_cnf : forall f a, + fst (ratom f a) = f. + Proof. + unfold ratom. + intros. + destruct (is_cnf_ff f || is_cnf_tt f); auto. + Qed. + + + + Lemma rxcnf_xcnf : forall {TX AF:Type} (f:TFormula TX AF) b, + fst (rxcnf b f) = xcnf b f. + Proof. + induction f ; simpl ; auto. + - destruct b; simpl ; auto. + - destruct b; simpl ; auto. + - destruct b ; simpl ; auto. + - intros. rewrite ratom_cnf. reflexivity. + - intros. + specialize (IHf1 b). + specialize (IHf2 b). + destruct (rxcnf b f1). + destruct (rxcnf b f2). + simpl in *. + subst. destruct b ; auto. + rewrite <- ror_opt_cnf_cnf. + destruct (ror_cnf_opt (xcnf false f1) (xcnf false f2)). + reflexivity. + - intros. + specialize (IHf1 b). + specialize (IHf2 b). + rewrite <- IHf1. + rewrite <- IHf2. + destruct (rxcnf b f1). + destruct (rxcnf b f2). + simpl in *. + subst. destruct b ; auto. + rewrite <- ror_opt_cnf_cnf. + destruct (ror_cnf_opt (xcnf true f1) (xcnf true f2)). + reflexivity. + - intros. + specialize (IHf1 (negb b)). + specialize (IHf2 b). + rewrite <- IHf1. + rewrite <- IHf2. + destruct (rxcnf (negb b) f1). + destruct (rxcnf b f2). + simpl in *. + subst. + destruct b;auto. + generalize (is_cnf_ff_inv (xcnf (negb true) f1)). + destruct (is_cnf_ff (xcnf (negb true) f1)). + + intros. + rewrite H by auto. + unfold or_cnf_opt. + simpl. + destruct (is_cnf_tt (xcnf true f2)) eqn:EQ;auto. + apply is_cnf_tt_inv in EQ; auto. + destruct (is_cnf_ff (xcnf true f2)) eqn:EQ1. + apply is_cnf_ff_inv in EQ1. congruence. + reflexivity. + + + rewrite <- ror_opt_cnf_cnf. + destruct (ror_cnf_opt (xcnf (negb true) f1) (xcnf true f2)). + intros. + reflexivity. + Qed. + Variable eval : Env -> Term -> Prop. @@ -365,8 +950,9 @@ Section S. - Variable deduce_prop : forall env t t' u, - eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u. + Variable deduce_prop : forall t t' u, + deduce t t' = Some u -> forall env, + eval' env t -> eval' env t' -> eval' env u. @@ -378,14 +964,55 @@ Section S. Definition eval_cnf (env : Env) (f:cnf) := make_conj (eval_clause env) f. - Lemma eval_cnf_app : forall env x y, eval_cnf env (x++y) -> eval_cnf env x /\ eval_cnf env y. + Lemma eval_cnf_app : forall env x y, eval_cnf env (x+++y) <-> eval_cnf env x /\ eval_cnf env y. Proof. unfold eval_cnf. intros. - rewrite make_conj_app in H ; auto. + rewrite make_conj_rapp. + rewrite make_conj_app ; auto. + tauto. Qed. + Lemma eval_cnf_ff : forall env, eval_cnf env cnf_ff <-> False. + Proof. + unfold cnf_ff, eval_cnf,eval_clause. + simpl. tauto. + Qed. + + Lemma eval_cnf_tt : forall env, eval_cnf env cnf_tt <-> True. + Proof. + unfold cnf_tt, eval_cnf,eval_clause. + simpl. tauto. + Qed. + + + Lemma eval_cnf_and_opt : forall env x y, eval_cnf env (and_cnf_opt x y) <-> eval_cnf env (and_cnf x y). + Proof. + unfold and_cnf_opt. + intros. + destruct (is_cnf_ff x) eqn:F1. + { apply is_cnf_ff_inv in F1. + simpl. subst. + unfold and_cnf. + rewrite eval_cnf_app. + rewrite eval_cnf_ff. + tauto. + } + simpl. + destruct (is_cnf_ff y) eqn:F2. + { apply is_cnf_ff_inv in F2. + simpl. subst. + unfold and_cnf. + rewrite eval_cnf_app. + rewrite eval_cnf_ff. + tauto. + } + tauto. + Qed. + + + Definition eval_opt_clause (env : Env) (cl: option clause) := match cl with | None => True @@ -393,57 +1020,50 @@ Section S. end. - Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl). + Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) <-> eval_clause env (t::cl). Proof. induction cl. - (* BC *) simpl. - case_eq (deduce (fst t) (fst t)) ; auto. - intros *. - case_eq (unsat t0) ; auto. - unfold eval_clause. - rewrite make_conj_cons. - intros. intro. - apply unsat_prop with (1:= H) (env := env). - apply deduce_prop with (3:= H0) ; tauto. + case_eq (deduce (fst t) (fst t)) ; try tauto. + intros. + generalize (@deduce_prop _ _ _ H env). + case_eq (unsat t0) ; try tauto. + { intros. + generalize (@unsat_prop _ H0 env). + unfold eval_clause. + rewrite make_conj_cons. + simpl; intros. + tauto. + } - (* IC *) simpl. - case_eq (deduce (fst t) (fst a)). - intro u. - case_eq (unsat u). - simpl. intros. - unfold eval_clause. - intro. - apply unsat_prop with (1:= H) (env:= env). - repeat rewrite make_conj_cons in H2. - apply deduce_prop with (3:= H0); tauto. - intro. - case_eq (add_term t cl) ; intros. - simpl in H2. - rewrite H0 in IHcl. - simpl in IHcl. - unfold eval_clause in *. - intros. - repeat rewrite make_conj_cons in *. - tauto. - rewrite H0 in IHcl ; simpl in *. - unfold eval_clause in *. + case_eq (deduce (fst t) (fst a)); intros. - repeat rewrite make_conj_cons in *. - tauto. - case_eq (add_term t cl) ; intros. - simpl in H1. - unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - rewrite H in IHcl. - simpl in IHcl. - tauto. - simpl in *. - rewrite H in IHcl. - simpl in IHcl. - unfold eval_clause in *. - repeat rewrite make_conj_cons in *. - tauto. + generalize (@deduce_prop _ _ _ H env). + case_eq (unsat t0); intros. + { + generalize (@unsat_prop _ H0 env). + simpl. + unfold eval_clause. + repeat rewrite make_conj_cons. + tauto. + } + destruct (add_term t cl) ; simpl in * ; try tauto. + { + intros. + unfold eval_clause in *. + repeat rewrite make_conj_cons in *. + tauto. + } + { + unfold eval_clause in *. + repeat rewrite make_conj_cons in *. + tauto. + } + destruct (add_term t cl) ; simpl in *; + unfold eval_clause in * ; + repeat rewrite make_conj_cons in *; tauto. Qed. @@ -456,80 +1076,84 @@ Section S. Hint Resolve no_middle_eval_tt : tauto. - Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'. + Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') <-> eval_clause env cl \/ eval_clause env cl'. Proof. induction cl. - - simpl. tauto. + - simpl. unfold eval_clause at 2. simpl. tauto. - intros *. simpl. assert (HH := add_term_correct env a cl'). - case_eq (add_term a cl'). + assert (eval_tt env a \/ ~ eval_tt env a) by (apply no_middle_eval'). + destruct (add_term a cl'); simpl in *. + - intros. - apply IHcl in H0. - rewrite H in HH. - simpl in HH. + rewrite IHcl. unfold eval_clause in *. - destruct H0. - * - repeat rewrite make_conj_cons in *. + rewrite !make_conj_cons in *. tauto. - * apply HH in H0. - apply not_make_conj_cons in H0 ; auto with tauto. + + unfold eval_clause in *. repeat rewrite make_conj_cons in *. tauto. - + - intros. - rewrite H in HH. - simpl in HH. - unfold eval_clause in *. - assert (HH' := HH Coq.Init.Logic.I). - apply not_make_conj_cons in HH'; auto with tauto. - repeat rewrite make_conj_cons in *. - tauto. Qed. - Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) -> (eval_clause env t) \/ (eval_cnf env f). + Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) <-> (eval_clause env t) \/ (eval_cnf env f). Proof. unfold eval_cnf. unfold or_clause_cnf. intros until t. - set (F := (fun (e : clause) (acc : list clause) => + set (F := (fun (acc : list clause) (e : clause) => match or_clause t e with | Some cl => cl :: acc | None => acc end)). - induction f;auto. - simpl. - intros. - destruct f. - - simpl in H. - simpl in IHf. - unfold F in H. - revert H. - intros. - apply or_clause_correct. - destruct (or_clause t a) ; simpl in * ; auto. - - - unfold F in H at 1. - revert H. - assert (HH := or_clause_correct t a env). - destruct (or_clause t a); simpl in HH ; - rewrite make_conj_cons in * ; intuition. - rewrite make_conj_cons in *. - tauto. + intro f. + assert ( make_conj (eval_clause env) (fold_left F f nil) <-> (eval_clause env t \/ make_conj (eval_clause env) f) /\ make_conj (eval_clause env) nil). + { + generalize (@nil clause) as acc. + induction f. + - simpl. + intros ; tauto. + - intros. + simpl fold_left. + rewrite IHf. + rewrite make_conj_cons. + unfold F in *; clear F. + generalize (or_clause_correct t a env). + destruct (or_clause t a). + + + rewrite make_conj_cons. + simpl. tauto. + + simpl. tauto. + } + destruct t ; auto. + - unfold eval_clause ; simpl. tauto. + - unfold xor_clause_cnf. + unfold F in H. + rewrite H. + unfold make_conj at 2. tauto. Qed. - Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval_tt env) a) -> eval_cnf env f -> eval_cnf env (a::f). + Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval_tt env) a /\ eval_cnf env f) <-> eval_cnf env (a::f). + Proof. + intros. + unfold eval_cnf in *. + rewrite make_conj_cons ; eauto. + unfold eval_clause at 2. + tauto. + Qed. + + Lemma eval_cnf_cons_iff : forall env a f, ((~ make_conj (eval_tt env) a) /\ eval_cnf env f) <-> eval_cnf env (a::f). Proof. intros. unfold eval_cnf in *. rewrite make_conj_cons ; eauto. + unfold eval_clause. + tauto. Qed. - Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') -> (eval_cnf env f) \/ (eval_cnf env f'). + + Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') <-> (eval_cnf env f) \/ (eval_cnf env f'). Proof. induction f. unfold eval_cnf. @@ -537,17 +1161,49 @@ Section S. tauto. (**) intros. - simpl in H. - destruct (eval_cnf_app _ _ _ H). - clear H. - destruct (IHf _ H0). - destruct (or_clause_cnf_correct _ _ _ H1). - left. - apply eval_cnf_cons ; auto. - right ; auto. - right ; auto. + simpl. + rewrite eval_cnf_app. + rewrite <- eval_cnf_cons_iff. + rewrite IHf. + rewrite or_clause_cnf_correct. + unfold eval_clause. + tauto. Qed. + Lemma or_cnf_opt_correct : forall env f f', eval_cnf env (or_cnf_opt f f') <-> eval_cnf env (or_cnf f f'). + Proof. + unfold or_cnf_opt. + intros. + destruct (is_cnf_tt f) eqn:TF. + { simpl. + apply is_cnf_tt_inv in TF. + subst. + rewrite or_cnf_correct. + rewrite eval_cnf_tt. + tauto. + } + destruct (is_cnf_tt f') eqn:TF'. + { simpl. + apply is_cnf_tt_inv in TF'. + subst. + rewrite or_cnf_correct. + rewrite eval_cnf_tt. + tauto. + } + { simpl. + destruct (is_cnf_ff f') eqn:EQ. + apply is_cnf_ff_inv in EQ. + subst. + rewrite or_cnf_correct. + rewrite eval_cnf_ff. + tauto. + tauto. + } + Qed. + + + + Variable normalise_correct : forall env t tg, eval_cnf env (normalise t tg) -> eval env t. Variable negate_correct : forall env t tg, eval_cnf env (negate t tg) -> ~ eval env t. @@ -555,16 +1211,16 @@ Section S. Lemma xcnf_correct : forall (f : @GFormula Term Prop Annot unit) pol env, eval_cnf env (xcnf pol f) -> eval_f (fun x => x) (eval env) (if pol then f else N f). Proof. induction f. - (* TT *) + - (* TT *) unfold eval_cnf. simpl. destruct pol ; simpl ; auto. - (* FF *) + - (* FF *) unfold eval_cnf. destruct pol; simpl ; auto. unfold eval_clause ; simpl. tauto. - (* P *) + - (* P *) simpl. destruct pol ; intros ;simpl. unfold eval_cnf in H. @@ -576,7 +1232,7 @@ Section S. unfold eval_cnf in H;simpl in H. unfold eval_clause in H ; simpl in H. tauto. - (* A *) + - (* A *) simpl. destruct pol ; simpl. intros. @@ -584,49 +1240,54 @@ Section S. (* A 2 *) intros. eapply negate_correct ; eauto. - auto. - (* Cj *) + - (* Cj *) destruct pol ; simpl. - (* pol = true *) + + (* pol = true *) intros. + rewrite eval_cnf_and_opt in H. unfold and_cnf in H. - destruct (eval_cnf_app _ _ _ H). - clear H. + rewrite eval_cnf_app in H. + destruct H. split. - apply (IHf1 _ _ H0). - apply (IHf2 _ _ H1). - (* pol = false *) + apply (IHf1 _ _ H). + apply (IHf2 _ _ H0). + + (* pol = false *) intros. - destruct (or_cnf_correct _ _ _ H). - generalize (IHf1 false env H0). + rewrite or_cnf_opt_correct in H. + rewrite or_cnf_correct in H. + destruct H as [H | H]. + generalize (IHf1 false env H). simpl. tauto. - generalize (IHf2 false env H0). + generalize (IHf2 false env H). simpl. tauto. - (* D *) + - (* D *) simpl. destruct pol. - (* pol = true *) + + (* pol = true *) intros. - destruct (or_cnf_correct _ _ _ H). - generalize (IHf1 _ env H0). + rewrite or_cnf_opt_correct in H. + rewrite or_cnf_correct in H. + destruct H as [H | H]. + generalize (IHf1 _ env H). simpl. tauto. - generalize (IHf2 _ env H0). + generalize (IHf2 _ env H). simpl. tauto. - (* pol = true *) - unfold and_cnf. + + (* pol = true *) intros. - destruct (eval_cnf_app _ _ _ H). - clear H. + rewrite eval_cnf_and_opt in H. + unfold and_cnf. + rewrite eval_cnf_app in H. + destruct H as [H0 H1]. simpl. generalize (IHf1 _ _ H0). generalize (IHf2 _ _ H1). simpl. tauto. - (**) + - (**) simpl. destruct pol ; simpl. intros. @@ -634,25 +1295,29 @@ Section S. intros. generalize (IHf _ _ H). tauto. - (* I *) + - (* I *) simpl; intros. destruct pol. - simpl. + + simpl. intro. - destruct (or_cnf_correct _ _ _ H). - generalize (IHf1 _ _ H1). + rewrite or_cnf_opt_correct in H. + rewrite or_cnf_correct in H. + destruct H as [H | H]. + generalize (IHf1 _ _ H). simpl in *. tauto. - generalize (IHf2 _ _ H1). + generalize (IHf2 _ _ H). auto. - (* pol = false *) - unfold and_cnf in H. - simpl in H. - destruct (eval_cnf_app _ _ _ H). - generalize (IHf1 _ _ H0). - generalize (IHf2 _ _ H1). - simpl. - tauto. + + (* pol = false *) + rewrite eval_cnf_and_opt in H. + unfold and_cnf in H. + simpl in H. + rewrite eval_cnf_app in H. + destruct H as [H0 H1]. + generalize (IHf1 _ _ H0). + generalize (IHf2 _ _ H1). + simpl. + tauto. Qed. diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index 79cb6a3a3e..f93fe021f9 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -27,16 +27,18 @@ Set Implicit Arguments. * As a side note, by dropping the polymorphism, one gets small, yet noticeable, speed-up. *) +Inductive t {A} : Type := +| Empty : t +| Elt : A -> t +| Branch : t -> A -> t -> t . +Arguments t : clear implicits. + Section MakeVarMap. Variable A : Type. Variable default : A. - #[universes(template)] - Inductive t : Type := - | Empty : t - | Elt : A -> t - | Branch : t -> A -> t -> t . + Notation t := (t A). Fixpoint find (vm : t) (p:positive) {struct vm} : A := match vm with @@ -49,7 +51,6 @@ Section MakeVarMap. end end. - Fixpoint singleton (x:positive) (v : A) : t := match x with | xH => Elt v diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index 3ea7635244..47c77ea927 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -23,6 +23,7 @@ Require Import ZCoeff. Require Import Refl. Require Import ZArith. (*Declare ML Module "micromega_plugin".*) +Open Scope Z_scope. Ltac flatten_bool := repeat match goal with @@ -32,10 +33,70 @@ Ltac flatten_bool := Ltac inv H := inversion H ; try subst ; clear H. +Lemma eq_le_iff : forall x, 0 = x <-> (0 <= x /\ x <= 0). +Proof. + intros. + split ; intros. + - subst. + compute. intuition congruence. + - destruct H. + apply Z.le_antisymm; auto. +Qed. + +Lemma lt_le_iff : forall x, + 0 < x <-> 0 <= x - 1. +Proof. + split ; intros. + - apply Zlt_succ_le. + ring_simplify. + auto. + - apply Zle_lt_succ in H. + ring_simplify in H. + auto. +Qed. + +Lemma le_0_iff : forall x y, + x <= y <-> 0 <= y - x. +Proof. + split ; intros. + - apply Zle_minus_le_0; auto. + - apply Zle_0_minus_le; auto. +Qed. + +Lemma le_neg : forall x, + ((0 <= x) -> False) <-> 0 < -x. +Proof. + intro. + rewrite lt_le_iff. + split ; intros. + - apply Znot_le_gt in H. + apply Zgt_le_succ in H. + rewrite le_0_iff in H. + ring_simplify in H; auto. + - assert (C := (Z.add_le_mono _ _ _ _ H H0)). + ring_simplify in C. + compute in C. + apply C ; reflexivity. +Qed. + +Lemma eq_cnf : forall x, + (0 <= x - 1 -> False) /\ (0 <= -1 - x -> False) <-> x = 0. +Proof. + intros. + rewrite Z.eq_sym_iff. + rewrite eq_le_iff. + rewrite (le_0_iff x 0). + rewrite !le_neg. + rewrite !lt_le_iff. + replace (- (x - 1) -1) with (-x) by ring. + replace (- (-1 - x) -1) with x by ring. + split ; intros (H1 & H2); auto. +Qed. -Require Import EnvRing. -Open Scope Z_scope. + + +Require Import EnvRing. Lemma Zsor : SOR 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt. Proof. @@ -65,7 +126,7 @@ Qed. Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z := match e with | PEc c => c - | PEX _ x => env x + | PEX x => env x | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2 | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2 | PEpow e1 n => Z.pow (Zeval_expr env e1) (Z.of_N n) @@ -78,7 +139,7 @@ Definition eval_expr := eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x Fixpoint Zeval_const (e: PExpr Z) : option Z := match e with | PEc c => Some c - | PEX _ x => None + | PEX x => None | PEadd e1 e2 => map_option2 (fun x y => Some (x + y)) (Zeval_const e1) (Zeval_const e2) | PEmul e1 e2 => map_option2 (fun x y => Some (x * y)) @@ -211,83 +272,213 @@ Proof. apply (eval_pol_norm Zsor ZSORaddon). Qed. -Definition xnormalise (t:Formula Z) : list (NFormula Z) := +Definition Zunsat := check_inconsistent 0 Zeq_bool Z.leb. + +Definition Zdeduce := nformula_plus_nformula 0 Z.add Zeq_bool. + +Lemma Zunsat_sound : forall f, + Zunsat f = true -> forall env, eval_nformula env f -> False. +Proof. + unfold Zunsat. + intros. + destruct f. + eapply check_inconsistent_sound with (1 := Zsor) (2 := ZSORaddon) in H; eauto. +Qed. + +Definition xnnormalise (t : Formula Z) : NFormula Z := let (lhs,o,rhs) := t in - let lhs := normZ lhs in - let rhs := normZ rhs in - match o with - | OpEq => - ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil - | OpNEq => (psub lhs rhs,Equal) :: nil - | OpGt => (psub rhs lhs,NonStrict) :: nil - | OpLt => (psub lhs rhs,NonStrict) :: nil - | OpGe => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil - | OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil - end. + let lhs := normZ lhs in + let rhs := normZ rhs in + match o with + | OpEq => (psub rhs lhs, Equal) + | OpNEq => (psub rhs lhs, NonEqual) + | OpGt => (psub lhs rhs, Strict) + | OpLt => (psub rhs lhs, Strict) + | OpGe => (psub lhs rhs, NonStrict) + | OpLe => (psub rhs lhs, NonStrict) + end. + +Lemma xnnormalise_correct : + forall env f, + eval_nformula env (xnnormalise f) <-> Zeval_formula env f. +Proof. + intros. + rewrite Zeval_formula_compat. + unfold xnnormalise. + destruct f as [lhs o rhs]. + destruct o eqn:O ; cbn ; rewrite ?eval_pol_sub; + rewrite <- !eval_pol_norm ; simpl in *; + unfold eval_expr; + generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Z.mul) env lhs); + generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Z.mul) env rhs); intros. + - split ; intros. + + assert (z0 + (z - z0) = z0 + 0) by congruence. + rewrite Z.add_0_r in H0. + rewrite <- H0. + ring. + + subst. + ring. + - split ; repeat intro. + subst. apply H. ring. + apply H. + assert (z0 + (z - z0) = z0 + 0) by congruence. + rewrite Z.add_0_r in H1. + rewrite <- H1. + ring. + - split ; intros. + + apply Zle_0_minus_le; auto. + + apply Zle_minus_le_0; auto. + - split ; intros. + + apply Zle_0_minus_le; auto. + + apply Zle_minus_le_0; auto. + - split ; intros. + + apply Zlt_0_minus_lt; auto. + + apply Zlt_left_lt in H. + apply H. + - split ; intros. + + apply Zlt_0_minus_lt ; auto. + + apply Zlt_left_lt in H. + apply H. +Qed. + +Definition xnormalise (f: NFormula Z) : list (NFormula Z) := + let (e,o) := f in + match o with + | Equal => (psub e (Pc 1),NonStrict) :: (psub (Pc (-1)) e, NonStrict) :: nil + | NonStrict => ((psub (Pc (-1)) e,NonStrict)::nil) + | Strict => ((psub (Pc 0)) e, NonStrict)::nil + | NonEqual => (e, Equal)::nil + end. + +Lemma eval_pol_Pc : forall env z, + eval_pol env (Pc z) = z. +Proof. + reflexivity. +Qed. + +Ltac iff_ring := + match goal with + | |- ?F 0 ?X <-> ?F 0 ?Y => replace X with Y by ring ; tauto + end. + + +Lemma xnormalise_correct : forall env f, + (make_conj (fun x => eval_nformula env x -> False) (xnormalise f)) <-> eval_nformula env f. +Proof. + intros. + destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; + repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; + generalize (eval_pol env e) as x; intro. + - apply eq_cnf. + - unfold not. tauto. + - rewrite le_neg. + iff_ring. + - rewrite le_neg. + rewrite lt_le_iff. + iff_ring. +Qed. + Require Import Coq.micromega.Tauto BinNums. -Definition normalise {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := - List.map (fun x => (x,tg)::nil) (xnormalise t). +Definition cnf_of_list {T: Type} (tg : T) (l : list (NFormula Z)) := + List.fold_right (fun x acc => + if Zunsat x then acc else ((x,tg)::nil)::acc) + (cnf_tt _ _) l. + +Lemma cnf_of_list_correct : + forall {T : Type} (tg:T) (f : list (NFormula Z)) env, + eval_cnf eval_nformula env (cnf_of_list tg f) <-> + make_conj (fun x : NFormula Z => eval_nformula env x -> False) f. +Proof. + unfold cnf_of_list. + intros. + set (F := (fun (x : NFormula Z) (acc : list (list (NFormula Z * T))) => + if Zunsat x then acc else ((x, tg) :: nil) :: acc)). + set (E := ((fun x : NFormula Z => eval_nformula env x -> False))). + induction f. + - compute. + tauto. + - rewrite make_conj_cons. + simpl. + unfold F at 1. + destruct (Zunsat a) eqn:EQ. + + rewrite IHf. + unfold E at 1. + specialize (Zunsat_sound _ EQ env). + tauto. + + + rewrite <- eval_cnf_cons_iff with (1:= fun env (term:Formula Z) => True) . + rewrite IHf. + simpl. + unfold E at 2. + unfold eval_tt. simpl. + tauto. +Qed. +Definition normalise {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := + let f := xnnormalise t in + if Zunsat f then cnf_ff _ _ + else cnf_of_list tg (xnormalise f). Lemma normalise_correct : forall (T: Type) env t (tg:T), eval_cnf eval_nformula env (normalise t tg) <-> Zeval_formula env t. Proof. - unfold normalise, xnormalise; cbn -[padd]; intros T env t tg. - rewrite Zeval_formula_compat. - unfold eval_cnf, eval_clause. - destruct t as [lhs o rhs]; case_eq o; cbn -[padd]; - repeat rewrite eval_pol_sub; - repeat rewrite eval_pol_add; - repeat rewrite <- eval_pol_norm ; simpl in *; - unfold eval_expr; - generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env lhs); - generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst; - intuition (auto with zarith). + intros. + rewrite <- xnnormalise_correct. + unfold normalise. + generalize (xnnormalise t) as f;intro. + destruct (Zunsat f) eqn:U. + - assert (US := Zunsat_sound _ U env). + rewrite eval_cnf_ff with (1:= eval_nformula). + tauto. + - rewrite cnf_of_list_correct. + apply xnormalise_correct. Qed. -Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := - let (lhs,o,rhs) := t in - let lhs := normZ lhs in - let rhs := normZ rhs in +Definition xnegate (f:NFormula Z) : list (NFormula Z) := + let (e,o) := f in match o with - | OpEq => (psub lhs rhs,Equal) :: nil - | OpNEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil - | OpGt => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil - | OpLt => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil - | OpGe => (psub lhs rhs,NonStrict) :: nil - | OpLe => (psub rhs lhs,NonStrict) :: nil + | Equal => (e,Equal) :: nil + | NonEqual => (psub e (Pc 1),NonStrict) :: (psub (Pc (-1)) e, NonStrict) :: nil + | NonStrict => (e,NonStrict)::nil + | Strict => (psub e (Pc 1),NonStrict)::nil end. Definition negate {T : Type} (t:Formula Z) (tg:T) : cnf (NFormula Z) T := - List.map (fun x => (x,tg)::nil) (xnegate t). + let f := xnnormalise t in + if Zunsat f then cnf_tt _ _ + else cnf_of_list tg (xnegate f). -Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env t. -Proof. +Lemma xnegate_correct : forall env f, + (make_conj (fun x => eval_nformula env x -> False) (xnegate f)) <-> ~ eval_nformula env f. Proof. - Opaque padd. - intros T env t tg. - rewrite Zeval_formula_compat. - unfold negate, xnegate ; simpl. - unfold eval_cnf,eval_clause. - destruct t as [lhs o rhs]; case_eq o; unfold eval_tt ; simpl; - repeat rewrite eval_pol_sub; - repeat rewrite eval_pol_add; - repeat rewrite <- eval_pol_norm ; simpl in *; - unfold eval_expr; - generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env lhs); - generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst; - intuition (auto with zarith). - Transparent padd. + intros. + destruct f as [e o]; destruct o eqn:Op; cbn - [psub]; + repeat rewrite eval_pol_sub; fold eval_pol; repeat rewrite eval_pol_Pc; + generalize (eval_pol env e) as x; intro. + - tauto. + - rewrite eq_cnf. + destruct (Z.eq_decidable x 0);tauto. + - rewrite lt_le_iff. + tauto. + - tauto. Qed. -Definition Zunsat := check_inconsistent 0 Zeq_bool Z.leb. - -Definition Zdeduce := nformula_plus_nformula 0 Z.add Zeq_bool. +Lemma negate_correct : forall T env t (tg:T), eval_cnf eval_nformula env (negate t tg) <-> ~ Zeval_formula env t. +Proof. + intros. + rewrite <- xnnormalise_correct. + unfold negate. + generalize (xnnormalise t) as f;intro. + destruct (Zunsat f) eqn:U. + - assert (US := Zunsat_sound _ U env). + rewrite eval_cnf_tt with (1:= eval_nformula). + tauto. + - rewrite cnf_of_list_correct. + apply xnegate_correct. +Qed. Definition cnfZ (Annot TX AF : Type) (f : TFormula (Formula Z) Annot TX AF) := rxcnf Zunsat Zdeduce normalise negate true f. @@ -742,7 +933,7 @@ Module Vars. Fixpoint vars_of_pexpr (e : PExpr Z) : Vars.t := match e with | PEc _ => Vars.empty - | PEX _ x => Vars.singleton x + | PEX x => Vars.singleton x | PEadd e1 e2 | PEsub e1 e2 | PEmul e1 e2 => let v1 := vars_of_pexpr e1 in let v2 := vars_of_pexpr e2 in @@ -774,10 +965,10 @@ Fixpoint vars_of_bformula {TX : Type} {TG : Type} {ID : Type} end. Definition bound_var (v : positive) : Formula Z := - Build_Formula (PEX _ v) OpGe (PEc 0). + Build_Formula (PEX v) OpGe (PEc 0). Definition mk_eq_pos (x : positive) (y:positive) (t : positive) : Formula Z := - Build_Formula (PEX _ x) OpEq (PEsub (PEX _ y) (PEX _ t)). + Build_Formula (PEX x) OpEq (PEsub (PEX y) (PEX t)). Section BOUND. Context {TX TG ID : Type}. @@ -1221,7 +1412,8 @@ Proof. unfold eval_nformula. unfold RingMicromega.eval_nformula. destruct t. apply (check_inconsistent_sound Zsor ZSORaddon) ; auto. - - unfold Zdeduce. apply (nformula_plus_nformula_correct Zsor ZSORaddon). + - unfold Zdeduce. intros. revert H. + apply (nformula_plus_nformula_correct Zsor ZSORaddon); auto. - intros env t tg. rewrite normalise_correct ; auto. @@ -1513,10 +1705,8 @@ Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt. - Open Scope Z_scope. - (** To ease bindings from ml code **) Definition make_impl := Refl.make_impl. Definition make_conj := Refl.make_conj. diff --git a/plugins/micromega/Zify.v b/plugins/micromega/Zify.v new file mode 100644 index 0000000000..57d812b0fd --- /dev/null +++ b/plugins/micromega/Zify.v @@ -0,0 +1,90 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import ZifyClasses. +Require Export ZifyInst. +Require Import InitialRing. + +(** From PreOmega *) + +(** I) translation of Z.max, Z.min, Z.abs, Z.sgn into recognized equations *) + +Ltac zify_unop_core t thm a := + (* Let's introduce the specification theorem for t *) + pose proof (thm a); + (* Then we replace (t a) everywhere with a fresh variable *) + let z := fresh "z" in set (z:=t a) in *; clearbody z. + +Ltac zify_unop_var_or_term t thm a := + (* If a is a variable, no need for aliasing *) + let za := fresh "z" in + (rename a into za; rename za into a; zify_unop_core t thm a) || + (* Otherwise, a is a complex term: we alias it. *) + (remember a as za; zify_unop_core t thm za). + +Ltac zify_unop t thm a := + (* If a is a scalar, we can simply reduce the unop. *) + (* Note that simpl wasn't enough to reduce [Z.max 0 0] (#5439) *) + let isz := isZcst a in + match isz with + | true => + let u := eval compute in (t a) in + change (t a) with u in * + | _ => zify_unop_var_or_term t thm a + end. + +Ltac zify_unop_nored t thm a := + (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *) + let isz := isZcst a in + match isz with + | true => zify_unop_core t thm a + | _ => zify_unop_var_or_term t thm a + end. + +Ltac zify_binop t thm a b:= + (* works as zify_unop, except that we should be careful when + dealing with b, since it can be equal to a *) + let isza := isZcst a in + match isza with + | true => zify_unop (t a) (thm a) b + | _ => + let za := fresh "z" in + (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) || + (remember a as za; match goal with + | H : za = b |- _ => zify_unop_nored (t za) (thm za) za + | _ => zify_unop_nored (t za) (thm za) b + end) + end. + +(* end from PreOmega *) + +Ltac applySpec S := + let t := type of S in + match t with + | @BinOpSpec _ _ ?Op _ => + let Spec := (eval unfold S, BSpec in (@BSpec _ _ Op _ S)) in + repeat + match goal with + | H : context[Op ?X ?Y] |- _ => zify_binop Op Spec X Y + | |- context[Op ?X ?Y] => zify_binop Op Spec X Y + end + | @UnOpSpec _ _ ?Op _ => + let Spec := (eval unfold S, USpec in (@USpec _ _ Op _ S)) in + repeat + match goal with + | H : context[Op ?X] |- _ => zify_unop Op Spec X + | |- context[Op ?X ] => zify_unop Op Spec X + end + end. + +(** [zify_post_hook] is there to be redefined. *) +Ltac zify_post_hook := idtac. + +Ltac zify := zify_tac ; (iter_specs applySpec) ; zify_post_hook. diff --git a/plugins/micromega/ZifyBool.v b/plugins/micromega/ZifyBool.v new file mode 100644 index 0000000000..ec37c2003f --- /dev/null +++ b/plugins/micromega/ZifyBool.v @@ -0,0 +1,255 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +Require Import Bool ZArith. +Require Import ZifyClasses. +Open Scope Z_scope. +(* Instances of [ZifyClasses] for dealing with boolean operators. + Various encodings of boolean are possible. One objective is to + have an encoding that is terse but also lia friendly. + *) + +(** [Z_of_bool] is the injection function for boolean *) +Definition Z_of_bool (b : bool) : Z := if b then 1 else 0. + +(** [bool_of_Z] is a compatible reverse operation *) +Definition bool_of_Z (z : Z) : bool := negb (Z.eqb z 0). + +Lemma Z_of_bool_bound : forall x, 0 <= Z_of_bool x <= 1. +Proof. + destruct x ; simpl; compute; intuition congruence. +Qed. + +Instance Inj_bool_Z : InjTyp bool Z := + { inj := Z_of_bool ; pred :=(fun x => 0 <= x <= 1) ; cstr := Z_of_bool_bound}. +Add InjTyp Inj_bool_Z. + +(** Boolean operators *) + +Instance Op_andb : BinOp andb := + { TBOp := Z.min ; + TBOpInj := ltac: (destruct n,m; reflexivity)}. +Add BinOp Op_andb. + +Instance Op_orb : BinOp orb := + { TBOp := Z.max ; + TBOpInj := ltac:(destruct n,m; reflexivity)}. +Add BinOp Op_orb. + +Instance Op_negb : UnOp negb := + { TUOp := fun x => 1 - x ; TUOpInj := ltac:(destruct x; reflexivity)}. +Add UnOp Op_negb. + +Instance Op_eq_bool : BinRel (@eq bool) := + {TR := @eq Z ; TRInj := ltac:(destruct n,m; simpl ; intuition congruence) }. +Add BinRel Op_eq_bool. + +Instance Op_true : CstOp true := + { TCst := 1 ; TCstInj := eq_refl }. + +Instance Op_false : CstOp false := + { TCst := 0 ; TCstInj := eq_refl }. + + +(** Comparisons are encoded using the predicates [isZero] and [isLeZero].*) + +Definition isZero (z : Z) := Z_of_bool (Z.eqb z 0). + +Definition isLeZero (x : Z) := Z_of_bool (Z.leb x 0). + +(* Some intermediate lemma *) + +Lemma Z_eqb_isZero : forall n m, + Z_of_bool (n =? m) = isZero (n - m). +Proof. + intros ; unfold isZero. + destruct ( n =? m) eqn:EQ. + - simpl. rewrite Z.eqb_eq in EQ. + rewrite EQ. rewrite Z.sub_diag. + reflexivity. + - + destruct (n - m =? 0) eqn:EQ'. + rewrite Z.eqb_neq in EQ. + rewrite Z.eqb_eq in EQ'. + apply Zminus_eq in EQ'. + congruence. + reflexivity. +Qed. + +Lemma Z_leb_sub : forall x y, x <=? y = ((x - y) <=? 0). +Proof. + intros. + destruct (x <=?y) eqn:B1 ; + destruct (x - y <=?0) eqn:B2 ; auto. + - rewrite Z.leb_le in B1. + rewrite Z.leb_nle in B2. + rewrite Z.le_sub_0 in B2. tauto. + - rewrite Z.leb_nle in B1. + rewrite Z.leb_le in B2. + rewrite Z.le_sub_0 in B2. tauto. +Qed. + +Lemma Z_ltb_leb : forall x y, x <? y = (x +1 <=? y). +Proof. + intros. + destruct (x <?y) eqn:B1 ; + destruct (x + 1 <=?y) eqn:B2 ; auto. + - rewrite Z.ltb_lt in B1. + rewrite Z.leb_nle in B2. + apply Zorder.Zlt_le_succ in B1. + unfold Z.succ in B1. + tauto. + - rewrite Z.ltb_nlt in B1. + rewrite Z.leb_le in B2. + apply Zorder.Zle_lt_succ in B2. + unfold Z.succ in B2. + apply Zorder.Zplus_lt_reg_r in B2. + tauto. +Qed. + + +(** Comparison over Z *) + +Instance Op_Zeqb : BinOp Z.eqb := + { TBOp := fun x y => isZero (Z.sub x y) ; TBOpInj := Z_eqb_isZero}. + +Instance Op_Zleb : BinOp Z.leb := + { TBOp := fun x y => isLeZero (x-y) ; + TBOpInj := + ltac: (intros;unfold isLeZero; + rewrite Z_leb_sub; + auto) }. +Add BinOp Op_Zleb. + +Instance Op_Zgeb : BinOp Z.geb := + { TBOp := fun x y => isLeZero (y-x) ; + TBOpInj := ltac:( + intros; + unfold isLeZero; + rewrite Z.geb_leb; + rewrite Z_leb_sub; + auto) }. +Add BinOp Op_Zgeb. + +Instance Op_Zltb : BinOp Z.ltb := + { TBOp := fun x y => isLeZero (x+1-y) ; + TBOpInj := ltac:( + intros; + unfold isLeZero; + rewrite Z_ltb_leb; + rewrite <- Z_leb_sub; + reflexivity) }. + +Instance Op_Zgtb : BinOp Z.gtb := + { TBOp := fun x y => isLeZero (y-x+1) ; + TBOpInj := ltac:( + intros; + unfold isLeZero; + rewrite Z.gtb_ltb; + rewrite Z_ltb_leb; + rewrite Z_leb_sub; + rewrite Z.add_sub_swap; + reflexivity) }. +Add BinOp Op_Zgtb. + +(** Comparison over nat *) + + +Lemma Z_of_nat_eqb_iff : forall n m, + (n =? m)%nat = (Z.of_nat n =? Z.of_nat m). +Proof. + intros. + rewrite Nat.eqb_compare. + rewrite Z.eqb_compare. + rewrite Nat2Z.inj_compare. + reflexivity. +Qed. + +Lemma Z_of_nat_leb_iff : forall n m, + (n <=? m)%nat = (Z.of_nat n <=? Z.of_nat m). +Proof. + intros. + rewrite Nat.leb_compare. + rewrite Z.leb_compare. + rewrite Nat2Z.inj_compare. + reflexivity. +Qed. + +Lemma Z_of_nat_ltb_iff : forall n m, + (n <? m)%nat = (Z.of_nat n <? Z.of_nat m). +Proof. + intros. + rewrite Nat.ltb_compare. + rewrite Z.ltb_compare. + rewrite Nat2Z.inj_compare. + reflexivity. +Qed. + +Instance Op_nat_eqb : BinOp Nat.eqb := + { TBOp := fun x y => isZero (Z.sub x y) ; + TBOpInj := ltac:( + intros; simpl; + rewrite <- Z_eqb_isZero; + f_equal; apply Z_of_nat_eqb_iff) }. +Add BinOp Op_nat_eqb. + +Instance Op_nat_leb : BinOp Nat.leb := + { TBOp := fun x y => isLeZero (x-y) ; + TBOpInj := ltac:( + intros; + rewrite Z_of_nat_leb_iff; + unfold isLeZero; + rewrite Z_leb_sub; + auto) }. +Add BinOp Op_nat_leb. + +Instance Op_nat_ltb : BinOp Nat.ltb := + { TBOp := fun x y => isLeZero (x+1-y) ; + TBOpInj := ltac:( + intros; + rewrite Z_of_nat_ltb_iff; + unfold isLeZero; + rewrite Z_ltb_leb; + rewrite <- Z_leb_sub; + reflexivity) }. +Add BinOp Op_nat_ltb. + +(** Injected boolean operators *) + +Lemma Z_eqb_ZSpec_ok : forall x, x <> isZero x. +Proof. + intros. + unfold isZero. + destruct (x =? 0) eqn:EQ. + - apply Z.eqb_eq in EQ. + simpl. congruence. + - apply Z.eqb_neq in EQ. + simpl. auto. +Qed. + +Instance Z_eqb_ZSpec : UnOpSpec isZero := + {| UPred := fun n r => n <> r ; USpec := Z_eqb_ZSpec_ok |}. +Add Spec Z_eqb_ZSpec. + +Lemma leZeroSpec_ok : forall x, x <= 0 /\ isLeZero x = 1 \/ x > 0 /\ isLeZero x = 0. +Proof. + intros. + unfold isLeZero. + destruct (x <=? 0) eqn:EQ. + - apply Z.leb_le in EQ. + simpl. intuition congruence. + - simpl. + apply Z.leb_nle in EQ. + apply Zorder.Znot_le_gt in EQ. + tauto. +Qed. + +Instance leZeroSpec : UnOpSpec isLeZero := + {| UPred := fun n r => (n<=0 /\ r = 1) \/ (n > 0 /\ r = 0) ; USpec := leZeroSpec_ok|}. +Add Spec leZeroSpec. diff --git a/plugins/micromega/ZifyClasses.v b/plugins/micromega/ZifyClasses.v new file mode 100644 index 0000000000..d3f7f91074 --- /dev/null +++ b/plugins/micromega/ZifyClasses.v @@ -0,0 +1,232 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +Set Primitive Projections. + +(** An alternative to [zify] in ML parametrised by user-provided classes instances. + + The framework has currently several limitations that are in place for simplicity. + For instance, we only consider binary operators of type [Op: S -> S -> S]. + Another limitation is that our injection theorems e.g. [TBOpInj], + are using Leibniz equality; the payoff is that there is no need for morphisms... + *) + +(** An injection [InjTyp S T] declares an injection + from source type S to target type T. +*) +Class InjTyp (S : Type) (T : Type) := + mkinj { + (* [inj] is the injection function *) + inj : S -> T; + pred : T -> Prop; + (* [cstr] states that [pred] holds for any injected element. + [cstr (inj x)] is introduced in the goal for any leaf + term of the form [inj x] + *) + cstr : forall x, pred (inj x) + }. + +(** [BinOp Op] declares a source operator [Op: S1 -> S2 -> S3]. + *) +Class BinOp {S1 S2 S3:Type} {T:Type} (Op : S1 -> S2 -> S3) {I1 : InjTyp S1 T} {I2 : InjTyp S2 T} {I3 : InjTyp S3 T} := + mkbop { + (* [TBOp] is the target operator after injection of operands. *) + TBOp : T -> T -> T; + (* [TBOpInj] states the correctness of the injection. *) + TBOpInj : forall (n:S1) (m:S2), inj (Op n m) = TBOp (inj n) (inj m) + }. + +(** [Unop Op] declares a source operator [Op : S1 -> S2]. *) +Class UnOp {S1 S2 T:Type} (Op : S1 -> S2) {I1 : InjTyp S1 T} {I2 : InjTyp S2 T} := + mkuop { + (* [TUOp] is the target operator after injection of operands. *) + TUOp : T -> T; + (* [TUOpInj] states the correctness of the injection. *) + TUOpInj : forall (x:S1), inj (Op x) = TUOp (inj x) + }. + +(** [CstOp Op] declares a source constant [Op : S]. *) +Class CstOp {S T:Type} (Op : S) {I : InjTyp S T} := + mkcst { + (* [TCst] is the target constant. *) + TCst : T; + (* [TCstInj] states the correctness of the injection. *) + TCstInj : inj Op = TCst + }. + +(** In the framework, [Prop] is mapped to [Prop] and the injection is phrased in + terms of [=] instead of [<->]. +*) + +(** [BinRel R] declares the injection of a binary relation. *) +Class BinRel {S:Type} {T:Type} (R : S -> S -> Prop) {I : InjTyp S T} := + mkbrel { + TR : T -> T -> Prop; + TRInj : forall n m : S, R n m <-> TR (@inj _ _ I n) (inj m) + }. + +(** [PropOp Op] declares morphisms for [<->]. + This will be used to deal with e.g. [and], [or],... *) +Class PropOp (Op : Prop -> Prop -> Prop) := + mkprop { + op_iff : forall (p1 p2 q1 q2:Prop), (p1 <-> q1) -> (p2 <-> q2) -> (Op p1 p2 <-> Op q1 q2) + }. + +Class PropUOp (Op : Prop -> Prop) := + mkuprop { + uop_iff : forall (p1 q1 :Prop), (p1 <-> q1) -> (Op p1 <-> Op q1) + }. + + + +(** Once the term is injected, terms can be replaced by their specification. + NB1: The Ltac code is currently limited to (Op: Z -> Z -> Z) + NB2: This is not sufficient to cope with [Z.div] or [Z.mod] + *) +Class BinOpSpec {S T: Type} (Op : T -> T -> T) {I : InjTyp S T} := + mkbspec { + BPred : T -> T -> T -> Prop; + BSpec : forall x y, BPred x y (Op x y) + }. + +Class UnOpSpec {S T: Type} (Op : T -> T) {I : InjTyp S T} := + mkuspec { + UPred : T -> T -> Prop; + USpec : forall x, UPred x (Op x) + }. + +(** After injections, e.g. nat -> Z, + the fact that Z.of_nat x * Z.of_nat y is positive is lost. + This information can be recovered using instance of the [Saturate] class. +*) +Class Saturate {T: Type} (Op : T -> T -> T) := + mksat { + (** Given [Op x y], + - [PArg1] is the pre-condition of x + - [PArg2] is the pre-condition of y + - [PRes] is the pos-condition of (Op x y) *) + PArg1 : T -> Prop; + PArg2 : T -> Prop; + PRes : T -> Prop; + (** [SatOk] states the correctness of the reasoning *) + SatOk : forall x y, PArg1 x -> PArg2 y -> PRes (Op x y) + }. +(* The [ZifyInst.saturate] iterates over all the instances + and for every pattern of the form + [H1 : PArg1 ?x , H2 : PArg2 ?y , T : context[Op ?x ?y] |- _ ] + [H1 : PArg1 ?x , H2 : PArg2 ?y |- context[Op ?x ?y] ] + asserts (SatOK x y H1 H2) *) + +(** The rest of the file is for internal use by the ML tactic. + There are data-structures and lemmas used to inductively construct + the injected terms. *) + +(** The data-structures [injterm] and [injected_prop] + are used to store source and target expressions together + with a correctness proof. *) + +Record injterm {S T: Type} {I : S -> T} := + mkinjterm { source : S ; target : T ; inj_ok : I source = target}. + +Record injprop := + mkinjprop { + source_prop : Prop ; target_prop : Prop ; + injprop_ok : source_prop <-> target_prop}. + +(** Lemmas for building [injterm] and [injprop]. *) + +Definition mkprop_op (Op : Prop -> Prop -> Prop) (POp : PropOp Op) + (p1 :injprop) (p2: injprop) : injprop := + {| source_prop := (Op (source_prop p1) (source_prop p2)) ; + target_prop := (Op (target_prop p1) (target_prop p2)) ; + injprop_ok := (op_iff (source_prop p1) (source_prop p2) (target_prop p1) (target_prop p2) + (injprop_ok p1) (injprop_ok p2)) + |}. + + +Definition mkuprop_op (Op : Prop -> Prop) (POp : PropUOp Op) + (p1 :injprop) : injprop := + {| source_prop := (Op (source_prop p1)) ; + target_prop := (Op (target_prop p1)) ; + injprop_ok := (uop_iff (source_prop p1) (target_prop p1) (injprop_ok p1)) + |}. + + +Lemma mkapp2 (S1 S2 S3 T : Type) (Op : S1 -> S2 -> S3) + {I1 : InjTyp S1 T} {I2 : InjTyp S2 T} {I3 : InjTyp S3 T} + (B : @BinOp S1 S2 S3 T Op I1 I2 I3) + (t1 : @injterm S1 T inj) (t2 : @injterm S2 T inj) + : @injterm S3 T inj. +Proof. + apply (mkinjterm _ _ inj (Op (source t1) (source t2)) (TBOp (target t1) (target t2))). + (rewrite <- inj_ok; + rewrite <- inj_ok; + apply TBOpInj). +Defined. + +Lemma mkapp (S1 S2 T : Type) (Op : S1 -> S2) + {I1 : InjTyp S1 T} + {I2 : InjTyp S2 T} + (B : @UnOp S1 S2 T Op I1 I2 ) + (t1 : @injterm S1 T inj) + : @injterm S2 T inj. +Proof. + apply (mkinjterm _ _ inj (Op (source t1)) (TUOp (target t1))). + (rewrite <- inj_ok; apply TUOpInj). +Defined. + +Lemma mkapp0 (S T : Type) (Op : S) + {I : InjTyp S T} + (B : @CstOp S T Op I) + : @injterm S T inj. +Proof. + apply (mkinjterm _ _ inj Op TCst). + (apply TCstInj). +Defined. + +Lemma mkrel (S T : Type) (R : S -> S -> Prop) + {Inj : InjTyp S T} + (B : @BinRel S T R Inj) + (t1 : @injterm S T inj) (t2 : @injterm S T inj) + : @injprop. +Proof. + apply (mkinjprop (R (source t1) (source t2)) (TR (target t1) (target t2))). + (rewrite <- inj_ok; rewrite <- inj_ok;apply TRInj). +Defined. + +(** Registering constants for use by the plugin *) +Register target_prop as ZifyClasses.target_prop. +Register mkrel as ZifyClasses.mkrel. +Register target as ZifyClasses.target. +Register mkapp2 as ZifyClasses.mkapp2. +Register mkapp as ZifyClasses.mkapp. +Register mkapp0 as ZifyClasses.mkapp0. +Register op_iff as ZifyClasses.op_iff. +Register uop_iff as ZifyClasses.uop_iff. +Register TR as ZifyClasses.TR. +Register TBOp as ZifyClasses.TBOp. +Register TUOp as ZifyClasses.TUOp. +Register TCst as ZifyClasses.TCst. +Register mkprop_op as ZifyClasses.mkprop_op. +Register mkuprop_op as ZifyClasses.mkuprop_op. +Register injprop_ok as ZifyClasses.injprop_ok. +Register inj_ok as ZifyClasses.inj_ok. +Register source as ZifyClasses.source. +Register source_prop as ZifyClasses.source_prop. +Register inj as ZifyClasses.inj. +Register TRInj as ZifyClasses.TRInj. +Register TUOpInj as ZifyClasses.TUOpInj. +Register not as ZifyClasses.not. +Register mkinjterm as ZifyClasses.mkinjterm. +Register eq_refl as ZifyClasses.eq_refl. +Register mkinjprop as ZifyClasses.mkinjprop. +Register iff_refl as ZifyClasses.iff_refl. +Register source_prop as ZifyClasses.source_prop. +Register injprop_ok as ZifyClasses.injprop_ok. +Register iff as ZifyClasses.iff. diff --git a/plugins/micromega/ZifyInst.v b/plugins/micromega/ZifyInst.v new file mode 100644 index 0000000000..1217e8a5f7 --- /dev/null +++ b/plugins/micromega/ZifyInst.v @@ -0,0 +1,449 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* Instances of [ZifyClasses] for emulating the existing zify. + Each instance is registered using a Add 'class' 'name_of_instance'. + *) + +Require Import Arith Max Min BinInt BinNat Znat Nnat. +Require Import ZifyClasses. +Declare ML Module "zify_plugin". +Open Scope Z_scope. + +(** Propositional logic *) +Instance PropAnd : PropOp and. +Proof. + constructor. + tauto. +Defined. +Add PropOp PropAnd. + +Instance PropOr : PropOp or. +Proof. + constructor. + tauto. +Defined. +Add PropOp PropOr. + +Instance PropArrow : PropOp (fun x y => x -> y). +Proof. + constructor. + intros. + tauto. +Defined. +Add PropOp PropArrow. + +Instance PropIff : PropOp iff. +Proof. + constructor. + intros. + tauto. +Defined. +Add PropOp PropIff. + +Instance PropNot : PropUOp not. +Proof. + constructor. + intros. + tauto. +Defined. +Add PropUOp PropNot. + + +Instance Inj_Z_Z : InjTyp Z Z := + mkinj _ _ (fun x => x) (fun x => True ) (fun _ => I). +Add InjTyp Inj_Z_Z. + +(** Support for nat *) + +Instance Inj_nat_Z : InjTyp nat Z := + mkinj _ _ Z.of_nat (fun x => 0 <= x ) Nat2Z.is_nonneg. +Add InjTyp Inj_nat_Z. + +(* zify_nat_rel *) +Instance Op_ge : BinRel ge := + {| TR := Z.ge; TRInj := Nat2Z.inj_ge |}. +Add BinRel Op_ge. + +Instance Op_lt : BinRel lt := + {| TR := Z.lt; TRInj := Nat2Z.inj_lt |}. +Add BinRel Op_lt. + +Instance Op_gt : BinRel gt := + {| TR := Z.gt; TRInj := Nat2Z.inj_gt |}. +Add BinRel Op_gt. + +Instance Op_le : BinRel le := + {| TR := Z.le; TRInj := Nat2Z.inj_le |}. +Add BinRel Op_le. + +Instance Op_eq_nat : BinRel (@eq nat) := + {| TR := @eq Z ; TRInj := fun x y : nat => iff_sym (Nat2Z.inj_iff x y) |}. +Add BinRel Op_eq_nat. + +(* zify_nat_op *) +Instance Op_plus : BinOp Nat.add := + {| TBOp := Z.add; TBOpInj := Nat2Z.inj_add |}. +Add BinOp Op_plus. + +Instance Op_sub : BinOp Nat.sub := + {| TBOp := fun n m => Z.max 0 (n - m) ; TBOpInj := Nat2Z.inj_sub_max |}. +Add BinOp Op_sub. + +Instance Op_mul : BinOp Nat.mul := + {| TBOp := Z.mul ; TBOpInj := Nat2Z.inj_mul |}. +Add BinOp Op_mul. + +Instance Op_min : BinOp Nat.min := + {| TBOp := Z.min ; TBOpInj := Nat2Z.inj_min |}. +Add BinOp Op_min. + +Instance Op_max : BinOp Nat.max := + {| TBOp := Z.max ; TBOpInj := Nat2Z.inj_max |}. +Add BinOp Op_max. + +Instance Op_pred : UnOp Nat.pred := + {| TUOp := fun n => Z.max 0 (n - 1) ; TUOpInj := Nat2Z.inj_pred_max |}. +Add UnOp Op_pred. + +Instance Op_S : UnOp S := + {| TUOp := fun x => Z.add x 1 ; TUOpInj := Nat2Z.inj_succ |}. +Add UnOp Op_S. + +Instance Op_O : CstOp O := + {| TCst := Z0 ; TCstInj := eq_refl (Z.of_nat 0) |}. + +Instance Op_Z_abs_nat : UnOp Z.abs_nat := + { TUOp := Z.abs ; TUOpInj := Zabs2Nat.id_abs }. +Add UnOp Op_Z_abs_nat. + +(** Support for positive *) + +Instance Inj_pos_Z : InjTyp positive Z := + {| inj := Zpos ; pred := (fun x => 0 < x ) ; cstr := Pos2Z.pos_is_pos |}. +Add InjTyp Inj_pos_Z. + +Instance Op_pos_to_nat : UnOp Pos.to_nat := + {TUOp := (fun x => x); TUOpInj := positive_nat_Z}. +Add UnOp Op_pos_to_nat. + +Instance Inj_N_Z : InjTyp N Z := + mkinj _ _ Z.of_N (fun x => 0 <= x ) N2Z.is_nonneg. +Add InjTyp Inj_N_Z. + + +Instance Op_N_to_nat : UnOp N.to_nat := + { TUOp := fun x => x ; TUOpInj := N_nat_Z }. +Add UnOp Op_N_to_nat. + +(* zify_positive_rel *) + +Instance Op_pos_ge : BinRel Pos.ge := + {| TR := Z.ge; TRInj := fun x y => iff_refl (Z.pos x >= Z.pos y) |}. +Add BinRel Op_pos_ge. + +Instance Op_pos_lt : BinRel Pos.lt := + {| TR := Z.lt; TRInj := fun x y => iff_refl (Z.pos x < Z.pos y) |}. +Add BinRel Op_pos_lt. + +Instance Op_pos_gt : BinRel Pos.gt := + {| TR := Z.gt; TRInj := fun x y => iff_refl (Z.pos x > Z.pos y) |}. +Add BinRel Op_pos_gt. + +Instance Op_pos_le : BinRel Pos.le := + {| TR := Z.le; TRInj := fun x y => iff_refl (Z.pos x <= Z.pos y) |}. +Add BinRel Op_pos_le. + +Instance Op_eq_pos : BinRel (@eq positive) := + {| TR := @eq Z ; TRInj := fun x y => iff_sym (Pos2Z.inj_iff x y) |}. +Add BinRel Op_eq_pos. + +(* zify_positive_op *) + + +Program Instance Op_Z_of_N : UnOp Z.of_N := + { TUOp := (fun x => x) ; TUOpInj := fun x => eq_refl (Z.of_N x) }. +Add UnOp Op_Z_of_N. + +Instance Op_Z_to_N : UnOp Z.to_N := + { TUOp := fun x => Z.max 0 x ; TUOpInj := ltac:(now intro x; destruct x) }. +Add UnOp Op_Z_to_N. + +Instance Op_Z_neg : UnOp Z.neg := + { TUOp := Z.opp ; TUOpInj := (fun x => eq_refl (Zneg x))}. +Add UnOp Op_Z_neg. + +Instance Op_Z_pos : UnOp Z.pos := + { TUOp := (fun x => x) ; TUOpInj := (fun x => eq_refl (Z.pos x))}. +Add UnOp Op_Z_pos. + +Instance Op_pos_succ : UnOp Pos.succ := + { TUOp := fun x => x + 1; TUOpInj := Pos2Z.inj_succ }. +Add UnOp Op_pos_succ. + +Instance Op_pos_pred : UnOp Pos.pred := + { TUOp := fun x => Z.max 1 (x - 1) ; + TUOpInj := ltac : + (intros; + rewrite <- Pos.sub_1_r; + apply Pos2Z.inj_sub_max) }. +Add UnOp Op_pos_pred. + +Instance Op_pos_of_succ_nat : UnOp Pos.of_succ_nat := + { TUOp := fun x => x + 1 ; TUOpInj := Zpos_P_of_succ_nat }. +Add UnOp Op_pos_of_succ_nat. + +Program Instance Op_pos_add : BinOp Pos.add := + { TBOp := Z.add ; TBOpInj := ltac: (reflexivity) }. +Add BinOp Op_pos_add. + +Instance Op_pos_sub : BinOp Pos.sub := + { TBOp := fun n m => Z.max 1 (n - m) ;TBOpInj := Pos2Z.inj_sub_max }. +Add BinOp Op_pos_sub. + +Instance Op_pos_mul : BinOp Pos.mul := + { TBOp := Z.mul ; TBOpInj := ltac: (reflexivity) }. +Add BinOp Op_pos_mul. + +Instance Op_pos_min : BinOp Pos.min := + { TBOp := Z.min ; TBOpInj := Pos2Z.inj_min }. +Add BinOp Op_pos_min. + +Instance Op_pos_max : BinOp Pos.max := + { TBOp := Z.max ; TBOpInj := Pos2Z.inj_max }. +Add BinOp Op_pos_max. + +Instance Op_xO : UnOp xO := + { TUOp := fun x => 2 * x ; TUOpInj := ltac: (reflexivity) }. +Add UnOp Op_xO. + +Instance Op_xI : UnOp xI := + { TUOp := fun x => 2 * x + 1 ; TUOpInj := ltac: (reflexivity) }. +Add UnOp Op_xI. + +Instance Op_xH : CstOp xH := + { TCst := 1%Z ; TCstInj := ltac:(reflexivity)}. +Add CstOp Op_xH. + +Instance Op_Z_of_nat : UnOp Z.of_nat:= + { TUOp := fun x => x ; TUOpInj := ltac:(reflexivity) }. +Add UnOp Op_Z_of_nat. + +(* zify_N_rel *) +Instance Op_N_ge : BinRel N.ge := + {| TR := Z.ge ; TRInj := N2Z.inj_ge |}. +Add BinRel Op_N_ge. + +Instance Op_N_lt : BinRel N.lt := + {| TR := Z.lt ; TRInj := N2Z.inj_lt |}. +Add BinRel Op_N_lt. + +Instance Op_N_gt : BinRel N.gt := + {| TR := Z.gt ; TRInj := N2Z.inj_gt |}. +Add BinRel Op_N_gt. + +Instance Op_N_le : BinRel N.le := + {| TR := Z.le ; TRInj := N2Z.inj_le |}. +Add BinRel Op_N_le. + +Instance Op_eq_N : BinRel (@eq N) := + {| TR := @eq Z ; TRInj := fun x y : N => iff_sym (N2Z.inj_iff x y) |}. +Add BinRel Op_eq_N. + +(* zify_N_op *) +Instance Op_N_of_nat : UnOp N.of_nat := + { TUOp := fun x => x ; TUOpInj := nat_N_Z }. +Add UnOp Op_N_of_nat. + +Instance Op_Z_abs_N : UnOp Z.abs_N := + { TUOp := Z.abs ; TUOpInj := N2Z.inj_abs_N }. +Add UnOp Op_Z_abs_N. + +Instance Op_N_pos : UnOp N.pos := + { TUOp := fun x => x ; TUOpInj := ltac:(reflexivity)}. +Add UnOp Op_N_pos. + +Instance Op_N_add : BinOp N.add := + {| TBOp := Z.add ; TBOpInj := N2Z.inj_add |}. +Add BinOp Op_N_add. + +Instance Op_N_min : BinOp N.min := + {| TBOp := Z.min ; TBOpInj := N2Z.inj_min |}. +Add BinOp Op_N_min. + +Instance Op_N_max : BinOp N.max := + {| TBOp := Z.max ; TBOpInj := N2Z.inj_max |}. +Add BinOp Op_N_max. + +Instance Op_N_mul : BinOp N.mul := + {| TBOp := Z.mul ; TBOpInj := N2Z.inj_mul |}. +Add BinOp Op_N_mul. + +Instance Op_N_sub : BinOp N.sub := + {| TBOp := fun x y => Z.max 0 (x - y) ; TBOpInj := N2Z.inj_sub_max|}. +Add BinOp Op_N_sub. + +Instance Op_N_div : BinOp N.div := + {| TBOp := Z.div ; TBOpInj := N2Z.inj_div|}. +Add BinOp Op_N_div. + + + +Instance Op_N_mod : BinOp N.modulo := + {| TBOp := Z.rem ; TBOpInj := N2Z.inj_rem|}. +Add BinOp Op_N_mod. + +Instance Op_N_pred : UnOp N.pred := + { TUOp := fun x => Z.max 0 (x - 1) ; + TUOpInj := + ltac:(intros; rewrite N.pred_sub; apply N2Z.inj_sub_max) }. +Add UnOp Op_N_pred. + +Instance Op_N_succ : UnOp N.succ := + {| TUOp := fun x => x + 1 ; TUOpInj := N2Z.inj_succ |}. +Add UnOp Op_N_succ. + +(** Support for Z - injected to itself *) + +(* zify_Z_rel *) +Instance Op_Z_ge : BinRel Z.ge := + {| TR := Z.ge ; TRInj := fun x y => iff_refl (x>= y)|}. +Add BinRel Op_Z_ge. + +Instance Op_Z_lt : BinRel Z.lt := + {| TR := Z.lt ; TRInj := fun x y => iff_refl (x < y)|}. +Add BinRel Op_Z_lt. + +Instance Op_Z_gt : BinRel Z.gt := + {| TR := Z.gt ;TRInj := fun x y => iff_refl (x > y)|}. +Add BinRel Op_Z_gt. + +Instance Op_Z_le : BinRel Z.le := + {| TR := Z.le ;TRInj := fun x y => iff_refl (x <= y)|}. +Add BinRel Op_Z_le. + +Instance Op_eqZ : BinRel (@eq Z) := + { TR := @eq Z ; TRInj := fun x y => iff_refl (x = y) }. +Add BinRel Op_eqZ. + +Instance Op_Z_add : BinOp Z.add := + { TBOp := Z.add ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_add. + +Instance Op_Z_min : BinOp Z.min := + { TBOp := Z.min ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_min. + +Instance Op_Z_max : BinOp Z.max := + { TBOp := Z.max ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_max. + +Instance Op_Z_mul : BinOp Z.mul := + { TBOp := Z.mul ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_mul. + +Instance Op_Z_sub : BinOp Z.sub := + { TBOp := Z.sub ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_sub. + +Instance Op_Z_div : BinOp Z.div := + { TBOp := Z.div ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_div. + +Instance Op_Z_mod : BinOp Z.modulo := + { TBOp := Z.modulo ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_mod. + +Instance Op_Z_rem : BinOp Z.rem := + { TBOp := Z.rem ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_rem. + +Instance Op_Z_quot : BinOp Z.quot := + { TBOp := Z.quot ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_quot. + +Instance Op_Z_succ : UnOp Z.succ := + { TUOp := fun x => x + 1 ; TUOpInj := ltac:(reflexivity) }. +Add UnOp Op_Z_succ. + +Instance Op_Z_pred : UnOp Z.pred := + { TUOp := fun x => x - 1 ; TUOpInj := ltac:(reflexivity) }. +Add UnOp Op_Z_pred. + +Instance Op_Z_opp : UnOp Z.opp := + { TUOp := Z.opp ; TUOpInj := ltac:(reflexivity) }. +Add UnOp Op_Z_opp. + +Instance Op_Z_abs : UnOp Z.abs := + { TUOp := Z.abs ; TUOpInj := ltac:(reflexivity) }. +Add UnOp Op_Z_abs. + +Instance Op_Z_sgn : UnOp Z.sgn := + { TUOp := Z.sgn ; TUOpInj := ltac:(reflexivity) }. +Add UnOp Op_Z_sgn. + +Instance Op_Z_pow_pos : BinOp Z.pow_pos := + { TBOp := Z.pow ; TBOpInj := ltac:(reflexivity) }. +Add BinOp Op_Z_pow_pos. + +Lemma of_nat_to_nat_eq : forall x, Z.of_nat (Z.to_nat x) = Z.max 0 x. +Proof. + destruct x. + - reflexivity. + - rewrite Z2Nat.id. + reflexivity. + compute. congruence. + - reflexivity. +Qed. + +Instance Op_Z_to_nat : UnOp Z.to_nat := + { TUOp := fun x => Z.max 0 x ; TUOpInj := of_nat_to_nat_eq }. +Add UnOp Op_Z_to_nat. + +(** Specification of derived operators over Z *) + +Instance ZmaxSpec : BinOpSpec Z.max := + {| BPred := fun n m r => n < m /\ r = m \/ m <= n /\ r = n ; BSpec := Z.max_spec|}. +Add Spec ZmaxSpec. + +Instance ZminSpec : BinOpSpec Z.min := + {| BPred := fun n m r : Z => n < m /\ r = n \/ m <= n /\ r = m ; + BSpec := Z.min_spec|}. +Add Spec ZminSpec. + +Instance ZsgnSpec : UnOpSpec Z.sgn := + {| UPred := fun n r : Z => 0 < n /\ r = 1 \/ 0 = n /\ r = 0 \/ n < 0 /\ r = - (1) ; + USpec := Z.sgn_spec|}. +Add Spec ZsgnSpec. + +Instance ZabsSpec : UnOpSpec Z.abs := + {| UPred := fun n r: Z => 0 <= n /\ r = n \/ n < 0 /\ r = - n ; + USpec := Z.abs_spec|}. +Add Spec ZabsSpec. + +(** Saturate positivity constraints *) + +Instance SatProd : Saturate Z.mul := + {| + PArg1 := fun x => 0 <= x; + PArg2 := fun y => 0 <= y; + PRes := fun r => 0 <= r; + SatOk := Z.mul_nonneg_nonneg + |}. +Add Saturate SatProd. + +Instance SatProdPos : Saturate Z.mul := + {| + PArg1 := fun x => 0 < x; + PArg2 := fun y => 0 < y; + PRes := fun r => 0 < r; + SatOk := Z.mul_pos_pos + |}. +Add Saturate SatProdPos. diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 5cc2c2e061..ceb651abed 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -27,7 +27,7 @@ open Context open Tactypes (** - * Debug flag + * Debug flag *) let debug = false @@ -39,7 +39,7 @@ let max_depth = max_int (* Search limit for provers over Q R *) let lra_proof_depth = ref max_depth - + (* Search limit for provers over Z *) let lia_enum = ref true let lia_proof_depth = ref max_depth @@ -50,10 +50,8 @@ let get_lia_option () = let get_lra_option () = !lra_proof_depth - - let () = - + let int_opt l vref = { optdepr = false; @@ -63,7 +61,7 @@ let () = optwrite = (fun x -> vref := (match x with None -> max_depth | Some v -> v)) } in - let lia_enum_opt = + let lia_enum_opt = { optdepr = false; optname = "Lia Enum"; @@ -90,6 +88,7 @@ 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 @@ -97,7 +96,7 @@ let () = let () = declare_bool_option lia_enum_opt in () - + (** * Initialize a tag type to the Tag module declaration (see Mutils). *) @@ -167,8 +166,8 @@ struct let logic_dir = ["Coq";"Logic";"Decidable"] - let mic_modules = - [ + let mic_modules = + [ ["Coq";"Lists";"List"]; ["Coq"; "micromega";"ZMicromega"]; ["Coq"; "micromega";"Tauto"]; @@ -419,7 +418,7 @@ struct | _ -> raise ParseError (* Access the Micromega module *) - + (* parse/dump/print from numbers up to expressions and formulas *) let rec parse_nat sigma term = @@ -437,15 +436,15 @@ struct | Mc.S p -> EConstr.mkApp(Lazy.force coq_S,[| dump_nat p |]) let rec parse_positive sigma term = - let (i,c) = get_left_construct sigma term in + let (i,c) = get_left_construct sigma term in match i with - | 1 -> Mc.XI (parse_positive sigma c.(0)) - | 2 -> Mc.XO (parse_positive sigma c.(0)) - | 3 -> Mc.XH - | i -> raise ParseError + | 1 -> Mc.XI (parse_positive sigma c.(0)) + | 2 -> Mc.XO (parse_positive sigma c.(0)) + | 3 -> Mc.XH + | i -> raise ParseError let rec dump_positive x = - match x with + match x with | Mc.XH -> Lazy.force coq_xH | Mc.XO p -> EConstr.mkApp(Lazy.force coq_xO,[| dump_positive p |]) | Mc.XI p -> EConstr.mkApp(Lazy.force coq_xI,[| dump_positive p |]) @@ -453,14 +452,14 @@ struct let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) let dump_n x = - match x with + match x with | Mc.N0 -> Lazy.force coq_N0 | Mc.Npos p -> EConstr.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) (** [is_ground_term env sigma term] holds if the term [term] is an instance of the typeclass [DeclConstant.GT term] i.e. built from user-defined constants and functions. - NB: This mechanism is used to customise the reification process to decide + NB: This mechanism can be used to customise the reification process to decide what to consider as a constant (see [parse_constant]) *) @@ -468,10 +467,10 @@ struct match EConstr.kind evd t with | Const _ | Construct _ -> (* Restrict typeclass resolution to trivial cases *) begin - let typ = Retyping.get_type_of env evd t in - try - ignore (Typeclasses.resolve_one_typeclass env evd (EConstr.mkApp(Lazy.force coq_DeclaredConstant,[| typ;t|]))) ; true - with Not_found -> false + let typ = Retyping.get_type_of env evd t in + try + ignore (Typeclasses.resolve_one_typeclass env evd (EConstr.mkApp(Lazy.force coq_DeclaredConstant,[| typ;t|]))) ; true + with Not_found -> false end | _ -> false @@ -485,12 +484,12 @@ struct let parse_z sigma term = - let (i,c) = get_left_construct sigma term in + let (i,c) = get_left_construct sigma term in match i with - | 1 -> Mc.Z0 - | 2 -> Mc.Zpos (parse_positive sigma c.(0)) - | 3 -> Mc.Zneg (parse_positive sigma c.(0)) - | i -> raise ParseError + | 1 -> Mc.Z0 + | 2 -> Mc.Zpos (parse_positive sigma c.(0)) + | 3 -> Mc.Zneg (parse_positive sigma c.(0)) + | i -> raise ParseError let dump_z x = match x with @@ -512,7 +511,7 @@ struct | _ -> raise ParseError - let rec pp_Rcst o cst = + let rec pp_Rcst o cst = match cst with | Mc.C0 -> output_string o "C0" | Mc.C1 -> output_string o "C1" @@ -526,9 +525,9 @@ struct | Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t - let rec dump_Rcst cst = + let rec dump_Rcst cst = match cst with - | Mc.C0 -> Lazy.force coq_C0 + | Mc.C0 -> Lazy.force coq_C0 | Mc.C1 -> Lazy.force coq_C1 | Mc.CQ q -> EConstr.mkApp(Lazy.force coq_CQ, [| dump_q q |]) | Mc.CZ z -> EConstr.mkApp(Lazy.force coq_CZ, [| dump_z z |]) @@ -682,7 +681,7 @@ struct type gl = { env : Environ.env; sigma : Evd.evar_map } - let is_convertible gl t1 t2 = + let is_convertible gl t1 t2 = Reductionops.is_conv gl.env gl.sigma t1 t2 let parse_zop gl (op,args) = @@ -778,7 +777,7 @@ struct | e::l -> if EConstr.eq_constr evd e v then n - else _get_rank l (n+1) in + else _get_rank l (n+1) in _get_rank env.vars 1 let elements env = env.vars @@ -810,7 +809,7 @@ struct let parse_variable env term = let (env,n) = Env.compute_rank_add env term in - (Mc.PEX n , env) in + (Mc.PEX n , env) in let rec parse_expr env term = let combine env op (t1,t2) = @@ -826,12 +825,12 @@ struct match EConstr.kind gl.sigma t with | Const c -> ( match assoc_ops gl.sigma t ops_spec with - | Binop f -> combine env f (args.(0),args.(1)) + | Binop f -> combine env f (args.(0),args.(1)) | Opp -> let (expr,env) = parse_expr env args.(0) in (Mc.PEopp expr, env) | Power -> begin - try + try let (expr,env) = parse_expr env args.(0) in let power = (parse_exp expr args.(1)) in (power , env) @@ -844,9 +843,9 @@ struct then (Printf.printf "unknown op: %s\n" s; flush stdout;); let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) ) - | _ -> parse_variable env term + | _ -> parse_variable env term ) - | _ -> parse_variable env term in + | _ -> parse_variable env term in parse_expr env term let zop_spec = @@ -920,14 +919,18 @@ struct Therefore, there is a specific parser for constant over R *) - let rconst_assoc = - [ + let rconst_assoc = + [ coq_Rplus , (fun x y -> Mc.CPlus(x,y)) ; - coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ; - coq_Rmult , (fun x y -> Mc.CMult(x,y)) ; + coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ; + coq_Rmult , (fun x y -> Mc.CMult(x,y)) ; (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) ] + + + + let rconstant gl term = let sigma = gl.sigma in @@ -950,12 +953,12 @@ struct f a b with ParseError -> - match op with - | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> + match op with + | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> let arg = rconstant args.(0) in if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH} then raise ParseError (* This is a division by zero -- no semantics *) - else Mc.CInv(arg) + else Mc.CInv(arg) | op when EConstr.eq_constr sigma op (Lazy.force coq_Rpower) -> Mc.CPow(rconstant args.(0) , Mc.Inr (parse_more_constant nconstant gl args.(1))) | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> @@ -963,18 +966,19 @@ struct | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> Mc.CZ (parse_more_constant zconstant gl args.(0)) | _ -> raise ParseError - end + end | _ -> raise ParseError in rconstant term + let rconstant gl term = if debug then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env gl.env gl.sigma term ++ fnl ()); let res = rconstant gl term in - if debug then - (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; + if debug then + (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; res @@ -1034,20 +1038,26 @@ struct (** * This is the big generic function for formula parsers. *) - + + let is_prop env sigma term = + let sort = Retyping.get_sort_of env sigma term in + Sorts.is_prop sort + let parse_formula gl parse_atom env tg term = let sigma = gl.sigma in + let is_prop term = is_prop gl.env gl.sigma term in + let parse_atom env tg t = try let (at,env) = parse_atom env t gl in (Mc.A(at,(tg,t)), env,Tag.next tg) - with e when CErrors.noncritical e -> (Mc.X(t),env,tg) in + with ParseError -> + if is_prop t + then (Mc.X(t),env,tg) + else raise ParseError + in - let is_prop term = - let sort = Retyping.get_sort_of gl.env gl.sigma term in - Sorts.is_prop sort in - let rec xparse_formula env tg term = match EConstr.kind sigma term with | App(l,rst) -> @@ -1106,7 +1116,7 @@ struct doit (doit env f1) f2 | N f -> doit env f in - + doit (Env.empty gl) form) let var_env_of_formula form = @@ -1118,7 +1128,7 @@ struct ISet.union (vars_of_expr e1) (vars_of_expr e2) | Mc.PEopp e | Mc.PEpow(e,_)-> vars_of_expr e in - + let vars_of_atom {Mc.flhs ; Mc.fop; Mc.frhs} = ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in Mc.( @@ -1129,10 +1139,10 @@ struct | N f -> doit f in doit form) - - + + type 'cst dump_expr = (* 'cst is the type of the syntactic constants *) { interp_typ : EConstr.constr; @@ -1169,12 +1179,12 @@ let dump_qexpr = lazy dump_mul = Lazy.force coq_Qmult; dump_pow = Lazy.force coq_Qpower; dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table + dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table } -let rec dump_Rcst_as_R cst = +let rec dump_Rcst_as_R cst = match cst with - | Mc.C0 -> Lazy.force coq_R0 + | Mc.C0 -> Lazy.force coq_R0 | Mc.C1 -> Lazy.force coq_R1 | Mc.CQ q -> EConstr.mkApp(Lazy.force coq_IQR, [| dump_q q |]) | Mc.CZ z -> EConstr.mkApp(Lazy.force coq_IZR, [| dump_z z |]) @@ -1201,18 +1211,11 @@ let dump_rexpr = lazy dump_mul = Lazy.force coq_Rmult; dump_pow = Lazy.force coq_Rpower; dump_pow_arg = (fun n -> dump_nat (CamlToCoq.nat (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) rop_table + dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) rop_table } - - -(** [make_goal_of_formula depxr vars props form] where - - vars is an environment for the arithmetic variables occurring in form - - props is an environment for the propositions occurring in form - @return a goal where all the variables and propositions of the formula are quantified -*) let prodn n env b = let rec prodrec = function @@ -1222,17 +1225,29 @@ let prodn n env b = in prodrec (n,env,b) +(** [make_goal_of_formula depxr vars props form] where + - vars is an environment for the arithmetic variables occurring in form + - props is an environment for the propositions occurring in form + @return a goal where all the variables and propositions of the formula are quantified + +*) + let make_goal_of_formula gl dexpr form = let vars_idx = List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) - + let props = prop_env_of_formula gl form in - let vars_n = List.map (fun (_,i) -> (Names.Id.of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in - let props_n = List.mapi (fun i _ -> (Names.Id.of_string (Printf.sprintf "__p%i" (i+1))) , EConstr.mkProp) (Env.elements props) in + let fresh_var str i = Names.Id.of_string (str^(string_of_int i)) in + + let fresh_prop str i = + Names.Id.of_string (str^(string_of_int i)) in + + let vars_n = List.map (fun (_,i) -> fresh_var "__x" i, dexpr.interp_typ) vars_idx in + let props_n = List.mapi (fun i _ -> fresh_prop "__p" (i+1) , EConstr.mkProp) (Env.elements props) in let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in @@ -1251,16 +1266,16 @@ let make_goal_of_formula gl dexpr form = | Mc.PEpow(e,n) -> EConstr.mkApp(dexpr.dump_pow, [| dump_expr e; dexpr.dump_pow_arg n|]) in dump_expr e in - + let mkop op e1 e2 = try EConstr.mkApp(List.assoc op dexpr.dump_op, [| e1; e2|]) with Not_found -> EConstr.mkApp(Lazy.force coq_Eq,[|dexpr.interp_typ ; e1 ;e2|]) in - + let dump_cstr i { Mc.flhs ; Mc.fop ; Mc.frhs } = mkop fop (dump_expr i flhs) (dump_expr i frhs) in - + let rec xdump pi xi f = match f with | Mc.TT -> Lazy.force coq_True @@ -1271,16 +1286,16 @@ let make_goal_of_formula gl dexpr form = | Mc.N(x) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (Lazy.force coq_False) | Mc.A(x,_) -> dump_cstr xi x | Mc.X(t) -> let idx = Env.get_rank props t in - EConstr.mkRel (pi+idx) in - + EConstr.mkRel (pi+idx) in + let nb_vars = List.length vars_n in - let nb_props = List.length props_n in + let nb_props = List.length props_n in (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) - + let subst_prop p = let idx = Env.get_rank props p in - EConstr.mkVar (Names.Id.of_string (Printf.sprintf "__p%i" idx)) in + EConstr.mkVar (Names.Id.of_string (Printf.sprintf "__p%i" idx)) in let form' = Mc.mapX subst_prop form in @@ -1288,13 +1303,13 @@ let make_goal_of_formula gl dexpr form = (prodn nb_vars (List.map (fun (x,y) -> Name.Name x,y) vars_n) (xdump (List.length vars_n) 0 form)), List.rev props_n, List.rev var_name_pos,form') - + (** * Given a conclusion and a list of affectations, rebuild a term prefixed by * the appropriate letins. * TODO: reverse the list of bindings! *) - + let set l concl = let rec xset acc = function | [] -> acc @@ -1306,7 +1321,7 @@ let make_goal_of_formula gl dexpr form = xset concl l end (** - * MODULE END: M + * MODULE END: M *) open M @@ -1317,14 +1332,14 @@ let coq_Branch = let coq_Elt = lazy (gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Elt") -let coq_Empty = +let coq_Empty = lazy (gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") -let coq_VarMap = +let coq_VarMap = lazy (gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t") - + let rec dump_varmap typ m = match m with @@ -1337,9 +1352,9 @@ let rec dump_varmap typ m = let vm_of_list env = match env with | [] -> Mc.Empty - | (d,_)::_ -> + | (d,_)::_ -> List.fold_left (fun vm (c,i) -> - Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env + Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env let rec dump_proof_term = function | Micromega.DoneProof -> Lazy.force coq_doneProof @@ -1347,12 +1362,12 @@ let rec dump_proof_term = function EConstr.mkApp(Lazy.force coq_ratProof, [| dump_psatz coq_Z dump_z cone; dump_proof_term rst|]) | Micromega.CutProof(cone,prf) -> EConstr.mkApp(Lazy.force coq_cutProof, - [| dump_psatz coq_Z dump_z cone ; - dump_proof_term prf|]) + [| dump_psatz coq_Z dump_z cone ; + dump_proof_term prf|]) | Micromega.EnumProof(c1,c2,prfs) -> EConstr.mkApp (Lazy.force coq_enumProof, - [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; - dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) + [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; + dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) let rec size_of_psatz = function @@ -1369,8 +1384,8 @@ let rec size_of_pf = function | Micromega.CutProof(p,a) -> (size_of_pf a) + (size_of_psatz p) | Micromega.EnumProof(p1,p2,l) -> (size_of_psatz p1) + (size_of_psatz p2) + (List.fold_left (fun acc p -> size_of_pf p + acc) 0 l) -let dump_proof_term t = - if debug then Printf.printf "dump_proof_term %i\n" (size_of_pf t) ; +let dump_proof_term t = + if debug then Printf.printf "dump_proof_term %i\n" (size_of_pf t) ; dump_proof_term t @@ -1384,7 +1399,7 @@ let rec pp_proof_term o = function | Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst | Micromega.EnumProof(c1,c2,rst) -> Printf.fprintf o "EP[%a,%a,%a]" - (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 + (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 (pp_list "[" "]" pp_proof_term) rst let rec parse_hyps gl parse_arith env tg hyps = @@ -1392,10 +1407,14 @@ let rec parse_hyps gl parse_arith env tg hyps = | [] -> ([],env,tg) | (i,t)::l -> let (lhyps,env,tg) = parse_hyps gl parse_arith env tg l in - try - let (c,env,tg) = parse_formula gl parse_arith env tg t in - ((i,c)::lhyps, env,tg) - with e when CErrors.noncritical e -> (lhyps,env,tg) + if is_prop gl.env gl.sigma t + then + try + let (c,env,tg) = parse_formula gl parse_arith env tg t in + ((i,c)::lhyps, env,tg) + with ParseError -> (lhyps,env,tg) + else (lhyps,env,tg) + let parse_goal gl parse_arith (env:Env.t) hyps term = let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in @@ -1408,8 +1427,8 @@ let parse_goal gl parse_arith (env:Env.t) hyps term = type ('synt_c, 'prf) domain_spec = { typ : EConstr.constr; (* is the type of the interpretation domain - Z, Q, R*) coeff : EConstr.constr ; (* is the type of the syntactic coeffs - Z , Q , Rcst *) - dump_coeff : 'synt_c -> EConstr.constr ; - proof_typ : EConstr.constr ; + dump_coeff : 'synt_c -> EConstr.constr ; + proof_typ : EConstr.constr ; dump_proof : 'prf -> EConstr.constr } @@ -1465,7 +1484,7 @@ let pre_processZ mt f = Mc.bound_problem_fr tag_of_var mt f (** Naive topological sort of constr according to the subterm-ordering *) -(* An element is minimal x is minimal w.r.t y if +(* An element is minimal x is minimal w.r.t y if x <= y or (x and y are incomparable) *) (** @@ -1473,7 +1492,7 @@ let pre_processZ mt f = * witness. *) -let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic*) = +let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic*) = (* let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[|spec.coeff|])) in let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in @@ -1490,7 +1509,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* ("__wit", cert, cert_typ) ] (Tacmach.New.pf_concl gl)) - ] + ] end @@ -1511,7 +1530,7 @@ type ('option,'a,'prf,'model) prover = { } - + (** * Given a prover and a disjunction of atoms, find a proof of any of * the atoms. Returns an (optional) pair of a proof and a prover @@ -1545,7 +1564,13 @@ let witness_list prover l = | Prf w -> Prf (w::l) in xwitness_list l -let witness_list_tags = witness_list +let witness_list_tags p g = witness_list p g +(* let t1 = System.get_time () in + let res = witness_list p g in + let t2 = System.get_time () in + Feedback.msg_info Pp.(str "Witness generation "++int (List.length g) ++ str " "++System.fmt_time_difference t1 t2) ; + res + *) (** * Prune the proof object, according to the 'diff' between two cnf formulas. @@ -1593,6 +1618,7 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = if debug then begin Printf.printf "CNFRES\n"; flush stdout; + Printf.printf "CNFOLD %a\n" pp_cnf_tag cnf_ff; List.iter (fun (cl,(prf,prover)) -> let hyps_idx = prover.hyps prf in let hyps = selecti hyps_idx cl in @@ -1619,37 +1645,27 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = * variables. See the Tag module in mutils.ml for more. *) -let abstract_formula hyps f = - Mc.( - let rec xabs f = - match f with - | X c -> X c - | A(a,(t,term)) -> if TagSet.mem t hyps then A(a,(t,term)) else X(term) - | Cj(f1,f2) -> - (match xabs f1 , xabs f2 with - | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_and, [|a1;a2|])) - | f1 , f2 -> Cj(f1,f2) ) - | D(f1,f2) -> - (match xabs f1 , xabs f2 with - | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_or, [|a1;a2|])) - | f1 , f2 -> D(f1,f2) ) - | N(f) -> - (match xabs f with - | X a -> X (EConstr.mkApp(Lazy.force coq_not, [|a|])) - | f -> N f) - | I(f1,hyp,f2) -> - (match xabs f1 , hyp, xabs f2 with - | X a1 , Some _ , af2 -> af2 - | X a1 , None , X a2 -> X (EConstr.mkArrow a1 Sorts.Relevant a2) - | af1 , _ , af2 -> I(af1,hyp,af2) - ) - | FF -> FF - | TT -> TT - in xabs f) + + +let abstract_formula : TagSet.t -> 'a formula -> 'a formula = + fun hyps f -> + let to_constr = Mc.({ + mkTT = Lazy.force coq_True; + mkFF = Lazy.force coq_False; + mkA = (fun a (tg, t) -> t); + mkCj = (let coq_and = Lazy.force coq_and in + fun x y -> EConstr.mkApp(coq_and,[|x;y|])); + mkD = (let coq_or = Lazy.force coq_or in + fun x y -> EConstr.mkApp(coq_or,[|x;y|])); + mkI = (fun x y -> EConstr.mkArrow x Sorts.Relevant y); + mkN = (let coq_not = Lazy.force coq_not in + (fun x -> EConstr.mkApp(coq_not,[|x|]))) + }) in + Mc.abst_form to_constr (fun (t,_) -> TagSet.mem t hyps) true f (* [abstract_wrt_formula] is used in contexts whre f1 is already an abstraction of f2 *) -let rec abstract_wrt_formula f1 f2 = +let rec abstract_wrt_formula f1 f2 = Mc.( match f1 , f2 with | X c , _ -> X c @@ -1669,13 +1685,13 @@ let rec abstract_wrt_formula f1 f2 = exception CsdpNotFound - + (** * This is the core of Micromega: apply the prover, analyze the result and * prune unused fomulas, and finally modify the proof state. *) -let formula_hyps_concl hyps concl = +let formula_hyps_concl hyps concl = List.fold_right (fun (id,f) (cc,ids) -> match f with @@ -1684,6 +1700,14 @@ let formula_hyps_concl hyps concl = hyps (concl,[]) +(* let time str f x = + let t1 = System.get_time () in + let res = f x in + let t2 = System.get_time () in + Feedback.msg_info (Pp.str str ++ Pp.str " " ++ System.fmt_time_difference t1 t2) ; + res + *) + let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst formula) list) (polys2: 'cst formula) gl = (* Express the goal as one big implication *) @@ -1691,34 +1715,36 @@ let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst let mt = CamlToCoq.positive (max_tag ff) in (* Construction of cnf *) - let pre_ff = (pre_process mt ff) in + let pre_ff = pre_process mt (ff:'a formula) in let (cnf_ff,cnf_ff_tags) = cnf pre_ff in match witness_list_tags prover cnf_ff with | Model m -> Model m | Unknown -> Unknown | Prf res -> (*Printf.printf "\nList %i" (List.length `res); *) - let hyps = List.fold_left + let deps = List.fold_left (fun s (cl,(prf,p)) -> let tags = ISet.fold (fun i s -> let t = fst (snd (List.nth cl i)) in if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in - TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty (List.map fst cnf_ff_tags)) (List.combine cnf_ff res) in + TagSet.union s tags) (List.fold_left (fun s (i,_) -> TagSet.add i s) TagSet.empty cnf_ff_tags) (List.combine cnf_ff res) in - let ff' = abstract_formula hyps ff in + let ff' = abstract_formula deps ff in - let pre_ff' = pre_process mt ff' in - let cnf_ff',_ = cnf pre_ff' in + let pre_ff' = pre_process mt ff' in + let (cnf_ff',_) = cnf pre_ff' in if debug then begin output_string stdout "\n"; Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; + Printf.printf "CNF : %a\n" pp_cnf_tag cnf_ff ; flush stdout; Printf.printf "TFormAbs : %a\n" pp_formula ff' ; flush stdout; Printf.printf "TFormPre : %a\n" pp_formula pre_ff ; flush stdout; Printf.printf "TFormPreAbs : %a\n" pp_formula pre_ff' ; flush stdout; + Printf.printf "CNF : %a\n" pp_cnf_tag cnf_ff' ; flush stdout; end; (* Even if it does not work, this does not mean it is not provable @@ -1730,6 +1756,7 @@ let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst | None -> failwith "abstraction is wrong" | Some res -> () end ; *) + let res' = compact_proofs cnf_ff res cnf_ff' in let (ff',res',ids) = (ff',res', Mc.ids_of_formula ff') in @@ -1749,12 +1776,22 @@ let micromega_tauto pre_process cnf spec prover env (polys1: (Names.Id.t * 'cst (** * Parse the proof environment, and call micromega_tauto *) - let fresh_id avoid id gl = Tactics.fresh_id_in_env avoid id (Proofview.Goal.env gl) +let clear_all_no_check = + Proofview.Goal.enter begin fun gl -> + let concl = Tacmach.New.pf_concl gl in + let env = Environ.reset_with_named_context Environ.empty_named_context_val (Tacmach.New.pf_env gl) in + (Refine.refine ~typecheck:false begin fun sigma -> + Evarutil.new_evar env sigma ~principal:true concl + end) + end + + + let micromega_gen - parse_arith + parse_arith pre_process cnf spec dumpexpr prover tac = @@ -1771,52 +1808,48 @@ let micromega_gen if debug then Feedback.msg_debug (Pp.str "Env " ++ (Env.pp gl0 env)) ; - + match micromega_tauto pre_process cnf spec prover env hyps concl gl0 with | Unknown -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") | Model(m,e) -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") | Prf (ids,ff',res') -> let (arith_goal,props,vars,ff_arith) = make_goal_of_formula gl0 dumpexpr ff' in - let intro (id,_) = Tactics.introduction id in + let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in + (* let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in*) let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in - let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in + let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in - let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; + let tac_arith = Tacticals.New.tclTHENLIST [ clear_all_no_check ;intro_props ; intro_vars ; micromega_order_change spec res' (EConstr.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in let goal_props = List.rev (Env.elements (prop_env_of_formula gl0 ff')) in - let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in - - let arith_args = goal_props @ goal_vars in + let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in - let kill_arith = - Tacticals.New.tclTHEN - (Tactics.keep []) - ((*Tactics.tclABSTRACT None*) - (Tacticals.New.tclTHEN tac_arith tac)) in + let arith_args = goal_props @ goal_vars in - Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) - [ - kill_arith; - (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map EConstr.mkVar ids)); - Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args)) - ] ) - ] + let kill_arith = Tacticals.New.tclTHEN tac_arith tac in +(* +(*tclABSTRACT fails in certain corner cases.*) +Tacticals.New.tclTHEN + clear_all_no_check + (Abstract.tclABSTRACT ~opaque:false None (Tacticals.New.tclTHEN tac_arith tac)) in *) + + Tacticals.New.tclTHEN + (Tactics.assert_by (Names.Name goal_name) arith_goal + ((*Proofview.tclTIME (Some "kill_arith")*) kill_arith)) + ((*Proofview.tclTIME (Some "apply_arith") *) + (Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args@(List.map EConstr.mkVar ids))))) with - | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") | CsdpNotFound -> flush stdout ; - Tacticals.New.tclFAIL 0 (Pp.str + Tacticals.New.tclFAIL 0 (Pp.str (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" + ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) | x -> begin if debug then Tacticals.New.tclFAIL 0 (Pp.str (Printexc.get_backtrace ())) @@ -1824,13 +1857,13 @@ let micromega_gen end end -let micromega_order_changer cert env ff = +let micromega_order_changer cert env ff = (*let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) let coeff = Lazy.force coq_Rcst in let dump_coeff = dump_Rcst in let typ = Lazy.force coq_R in let cert_typ = (EConstr.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in - + let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[| coeff|])) in let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in let vm = dump_varmap (typ) (vm_of_list env) in @@ -1843,7 +1876,7 @@ let micromega_order_changer cert env ff = ("__ff", ff, EConstr.mkApp(Lazy.force coq_Formula, [|formula_typ |])); ("__varmap", vm, EConstr.mkApp (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); + [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); ("__wit", cert, cert_typ) ] (Tacmach.New.pf_concl gl))); @@ -1870,68 +1903,62 @@ let micromega_genr prover tac = let (hyps,concl,env) = parse_goal gl0 parse_arith (Env.empty gl0) hyps concl in let env = Env.elements env in let spec = Lazy.force spec in - + let hyps' = List.map (fun (n,f) -> (n, Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in let concl' = Mc.map_bformula (Micromega.map_Formula Micromega.q_of_Rcst) concl in - + match micromega_tauto (fun _ x -> x) Mc.cnfQ spec prover env hyps' concl' gl0 with | Unknown | Model _ -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") | Prf (ids,ff',res') -> - let (ff,ids) = formula_hyps_concl - (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in + let (ff,ids) = formula_hyps_concl + (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in + let ff' = abstract_wrt_formula ff' ff in let (arith_goal,props,vars,ff_arith) = make_goal_of_formula gl0 (Lazy.force dump_rexpr) ff' in - let intro (id,_) = Tactics.introduction id in + let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in - let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in - - let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; + let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in + + let tac_arith = Tacticals.New.tclTHENLIST [ clear_all_no_check ; intro_props ; intro_vars ; micromega_order_changer res' env' ff_arith ] in let goal_props = List.rev (Env.elements (prop_env_of_formula gl0 ff')) in - let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in - + let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in + let arith_args = goal_props @ goal_vars in - let kill_arith = - Tacticals.New.tclTHEN + let kill_arith = Tacticals.New.tclTHEN tac_arith tac in + (* Tacticals.New.tclTHEN (Tactics.keep []) - ((*Tactics.tclABSTRACT None*) - (Tacticals.New.tclTHEN tac_arith tac)) in + (Tactics.tclABSTRACT None*) Tacticals.New.tclTHENS (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) [ kill_arith; (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map EConstr.mkVar ids)); - Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args)) + [(Tactics.generalize (List.map EConstr.mkVar ids)); + (Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args))) ] ) ] with - | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") | CsdpNotFound -> flush stdout ; - Tacticals.New.tclFAIL 0 (Pp.str + Tacticals.New.tclFAIL 0 (Pp.str (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" + ^ "the use of a specialized external tool called csdp. \n\n" ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) end - - -let micromega_genr prover = (micromega_genr prover) - - let lift_ratproof prover l = match prover l with | Unknown | Model _ -> Unknown @@ -1966,7 +1993,7 @@ let csdp_cache = ".csdp.cache" *) let require_csdp = - if System.is_in_system_path "csdp" + if System.is_in_system_path "csdp" then lazy () else lazy (raise CsdpNotFound) @@ -2028,9 +2055,9 @@ let xhyps_of_cone base acc prf = match e with | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> acc | Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in - if n >= base - then ISet.add (n-base) acc - else acc + if n >= base + then ISet.add (n-base) acc + else acc | Mc.PsatzMulC(_,c) -> xtract c acc | Mc.PsatzAdd(e1,e2) | Mc.PsatzMulE(e1,e2) -> xtract e1 (xtract e2 acc) in @@ -2059,8 +2086,8 @@ let hyps_of_pt pt = | Mc.RatProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) | Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) | Mc.EnumProof(c1,c2,l) -> - let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in - List.fold_left (fun s x -> xhyps (base + 1) x s) s l in + let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in + List.fold_left (fun s x -> xhyps (base + 1) x s) s l in xhyps 0 pt ISet.empty @@ -2075,10 +2102,10 @@ let compact_pt pt f = | Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) | Mc.CutProof(c,pt) -> Mc.CutProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) | Mc.EnumProof(c1,c2,l) -> Mc.EnumProof(compact_cone c1 (translate (ofset)), compact_cone c2 (translate (ofset)), - Mc.map (fun x -> compact_pt (ofset+1) x) l) in + Mc.map (fun x -> compact_pt (ofset+1) x) l) in compact_pt 0 pt -(** +(** * Definition of provers. * Instantiates the type ('a,'prf) prover defined above. *) @@ -2099,15 +2126,15 @@ module CacheQ = PHashtable(struct let hash = Hashtbl.hash end) -let memo_zlinear_prover = CacheZ.memo ".lia.cache" (fun ((_,ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s) +let memo_zlinear_prover = CacheZ.memo ".lia.cache" (fun ((_,ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s) let memo_nlia = CacheZ.memo ".nia.cache" (fun ((_,ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s) let memo_nra = CacheQ.memo ".nra.cache" (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s) - + let linear_prover_Q = { name = "linear prover"; - get_option = get_lra_option ; + get_option = get_lra_option ; prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o ) l) ; hyps = hyps_of_cone ; compact = compact_cone ; @@ -2118,7 +2145,7 @@ let linear_prover_Q = { let linear_prover_R = { name = "linear prover"; - get_option = get_lra_option ; + get_option = get_lra_option ; prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o ) l) ; hyps = hyps_of_cone ; compact = compact_cone ; @@ -2186,11 +2213,26 @@ let nlinear_Z = { pp_f = fun o x -> pp_pol pp_z o (fst x) } -(** +(** * Functions instantiating micromega_gen with the appropriate theories and * solvers *) +let exfalso_if_concl_not_Prop = + Proofview.Goal.enter begin fun gl -> + Tacmach.New.( + if is_prop (pf_env gl) (project gl) (pf_concl gl) + then Tacticals.New.tclIDTAC + else Tactics.elim_type (Lazy.force coq_False) + ) + end + +let micromega_gen parse_arith pre_process cnf spec dumpexpr prover tac = + Tacticals.New.tclTHEN exfalso_if_concl_not_Prop (micromega_gen parse_arith pre_process cnf spec dumpexpr prover tac) + +let micromega_genr prover tac = + Tacticals.New.tclTHEN exfalso_if_concl_not_Prop (micromega_genr prover tac) + let lra_Q = micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr linear_prover_Q @@ -2232,26 +2274,13 @@ let xnlia = micromega_gen parse_zarith (fun _ x -> x) Mc.cnfZ zz_domain_spec dump_zexpr nlinear_Z -let nra = +let nra = micromega_genr nlinear_prover_R let nqa = micromega_gen parse_qarith (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr nlinear_prover_R -(** Let expose [is_ground_tac] *) - -let is_ground_tac t = - Proofview.Goal.enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let env = Tacmach.New.pf_env gl in - if is_ground_term env sigma t - then Tacticals.New.tclIDTAC - else Tacticals.New.tclFAIL 0 (Pp.str "Not ground") - end - - - (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/coq_micromega.mli b/plugins/micromega/coq_micromega.mli index 7567e7c322..844ff5b1a6 100644 --- a/plugins/micromega/coq_micromega.mli +++ b/plugins/micromega/coq_micromega.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val is_ground_tac : EConstr.constr -> unit Proofview.tactic +(*val is_ground_tac : EConstr.constr -> unit Proofview.tactic*) val psatz_Z : int -> unit Proofview.tactic -> unit Proofview.tactic val psatz_Q : int -> unit Proofview.tactic -> unit Proofview.tactic val psatz_R : int -> unit Proofview.tactic -> unit Proofview.tactic diff --git a/plugins/micromega/g_micromega.mlg b/plugins/micromega/g_micromega.mlg index ffc803af44..bcf546f059 100644 --- a/plugins/micromega/g_micromega.mlg +++ b/plugins/micromega/g_micromega.mlg @@ -22,6 +22,8 @@ open Ltac_plugin open Stdarg open Tacarg + + } DECLARE PLUGIN "micromega_plugin" @@ -30,11 +32,6 @@ TACTIC EXTEND RED | [ "myred" ] -> { Tactics.red_in_concl } END -TACTIC EXTEND ISGROUND -| [ "is_ground" constr(t) ] -> { Coq_micromega.is_ground_tac t } -END - - TACTIC EXTEND PsatzZ | [ "psatz_Z" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Z i (Tacinterp.tactic_of_value ist t)) diff --git a/plugins/micromega/g_zify.mlg b/plugins/micromega/g_zify.mlg new file mode 100644 index 0000000000..424a7d7c54 --- /dev/null +++ b/plugins/micromega/g_zify.mlg @@ -0,0 +1,52 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +{ + +open Ltac_plugin +open Stdarg +open Tacarg + + +} + +DECLARE PLUGIN "zify_plugin" + +VERNAC COMMAND EXTEND DECLAREINJECTION CLASSIFIED AS SIDEFF +| ["Add" "InjTyp" constr(t) ] -> { Zify.InjTable.register t } +| ["Add" "BinOp" constr(t) ] -> { Zify.BinOp.register t } +| ["Add" "UnOp" constr(t) ] -> { Zify.UnOp.register t } +| ["Add" "CstOp" constr(t) ] -> { Zify.CstOp.register t } +| ["Add" "BinRel" constr(t) ] -> { Zify.BinRel.register t } +| ["Add" "PropOp" constr(t) ] -> { Zify.PropOp.register t } +| ["Add" "PropUOp" constr(t) ] -> { Zify.PropOp.register t } +| ["Add" "Spec" constr(t) ] -> { Zify.Spec.register t } +| ["Add" "BinOpSpec" constr(t) ] -> { Zify.Spec.register t } +| ["Add" "UnOpSpec" constr(t) ] -> { Zify.Spec.register t } +| ["Add" "Saturate" constr(t) ] -> { Zify.Saturate.register t } +END + +TACTIC EXTEND ITER +| [ "iter_specs" tactic(t)] -> { Zify.iter_specs t } +END + +TACTIC EXTEND TRANS +| [ "zify_tac" ] -> { Zify.zify_tac } +| [ "saturate" ] -> { Zify.saturate } +END + +VERNAC COMMAND EXTEND ZifyPrint CLASSIFIED AS SIDEFF +|[ "Show" "Zify" "InjTyp" ] -> { Zify.InjTable.print () } +|[ "Show" "Zify" "BinOp" ] -> { Zify.BinOp.print () } +|[ "Show" "Zify" "UnOp" ] -> { Zify.UnOp.print () } +|[ "Show" "Zify" "CstOp"] -> { Zify.CstOp.print () } +|[ "Show" "Zify" "BinRel"] -> { Zify.BinRel.print () } +|[ "Show" "Zify" "Spec"] -> { Zify.Spec.print () } +END diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index a64a5a84b3..f508b3dc56 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -67,12 +67,26 @@ let rec nth n0 l default = | [] -> default | _::t0 -> nth m t0 default) +(** val rev_append : 'a1 list -> 'a1 list -> 'a1 list **) + +let rec rev_append l l' = + match l with + | [] -> l' + | a::l0 -> rev_append l0 (a::l') + (** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) let rec map f = function | [] -> [] | a::t0 -> (f a)::(map f t0) +(** val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 **) + +let rec fold_left f l a0 = + match l with + | [] -> a0 + | b::t0 -> fold_left f t0 (f a0 b) + (** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) let rec fold_right f a0 = function @@ -556,6 +570,15 @@ let zeq_bool x y = | Eq -> true | _ -> false +type 'c pExpr = +| PEc of 'c +| PEX of positive +| PEadd of 'c pExpr * 'c pExpr +| PEsub of 'c pExpr * 'c pExpr +| PEmul of 'c pExpr * 'c pExpr +| PEopp of 'c pExpr +| PEpow of 'c pExpr * n + type 'c pol = | Pc of 'c | Pinj of positive * 'c pol @@ -868,15 +891,6 @@ let rec psquare cO cI cadd cmul ceqb = function let p3 = psquare cO cI cadd cmul ceqb p2 in mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb p3 i (p0 cO)) twoPQ) i q2 -type 'c pExpr = -| PEc of 'c -| PEX of positive -| PEadd of 'c pExpr * 'c pExpr -| PEsub of 'c pExpr * 'c pExpr -| PEmul of 'c pExpr * 'c pExpr -| PEopp of 'c pExpr -| PEpow of 'c pExpr * n - (** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **) let mk_X cO cI j = @@ -1061,15 +1075,24 @@ let rec or_clause unsat deduce cl1 cl2 = | Some cl' -> or_clause unsat deduce cl cl' | None -> None) -(** val or_clause_cnf : +(** val xor_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) -let or_clause_cnf unsat deduce t0 f = - fold_right (fun e acc -> +let xor_clause_cnf unsat deduce t0 f = + fold_left (fun acc e -> match or_clause unsat deduce t0 e with | Some cl -> cl::acc - | None -> acc) [] f + | None -> acc) f [] + +(** val or_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, + 'a2) cnf -> ('a1, 'a2) cnf **) + +let or_clause_cnf unsat deduce t0 f = + match t0 with + | [] -> f + | _::_ -> xor_clause_cnf unsat deduce t0 f (** val or_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, @@ -1079,45 +1102,78 @@ let rec or_cnf unsat deduce f f' = match f with | [] -> cnf_tt | e::rst -> - app (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') + rev_append (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') (** val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) let and_cnf = - app + rev_append type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula +(** val is_cnf_tt : ('a1, 'a2) cnf -> bool **) + +let is_cnf_tt = function +| [] -> true +| _::_ -> false + +(** val is_cnf_ff : ('a1, 'a2) cnf -> bool **) + +let is_cnf_ff = function +| [] -> false +| c0::l -> + (match c0 with + | [] -> (match l with + | [] -> true + | _::_ -> false) + | _::_ -> false) + +(** val and_cnf_opt : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf **) + +let and_cnf_opt f1 f2 = + if if is_cnf_ff f1 then true else is_cnf_ff f2 + then cnf_ff + else and_cnf f1 f2 + +(** val or_cnf_opt : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, + 'a2) cnf -> ('a1, 'a2) cnf **) + +let or_cnf_opt unsat deduce f1 f2 = + if if is_cnf_tt f1 then true else is_cnf_tt f2 + then cnf_tt + else if is_cnf_ff f2 then f1 else or_cnf unsat deduce f1 f2 + (** val xcnf : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf **) -let rec xcnf unsat deduce normalise0 negate0 pol0 = function +let rec xcnf unsat deduce normalise1 negate0 pol0 = function | TT -> if pol0 then cnf_tt else cnf_ff | FF -> if pol0 then cnf_ff else cnf_tt | X _ -> cnf_ff -| A (x, t0) -> if pol0 then normalise0 x t0 else negate0 x t0 +| A (x, t0) -> if pol0 then normalise1 x t0 else negate0 x t0 | Cj (e1, e2) -> if pol0 - then and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) - else or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) + then and_cnf_opt (xcnf unsat deduce normalise1 negate0 pol0 e1) + (xcnf unsat deduce normalise1 negate0 pol0 e2) + else or_cnf_opt unsat deduce (xcnf unsat deduce normalise1 negate0 pol0 e1) + (xcnf unsat deduce normalise1 negate0 pol0 e2) | D (e1, e2) -> if pol0 - then or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) - else and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) -| N e -> xcnf unsat deduce normalise0 negate0 (negb pol0) e + then or_cnf_opt unsat deduce (xcnf unsat deduce normalise1 negate0 pol0 e1) + (xcnf unsat deduce normalise1 negate0 pol0 e2) + else and_cnf_opt (xcnf unsat deduce normalise1 negate0 pol0 e1) + (xcnf unsat deduce normalise1 negate0 pol0 e2) +| N e -> xcnf unsat deduce normalise1 negate0 (negb pol0) e | I (e1, _, e2) -> if pol0 - then or_cnf unsat deduce - (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) - else and_cnf (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) - (xcnf unsat deduce normalise0 negate0 pol0 e2) + then or_cnf_opt unsat deduce + (xcnf unsat deduce normalise1 negate0 (negb pol0) e1) + (xcnf unsat deduce normalise1 negate0 pol0 e2) + else and_cnf_opt (xcnf unsat deduce normalise1 negate0 (negb pol0) e1) + (xcnf unsat deduce normalise1 negate0 pol0 e2) (** val radd_term : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) @@ -1153,19 +1209,28 @@ let rec ror_clause unsat deduce cl1 cl2 = | Inl cl' -> ror_clause unsat deduce cl cl' | Inr l -> Inr l) -(** val ror_clause_cnf : +(** val xror_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list -> ('a1, 'a2) clause list * 'a2 list **) -let ror_clause_cnf unsat deduce t0 f = - fold_right (fun e pat -> +let xror_clause_cnf unsat deduce t0 f = + fold_left (fun pat e -> let acc,tg = pat in (match ror_clause unsat deduce t0 e with | Inl cl -> (cl::acc),tg - | Inr l -> acc,(app tg l))) ([],[]) f + | Inr l -> acc,(rev_append tg l))) f ([],[]) + +(** val ror_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, + 'a2) clause list -> ('a1, 'a2) clause list * 'a2 list **) + +let ror_clause_cnf unsat deduce t0 f = + match t0 with + | [] -> f,[] + | _::_ -> xror_clause_cnf unsat deduce t0 f (** val ror_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list list -> + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause list -> ('a1, 'a2) clause list -> ('a1, 'a2) cnf * 'a2 list **) let rec ror_cnf unsat deduce f f' = @@ -1174,37 +1239,159 @@ let rec ror_cnf unsat deduce f f' = | e::rst -> let rst_f',t0 = ror_cnf unsat deduce rst f' in let e_f',t' = ror_clause_cnf unsat deduce e f' in - (app rst_f' e_f'),(app t0 t') + (rev_append rst_f' e_f'),(rev_append t0 t') + +(** val ror_cnf_opt : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, + 'a2) cnf -> ('a1, 'a2) cnf * 'a2 list **) + +let ror_cnf_opt unsat deduce f1 f2 = + if is_cnf_tt f1 + then cnf_tt,[] + else if is_cnf_tt f2 + then cnf_tt,[] + else if is_cnf_ff f2 then f1,[] else ror_cnf unsat deduce f1 f2 + +(** val ratom : ('a1, 'a2) cnf -> 'a2 -> ('a1, 'a2) cnf * 'a2 list **) + +let ratom c a = + if if is_cnf_ff c then true else is_cnf_tt c then c,(a::[]) else c,[] (** val rxcnf : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list **) -let rec rxcnf unsat deduce normalise0 negate0 polarity = function +let rec rxcnf unsat deduce normalise1 negate0 polarity = function | TT -> if polarity then cnf_tt,[] else cnf_ff,[] | FF -> if polarity then cnf_ff,[] else cnf_tt,[] | X _ -> cnf_ff,[] -| A (x, t0) -> (if polarity then normalise0 x t0 else negate0 x t0),[] +| A (x, t0) -> ratom (if polarity then normalise1 x t0 else negate0 x t0) t0 | Cj (e1, e2) -> - let e3,t1 = rxcnf unsat deduce normalise0 negate0 polarity e1 in - let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + let e3,t1 = rxcnf unsat deduce normalise1 negate0 polarity e1 in + let e4,t2 = rxcnf unsat deduce normalise1 negate0 polarity e2 in if polarity - then (app e3 e4),(app t1 t2) - else let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) + then (and_cnf_opt e3 e4),(rev_append t1 t2) + else let f',t' = ror_cnf_opt unsat deduce e3 e4 in + f',(rev_append t1 (rev_append t2 t')) | D (e1, e2) -> - let e3,t1 = rxcnf unsat deduce normalise0 negate0 polarity e1 in - let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + let e3,t1 = rxcnf unsat deduce normalise1 negate0 polarity e1 in + let e4,t2 = rxcnf unsat deduce normalise1 negate0 polarity e2 in if polarity - then let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) - else (app e3 e4),(app t1 t2) -| N e -> rxcnf unsat deduce normalise0 negate0 (negb polarity) e + then let f',t' = ror_cnf_opt unsat deduce e3 e4 in + f',(rev_append t1 (rev_append t2 t')) + else (and_cnf_opt e3 e4),(rev_append t1 t2) +| N e -> rxcnf unsat deduce normalise1 negate0 (negb polarity) e | I (e1, _, e2) -> - let e3,t1 = rxcnf unsat deduce normalise0 negate0 (negb polarity) e1 in - let e4,t2 = rxcnf unsat deduce normalise0 negate0 polarity e2 in + let e3,t1 = rxcnf unsat deduce normalise1 negate0 (negb polarity) e1 in if polarity - then let f',t' = ror_cnf unsat deduce e3 e4 in f',(app t1 (app t2 t')) - else (and_cnf e3 e4),(app t1 t2) + then if is_cnf_ff e3 + then rxcnf unsat deduce normalise1 negate0 polarity e2 + else let e4,t2 = rxcnf unsat deduce normalise1 negate0 polarity e2 in + let f',t' = ror_cnf_opt unsat deduce e3 e4 in + f',(rev_append t1 (rev_append t2 t')) + else let e4,t2 = rxcnf unsat deduce normalise1 negate0 polarity e2 in + (and_cnf_opt e3 e4),(rev_append t1 t2) + +type ('term, 'annot, 'tX) to_constrT = { mkTT : 'tX; mkFF : 'tX; + mkA : ('term -> 'annot -> 'tX); + mkCj : ('tX -> 'tX -> 'tX); + mkD : ('tX -> 'tX -> 'tX); + mkI : ('tX -> 'tX -> 'tX); + mkN : ('tX -> 'tX) } + +(** val aformula : + ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 **) + +let rec aformula to_constr = function +| TT -> to_constr.mkTT +| FF -> to_constr.mkFF +| X p -> p +| A (x, t0) -> to_constr.mkA x t0 +| Cj (f1, f2) -> + to_constr.mkCj (aformula to_constr f1) (aformula to_constr f2) +| D (f1, f2) -> to_constr.mkD (aformula to_constr f1) (aformula to_constr f2) +| N f0 -> to_constr.mkN (aformula to_constr f0) +| I (f1, _, f2) -> + to_constr.mkI (aformula to_constr f1) (aformula to_constr f2) + +(** val is_X : ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 option **) + +let is_X = function +| X p -> Some p +| _ -> None + +(** val abs_and : + ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula -> (('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> ('a1, 'a3, 'a2, 'a4) + gFormula **) + +let abs_and to_constr f1 f2 c = + match is_X f1 with + | Some _ -> X (aformula to_constr (c f1 f2)) + | None -> + (match is_X f2 with + | Some _ -> X (aformula to_constr (c f1 f2)) + | None -> c f1 f2) + +(** val abs_or : + ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula -> (('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> ('a1, 'a3, 'a2, 'a4) + gFormula **) + +let abs_or to_constr f1 f2 c = + match is_X f1 with + | Some _ -> + (match is_X f2 with + | Some _ -> X (aformula to_constr (c f1 f2)) + | None -> c f1 f2) + | None -> c f1 f2 + +(** val mk_arrow : + 'a4 option -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula **) + +let mk_arrow o f1 f2 = + match o with + | Some _ -> (match is_X f1 with + | Some _ -> f2 + | None -> I (f1, o, f2)) + | None -> I (f1, None, f2) + +(** val abst_form : + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> bool -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a3, 'a2, 'a4) gFormula **) + +let rec abst_form to_constr needA pol0 = function +| TT -> if pol0 then TT else X to_constr.mkTT +| FF -> if pol0 then X to_constr.mkFF else FF +| X p -> X p +| A (x, t0) -> if needA t0 then A (x, t0) else X (to_constr.mkA x t0) +| Cj (f1, f2) -> + let f3 = abst_form to_constr needA pol0 f1 in + let f4 = abst_form to_constr needA pol0 f2 in + if pol0 + then abs_and to_constr f3 f4 (fun x x0 -> Cj (x, x0)) + else abs_or to_constr f3 f4 (fun x x0 -> Cj (x, x0)) +| D (f1, f2) -> + let f3 = abst_form to_constr needA pol0 f1 in + let f4 = abst_form to_constr needA pol0 f2 in + if pol0 + then abs_or to_constr f3 f4 (fun x x0 -> D (x, x0)) + else abs_and to_constr f3 f4 (fun x x0 -> D (x, x0)) +| N f0 -> + let f1 = abst_form to_constr needA (negb pol0) f0 in + (match is_X f1 with + | Some a -> X (to_constr.mkN a) + | None -> N f1) +| I (f1, o, f2) -> + let f3 = abst_form to_constr needA (negb pol0) f1 in + let f4 = abst_form to_constr needA pol0 f2 in + if pol0 + then abs_or to_constr f3 f4 (mk_arrow o) + else abs_and to_constr f3 f4 (mk_arrow o) (** val cnf_checker : (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool **) @@ -1222,8 +1409,8 @@ let rec cnf_checker checker f l = cnf) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, 'a3, unit0) gFormula -> 'a4 list -> bool **) -let tauto_checker unsat deduce normalise0 negate0 checker f w = - cnf_checker checker (xcnf unsat deduce normalise0 negate0 true f) w +let tauto_checker unsat deduce normalise1 negate0 checker f w = + cnf_checker checker (xcnf unsat deduce normalise1 negate0 true f) w (** val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) @@ -1413,62 +1600,76 @@ let psub0 = let padd0 = padd -(** val xnormalise : +(** val popp0 : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) + +let popp0 = + popp + +(** val normalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula list **) + nFormula **) -let xnormalise cO cI cplus ctimes cminus copp ceqb t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in +let normalise cO cI cplus ctimes cminus copp ceqb f = + let { flhs = lhs; fop = op; frhs = rhs } = f in let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in + (match op with + | OpEq -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal + | OpNEq -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonEqual + | OpLe -> (psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict + | OpGe -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict + | OpLt -> (psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict + | OpGt -> (psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict) + +(** val xnormalise : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list **) + +let xnormalise copp = function +| e,o -> (match o with - | OpEq -> - ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus - cminus copp - ceqb rhs0 lhs0),Strict)::[]) - | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[] - | OpLe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[] - | OpGe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[] - | OpLt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict)::[] - | OpGt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[]) + | Equal -> (e,Strict)::(((popp0 copp e),Strict)::[]) + | NonEqual -> (e,Equal)::[] + | Strict -> ((popp0 copp e),NonStrict)::[] + | NonStrict -> ((popp0 copp e),Strict)::[]) -(** val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> - ('a1 nFormula, 'a2) cnf **) +(** val xnegate : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list **) + +let xnegate copp = function +| e,o -> + (match o with + | NonEqual -> (e,Strict)::(((popp0 copp e),Strict)::[]) + | x -> (e,x)::[]) + +(** val cnf_of_list : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list + -> 'a2 -> ('a1 nFormula, 'a2) cnf **) -let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 tg = - map (fun x -> (x,tg)::[]) - (xnormalise cO cI cplus ctimes cminus copp ceqb t0) +let cnf_of_list cO ceqb cleb l tg = + fold_right (fun x acc -> + if check_inconsistent cO ceqb cleb x then acc else ((x,tg)::[])::acc) + cnf_tt l -(** val xnegate : +(** val cnf_normalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula list **) + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) + -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf **) -let xnegate cO cI cplus ctimes cminus copp ceqb t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in - let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in - (match o with - | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[] - | OpNEq -> - ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus - cminus copp - ceqb rhs0 lhs0),Strict)::[]) - | OpLe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[] - | OpGe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict)::[] - | OpLt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[] - | OpGt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[]) +let cnf_normalise cO cI cplus ctimes cminus copp ceqb cleb t0 tg = + let f = normalise cO cI cplus ctimes cminus copp ceqb t0 in + if check_inconsistent cO ceqb cleb f + then cnf_ff + else cnf_of_list cO ceqb cleb (xnormalise copp f) tg (** val cnf_negate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> - ('a1 nFormula, 'a2) cnf **) + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) + -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf **) -let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 tg = - map (fun x -> (x,tg)::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t0) +let cnf_negate cO cI cplus ctimes cminus copp ceqb cleb t0 tg = + let f = normalise cO cI cplus ctimes cminus copp ceqb t0 in + if check_inconsistent cO ceqb cleb f + then cnf_tt + else cnf_of_list cO ceqb cleb (xnegate copp f) tg (** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **) @@ -1568,14 +1769,6 @@ module PositiveSet = type q = { qnum : z; qden : positive } -(** val qnum : q -> z **) - -let qnum x = x.qnum - -(** val qden : q -> positive **) - -let qden x = x.qden - (** val qeq_bool : q -> q -> bool **) let qeq_bool x y = @@ -1704,67 +1897,75 @@ let padd1 = let normZ = norm Z0 (Zpos XH) Z.add Z.mul Z.sub Z.opp zeq_bool -(** val xnormalise0 : z formula -> z nFormula list **) +(** val zunsat : z nFormula -> bool **) -let xnormalise0 t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = normZ lhs in - let rhs0 = normZ rhs in - (match o with - | OpEq -> - ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 - (padd1 lhs0 - (Pc (Zpos - XH)))),NonStrict)::[]) - | OpNEq -> ((psub1 lhs0 rhs0),Equal)::[] - | OpLe -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[] - | OpGe -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] - | OpLt -> ((psub1 lhs0 rhs0),NonStrict)::[] - | OpGt -> ((psub1 rhs0 lhs0),NonStrict)::[]) +let zunsat = + check_inconsistent Z0 zeq_bool Z.leb -(** val normalise : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) +(** val zdeduce : z nFormula -> z nFormula -> z nFormula option **) -let normalise t0 tg = - map (fun x -> (x,tg)::[]) (xnormalise0 t0) +let zdeduce = + nformula_plus_nformula Z0 Z.add zeq_bool -(** val xnegate0 : z formula -> z nFormula list **) +(** val xnnormalise : z formula -> z nFormula **) -let xnegate0 t0 = +let xnnormalise t0 = let { flhs = lhs; fop = o; frhs = rhs } = t0 in let lhs0 = normZ lhs in let rhs0 = normZ rhs in (match o with - | OpEq -> ((psub1 lhs0 rhs0),Equal)::[] - | OpNEq -> - ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 - (padd1 lhs0 - (Pc (Zpos - XH)))),NonStrict)::[]) - | OpLe -> ((psub1 rhs0 lhs0),NonStrict)::[] - | OpGe -> ((psub1 lhs0 rhs0),NonStrict)::[] - | OpLt -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] - | OpGt -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[]) + | OpEq -> (psub1 rhs0 lhs0),Equal + | OpNEq -> (psub1 rhs0 lhs0),NonEqual + | OpLe -> (psub1 rhs0 lhs0),NonStrict + | OpGe -> (psub1 lhs0 rhs0),NonStrict + | OpLt -> (psub1 rhs0 lhs0),Strict + | OpGt -> (psub1 lhs0 rhs0),Strict) -(** val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) +(** val xnormalise0 : z nFormula -> z nFormula list **) -let negate t0 tg = - map (fun x -> (x,tg)::[]) (xnegate0 t0) +let xnormalise0 = function +| e,o -> + (match o with + | Equal -> + ((psub1 e (Pc (Zpos XH))),NonStrict)::(((psub1 (Pc (Zneg XH)) e),NonStrict)::[]) + | NonEqual -> (e,Equal)::[] + | Strict -> ((psub1 (Pc Z0) e),NonStrict)::[] + | NonStrict -> ((psub1 (Pc (Zneg XH)) e),NonStrict)::[]) -(** val zunsat : z nFormula -> bool **) +(** val cnf_of_list0 : + 'a1 -> z nFormula list -> (z nFormula * 'a1) list list **) -let zunsat = - check_inconsistent Z0 zeq_bool Z.leb +let cnf_of_list0 tg l = + fold_right (fun x acc -> if zunsat x then acc else ((x,tg)::[])::acc) + cnf_tt l -(** val zdeduce : z nFormula -> z nFormula -> z nFormula option **) +(** val normalise0 : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) -let zdeduce = - nformula_plus_nformula Z0 Z.add zeq_bool +let normalise0 t0 tg = + let f = xnnormalise t0 in + if zunsat f then cnf_ff else cnf_of_list0 tg (xnormalise0 f) + +(** val xnegate0 : z nFormula -> z nFormula list **) + +let xnegate0 = function +| e,o -> + (match o with + | NonEqual -> + ((psub1 e (Pc (Zpos XH))),NonStrict)::(((psub1 (Pc (Zneg XH)) e),NonStrict)::[]) + | Strict -> ((psub1 e (Pc (Zpos XH))),NonStrict)::[] + | x -> (e,x)::[]) + +(** val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf **) + +let negate t0 tg = + let f = xnnormalise t0 in + if zunsat f then cnf_tt else cnf_of_list0 tg (xnegate0 f) (** val cnfZ : (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list **) let cnfZ f = - rxcnf zunsat zdeduce normalise negate true f + rxcnf zunsat zdeduce normalise0 negate true f (** val ceiling : z -> z -> z **) @@ -2035,7 +2236,7 @@ let rec zChecker l = function (** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **) let zTautoChecker f w = - tauto_checker zunsat zdeduce normalise negate (fun cl -> + tauto_checker zunsat zdeduce normalise0 negate (fun cl -> zChecker (map fst cl)) f w type qWitness = q psatz @@ -2050,13 +2251,13 @@ let qWeakChecker = let qnormalise t0 tg = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool t0 tg + qplus qmult qminus qopp qeq_bool qle_bool t0 tg (** val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) let qnegate t0 tg = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool t0 tg + qmult qminus qopp qeq_bool qle_bool t0 tg (** val qunsat : q nFormula -> bool **) @@ -2130,13 +2331,13 @@ let rWeakChecker = let rnormalise t0 tg = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool t0 tg + qplus qmult qminus qopp qeq_bool qle_bool t0 tg (** val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf **) let rnegate t0 tg = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool t0 tg + qmult qminus qopp qeq_bool qle_bool t0 tg (** val runsat : q nFormula -> bool **) diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 64cb3a8355..822fde9ab0 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -31,8 +31,12 @@ val add : nat -> nat -> nat val nth : nat -> 'a1 list -> 'a1 -> 'a1 +val rev_append : 'a1 list -> 'a1 list -> 'a1 list + val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list +val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 + val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 type positive = @@ -187,45 +191,43 @@ val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol val paddI : - ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol - -> 'a1 pol + ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> + 'a1 pol val psubI : - ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> - positive -> 'a1 pol -> 'a1 pol + ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive + -> 'a1 pol -> 'a1 pol val paddX : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> - 'a1 pol -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 + pol -> 'a1 pol val psubX : - 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 - pol -> positive -> 'a1 pol -> 'a1 pol + 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> + positive -> 'a1 pol -> 'a1 pol -val padd : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol val psub : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + 'a1 pol -> 'a1 pol -> 'a1 pol -val pmulC_aux : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol +val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol val pmulC : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1 pol val pmulI : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 - pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) + -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val pmul : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 - pol -> 'a1 pol -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol + -> 'a1 pol -> 'a1 pol val psquare : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 - pol -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol + -> 'a1 pol type 'c pExpr = | PEc of 'c @@ -239,16 +241,16 @@ type 'c pExpr = val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol val ppow_pos : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 - pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol + -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol val ppow_N : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 - pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol + -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 - -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol type ('tA, 'tX, 'aA, 'aF) gFormula = | TT @@ -284,56 +286,106 @@ val cnf_tt : ('a1, 'a2) cnf val cnf_ff : ('a1, 'a2) cnf val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> ('a1, - 'a2) clause option + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> ('a1, 'a2) + clause option val or_clause : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) clause -> ('a1, 'a2) clause option +val xor_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, + 'a2) cnf + val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> - ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, + 'a2) cnf val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, - 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula +val is_cnf_tt : ('a1, 'a2) cnf -> bool + +val is_cnf_ff : ('a1, 'a2) cnf -> bool + +val and_cnf_opt : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf + +val or_cnf_opt : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf + val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> - 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 + -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val radd_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> - (('a1, 'a2) clause, 'a2 list) sum + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> (('a1, + 'a2) clause, 'a2 list) sum val ror_clause : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause -> (('a1, 'a2) clause, 'a2 list) sum +val xror_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list -> + ('a1, 'a2) clause list * 'a2 list + val ror_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause - list -> ('a1, 'a2) clause list * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list -> + ('a1, 'a2) clause list * 'a2 list val ror_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list list -> ('a1, 'a2) - clause list -> ('a1, 'a2) cnf * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause list -> ('a1, 'a2) clause + list -> ('a1, 'a2) cnf * 'a2 list + +val ror_cnf_opt : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf * 'a2 list + +val ratom : ('a1, 'a2) cnf -> 'a2 -> ('a1, 'a2) cnf * 'a2 list val rxcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> - 'a3 -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 - list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 + -> ('a2, 'a3) cnf) -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list + +type ('term, 'annot, 'tX) to_constrT = { mkTT : 'tX; mkFF : 'tX; + mkA : ('term -> 'annot -> 'tX); + mkCj : ('tX -> 'tX -> 'tX); mkD : ('tX -> 'tX -> 'tX); + mkI : ('tX -> 'tX -> 'tX); mkN : ('tX -> 'tX) } + +val aformula : ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 + +val is_X : ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 option + +val abs_and : + ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula + -> (('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula + +val abs_or : + ('a1, 'a2, 'a3) to_constrT -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula + -> (('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula + +val mk_arrow : + 'a4 option -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula + +val abst_form : + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> bool -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, + 'a3, 'a2, 'a4) gFormula val cnf_checker : (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> - 'a3 -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, 'a3, unit0) - gFormula -> 'a4 list -> bool + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 + -> ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, __, 'a3, unit0) gFormula -> + 'a4 list -> bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool @@ -367,27 +419,27 @@ val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option val map_option2 : ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option val pexpr_times_nformula : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 - polC -> 'a1 nFormula -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 polC + -> 'a1 nFormula -> 'a1 nFormula option val nformula_times_nformula : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option val nformula_plus_nformula : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> - 'a1 nFormula option + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 + nFormula option val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 - -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> + 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 nFormula option val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 - -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> + 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool type op2 = | OpEq @@ -400,31 +452,38 @@ type op2 = type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } val norm : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 - -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol val psub0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> + 'a1 pol -> 'a1 pol -> 'a1 pol -val padd0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol +val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol -val xnormalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 - -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list +val popp0 : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol -val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 - -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf +val normalise : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula + +val xnormalise : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list + +val xnegate : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list -val xnegate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 - -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list +val cnf_of_list : + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a2 -> ('a1 + nFormula, 'a2) cnf + +val cnf_normalise : + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, + 'a2) cnf val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 - -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, + 'a2) cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr @@ -446,10 +505,6 @@ module PositiveSet : type q = { qnum : z; qden : positive } -val qnum : q -> z - -val qden : q -> positive - val qeq_bool : q -> q -> bool val qle_bool : q -> q -> bool @@ -491,17 +546,21 @@ val padd1 : z pol -> z pol -> z pol val normZ : z pExpr -> z pol -val xnormalise0 : z formula -> z nFormula list +val zunsat : z nFormula -> bool -val normalise : z formula -> 'a1 -> (z nFormula, 'a1) cnf +val zdeduce : z nFormula -> z nFormula -> z nFormula option -val xnegate0 : z formula -> z nFormula list +val xnnormalise : z formula -> z nFormula -val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf +val xnormalise0 : z nFormula -> z nFormula list -val zunsat : z nFormula -> bool +val cnf_of_list0 : 'a1 -> z nFormula list -> (z nFormula * 'a1) list list -val zdeduce : z nFormula -> z nFormula -> z nFormula option +val normalise0 : z formula -> 'a1 -> (z nFormula, 'a1) cnf + +val xnegate0 : z nFormula -> z nFormula list + +val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf val cnfZ : (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list @@ -569,8 +628,8 @@ val bound_var : positive -> z formula val mk_eq_pos : positive -> positive -> positive -> z formula val bound_vars : - (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z formula, 'a1, - 'a2, 'a3) gFormula + (positive -> positive -> bool option -> 'a2) -> positive -> Vars.t -> (z formula, 'a1, 'a2, + 'a3) gFormula val bound_problem_fr : (positive -> positive -> bool option -> 'a2) -> positive -> (z formula, 'a1, 'a2, 'a3) diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 5829292a0c..14a1bc9712 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -16,25 +16,19 @@ module type PHashtable = sig + (* see documentation in [persistent_cache.mli] *) type 'a t type key val open_in : string -> 'a t - (** [open_in f] rebuilds a table from the records stored in file [f]. - As marshaling is not type-safe, it might segfault. - *) val find : 'a t -> key -> 'a - (** find has the specification of Hashtable.find *) val add : 'a t -> key -> 'a -> unit - (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl]. - (and writes the binding to the file associated with [tbl].) - If [key] is already bound, raises KeyAlreadyBound *) val memo : string -> (key -> 'a) -> (key -> 'a) - (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. - Note that the cache will only be loaded when the function is used for the first time *) + + val memo_cond : string -> (key -> bool) -> (key -> 'a) -> (key -> 'a) end @@ -200,6 +194,24 @@ let memo cache f = add tbl x res ; res +let memo_cond cache cond f = + let tbl = lazy (try Some (open_in cache) with _ -> None) in + fun x -> + match Lazy.force tbl with + | None -> f x + | Some tbl -> + if cond x + then + begin + try find tbl x + with Not_found -> + let res = f x in + add tbl x res ; + res + end + else f x + + end diff --git a/plugins/micromega/persistent_cache.mli b/plugins/micromega/persistent_cache.mli index 4248407221..cb14d73972 100644 --- a/plugins/micromega/persistent_cache.mli +++ b/plugins/micromega/persistent_cache.mli @@ -32,6 +32,10 @@ module type PHashtable = (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. Note that the cache will only be loaded when the function is used for the first time *) + val memo_cond : string -> (key -> bool) -> (key -> 'a) -> (key -> 'a) + (** [memo cache cond f] only use the cache if [cond k] holds for the key [k]. *) + + end module PHashtable(Key:HashedType) : PHashtable with type key = Key.t diff --git a/plugins/micromega/plugin_base.dune b/plugins/micromega/plugin_base.dune index c2d396f0f9..4153d06161 100644 --- a/plugins/micromega/plugin_base.dune +++ b/plugins/micromega/plugin_base.dune @@ -2,7 +2,7 @@ (name micromega_plugin) (public_name coq.plugins.micromega) ; be careful not to link the executable to the plugin! - (modules (:standard \ csdpcert)) + (modules (:standard \ csdpcert g_zify zify)) (synopsis "Coq's micromega plugin") (libraries num coq.plugins.ltac)) @@ -13,3 +13,10 @@ (modules csdpcert) (flags :standard -open Micromega_plugin) (libraries coq.plugins.micromega)) + +(library + (name zify_plugin) + (public_name coq.plugins.zify) + (modules g_zify zify) + (synopsis "Coq's zify plugin") + (libraries coq.plugins.ltac)) diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml new file mode 100644 index 0000000000..be6037ccdb --- /dev/null +++ b/plugins/micromega/zify.ml @@ -0,0 +1,1117 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Constr +open Names +open Pp +open Lazy + +(** [get_type_of] performs beta reduction ; + Is it ok for Retyping.get_type_of (Zpower_nat n q) to return (fun _ : nat => Z) q ? *) +let get_type_of env evd e = + Tacred.cbv_beta env evd (Retyping.get_type_of env evd e) + +(** [unsafe_to_constr c] returns a [Constr.t] without considering an evar_map. + This is useful for calling Constr.hash *) +let unsafe_to_constr = EConstr.Unsafe.to_constr + +let pr_constr env evd e = Printer.pr_econstr_env env evd e + +(** [get_arrow_typ evd t] returns [t1;.tn] such that t = t1 -> .. -> tn.ci_npar + (only syntactic matching) + *) +let rec get_arrow_typ evd t = + match EConstr.kind evd t with + | Prod (a, p1, p2) (*when a.Context.binder_name = Names.Anonymous*) -> + p1 :: get_arrow_typ evd p2 + | _ -> [t] + +(** [get_binary_arrow t] return t' such that t = t' -> t' -> t' *) +let get_binary_arrow evd t = + let l = get_arrow_typ evd t in + match l with + | [] -> assert false + | [t1; t2; t3] -> Some (t1, t2, t3) + | _ -> None + +(** [get_unary_arrow t] return t' such that t = t' -> t' *) +let get_unary_arrow evd t = + let l = get_arrow_typ evd t in + match l with [] -> assert false | [t1; t2] -> Some (t1, t2) | _ -> None + +(** [HConstr] is a map indexed by EConstr.t. + It should only be used using closed terms. + *) +module HConstr = struct + module M = Map.Make (struct + type t = EConstr.t + + let compare c c' = + Constr.compare (unsafe_to_constr c) (unsafe_to_constr c') + end) + + let lfind h m = try M.find h m with Not_found -> [] + + let add h e m = + let l = lfind h m in + M.add h (e :: l) m + + let empty = M.empty + + let find h m = match lfind h m with e :: _ -> e | [] -> raise Not_found + + let find_all = lfind + + let fold f m acc = + M.fold (fun k l acc -> List.fold_left (fun acc e -> f k e acc) acc l) m acc + + let iter = M.iter + +end + +(** [get_projections_from_constant (evd,c) ] + returns an array of constr [| a1,.. an|] such that [c] is defined as + Definition c := mk a1 .. an with mk a constructor. + ai is therefore either a type parameter or a projection. + *) +let get_projections_from_constant (evd, i) = + match Constr.kind (unsafe_to_constr i) with + | Constr.Const (c, u) -> + (match Environ.constant_opt_value_in (Global.env ()) (c,u) with + | None -> failwith "Add Injection requires a constant (with a body)" + | Some c -> ( + match EConstr.kind evd (EConstr.of_constr c) with + | App (c, a) -> Some a + | _ -> None )) + | _ -> None + + +(** An instance of type, say T, is registered into a hashtable, say TableT. *) + +type 'a decl = + { decl: EConstr.t + ; (* Registered type instance *) + deriv: 'a + (* Projections of insterest *) } + +(* Different type of declarations *) +type decl_kind = + | PropOp + | InjTyp + | BinRel + | BinOp + | UnOp + | CstOp + | Saturate + +let string_of_decl = function + | PropOp -> "PropOp" + | InjTyp -> "InjTyp" + | BinRel -> "BinRel" + | BinOp -> "BinOp" + | UnOp -> "UnOp" + | CstOp -> "CstOp" + | Saturate -> "Saturate" + + + + + +module type Elt = sig + type elt + + val name : decl_kind + (** [name] of the table *) + + val get_key : int + (** [get_key] is the type-index used as key for the instance *) + + val mk_elt : Evd.evar_map -> EConstr.t -> EConstr.t array -> elt + (** [mk_elt evd i [a0,..,an] returns the element of the table + built from the type-instance i and the arguments (type indexes and projections) + of the type-class constructor. *) + + val reduce_term : Evd.evar_map -> EConstr.t -> EConstr.t + (** [reduce_term evd t] normalises [t] in a table dependent way. *) + +end + +module type S = sig + val register : Constrexpr.constr_expr -> unit + + val print : unit -> unit +end + +let not_registered = Summary.ref ~name:"zify_to_register" [] + +module MakeTable (E : Elt) = struct + (** Given a term [c] and its arguments ai, + we construct a HConstr.t table that is + indexed by ai for i = E.get_key. + The elements of the table are built using E.mk_elt c [|a0,..,an|] + *) + + let make_elt (evd, i) = + match get_projections_from_constant (evd, i) with + | None -> + let env = Global.env () in + let t = string_of_ppcmds (pr_constr env evd i) in + failwith ("Cannot register term " ^ t) + | Some a -> E.mk_elt evd i a + + let table = Summary.ref ~name:("zify_" ^ string_of_decl E.name) HConstr.empty + + let register_constr env evd c = + let c = EConstr.of_constr c in + let t = get_type_of env evd c in + match EConstr.kind evd t with + | App (intyp, args) -> + let styp = E.reduce_term evd args.(E.get_key) in + let elt = {decl= c; deriv= make_elt (evd, c)} in + table := HConstr.add styp elt !table + | _ -> failwith "Can only register terms of type [F X1 .. Xn]" + + let get evd c = + let c' = E.reduce_term evd c in + HConstr.find c' !table + + let get_all evd c = + let c' = E.reduce_term evd c in + HConstr.find_all c' !table + + let fold_declared_const f evd acc = + HConstr.fold + (fun _ e acc -> f (fst (EConstr.destConst evd e.decl)) acc) + !table acc + + exception FoundNorm of EConstr.t + + let can_unify evd k t = + try + let _ = Unification.w_unify (Global.env ()) evd Reduction.CONV k t in + true ; + with _ -> false + + let unify_with_key evd t = + try + HConstr.iter + (fun k _ -> + if can_unify evd k t + then raise (FoundNorm k) + else ()) !table ; t + with FoundNorm k -> k + + + let pp_keys () = + let env = Global.env () in + let evd = Evd.from_env env in + HConstr.fold + (fun k _ acc -> Pp.(pr_constr env evd k ++ str " " ++ acc)) + !table (Pp.str "") + + let register_obj : Constr.constr -> Libobject.obj = + let cache_constr (_, c) = + not_registered := (E.name,c)::!not_registered + in + let subst_constr (subst, c) = Mod_subst.subst_mps subst c in + Libobject.declare_object + @@ Libobject.superglobal_object_nodischarge + ("register-zify-" ^ string_of_decl E.name) + ~cache:cache_constr ~subst:(Some subst_constr) + + (** [register c] is called from the VERNACULAR ADD [name] constr(t). + The term [c] is interpreted and + registered as a [superglobal_object_nodischarge]. + TODO: pre-compute [get_type_of] - [cache_constr] is using another environment. + *) + let register c = + let env = Global.env () in + let evd = Evd.from_env env in + let evd, c = Constrintern.interp_open_constr env evd c in + let _ = Lib.add_anonymous_leaf (register_obj (EConstr.to_constr evd c)) in + () + + let print () = Feedback.msg_notice (pp_keys ()) +end + +(** Each type-class gives rise to a different table. + They only differ on how projections are extracted. *) +module InjElt = struct + type elt = + { isid: bool + ; (* S = T -> inj = fun x -> x*) + source: EConstr.t + ; (* S *) + target: EConstr.t + ; (* T *) + (* projections *) + inj: EConstr.t + ; (* S -> T *) + pred: EConstr.t + ; (* T -> Prop *) + cstr: EConstr.t option + (* forall x, pred (inj x) *) } + + let name = InjTyp + + let mk_elt evd i (a : EConstr.t array) = + let isid = EConstr.eq_constr evd a.(0) a.(1) in + { isid + ; source= a.(0) + ; target= a.(1) + ; inj= a.(2) + ; pred= a.(3) + ; cstr= (if isid then None else Some a.(4)) } + + let get_key = 0 + + let reduce_term evd t = t + +end + +module InjTable = MakeTable (InjElt) + + +let coq_eq = lazy ( EConstr.of_constr + (UnivGen.constr_of_monomorphic_global + (Coqlib.lib_ref ("core.eq.type")))) + +let reduce_type evd ty = + try ignore (InjTable.get evd ty) ; ty + with Not_found -> + (* Maybe it unifies *) + InjTable.unify_with_key evd ty + +module EBinOp = struct + type elt = + { (* Op : source1 -> source2 -> source3 *) + source1: EConstr.t + ; source2: EConstr.t + ; source3: EConstr.t + ; target: EConstr.t + ; inj1: EConstr.t + ; (* InjTyp source1 target *) + inj2: EConstr.t + ; (* InjTyp source2 target *) + inj3: EConstr.t + ; (* InjTyp source3 target *) + tbop: EConstr.t + (* TBOpInj *) } + + let name = BinOp + + let mk_elt evd i a = + { source1= a.(0) + ; source2= a.(1) + ; source3= a.(2) + ; target= a.(3) + ; inj1= a.(5) + ; inj2= a.(6) + ; inj3= a.(7) + ; tbop= a.(9) } + + let get_key = 4 + + let reduce_term evd t = t + +end + +module ECstOp = struct + type elt = {source: EConstr.t; target: EConstr.t; inj: EConstr.t} + + let name = CstOp + + let mk_elt evd i a = {source= a.(0); target= a.(1); inj= a.(3)} + + let get_key = 2 + + let reduce_term evd t = t + +end + + +module EUnOp = struct + type elt = + { source1: EConstr.t + ; source2: EConstr.t + ; target: EConstr.t + ; inj1_t: EConstr.t + ; inj2_t: EConstr.t + ; unop: EConstr.t } + + let name = UnOp + + let mk_elt evd i a = + { source1= a.(0) + ; source2= a.(1) + ; target= a.(2) + ; inj1_t= a.(4) + ; inj2_t= a.(5) + ; unop= a.(6) } + + let get_key = 3 + + let reduce_term evd t = t + +end + +open EUnOp + +module EBinRel = struct + type elt = + {source: EConstr.t; target: EConstr.t; inj: EConstr.t; brel: EConstr.t} + + let name = BinRel + + let mk_elt evd i a = {source= a.(0); target= a.(1); inj= a.(3); brel= a.(4)} + + let get_key = 2 + + + (** [reduce_term evd t] if t = @eq ty normalises ty to a declared type e.g Z if it exists. *) + let reduce_term evd t = + match EConstr.kind evd t with + | App(c,a) -> if EConstr.eq_constr evd (Lazy.force coq_eq) c + then + match a with + | [| ty |] -> EConstr.mkApp(c,[| reduce_type evd ty|]) + | _ -> t + else t + | _ -> t + +end + +module EPropOp = struct + type elt = EConstr.t + + let name = PropOp + + let mk_elt evd i a = i + + let get_key = 0 + + let reduce_term evd t = t + +end + +module ESat = struct + type elt = {parg1: EConstr.t; parg2: EConstr.t; satOK: EConstr.t} + + let name = Saturate + + let mk_elt evd i a = {parg1= a.(2); parg2= a.(3); satOK= a.(5)} + + let get_key = 1 + + let reduce_term evd t = t + +end + + + +module BinOp = MakeTable (EBinOp) +module UnOp = MakeTable (EUnOp) +module CstOp = MakeTable (ECstOp) +module BinRel = MakeTable (EBinRel) +module PropOp = MakeTable (EPropOp) +module Saturate = MakeTable (ESat) + + + + +(** The module [Spec] is used to register + the instances of [BinOpSpec], [UnOpSpec]. + They are not indexed and stored in a list. *) + +module Spec = struct + let table = Summary.ref ~name:"zify_Spec" [] + + let register_obj : Constr.constr -> Libobject.obj = + let cache_constr (_, c) = table := EConstr.of_constr c :: !table in + let subst_constr (subst, c) = Mod_subst.subst_mps subst c in + Libobject.declare_object + @@ Libobject.superglobal_object_nodischarge "register-zify-Spec" + ~cache:cache_constr ~subst:(Some subst_constr) + + let register c = + let env = Global.env () in + let evd = Evd.from_env env in + let _, c = Constrintern.interp_open_constr env evd c in + let _ = Lib.add_anonymous_leaf (register_obj (EConstr.to_constr evd c)) in + () + + let get () = !table + + let print () = + let env = Global.env () in + let evd = Evd.from_env env in + let constr_of_spec c = + let t = get_type_of env evd c in + match EConstr.kind evd t with + | App (intyp, args) -> pr_constr env evd args.(2) + | _ -> Pp.str "" + in + let l = + List.fold_left + (fun acc c -> Pp.(constr_of_spec c ++ str " " ++ acc)) + (Pp.str "") !table + in + Feedback.msg_notice l +end + + +let register_decl = function + | PropOp -> PropOp.register_constr + | InjTyp -> InjTable.register_constr + | BinRel -> BinRel.register_constr + | BinOp -> BinOp.register_constr + | UnOp -> UnOp.register_constr + | CstOp -> CstOp.register_constr + | Saturate -> Saturate.register_constr + + +let process_decl (d,c) = + let env = Global.env () in + let evd = Evd.from_env env in + register_decl d env evd c + +let process_all_decl () = + List.iter process_decl !not_registered ; + not_registered := [] + + +let unfold_decl evd = + let f cst acc = cst :: acc in + let acc = InjTable.fold_declared_const f evd [] in + let acc = BinOp.fold_declared_const f evd acc in + let acc = UnOp.fold_declared_const f evd acc in + let acc = CstOp.fold_declared_const f evd acc in + let acc = BinRel.fold_declared_const f evd acc in + let acc = PropOp.fold_declared_const f evd acc in + acc + +open InjElt + +(** Get constr of lemma and projections in ZifyClasses. *) + +let zify str = + EConstr.of_constr + (UnivGen.constr_of_monomorphic_global + (Coqlib.lib_ref ("ZifyClasses." ^ str))) + +let locate_const str = + let rf = "ZifyClasses." ^ str in + match Coqlib.lib_ref rf with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly Pp.(str rf ++ str " should be a constant") + +(* The following [constr] are necessary for constructing the proof terms *) +let mkapp2 = lazy (zify "mkapp2") + +let mkapp = lazy (zify "mkapp") + +let mkapp0 = lazy (zify "mkapp0") + +let mkdp = lazy (zify "mkinjterm") + +let eq_refl = lazy (zify "eq_refl") + +let mkrel = lazy (zify "mkrel") + +let mkprop_op = lazy (zify "mkprop_op") + +let mkuprop_op = lazy (zify "mkuprop_op") + +let mkdpP = lazy (zify "mkinjprop") + +let iff_refl = lazy (zify "iff_refl") + +let q = lazy (zify "target_prop") + +let ieq = lazy (zify "injprop_ok") + +let iff = lazy (zify "iff") + + + +(* A super-set of the previous are needed to unfold the generated proof terms. *) + +let to_unfold = + lazy + (List.map locate_const + [ "source_prop" + ; "target_prop" + ; "uop_iff" + ; "op_iff" + ; "mkuprop_op" + ; "TUOp" + ; "inj_ok" + ; "TRInj" + ; "inj" + ; "source" + ; "injprop_ok" + ; "TR" + ; "TBOp" + ; "TCst" + ; "target" + ; "mkrel" + ; "mkapp2" + ; "mkapp" + ; "mkapp0" + ; "mkprop_op" ]) + +(** Module [CstrTable] records terms [x] injected into [inj x] + together with the corresponding type constraint. + The terms are stored by side-effect during the traversal + of the goal. It must therefore be cleared before calling + the main tactic. + *) + +module CstrTable = struct + module HConstr = Hashtbl.Make (struct + type t = EConstr.t + + let hash c = Constr.hash (unsafe_to_constr c) + + let equal c c' = Constr.equal (unsafe_to_constr c) (unsafe_to_constr c') + end) + + let table : EConstr.t HConstr.t = HConstr.create 10 + + let register evd t (i : EConstr.t) = HConstr.replace table t i + + let get () = + let l = HConstr.fold (fun k i acc -> (k, i) :: acc) table [] in + HConstr.clear table ; l + + (** [gen_cstr table] asserts (cstr k) for each element of the table (k,cstr). + NB: the constraint is only asserted if it does not already exist in the context. + *) + let gen_cstr table = + Proofview.Goal.enter (fun gl -> + let evd = Tacmach.New.project gl in + (* Build the table of existing hypotheses *) + let has_hyp = + let hyps_table = HConstr.create 20 in + List.iter + (fun (_, (t : EConstr.types)) -> HConstr.replace hyps_table t ()) + (Tacmach.New.pf_hyps_types gl) ; + fun c -> HConstr.mem hyps_table c + in + (* Add the constraint (cstr k) if it is not already present *) + let gen k cstr = + Proofview.Goal.enter (fun gl -> + let env = Tacmach.New.pf_env gl in + let term = EConstr.mkApp (cstr, [|k|]) in + let types = get_type_of env evd term in + if has_hyp types then Tacticals.New.tclIDTAC + else + let n = + Tactics.fresh_id_in_env Id.Set.empty + (Names.Id.of_string "cstr") + env + in + Tactics.pose_proof (Names.Name n) term ) + in + List.fold_left + (fun acc (k, i) -> Tacticals.New.tclTHEN (gen k i) acc) + Tacticals.New.tclIDTAC table ) +end + +let mkvar red evd inj v = + ( if not red then + match inj.cstr with None -> () | Some ctr -> CstrTable.register evd v ctr + ) ; + let iv = EConstr.mkApp (inj.inj, [|v|]) in + let iv = if red then Tacred.compute (Global.env ()) evd iv else iv in + EConstr.mkApp + ( force mkdp + , [| inj.source + ; inj.target + ; inj.inj + ; v + ; iv + ; EConstr.mkApp (force eq_refl, [|inj.target; iv|]) |] ) + +type texpr = + | Var of InjElt.elt * EConstr.t + (** Var is a term that cannot be injected further *) + | Constant of InjElt.elt * EConstr.t + (** Constant is a term that is solely built from constructors *) + | Injterm of EConstr.t + (** Injected is an injected term represented by a term of type [injterm] *) + +let is_constant = function Constant _ -> true | _ -> false + +let constr_of_texpr = function + | Constant (i, e) | Var (i, e) -> if i.isid then Some e else None + | _ -> None + +let inj_term_of_texpr evd = function + | Injterm e -> e + | Var (inj, e) -> mkvar false evd inj e + | Constant (inj, e) -> mkvar true evd inj e + +let mkapp2_id evd i (* InjTyp S3 T *) + inj (* deriv i *) + t (* S1 -> S2 -> S3 *) + b (* Binop S1 S2 S3 t ... *) + dbop (* deriv b *) e1 e2 = + let default () = + let e1' = inj_term_of_texpr evd e1 in + let e2' = inj_term_of_texpr evd e2 in + EBinOp.( + Injterm + (EConstr.mkApp + ( force mkapp2 + , [| dbop.source1 + ; dbop.source2 + ; dbop.source3 + ; dbop.target + ; t + ; dbop.inj1 + ; dbop.inj2 + ; dbop.inj3 + ; b + ; e1' + ; e2' |] ))) + in + if not inj.isid then default () + else + match (e1, e2) with + | Constant (_, e1), Constant (_, e2) + |Var (_, e1), Var (_, e2) + |Constant (_, e1), Var (_, e2) + |Var (_, e1), Constant (_, e2) -> + Var (inj, EConstr.mkApp (t, [|e1; e2|])) + | _, _ -> default () + +let mkapp_id evd i inj (unop, u) f e1 = + if EConstr.eq_constr evd u.unop f then + (* Injection does nothing *) + match e1 with + | Constant (_, e) | Var (_, e) -> Var (inj, EConstr.mkApp (f, [|e|])) + | Injterm e1 -> + Injterm + (EConstr.mkApp + ( force mkapp + , [| u.source1 + ; u.source2 + ; u.target + ; f + ; u.inj1_t + ; u.inj2_t + ; unop + ; e1 |] )) + else + let e1 = inj_term_of_texpr evd e1 in + Injterm + (EConstr.mkApp + ( force mkapp + , [|u.source1; u.source2; u.target; f; u.inj1_t; u.inj2_t; unop; e1|] + )) + +type typed_constr = {constr: EConstr.t; typ: EConstr.t} + +type op = + | Unop of + { unop: EConstr.t + ; (* unop : typ unop_arg -> unop_typ *) + unop_typ: EConstr.t + ; unop_arg: typed_constr } + | Binop of + { binop: EConstr.t + ; (* binop : typ binop_arg1 -> typ binop_arg2 -> binop_typ *) + binop_typ: EConstr.t + ; binop_arg1: typed_constr + ; binop_arg2: typed_constr } + + +let rec trans_expr env evd e = + (* Get the injection *) + let {decl= i; deriv= inj} = InjTable.get evd e.typ in + let e = e.constr in + if EConstr.isConstruct evd e then Constant (inj, e) (* Evaluate later *) + else + try + (* The term [e] might be a registered constant *) + let {decl= c} = CstOp.get evd e in + Injterm + (EConstr.mkApp (force mkapp0, [|inj.source; inj.target; e; i; c|])) + with Not_found -> ( + (* Let decompose the term *) + match EConstr.kind evd e with + | App (t, a) -> ( + try + match Array.length a with + | 1 -> + let {decl= unop; deriv= u} = UnOp.get evd t in + let a' = trans_expr env evd {constr= a.(0); typ= u.source1} in + if is_constant a' && EConstr.isConstruct evd t then + Constant (inj, e) + else mkapp_id evd i inj (unop, u) t a' + | 2 -> + let {decl= bop; deriv= b} = BinOp.get evd t in + let a0 = + trans_expr env evd {constr= a.(0); typ= b.EBinOp.source1} + in + let a1 = + trans_expr env evd {constr= a.(1); typ= b.EBinOp.source2} + in + if is_constant a0 && is_constant a1 && EConstr.isConstruct evd t + then Constant (inj, e) + else mkapp2_id evd i inj t bop b a0 a1 + | _ -> Var (inj, e) + with Not_found -> Var (inj, e) ) + | _ -> Var (inj, e) ) + +let trans_expr env evd e = + try trans_expr env evd e with Not_found -> + raise + (CErrors.user_err + ( Pp.str "Missing injection for type " + ++ Printer.pr_leconstr_env env evd e.typ )) + +let is_prop env sigma term = + let sort = Retyping.get_sort_of env sigma term in + Sorts.is_prop sort + +let get_rel env evd e = + let is_arrow a p1 p2 = + is_prop env evd p1 && is_prop (EConstr.push_rel (Context.Rel.Declaration.LocalAssum(a,p1)) env) evd p2 + && (a.Context.binder_name = Names.Anonymous || EConstr.Vars.noccurn evd 1 p2) + in + match EConstr.kind evd e with + | Prod (a, p1, p2) when is_arrow a p1 p2 -> + (* X -> Y becomes (fun x y => x -> y) x y *) + let name x = + Context.make_annot (Name.mk_name (Names.Id.of_string x)) Sorts.Relevant + in + let arrow = + EConstr.mkLambda + ( name "x" + , EConstr.mkProp + , EConstr.mkLambda + ( name "y" + , EConstr.mkProp + , EConstr.mkProd + ( Context.make_annot Names.Anonymous Sorts.Relevant + , EConstr.mkRel 2 + , EConstr.mkRel 2 ) ) ) + in + Binop + { binop= arrow + ; binop_typ= EConstr.mkProp + ; binop_arg1= {constr= p1; typ= EConstr.mkProp} + ; binop_arg2= {constr= p2; typ= EConstr.mkProp} } + | App (c, a) -> + let len = Array.length a in + if len >= 2 then + let c, a1, a2 = + if len = 2 then (c, a.(0), a.(1)) + else if len > 2 then + ( EConstr.mkApp (c, Array.sub a 0 (len - 2)) + , a.(len - 2) + , a.(len - 1) ) + else raise Not_found + in + let typ = get_type_of env evd c in + match get_binary_arrow evd typ with + | None -> raise Not_found + | Some (t1, t2, t3) -> + Binop + { binop= c + ; binop_typ= t3 + ; binop_arg1= {constr= a1; typ= t1} + ; binop_arg2= {constr= a2; typ= t2} } + else if len = 1 then + let typ = get_type_of env evd c in + match get_unary_arrow evd typ with + | None -> raise Not_found + | Some (t1, t2) -> + Unop {unop= c; unop_typ= t2; unop_arg= {constr= a.(0); typ= t1}} + else raise Not_found + | _ -> raise Not_found + +let get_rel env evd e = try Some (get_rel env evd e) with Not_found -> None + +type tprop = + | TProp of EConstr.t (** Transformed proposition *) + | IProp of EConstr.t (** Identical proposition *) + +let mk_iprop e = + EConstr.mkApp (force mkdpP, [|e; e; EConstr.mkApp (force iff_refl, [|e|])|]) + +let inj_prop_of_tprop = function TProp p -> p | IProp e -> mk_iprop e + +let rec trans_prop env evd e = + match get_rel env evd e with + | None -> IProp e + | Some (Binop {binop= r; binop_typ= t1; binop_arg1= a1; binop_arg2= a2}) -> + assert (EConstr.eq_constr evd EConstr.mkProp t1) ; + if EConstr.eq_constr evd a1.typ a2.typ then + (* Arguments have the same type *) + if + EConstr.eq_constr evd EConstr.mkProp t1 + && EConstr.eq_constr evd EConstr.mkProp a1.typ + then + (* Prop -> Prop -> Prop *) + try + let {decl= rop} = PropOp.get evd r in + let t1 = trans_prop env evd a1.constr in + let t2 = trans_prop env evd a2.constr in + match (t1, t2) with + | IProp _, IProp _ -> IProp e + | _, _ -> + let t1 = inj_prop_of_tprop t1 in + let t2 = inj_prop_of_tprop t2 in + TProp (EConstr.mkApp (force mkprop_op, [|r; rop; t1; t2|])) + with Not_found -> IProp e + else + (* A -> A -> Prop *) + try + let {decl= br; deriv= rop} = BinRel.get evd r in + let a1 = trans_expr env evd {a1 with typ = rop.EBinRel.source} in + let a2 = trans_expr env evd {a2 with typ = rop.EBinRel.source} in + if EConstr.eq_constr evd r rop.EBinRel.brel then + match (constr_of_texpr a1, constr_of_texpr a2) with + | Some e1, Some e2 -> IProp (EConstr.mkApp (r, [|e1; e2|])) + | _, _ -> + let a1 = inj_term_of_texpr evd a1 in + let a2 = inj_term_of_texpr evd a2 in + TProp + (EConstr.mkApp + ( force mkrel + , [| rop.EBinRel.source + ; rop.EBinRel.target + ; r + ; rop.EBinRel.inj + ; br + ; a1 + ; a2 |] )) + else + let a1 = inj_term_of_texpr evd a1 in + let a2 = inj_term_of_texpr evd a2 in + TProp + (EConstr.mkApp + ( force mkrel + , [| rop.EBinRel.source + ; rop.EBinRel.target + ; r + ; rop.EBinRel.inj + ; br + ; a1 + ; a2 |] )) + with Not_found -> IProp e + else IProp e + | Some (Unop {unop; unop_typ; unop_arg}) -> + if + EConstr.eq_constr evd EConstr.mkProp unop_typ + && EConstr.eq_constr evd EConstr.mkProp unop_arg.typ + then + try + let {decl= rop} = PropOp.get evd unop in + let t1 = trans_prop env evd unop_arg.constr in + match t1 with + | IProp _ -> IProp e + | _ -> + let t1 = inj_prop_of_tprop t1 in + TProp (EConstr.mkApp (force mkuprop_op, [|unop; rop; t1|])) + with Not_found -> IProp e + else IProp e + +let unfold n env evd c = + let cbv l = + CClosure.RedFlags.( + Tacred.cbv_norm_flags + (mkflags + (fBETA :: fMATCH :: fFIX :: fCOFIX :: fZETA :: List.map fCONST l))) + in + let unfold_decl = unfold_decl evd in + (* Unfold the let binding *) + let c = + match n with + | None -> c + | Some n -> + Tacred.unfoldn [(Locus.AllOccurrences, Names.EvalVarRef n)] env evd c + in + (* Reduce the term *) + let c = cbv (force to_unfold @ unfold_decl) env evd c in + c + +let trans_check_prop env evd t = + if is_prop env evd t then + (*let t = Tacred.unfoldn [Locus.AllOccurrences, Names.EvalConstRef coq_not] env evd t in*) + match trans_prop env evd t with IProp e -> None | TProp e -> Some e + else None + +let trans_hyps env evd l = + List.fold_left + (fun acc (h, p) -> + match trans_check_prop env evd p with + | None -> acc + | Some p' -> (h, p, p') :: acc ) + [] (List.rev l) + +(* Only used if a direct rewrite fails *) +let trans_hyp h t = + Tactics.( + Tacticals.New.( + Proofview.Goal.enter (fun gl -> + let env = Tacmach.New.pf_env gl in + let n = + fresh_id_in_env Id.Set.empty (Names.Id.of_string "__zify") env + in + let h' = fresh_id_in_env Id.Set.empty h env in + tclTHENLIST + [ letin_tac None (Names.Name n) t None + Locus.{onhyps= None; concl_occs= NoOccurrences} + ; assert_by (Name.Name h') + (EConstr.mkApp (force q, [|EConstr.mkVar n|])) + (tclTHEN + (Equality.rewriteRL + (EConstr.mkApp (force ieq, [|EConstr.mkVar n|]))) + (exact_check (EConstr.mkVar h))) + ; reduct_in_hyp ~check:true ~reorder:false (unfold (Some n)) + (h', Locus.InHyp) + ; clear [n] + ; (* [clear H] may fail if [h] has dependencies *) + tclTRY (clear [h]) ] ))) + +let is_progress_rewrite evd t rew = + match EConstr.kind evd rew with + | App (c, [|lhs; rhs|]) -> + if EConstr.eq_constr evd (force iff) c then + (* This is a successful rewriting *) + not (EConstr.eq_constr evd lhs rhs) + else + CErrors.anomaly + Pp.( + str "is_progress_rewrite: not a rewrite" + ++ pr_constr (Global.env ()) evd rew) + | _ -> failwith "is_progress_rewrite: not even an application" + +let trans_hyp h t0 t = + Tacticals.New.( + Proofview.Goal.enter (fun gl -> + let env = Tacmach.New.pf_env gl in + let evd = Tacmach.New.project gl in + let t' = unfold None env evd (EConstr.mkApp (force ieq, [|t|])) in + if is_progress_rewrite evd t0 (get_type_of env evd t') then + tclFIRST + [ Equality.general_rewrite_in true Locus.AllOccurrences true false + h t' false + ; trans_hyp h t ] + else tclIDTAC )) + +let trans_concl t = + Tacticals.New.( + Proofview.Goal.enter (fun gl -> + let concl = Tacmach.New.pf_concl gl in + let env = Tacmach.New.pf_env gl in + let evd = Tacmach.New.project gl in + let t' = unfold None env evd (EConstr.mkApp (force ieq, [|t|])) in + if is_progress_rewrite evd concl (get_type_of env evd t') then + Equality.general_rewrite true Locus.AllOccurrences true false t' + else tclIDTAC )) + +let tclTHENOpt e tac tac' = + match e with None -> tac' | Some e' -> Tacticals.New.tclTHEN (tac e') tac' + +let zify_tac = + Proofview.Goal.enter (fun gl -> + Coqlib.check_required_library ["Coq"; "micromega"; "ZifyClasses"] ; + Coqlib.check_required_library ["Coq"; "micromega"; "ZifyInst"] ; + process_all_decl (); + let evd = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in + let concl = trans_check_prop env evd (Tacmach.New.pf_concl gl) in + let hyps = trans_hyps env evd (Tacmach.New.pf_hyps_types gl) in + let l = CstrTable.get () in + tclTHENOpt concl trans_concl + (Tacticals.New.tclTHEN + (Tacticals.New.tclTHENLIST + (List.map (fun (h, p, t) -> trans_hyp h p t) hyps)) + (CstrTable.gen_cstr l)) ) + +let iter_specs tac = + Tacticals.New.tclTHENLIST + (List.fold_right (fun d acc -> tac d :: acc) (Spec.get ()) []) + + +let iter_specs (tac: Ltac_plugin.Tacinterp.Value.t) = + iter_specs (fun c -> Ltac_plugin.Tacinterp.Value.apply tac [Ltac_plugin.Tacinterp.Value.of_constr c]) + +let find_hyp evd t l = + try Some (fst (List.find (fun (h, t') -> EConstr.eq_constr evd t t') l)) + with Not_found -> None + +let sat_constr c d = + Proofview.Goal.enter (fun gl -> + let evd = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in + let hyps = Tacmach.New.pf_hyps_types gl in + match EConstr.kind evd c with + | App (c, args) -> + if Array.length args = 2 then ( + let h1 = + Tacred.cbv_beta env evd + (EConstr.mkApp (d.ESat.parg1, [|args.(0)|])) + in + let h2 = + Tacred.cbv_beta env evd + (EConstr.mkApp (d.ESat.parg2, [|args.(1)|])) + in + match (find_hyp evd h1 hyps, find_hyp evd h2 hyps) with + | Some h1, Some h2 -> + let n = + Tactics.fresh_id_in_env Id.Set.empty + (Names.Id.of_string "__sat") + env + in + let trm = + EConstr.mkApp + ( d.ESat.satOK + , [|args.(0); args.(1); EConstr.mkVar h1; EConstr.mkVar h2|] + ) + in + Tactics.pose_proof (Names.Name n) trm + | _, _ -> Tacticals.New.tclIDTAC ) + else Tacticals.New.tclIDTAC + | _ -> Tacticals.New.tclIDTAC ) + +let saturate = + Proofview.Goal.enter (fun gl -> + let table = CstrTable.HConstr.create 20 in + let concl = Tacmach.New.pf_concl gl in + let hyps = Tacmach.New.pf_hyps_types gl in + let evd = Tacmach.New.project gl in + process_all_decl (); + let rec sat t = + match EConstr.kind evd t with + | App (c, args) -> + sat c ; + Array.iter sat args ; + if Array.length args = 2 then + let ds = Saturate.get_all evd c in + if ds = [] then () + else ( + List.iter (fun x -> CstrTable.HConstr.add table t x.deriv) ds ) + else () + | Prod (a, t1, t2) when a.Context.binder_name = Names.Anonymous -> + sat t1 ; sat t2 + | _ -> () + in + (* Collect all the potential saturation lemma *) + sat concl ; + List.iter (fun (_, t) -> sat t) hyps ; + Tacticals.New.tclTHENLIST + (CstrTable.HConstr.fold (fun c d acc -> sat_constr c d :: acc) table []) + ) diff --git a/plugins/micromega/zify.mli b/plugins/micromega/zify.mli new file mode 100644 index 0000000000..f7844f53bc --- /dev/null +++ b/plugins/micromega/zify.mli @@ -0,0 +1,25 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +open Constrexpr + +module type S = sig val register : constr_expr -> unit val print : unit -> unit end + +module InjTable : S +module UnOp : S +module BinOp : S +module CstOp : S +module BinRel : S +module PropOp : S +module Spec : S +module Saturate : S + +val zify_tac : unit Proofview.tactic +val saturate : unit Proofview.tactic +val iter_specs : Ltac_plugin.Tacinterp.Value.t -> unit Proofview.tactic diff --git a/plugins/micromega/zify_plugin.mlpack b/plugins/micromega/zify_plugin.mlpack new file mode 100644 index 0000000000..8d301b53c4 --- /dev/null +++ b/plugins/micromega/zify_plugin.mlpack @@ -0,0 +1,2 @@ +Zify +G_zify diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index acc8214e3e..f5d53cbbf3 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -127,6 +127,8 @@ Module Z. Ltac to_euclidean_division_equations := div_mod_to_equations'; quot_rem_to_equations'; euclidean_division_equations_cleanup. End Z. +Set Warnings "-deprecated-tactic". + (** * zify: the Z-ification tactic *) (* This tactic searches for nat and N and positive elements in the goal and @@ -150,12 +152,14 @@ End Z. (** I) translation of Z.max, Z.min, Z.abs, Z.sgn into recognized equations *) +#[deprecated( note = "Use 'zify' instead")] Ltac zify_unop_core t thm a := (* Let's introduce the specification theorem for t *) pose proof (thm a); (* Then we replace (t a) everywhere with a fresh variable *) let z := fresh "z" in set (z:=t a) in *; clearbody z. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_unop_var_or_term t thm a := (* If a is a variable, no need for aliasing *) let za := fresh "z" in @@ -163,6 +167,7 @@ Ltac zify_unop_var_or_term t thm a := (* Otherwise, a is a complex term: we alias it. *) (remember a as za; zify_unop_core t thm za). +#[deprecated( note = "Use 'zify' instead")] Ltac zify_unop t thm a := (* If a is a scalar, we can simply reduce the unop. *) (* Note that simpl wasn't enough to reduce [Z.max 0 0] (#5439) *) @@ -174,6 +179,7 @@ Ltac zify_unop t thm a := | _ => zify_unop_var_or_term t thm a end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_unop_nored t thm a := (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *) let isz := isZcst a in @@ -182,6 +188,7 @@ Ltac zify_unop_nored t thm a := | _ => zify_unop_var_or_term t thm a end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_binop t thm a b:= (* works as zify_unop, except that we should be careful when dealing with b, since it can be equal to a *) @@ -197,6 +204,7 @@ Ltac zify_binop t thm a b:= end) end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_op_1 := match goal with | x := ?t : Z |- _ => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x @@ -213,9 +221,6 @@ Ltac zify_op_1 := Ltac zify_op := repeat zify_op_1. - - - (** II) Conversion from nat to Z *) @@ -226,6 +231,7 @@ Ltac hide_Z_of_nat t := change Z.of_nat with Z_of_nat' in z; unfold z in *; clear z. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_nat_rel := match goal with (* I: equalities *) @@ -321,11 +327,9 @@ Ltac zify_nat_op := pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *. - - - (* III) conversion from positive to Z *) Definition Zpos' := Zpos. @@ -336,6 +340,7 @@ Ltac hide_Zpos t := change Zpos with Zpos' in z; unfold z in *; clear z. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_positive_rel := match goal with (* I: equalities *) @@ -357,6 +362,7 @@ Ltac zify_positive_rel := | |- context [ (?a >= ?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b) end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_positive_op := match goal with (* Z.pow_pos -> Z.pow *) @@ -453,6 +459,7 @@ Ltac zify_positive_op := | |- context [ Zpos ?a ] => pose proof (Pos2Z.is_pos a); hide_Zpos a end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_positive := repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *. @@ -469,6 +476,7 @@ Ltac hide_Z_of_N t := change Z.of_N with Z_of_N' in z; unfold z in *; clear z. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_N_rel := match goal with (* I: equalities *) @@ -490,6 +498,7 @@ Ltac zify_N_rel := | |- context [ (?a >= ?b)%N ] => rewrite (N2Z.inj_ge a b) end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_N_op := match goal with (* misc type conversions: nat to positive *) @@ -556,10 +565,35 @@ Ltac zify_N_op := | |- context [ Z.of_N ?a ] => pose proof (N2Z.is_nonneg a); hide_Z_of_N a end. +#[deprecated( note = "Use 'zify' instead")] Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. +(** The complete Z-ification tactic *) +Require Import ZifyClasses ZifyInst. +Require Zify. + + +(** [is_inj T] returns true iff the type T has an injection *) +Ltac is_inj T := + match T with + | _ => let x := constr:(_ : InjTyp T _ ) in true + | _ => false + end. + +(* [elim_let] replaces a let binding (x := e : t) + by an equation (x = e) if t is an injected type *) +Ltac elim_let := + repeat + match goal with + | x := ?t : ?ty |- _ => + let b := is_inj ty in + match b with + | true => let h := fresh "heq_" x in pose proof (eq_refl : x = t) as h; clearbody x + end + end. -(** The complete Z-ification tactic *) -Ltac zify := repeat (zify_nat; zify_positive; zify_N); zify_op. +Ltac zify := + intros ; elim_let ; + Zify.zify ; ZifyInst.saturate. diff --git a/plugins/omega/g_omega.mlg b/plugins/omega/g_omega.mlg index bb9bee080a..84964a7bd2 100644 --- a/plugins/omega/g_omega.mlg +++ b/plugins/omega/g_omega.mlg @@ -54,6 +54,7 @@ END TACTIC EXTEND omega' | [ "omega" "with" ne_ident_list(l) ] -> { omega_tactic (List.map Names.Id.to_string l) } -| [ "omega" "with" "*" ] -> { omega_tactic ["nat";"positive";"N";"Z"] } +| [ "omega" "with" "*" ] -> + { Tacticals.New.tclTHEN (eval_tactic "zify") (omega_tactic []) } END diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 0ca0d0c12d..6b92445326 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -77,20 +77,24 @@ Lget i (l ++ delta) = Some a. induction l;destruct i;simpl;try congruence;auto. Qed. -Section Store. - -Variable A:Type. - -#[universes(template)] -Inductive Poption : Type:= +Inductive Poption {A} : Type:= PSome : A -> Poption | PNone : Poption. +Arguments Poption : clear implicits. -#[universes(template)] -Inductive Tree : Type := +Inductive Tree {A} : Type := Tempty : Tree | Branch0 : Tree -> Tree -> Tree | Branch1 : A -> Tree -> Tree -> Tree. +Arguments Tree : clear implicits. + +Section Store. + +Variable A:Type. + +Notation Poption := (Poption A). +Notation Tree := (Tree A). + Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := match T with @@ -179,7 +183,6 @@ generalize i;clear i;induction j;destruct T;simpl in H|-*; destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. Qed. -#[universes(template)] Record Store : Type := mkStore {index:positive;contents:Tree}. @@ -194,7 +197,6 @@ Lemma get_empty : forall i, get i empty = PNone. intro i; case i; unfold empty,get; simpl;reflexivity. Qed. -#[universes(template)] Inductive Full : Store -> Type:= F_empty : Full empty | F_push : forall a S, Full S -> Full (push a S). diff --git a/plugins/setoid_ring/Cring.v b/plugins/setoid_ring/Cring.v index 4f3f0c3878..df0313a624 100644 --- a/plugins/setoid_ring/Cring.v +++ b/plugins/setoid_ring/Cring.v @@ -19,6 +19,7 @@ Require Export Algebra_syntax. Require Export Ncring. Require Export Ncring_initial. Require Export Ncring_tac. +Require Import InitialRing. Class Cring {R:Type}`{Rr:Ring R} := cring_mul_comm: forall x y:R, x * y == y * x. diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index b4300da4d5..3736bc47a5 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -730,7 +730,6 @@ Qed. (* The input: syntax of a field expression *) -#[universes(template)] Inductive FExpr : Type := | FEO : FExpr | FEI : FExpr @@ -763,7 +762,6 @@ Strategy expand [FEeval]. (* The result of the normalisation *) -#[universes(template)] Record linear : Type := mk_linear { num : PExpr C; denum : PExpr C; @@ -946,7 +944,6 @@ induction e2; intros p1 p2; now rewrite <- PEpow_mul_r. Qed. -#[universes(template)] Record rsplit : Type := mk_rsplit { rsplit_left : PExpr C; rsplit_common : PExpr C; diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index b024f65988..a98a963207 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -740,7 +740,6 @@ Ltac abstract_ring_morphism set ext rspec := | _ => fail 1 "bad ring structure" end. -#[universes(template)] Record hypo : Type := mkhypo { hypo_type : Type; hypo_proof : hypo_type diff --git a/plugins/setoid_ring/Ncring_polynom.v b/plugins/setoid_ring/Ncring_polynom.v index 6a8c514a7b..048c8eecf9 100644 --- a/plugins/setoid_ring/Ncring_polynom.v +++ b/plugins/setoid_ring/Ncring_polynom.v @@ -32,7 +32,6 @@ Variable phiCR_comm: forall (c:C)(x:R), x * [c] == [c] * x. with coefficients in C : *) -#[universes(template)] Inductive Pol : Type := | Pc : C -> Pol | PX : Pol -> positive -> positive -> Pol -> Pol. diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index 9d56084fd4..092114ff0b 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -121,7 +121,6 @@ Section MakeRingPol. - (Pinj i (Pc c)) is (Pc c) *) - #[universes(template)] Inductive Pol : Type := | Pc : C -> Pol | Pinj : positive -> Pol -> Pol @@ -909,7 +908,6 @@ Section MakeRingPol. (** Definition of polynomial expressions *) - #[universes(template)] Inductive PExpr : Type := | PEO : PExpr | PEI : PExpr diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index 8f24b281c6..dc45853458 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -540,7 +540,6 @@ Section AddRing. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. *) -#[universes(template)] Inductive ring_kind : Type := | Abstract | Computational diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index eb75fca0a1..76c393450b 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -18,7 +18,6 @@ open EConstr open Vars open CClosure open Environ -open Libnames open Globnames open Glob_term open Locus @@ -151,7 +150,7 @@ let ic_unsafe c = (*FIXME remove *) let decl_constant na univs c = let open Constr in let vars = CVars.universes_of_constr c in - let univs = UState.restrict_universe_context univs vars in + let univs = UState.restrict_universe_context ~lbound:(Global.universes_lbound ()) univs vars in let () = Declare.declare_universe_context ~poly:false univs in let types = (Typeops.infer (Global.env ()) c).uj_type in let univs = Monomorphic_entry Univ.ContextSet.empty in @@ -326,19 +325,18 @@ let _ = add_map "ring" module Cmap = Map.Make(Constr) let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table" -let from_name = Summary.ref Spmap.empty ~name:"ring-tac-name-table" let print_rings () = Feedback.msg_notice (strbrk "The following ring structures have been declared:"); - Spmap.iter (fun fn fi -> + Cmap.iter (fun _carrier ring -> let env = Global.env () in let sigma = Evd.from_env env in Feedback.msg_notice (hov 2 - (Ppconstr.pr_id (Libnames.basename fn)++spc()++ - str"with carrier "++ pr_constr_env env sigma fi.ring_carrier++spc()++ - str"and equivalence relation "++ pr_constr_env env sigma fi.ring_req)) - ) !from_name + (Ppconstr.pr_id ring.ring_name ++ spc() ++ + str"with carrier "++ pr_constr_env env sigma ring.ring_carrier++spc()++ + str"and equivalence relation "++ pr_constr_env env sigma ring.ring_req)) + ) !from_carrier let ring_for_carrier r = Cmap.find r !from_carrier @@ -361,9 +359,7 @@ let find_ring_structure env sigma l = | [] -> assert false let add_entry (sp,_kn) e = - from_carrier := Cmap.add e.ring_carrier e !from_carrier; - from_name := Spmap.add sp e !from_name - + from_carrier := Cmap.add e.ring_carrier e !from_carrier let subst_th (subst,th) = let c' = subst_mps subst th.ring_carrier in @@ -391,7 +387,8 @@ let subst_th (subst,th) = pretac' == th.ring_pre_tac && posttac' == th.ring_post_tac then th else - { ring_carrier = c'; + { ring_name = th.ring_name; + ring_carrier = c'; ring_req = eq'; ring_setoid = set'; ring_ext = ext'; @@ -428,59 +425,6 @@ let op_morph r add mul opp req m1 m2 m3 = let op_smorph r add mul req m1 m2 = lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |] -(* let default_ring_equality (r,add,mul,opp,req) = *) -(* let is_setoid = function *) -(* {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *) -(* eq_constr_nounivs req rel (\* Qu: use conversion ? *\) *) -(* | _ -> false in *) -(* match default_relation_for_carrier ~filter:is_setoid r with *) -(* Leibniz _ -> *) -(* let setoid = lapp coq_eq_setoid [|r|] in *) -(* let op_morph = *) -(* match opp with *) -(* Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] *) -(* | None -> lapp coq_eq_smorph [|r;add;mul|] in *) -(* (setoid,op_morph) *) -(* | Relation rel -> *) -(* let setoid = setoid_of_relation rel in *) -(* let is_endomorphism = function *) -(* { args=args } -> List.for_all *) -(* (function (var,Relation rel) -> *) -(* var=None && eq_constr_nounivs req rel *) -(* | _ -> false) args in *) -(* let add_m = *) -(* try default_morphism ~filter:is_endomorphism add *) -(* with Not_found -> *) -(* error "ring addition should be declared as a morphism" in *) -(* let mul_m = *) -(* try default_morphism ~filter:is_endomorphism mul *) -(* with Not_found -> *) -(* error "ring multiplication should be declared as a morphism" in *) -(* let op_morph = *) -(* match opp with *) -(* | Some opp -> *) -(* (let opp_m = *) -(* try default_morphism ~filter:is_endomorphism opp *) -(* with Not_found -> *) -(* error "ring opposite should be declared as a morphism" in *) -(* let op_morph = *) -(* op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in *) -(* msgnl *) -(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++ *) -(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) -(* str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++ *) -(* str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++ *) -(* str"\""); *) -(* op_morph) *) -(* | None -> *) -(* (msgnl *) -(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++ *) -(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) -(* str"\""++spc()++str"and \""++ *) -(* pr_constr mul_m.morphism_theory++str"\""); *) -(* op_smorph r add mul req add_m.lem mul_m.lem) in *) -(* (setoid,op_morph) *) - let ring_equality env evd (r,add,mul,opp,req) = match EConstr.kind !evd req with | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> @@ -657,7 +601,8 @@ let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div let _ = Lib.add_leaf name (theory_to_obj - { ring_carrier = r; + { ring_name = name; + ring_carrier = r; ring_req = req; ring_setoid = sth; ring_ext = params.(1); @@ -835,19 +780,18 @@ let dest_field env evd th_spec = | _ -> error "bad field structure" let field_from_carrier = Summary.ref Cmap.empty ~name:"field-tac-carrier-table" -let field_from_name = Summary.ref Spmap.empty ~name:"field-tac-name-table" let print_fields () = Feedback.msg_notice (strbrk "The following field structures have been declared:"); - Spmap.iter (fun fn fi -> + Cmap.iter (fun _carrier fi -> let env = Global.env () in let sigma = Evd.from_env env in Feedback.msg_notice (hov 2 - (Ppconstr.pr_id (Libnames.basename fn)++spc()++ + (Id.print fi.field_name ++ spc() ++ str"with carrier "++ pr_constr_env env sigma fi.field_carrier++spc()++ str"and equivalence relation "++ pr_constr_env env sigma fi.field_req)) - ) !field_from_name + ) !field_from_carrier let field_for_carrier r = Cmap.find r !field_from_carrier @@ -871,8 +815,7 @@ let find_field_structure env sigma l = | [] -> assert false let add_field_entry (sp,_kn) e = - field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier; - field_from_name := Spmap.add sp e !field_from_name + field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier let subst_th (subst,th) = let c' = subst_mps subst th.field_carrier in @@ -898,7 +841,8 @@ let subst_th (subst,th) = pretac' == th.field_pre_tac && posttac' == th.field_post_tac then th else - { field_carrier = c'; + { field_name = th.field_name; + field_carrier = c'; field_req = eq'; field_cst_tac = tac'; field_pow_tac = pow_tac'; @@ -983,7 +927,8 @@ let add_field_theory0 name fth eqth morphth cst_tac inj (pre,post) power sign od let _ = Lib.add_leaf name (ftheory_to_obj - { field_carrier = r; + { field_name = name; + field_carrier = r; field_req = req; field_cst_tac = cst_tac; field_pow_tac = pow_tac; diff --git a/plugins/setoid_ring/newring_ast.ml b/plugins/setoid_ring/newring_ast.ml index 0a3e7bd9ca..b81f5f7d14 100644 --- a/plugins/setoid_ring/newring_ast.ml +++ b/plugins/setoid_ring/newring_ast.ml @@ -40,7 +40,8 @@ type 'constr field_mod = | Inject of constr_expr type ring_info = - { ring_carrier : types; + { ring_name : Names.Id.t; + ring_carrier : types; ring_req : constr; ring_setoid : constr; ring_ext : constr; @@ -54,7 +55,8 @@ type ring_info = ring_post_tac : glob_tactic_expr } type field_info = - { field_carrier : types; + { field_name : Names.Id.t; + field_carrier : types; field_req : constr; field_cst_tac : glob_tactic_expr; field_pow_tac : glob_tactic_expr; diff --git a/plugins/setoid_ring/newring_ast.mli b/plugins/setoid_ring/newring_ast.mli index 0a3e7bd9ca..b81f5f7d14 100644 --- a/plugins/setoid_ring/newring_ast.mli +++ b/plugins/setoid_ring/newring_ast.mli @@ -40,7 +40,8 @@ type 'constr field_mod = | Inject of constr_expr type ring_info = - { ring_carrier : types; + { ring_name : Names.Id.t; + ring_carrier : types; ring_req : constr; ring_setoid : constr; ring_ext : constr; @@ -54,7 +55,8 @@ type ring_info = ring_post_tac : glob_tactic_expr } type field_info = - { field_carrier : types; + { field_name : Names.Id.t; + field_carrier : types; field_req : constr; field_cst_tac : glob_tactic_expr; field_pow_tac : glob_tactic_expr; diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index bf0761d3ae..376410658a 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -1323,7 +1323,6 @@ Proof. by move=> x y r2xy; apply/orP; right. Qed. (** Variant of simpl_pred specialised to the membership operator. **) -#[universes(template)] Variant mem_pred T := Mem of pred T. (** @@ -1464,7 +1463,6 @@ Implicit Types (mp : mem_pred T). Definition Acoll : collective_pred T := [pred x | ...]. as the collective_pred_of_simpl is _not_ convertible to pred_of_simpl. **) -#[universes(template)] Structure registered_applicative_pred p := RegisteredApplicativePred { applicative_pred_value :> pred T; _ : applicative_pred_value = p @@ -1473,21 +1471,18 @@ Definition ApplicativePred p := RegisteredApplicativePred (erefl p). Canonical applicative_pred_applicative sp := ApplicativePred (applicative_pred_of_simpl sp). -#[universes(template)] Structure manifest_simpl_pred p := ManifestSimplPred { simpl_pred_value :> simpl_pred T; _ : simpl_pred_value = SimplPred p }. Canonical expose_simpl_pred p := ManifestSimplPred (erefl (SimplPred p)). -#[universes(template)] Structure manifest_mem_pred p := ManifestMemPred { mem_pred_value :> mem_pred T; _ : mem_pred_value = Mem [eta p] }. Canonical expose_mem_pred p := ManifestMemPred (erefl (Mem [eta p])). -#[universes(template)] Structure applicative_mem_pred p := ApplicativeMemPred {applicative_mem_pred_value :> manifest_mem_pred p}. Canonical check_applicative_mem_pred p (ap : registered_applicative_pred p) := @@ -1538,7 +1533,6 @@ End PredicateSimplification. (** Qualifiers and keyed predicates. **) -#[universes(template)] Variant qualifier (q : nat) T := Qualifier of {pred T}. Coercion has_quality n T (q : qualifier n T) : {pred T} := @@ -1573,7 +1567,6 @@ Variable T : Type. Variant pred_key (p : {pred T}) := DefaultPredKey. Variable p : {pred T}. -#[universes(template)] Structure keyed_pred (k : pred_key p) := PackKeyedPred {unkey_pred :> {pred T}; _ : unkey_pred =i p}. @@ -1605,7 +1598,6 @@ Section KeyedQualifier. Variables (T : Type) (n : nat) (q : qualifier n T). -#[universes(template)] Structure keyed_qualifier (k : pred_key q) := PackKeyedQualifier {unkey_qualifier; _ : unkey_qualifier = q}. Definition KeyedQualifier k := PackKeyedQualifier k (erefl q). diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 473612fda7..dbb60e6712 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -680,6 +680,10 @@ let pf_type_id gl t = Id.of_string (Namegen.hdchar (pf_env gl) (project gl) t) let pfe_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty +let pfe_new_type gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma,t = Evarutil.new_Type sigma in + re_sig it sigma, t let pfe_type_relevance_of gl t = let gl, ty = pfe_type_of gl t in gl, ty, pf_apply Retyping.relevance_of_term gl t diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index e920bc318a..db1d2d456e 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -205,6 +205,7 @@ val pf_type_of : val pfe_type_of : Goal.goal Evd.sigma -> EConstr.t -> Goal.goal Evd.sigma * EConstr.types +val pfe_new_type : Goal.goal Evd.sigma -> Goal.goal Evd.sigma * EConstr.types val pfe_type_relevance_of : Goal.goal Evd.sigma -> EConstr.t -> Goal.goal Evd.sigma * EConstr.types * Sorts.relevance diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index 71abafc22f..9ebdf71329 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -209,7 +209,6 @@ Register abstract_key as plugins.ssreflect.abstract_key. Register abstract as plugins.ssreflect.abstract. (** Constants for tactic-views **) -#[universes(template)] Inductive external_view : Type := tactic_view of Type. (** diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 4c6b7cdcb6..742890637a 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -109,6 +109,11 @@ let congrtac ((n, t), ty) ist gl = loop 1 in tclTHEN (refine_with cf) (tclTRY (Proofview.V82.of_tactic Tactics.reflexivity)) gl +let pf_typecheck t gl = + let it = sig_it gl in + let sigma,_ = pf_type_of gl t in + re_sig [it] sigma + let newssrcongrtac arg ist gl = ppdebug(lazy Pp.(str"===newcongr===")); ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (pf_concl gl))); @@ -134,10 +139,17 @@ let newssrcongrtac arg ist gl = tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) (fun ty -> congrtac (arg, Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) ty) ist) (fun () -> - let lhs, gl' = mk_evar gl EConstr.mkProp in let rhs, gl' = mk_evar gl' EConstr.mkProp in + let gl', t_lhs = pfe_new_type gl in + let gl', t_rhs = pfe_new_type gl' in + let lhs, gl' = mk_evar gl' t_lhs in + let rhs, gl' = mk_evar gl' t_rhs in let arrow = EConstr.mkArrow lhs Sorts.Relevant (EConstr.Vars.lift 1 rhs) in tclMATCH_GOAL (arrow, gl') (fun gl' -> [|fs gl' lhs;fs gl' rhs|]) - (fun lr -> tclTHEN (Proofview.V82.of_tactic (Tactics.apply (ssr_congr lr))) (congrtac (arg, mkRType) ist)) + (fun lr -> + let a = ssr_congr lr in + tclTHENLIST [ pf_typecheck a + ; Proofview.V82.of_tactic (Tactics.apply a) + ; congrtac (arg, mkRType) ist ]) (fun _ _ -> errorstrm Pp.(str"Conclusion is not an equality nor an arrow"))) gl diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index 5e600362b4..0ce3752a51 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -391,19 +391,19 @@ Notation "@^~ x" := (fun f => f x) : fun_scope. Definitions and notation for explicit functions with simplification, i.e., which simpl and /= beta expand (this is complementary to nosimpl). **) +#[universes(template)] +Variant simpl_fun (aT rT : Type) := SimplFun of aT -> rT. + Section SimplFun. Variables aT rT : Type. -#[universes(template)] -Variant simpl_fun := SimplFun of aT -> rT. +Definition fun_of_simpl (f : simpl_fun aT rT) := fun x => let: SimplFun lam := f in lam x. -Definition fun_of_simpl f := fun x => let: SimplFun lam := f in lam x. +End SimplFun. Coercion fun_of_simpl : simpl_fun >-> Funclass. -End SimplFun. - Notation "[ 'fun' : T => E ]" := (SimplFun (fun _ : T => E)) : fun_scope. Notation "[ 'fun' x => E ]" := (SimplFun (fun x => E)) : fun_scope. Notation "[ 'fun' x y => E ]" := (fun x => [fun y => E]) : fun_scope. diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index f3f1d713e9..064ea0a3e3 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -279,7 +279,7 @@ let interp_search_notation ?loc tag okey = Feedback.msg_warning (hov 4 (qtag "In" ++ str "also occurs in " ++ pr_ntns')) end; ntn | [ntn] -> - Feedback.msg_info (hov 4 (qtag "In" ++ str "is part of notation " ++ pr_ntn ntn)); ntn + Feedback.msg_notice (hov 4 (qtag "In" ++ str "is part of notation " ++ pr_ntn ntn)); ntn | ntns' -> let e = str "occurs in" ++ spc() ++ pr_and_list pr_ntn ntns' in err (hov 4 (str "ambiguous: " ++ qtag "in" ++ e)) in @@ -297,7 +297,7 @@ let interp_search_notation ?loc tag okey = let rbody = glob_constr_of_notation_constr ?loc body in let m_body = hov 0 (Constrextern.without_symbols prl_glob_constr rbody) in let m = m_sc ++ pr_ntn ntn_pat ++ spc () ++ str "denotes " ++ m_body in - Feedback.msg_info (hov 0 m) in + Feedback.msg_notice (hov 0 m) in if List.length !scs > 1 then let scs' = List.remove (=) sc !scs in let w = pr_ntn ntn ++ str " is also defined " ++ pr_scs scs' in @@ -464,7 +464,7 @@ let interp_modloc mr = let ssrdisplaysearch gr env t = let pr_res = pr_global gr ++ str ":" ++ spc () ++ pr_lconstr_env env Evd.empty t in - Feedback.msg_info (hov 2 pr_res ++ fnl ()) + Feedback.msg_notice (hov 2 pr_res ++ fnl ()) } @@ -559,7 +559,7 @@ END let print_view_hints env sigma kind l = let pp_viewname = str "Hint View" ++ pr_viewpos (Some kind) ++ str " " in let pp_hints = pr_list spc (pr_rawhintref env sigma) l in - Feedback.msg_info (pp_viewname ++ hov 0 pp_hints ++ Pp.cut ()) + Feedback.msg_notice (pp_viewname ++ hov 0 pp_hints ++ Pp.cut ()) } diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index be21a3a60d..288a349b8b 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -773,7 +773,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (* Evar must be undefined since we have flushed evars *) let () = if !debug_unification then let open Pp in - Feedback.msg_notice (v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ())) in + Feedback.msg_debug (v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ())) in match (flex_kind_of_term flags env evd term1 sk1, flex_kind_of_term flags env evd term2 sk2) with | Flexible (sp1,al1), Flexible (sp2,al2) -> @@ -1569,7 +1569,7 @@ let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = let (term2,l2 as appr2) = try destApp evd t2 with DestKO -> (t2, [||]) in let () = if !debug_unification then let open Pp in - Feedback.msg_notice (v 0 (str "Heuristic:" ++ spc () ++ + Feedback.msg_debug (v 0 (str "Heuristic:" ++ spc () ++ Termops.Internal.print_constr_env env evd t1 ++ cut () ++ Termops.Internal.print_constr_env env evd t2 ++ cut ())) in let app_empty = Array.is_empty l1 && Array.is_empty l2 in diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 7362955eb7..df161b747a 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -918,7 +918,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let () = if !debug_RAKAM then let open Pp in let pr c = Termops.Internal.print_constr_env env sigma c in - Feedback.msg_notice + Feedback.msg_debug (h 0 (str "<<" ++ pr x ++ str "|" ++ cut () ++ Cst_stack.pr env sigma cst_l ++ str "|" ++ cut () ++ Stack.pr pr stack ++ @@ -927,7 +927,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let c0 = EConstr.kind sigma x in let fold () = let () = if !debug_RAKAM then - let open Pp in Feedback.msg_notice (str "<><><><><>") in + let open Pp in Feedback.msg_debug (str "<><><><><>") in ((EConstr.of_kind c0, stack),cst_l) in match c0 with diff --git a/printing/prettyp.ml b/printing/prettyp.ml index f82b9cef68..fb0b1eca8d 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -35,14 +35,14 @@ module NamedDecl = Context.Named.Declaration type object_pr = { print_inductive : MutInd.t -> UnivNames.univ_name_list option -> Pp.t; - print_constant_with_infos : Constant.t -> UnivNames.univ_name_list option -> Pp.t; + print_constant_with_infos : Opaqueproof.indirect_accessor -> Constant.t -> UnivNames.univ_name_list option -> Pp.t; print_section_variable : env -> Evd.evar_map -> variable -> Pp.t; print_syntactic_def : env -> KerName.t -> Pp.t; print_module : bool -> ModPath.t -> Pp.t; print_modtype : ModPath.t -> Pp.t; print_named_decl : env -> Evd.evar_map -> Constr.named_declaration -> Pp.t; - print_library_entry : env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option; - print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; + print_library_entry : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option; + print_context : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.t; print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t; } @@ -221,14 +221,22 @@ let print_if_is_coercion ref = (*******************) (* *) +let pr_template_variables = function + | [] -> mt () + | vars -> str "on " ++ prlist_with_sep spc UnivNames.pr_with_global_universes vars + let print_polymorphism ref = let poly = Global.is_polymorphic ref in let template_poly = Global.is_template_polymorphic ref in - [ pr_global ref ++ str " is " ++ str - (if poly then "universe polymorphic" + let template_checked = Global.is_template_checked ref in + let template_variables = Global.get_template_polymorphic_variables ref in + [ pr_global ref ++ str " is " ++ + (if poly then str "universe polymorphic" else if template_poly then - "template universe polymorphic" - else "not universe polymorphic") ] + (if not template_checked then str "assumed " else mt()) ++ + str "template universe polymorphic " + ++ h 0 (pr_template_variables template_variables) + else str "not universe polymorphic") ] let print_type_in_type ref = let unsafe = Global.is_type_in_type ref in @@ -552,10 +560,10 @@ let print_instance sigma cb = let inst = Univ.make_abstract_instance univs in pr_universe_instance sigma inst else mt() - -let print_constant with_values sep sp udecl = + +let print_constant indirect_accessor with_values sep sp udecl = let cb = Global.lookup_constant sp in - let val_0 = Global.body_of_constant_body Library.indirect_accessor cb in + let val_0 = Global.body_of_constant_body indirect_accessor cb in let typ = cb.const_type in let univs = let open Univ in @@ -563,7 +571,7 @@ let print_constant with_values sep sp udecl = match cb.const_body with | Undef _ | Def _ | Primitive _ -> cb.const_universes | OpaqueDef o -> - let body_uctxs = Opaqueproof.force_constraints Library.indirect_accessor otab o in + let body_uctxs = Opaqueproof.force_constraints indirect_accessor otab o in match cb.const_universes with | Monomorphic ctx -> Monomorphic (ContextSet.union body_uctxs ctx) @@ -593,8 +601,8 @@ let print_constant with_values sep sp udecl = (if with_values then print_typed_body env sigma (Some c,typ) else pr_ltype typ)++ Printer.pr_universes sigma univs ?priv) -let gallina_print_constant_with_infos sp udecl = - print_constant true " = " sp udecl ++ +let gallina_print_constant_with_infos indirect_accessor sp udecl = + print_constant indirect_accessor true " = " sp udecl ++ with_line_skip (print_name_infos (GlobRef.ConstRef sp)) let gallina_print_syntactic_def env kn = @@ -610,7 +618,7 @@ let gallina_print_syntactic_def env kn = Constrextern.without_specific_symbols [Notation.SynDefRule kn] (pr_glob_constr_env env) c) -let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) = +let gallina_print_leaf_entry indirect_accessor env sigma with_values ((sp,kn as oname),lobj) = let sep = if with_values then " = " else " : " in match lobj with | AtomicObject o -> @@ -621,7 +629,7 @@ let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) = constraints *) (try Some(print_named_decl env sigma (basename sp)) with Not_found -> None) | (_,"CONSTANT") -> - Some (print_constant with_values sep (Constant.make1 kn) None) + Some (print_constant indirect_accessor with_values sep (Constant.make1 kn) None) | (_,"INDUCTIVE") -> Some (gallina_print_inductive (MutInd.make1 kn) None) | (_,("AUTOHINT"|"GRAMMAR"|"SYNTAXCONSTANT"|"PPSYNTAX"|"TOKEN"|"CLASS"| @@ -637,24 +645,24 @@ let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) = Some (print_modtype (MPdot (mp,l))) | _ -> None -let gallina_print_library_entry env sigma with_values ent = +let gallina_print_library_entry indirect_accessor env sigma with_values ent = let pr_name (sp,_) = Id.print (basename sp) in match ent with | (oname,Lib.Leaf lobj) -> - gallina_print_leaf_entry env sigma with_values (oname,lobj) + gallina_print_leaf_entry indirect_accessor env sigma with_values (oname,lobj) | (oname,Lib.OpenedSection (dir,_)) -> - Some (str " >>>>>>> Section " ++ pr_name oname) + Some (str " >>>>>>> Section " ++ pr_name oname) | (_,Lib.CompilingLibrary { Nametab.obj_dir; _ }) -> - Some (str " >>>>>>> Library " ++ DirPath.print obj_dir) + Some (str " >>>>>>> Library " ++ DirPath.print obj_dir) | (oname,Lib.OpenedModule _) -> - Some (str " >>>>>>> Module " ++ pr_name oname) + Some (str " >>>>>>> Module " ++ pr_name oname) -let gallina_print_context env sigma with_values = +let gallina_print_context indirect_accessor env sigma with_values = let rec prec n = function | h::rest when Option.is_empty n || Option.get n > 0 -> - (match gallina_print_library_entry env sigma with_values h with - | None -> prec n rest - | Some pp -> prec (Option.map ((+) (-1)) n) rest ++ pp ++ fnl ()) + (match gallina_print_library_entry indirect_accessor env sigma with_values h with + | None -> prec n rest + | Some pp -> prec (Option.map ((+) (-1)) n) rest ++ pp ++ fnl ()) | _ -> mt () in prec @@ -712,10 +720,10 @@ let print_safe_judgment env sigma j = (*********************) (* *) -let print_full_context env sigma = print_context env sigma true None (Lib.contents ()) -let print_full_context_typ env sigma = print_context env sigma false None (Lib.contents ()) +let print_full_context indirect_accessor env sigma = print_context indirect_accessor env sigma true None (Lib.contents ()) +let print_full_context_typ indirect_accessor env sigma = print_context indirect_accessor env sigma false None (Lib.contents ()) -let print_full_pure_context env sigma = +let print_full_pure_context ~library_accessor env sigma = let rec prec = function | ((_,kn),Lib.Leaf AtomicObject lobj)::rest -> let pp = match object_tag lobj with @@ -731,8 +739,8 @@ let print_full_pure_context env sigma = | OpaqueDef lc -> str "Theorem " ++ print_basename con ++ cut () ++ str " : " ++ pr_ltype_env env sigma typ ++ str "." ++ fnl () ++ - str "Proof " ++ pr_lconstr_env env sigma (fst (Opaqueproof.force_proof Library.indirect_accessor (Global.opaque_tables ()) lc)) - | Def c -> + str "Proof " ++ pr_lconstr_env env sigma (fst (Opaqueproof.force_proof library_accessor (Global.opaque_tables ()) lc)) + | Def c -> str "Definition " ++ print_basename con ++ cut () ++ str " : " ++ pr_ltype_env env sigma typ ++ cut () ++ str " := " ++ pr_lconstr_env env sigma (Mod_subst.force_constr c) @@ -779,11 +787,11 @@ let read_sec_context qid = let cxt = Lib.contents () in List.rev (get_cxt [] cxt) -let print_sec_context env sigma sec = - print_context env sigma true None (read_sec_context sec) +let print_sec_context indirect_accessor env sigma sec = + print_context indirect_accessor env sigma true None (read_sec_context sec) -let print_sec_context_typ env sigma sec = - print_context env sigma false None (read_sec_context sec) +let print_sec_context_typ indirect_accessor env sigma sec = + print_context indirect_accessor env sigma false None (read_sec_context sec) let maybe_error_reject_univ_decl na udecl = let open GlobRef in @@ -793,11 +801,11 @@ let maybe_error_reject_univ_decl na udecl = (* TODO Print na somehow *) user_err ~hdr:"reject_univ_decl" (str "This object does not support universe names.") -let print_any_name env sigma na udecl = +let print_any_name indirect_accessor env sigma na udecl = maybe_error_reject_univ_decl na udecl; let open GlobRef in match na with - | Term (ConstRef sp) -> print_constant_with_infos sp udecl + | Term (ConstRef sp) -> print_constant_with_infos indirect_accessor sp udecl | Term (IndRef (sp,_)) -> print_inductive sp udecl | Term (ConstructRef ((sp,_),_)) -> print_inductive sp udecl | Term (VarRef sp) -> print_section_variable env sigma sp @@ -816,34 +824,34 @@ let print_any_name env sigma na udecl = user_err ~hdr:"print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") -let print_name env sigma na udecl = +let print_name indirect_accessor env sigma na udecl = match na with | {loc; v=Constrexpr.ByNotation (ntn,sc)} -> - print_any_name env sigma - (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) + print_any_name indirect_accessor env sigma + (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc)) - udecl + udecl | {loc; v=Constrexpr.AN ref} -> - print_any_name env sigma (locate_any_name ref) udecl + print_any_name indirect_accessor env sigma (locate_any_name ref) udecl -let print_opaque_name env sigma qid = +let print_opaque_name indirect_accessor env sigma qid = let open GlobRef in match Nametab.global qid with | ConstRef cst -> - let cb = Global.lookup_constant cst in - if Declareops.constant_has_body cb then - print_constant_with_infos cst None - else - user_err Pp.(str "Not a defined constant.") + let cb = Global.lookup_constant cst in + if Declareops.constant_has_body cb then + print_constant_with_infos indirect_accessor cst None + else + user_err Pp.(str "Not a defined constant.") | IndRef (sp,_) -> - print_inductive sp None + print_inductive sp None | ConstructRef cstr as gr -> - let ty, ctx = Typeops.type_of_global_in_context env gr in - let ty = EConstr.of_constr ty in - let open EConstr in - print_typed_value_in_env env sigma (mkConstruct cstr, ty) + let ty, ctx = Typeops.type_of_global_in_context env gr in + let ty = EConstr.of_constr ty in + let open EConstr in + print_typed_value_in_env env sigma (mkConstruct cstr, ty) | VarRef id -> - env |> lookup_named id |> print_named_decl env sigma + env |> lookup_named id |> print_named_decl env sigma let print_about_any ?loc env sigma k udecl = maybe_error_reject_univ_decl k udecl; @@ -880,9 +888,8 @@ let print_about env sigma na udecl = print_about_any ?loc env sigma (locate_any_name ref) udecl (* for debug *) -let inspect env sigma depth = - print_context env sigma false (Some depth) (Lib.contents ()) - +let inspect indirect_accessor env sigma depth = + print_context indirect_accessor env sigma false (Some depth) (Lib.contents ()) (*************************************************************************) (* Pretty-printing functions coming from classops.ml *) diff --git a/printing/prettyp.mli b/printing/prettyp.mli index 7485f4bd19..4299bcc880 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -18,22 +18,41 @@ open Libnames val assumptions_for_print : Name.t list -> Termops.names_context val print_closed_sections : bool ref -val print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t -val print_library_entry : env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option -val print_full_context : env -> Evd.evar_map -> Pp.t -val print_full_context_typ : env -> Evd.evar_map -> Pp.t -val print_full_pure_context : env -> Evd.evar_map -> Pp.t -val print_sec_context : env -> Evd.evar_map -> qualid -> Pp.t -val print_sec_context_typ : env -> Evd.evar_map -> qualid -> Pp.t +val print_context + : Opaqueproof.indirect_accessor + -> env -> Evd.evar_map + -> bool -> int option -> Lib.library_segment -> Pp.t +val print_library_entry + : Opaqueproof.indirect_accessor + -> env -> Evd.evar_map + -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option +val print_full_context + : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> Pp.t +val print_full_context_typ + : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> Pp.t + +val print_full_pure_context + : library_accessor:Opaqueproof.indirect_accessor + -> env + -> Evd.evar_map + -> Pp.t + +val print_sec_context + : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> qualid -> Pp.t +val print_sec_context_typ + : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> qualid -> Pp.t val print_judgment : env -> Evd.evar_map -> EConstr.unsafe_judgment -> Pp.t val print_safe_judgment : env -> Evd.evar_map -> Safe_typing.judgment -> Pp.t val print_eval : reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t -val print_name : env -> Evd.evar_map -> qualid Constrexpr.or_by_notation -> - UnivNames.univ_name_list option -> Pp.t -val print_opaque_name : env -> Evd.evar_map -> qualid -> Pp.t +val print_name + : Opaqueproof.indirect_accessor + -> env -> Evd.evar_map -> qualid Constrexpr.or_by_notation + -> UnivNames.univ_name_list option -> Pp.t +val print_opaque_name + : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> qualid -> Pp.t val print_about : env -> Evd.evar_map -> qualid Constrexpr.or_by_notation -> UnivNames.univ_name_list option -> Pp.t val print_impargs : qualid Constrexpr.or_by_notation -> Pp.t @@ -50,7 +69,7 @@ val print_typeclasses : unit -> Pp.t val print_instances : GlobRef.t -> Pp.t val print_all_instances : unit -> Pp.t -val inspect : env -> Evd.evar_map -> int -> Pp.t +val inspect : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> int -> Pp.t (** {5 Locate} *) @@ -83,14 +102,14 @@ val print_located_other : string -> qualid -> Pp.t type object_pr = { print_inductive : MutInd.t -> UnivNames.univ_name_list option -> Pp.t; - print_constant_with_infos : Constant.t -> UnivNames.univ_name_list option -> Pp.t; + print_constant_with_infos : Opaqueproof.indirect_accessor -> Constant.t -> UnivNames.univ_name_list option -> Pp.t; print_section_variable : env -> Evd.evar_map -> variable -> Pp.t; print_syntactic_def : env -> KerName.t -> Pp.t; print_module : bool -> ModPath.t -> Pp.t; print_modtype : ModPath.t -> Pp.t; print_named_decl : env -> Evd.evar_map -> Constr.named_declaration -> Pp.t; - print_library_entry : env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option; - print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; + print_library_entry : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option; + print_context : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.t; print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t; } diff --git a/printing/printer.ml b/printing/printer.ml index e3225fadd5..328082fbc2 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -854,6 +854,8 @@ type axiom = | Constant of Constant.t (* An axiom or a constant. *) | Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *) | Guarded of GlobRef.t (* a constant whose (co)fixpoints have been assumed to be guarded *) + | TemplatePolymorphic of MutInd.t (* A mutually inductive definition whose template polymorphism + on parameter universes has not been checked. *) | TypeInType of GlobRef.t (* a constant which relies on type in type *) type context_object = @@ -873,10 +875,13 @@ struct Constant.CanOrd.compare k1 k2 | Positive m1 , Positive m2 -> MutInd.CanOrd.compare m1 m2 + | TemplatePolymorphic m1, TemplatePolymorphic m2 -> + MutInd.CanOrd.compare m1 m2 | Guarded k1 , Guarded k2 -> GlobRef.Ordered.compare k1 k2 | _ , Constant _ -> 1 | _ , Positive _ -> 1 + | _, TemplatePolymorphic _ -> 1 | _ -> -1 let compare x y = @@ -937,6 +942,9 @@ let pr_assumptionset env sigma s = hov 2 (safe_pr_inductive env m ++ spc () ++ strbrk"is assumed to be positive.") | Guarded gr -> hov 2 (safe_pr_global env gr ++ spc () ++ strbrk"is assumed to be guarded.") + | TemplatePolymorphic m -> + hov 2 (safe_pr_inductive env m ++ spc () ++ + strbrk"is assumed template polymorphic on all its universe parameters.") | TypeInType gr -> hov 2 (safe_pr_global env gr ++ spc () ++ strbrk"relies on an unsafe hierarchy.") in diff --git a/printing/printer.mli b/printing/printer.mli index 788f303aee..d62d3789d3 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -192,6 +192,8 @@ type axiom = | Constant of Constant.t (* An axiom or a constant. *) | Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *) | Guarded of GlobRef.t (* a constant whose (co)fixpoints have been assumed to be guarded *) + | TemplatePolymorphic of MutInd.t (* A mutually inductive definition whose template polymorphism + on parameter universes has not been checked. *) | TypeInType of GlobRef.t (* a constant which relies on type in type *) type context_object = diff --git a/printing/printmod.ml b/printing/printmod.ml index 43992ec9d3..141469ff9c 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -242,7 +242,7 @@ let nametab_register_body mp dir (l,body) = let nametab_register_module_body mp struc = (* If [mp] is a globally visible module, we simply import it *) - try Declaremods.really_import_module mp + try Declaremods.import_module ~export:false mp with Not_found -> (* Otherwise we try to emulate an import by playing with nametab *) nametab_register_dir mp; diff --git a/proofs/goal.ml b/proofs/goal.ml index 888c4785df..f95a904a5f 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -91,7 +91,8 @@ module V82 = struct let weak_progress glss gls = match glss.Evd.it with - | [ g ] -> not (Proofview.Progress.goal_equal glss.Evd.sigma g gls.Evd.sigma gls.Evd.it) + | [ g ] -> not (Proofview.Progress.goal_equal ~evd:gls.Evd.sigma + ~extended_evd:glss.Evd.sigma gls.Evd.it g) | _ -> true let progress glss gls = diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 0ce726db25..756fef0511 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -6,9 +6,7 @@ Proof Logic Goal_select Proof_bullet -Proof_global Refiner Tacmach -Pfedit Clenv Clenvtac diff --git a/stm/stm.ml b/stm/stm.ml index 7f0632bd7c..1042061021 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2617,13 +2617,10 @@ let dirpath_of_file f = let new_doc { doc_type ; iload_path; require_libs; stm_options } = - let load_objs libs = - let rq_file (dir, from, exp) = - let mp = Libnames.qualid_of_string dir in - let mfrom = Option.map Libnames.qualid_of_string from in - Flags.silently (Vernacentries.vernac_require mfrom exp) [mp] in - List.(iter rq_file (rev libs)) - in + let require_file (dir, from, exp) = + let mp = Libnames.qualid_of_string dir in + let mfrom = Option.map Libnames.qualid_of_string from in + Flags.silently (Vernacentries.vernac_require mfrom exp) [mp] in (* Set the options from the new documents *) AsyncOpts.cur_opt := stm_options; @@ -2662,7 +2659,7 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = end; (* Import initial libraries. *) - load_objs require_libs; + List.iter require_file require_libs; (* We record the state at this point! *) State.define ~doc ~cache:true ~redefine:true (fun () -> ()) Stateid.initial; diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index fab6767beb..baa7b3570c 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -11,7 +11,6 @@ open Util let check_vio (ts,f_in) = - Dumpglob.noglob (); let _, _, _, tasks, _ = Library.load_library_todo f_in in Stm.set_compilation_hints f_in; List.fold_left (fun acc ids -> Stm.check_task f_in tasks ids && acc) true ts @@ -142,5 +141,3 @@ let schedule_vio_compilation j fs = List.iter (fun (f,_) -> Unix.utimes (Filename.chop_extension f^".vo") t t) all_jobs; end; exit !rc - - diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 09d7e0278a..edeb27ab88 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -69,7 +69,7 @@ let rec shrink ctx sign c t accu = | _ -> assert false let shrink_entry sign const = - let open Proof_global in + let open Declare in let typ = match const.proof_entry_type with | None -> assert false | Some t -> t @@ -151,7 +151,7 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = in let const, args = shrink_entry sign const in let args = List.map EConstr.of_constr args in - let cd = Declare.DefinitionEntry { const with Proof_global.proof_entry_opaque = opaque } in + let cd = Declare.DefinitionEntry { const with Declare.proof_entry_opaque = opaque } in let kind = if opaque then Decls.(IsProof Lemma) else Decls.(IsDefinition Definition) in let cst () = (* do not compute the implicit arguments, it may be costly *) @@ -160,20 +160,20 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = Declare.declare_private_constant ~local:Declare.ImportNeedQualified ~name ~kind cd in let cst, eff = Impargs.with_implicit_protection cst () in - let inst = match const.Proof_global.proof_entry_universes with + let inst = match const.Declare.proof_entry_universes with | Entries.Monomorphic_entry _ -> EInstance.empty | Entries.Polymorphic_entry (_, ctx) -> (* We mimic what the kernel does, that is ensuring that no additional constraints appear in the body of polymorphic constants. Ideally this should be enforced statically. *) - let (_, body_uctx), _ = Future.force const.Proof_global.proof_entry_body in + let (_, body_uctx), _ = Future.force const.Declare.proof_entry_body in let () = assert (Univ.ContextSet.is_empty body_uctx) in EInstance.make (Univ.UContext.instance ctx) in let lem = mkConstU (cst, inst) in let evd = Evd.set_universe_context evd ectx in let effs = Evd.concat_side_effects eff - Proof_global.(snd (Future.force const.proof_entry_body)) in + (snd (Future.force const.Declare.proof_entry_body)) in let solve = Proofview.tclEFFECTS effs <*> tacK lem args diff --git a/tactics/abstract.mli b/tactics/abstract.mli index e278729f89..96ddbea7b2 100644 --- a/tactics/abstract.mli +++ b/tactics/abstract.mli @@ -26,5 +26,5 @@ val tclABSTRACT : ?opaque:bool -> Id.t option -> unit Proofview.tactic -> unit P save path *) val shrink_entry : ('a, 'b) Context.Named.Declaration.pt list - -> 'c Proof_global.proof_entry - -> 'c Proof_global.proof_entry * Constr.t list + -> 'c Declare.proof_entry + -> 'c Declare.proof_entry * Constr.t list diff --git a/tactics/auto.ml b/tactics/auto.ml index 67f49f0074..0b465418f2 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -220,13 +220,13 @@ let tclLOG (dbg,_,depth,trace) pp tac = tac >>= fun v -> tclENV >>= fun env -> tclEVARMAP >>= fun sigma -> - Feedback.msg_debug (str s ++ spc () ++ pp env sigma ++ str ". (*success*)"); + Feedback.msg_notice (str s ++ spc () ++ pp env sigma ++ str ". (*success*)"); tclUNIT v ) tclUNIT (fun (exn, info) -> tclENV >>= fun env -> tclEVARMAP >>= fun sigma -> - Feedback.msg_debug (str s ++ spc () ++ pp env sigma ++ str ". (*fail*)"); + Feedback.msg_notice (str s ++ spc () ++ pp env sigma ++ str ". (*fail*)"); tclZERO ~info exn)) | Info -> (* For "info (trivial/auto)", we store a log trace *) @@ -260,19 +260,19 @@ let pr_info_atom env sigma (d,pp) = let pr_info_trace env sigma = function | (Info,_,_,{contents=(d,Some pp)::l}) -> - Feedback.msg_info (prlist_with_sep fnl (pr_info_atom env sigma) (cleanup_info_trace d [(d,pp)] l)) + Feedback.msg_notice (prlist_with_sep fnl (pr_info_atom env sigma) (cleanup_info_trace d [(d,pp)] l)) | _ -> () let pr_info_nop = function - | (Info,_,_,_) -> Feedback.msg_info (str "idtac.") + | (Info,_,_,_) -> Feedback.msg_notice (str "idtac.") | _ -> () let pr_dbg_header = function | (Off,_,_,_) -> () - | (Debug,ReportForTrivial,_,_) -> Feedback.msg_debug (str "(* debug trivial: *)") - | (Debug,ReportForAuto,_,_) -> Feedback.msg_debug (str "(* debug auto: *)") - | (Info,ReportForTrivial,_,_) -> Feedback.msg_info (str "(* info trivial: *)") - | (Info,ReportForAuto,_,_) -> Feedback.msg_info (str "(* info auto: *)") + | (Debug,ReportForTrivial,_,_) -> Feedback.msg_notice (str "(* debug trivial: *)") + | (Debug,ReportForAuto,_,_) -> Feedback.msg_notice (str "(* debug auto: *)") + | (Info,ReportForTrivial,_,_) -> Feedback.msg_notice (str "(* info trivial: *)") + | (Info,ReportForAuto,_,_) -> Feedback.msg_notice (str "(* info auto: *)") let tclTRY_dbg d tac = let delay f = Proofview.tclUNIT () >>= fun () -> f () in diff --git a/tactics/declare.ml b/tactics/declare.ml index c280760e84..3a02e5451a 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -55,8 +55,20 @@ type constant_obj = { cst_locl : import_status; } +type 'a proof_entry = { + proof_entry_body : 'a Entries.const_entry_body; + (* List of section variables *) + proof_entry_secctx : Constr.named_context option; + (* State id on which the completion of type checking is reported *) + proof_entry_feedback : Stateid.t option; + proof_entry_type : Constr.types option; + proof_entry_universes : Entries.universes_entry; + proof_entry_opaque : bool; + proof_entry_inline_code : bool; +} + type 'a constant_entry = - | DefinitionEntry of 'a Proof_global.proof_entry + | DefinitionEntry of 'a proof_entry | ParameterEntry of parameter_entry | PrimitiveEntry of primitive_entry @@ -174,7 +186,6 @@ let record_aux env s_ty s_bo = let default_univ_entry = Monomorphic_entry Univ.ContextSet.empty let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types ?(univs=default_univ_entry) ?(eff=Evd.empty_side_effects) body = - let open Proof_global in { proof_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), eff); proof_entry_secctx = None; proof_entry_type = types; @@ -184,7 +195,6 @@ let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types proof_entry_inline_code = inline} let cast_proof_entry e = - let open Proof_global in let (body, ctx), () = Future.force e.proof_entry_body in let univs = if Univ.ContextSet.is_empty ctx then e.proof_entry_universes @@ -205,7 +215,6 @@ let cast_proof_entry e = } let cast_opaque_proof_entry e = - let open Proof_global in let typ = match e.proof_entry_type with | None -> assert false | Some typ -> typ @@ -224,7 +233,7 @@ let cast_opaque_proof_entry e = let vars = global_vars_set env pf in ids_typ, vars in - let () = if !Flags.record_aux_file then record_aux env hyp_typ hyp_def in + let () = if Aux_file.recording () then record_aux env hyp_typ hyp_def in keep_hyps env (Id.Set.union hyp_typ hyp_def) | Some hyps -> hyps in @@ -249,7 +258,6 @@ let is_unsafe_typing_flags () = not (flags.check_universes && flags.check_guarded && flags.check_positive) let define_constant ~side_effect ~name cd = - let open Proof_global in (* Logically define the constant and its subproofs, no libobject tampering *) let in_section = Lib.sections_are_opened () in let export, decl, unsafe = match cd with @@ -299,7 +307,7 @@ let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind (** Declaration of section variables and local definitions *) type variable_declaration = - | SectionLocalDef of Evd.side_effects Proof_global.proof_entry + | SectionLocalDef of Evd.side_effects proof_entry | SectionLocalAssum of { typ:Constr.types; univs:Univ.ContextSet.t; poly:bool; impl:Glob_term.binding_kind } (* This object is only for things which iterate over objects to find @@ -321,7 +329,6 @@ let declare_variable ~name ~kind d = | SectionLocalDef (de) -> (* The body should already have been forced upstream because it is a section-local definition, but it's not enforced by typing *) - let open Proof_global in let (body, eff) = Future.force de.proof_entry_body in let ((body, uctx), export) = Global.export_private_constants ~in_section:true (body, eff.Evd.seff_private) in let eff = get_roles export eff in diff --git a/tactics/declare.mli b/tactics/declare.mli index 4ae9f6c7ae..4cb876cecb 100644 --- a/tactics/declare.mli +++ b/tactics/declare.mli @@ -19,14 +19,27 @@ open Entries reset works properly --- and will fill some global tables such as [Nametab] and [Impargs]. *) +(** Proof entries *) +type 'a proof_entry = { + proof_entry_body : 'a Entries.const_entry_body; + (* List of section variables *) + proof_entry_secctx : Constr.named_context option; + (* State id on which the completion of type checking is reported *) + proof_entry_feedback : Stateid.t option; + proof_entry_type : Constr.types option; + proof_entry_universes : Entries.universes_entry; + proof_entry_opaque : bool; + proof_entry_inline_code : bool; +} + (** Declaration of local constructions (Variable/Hypothesis/Local) *) type variable_declaration = - | SectionLocalDef of Evd.side_effects Proof_global.proof_entry + | SectionLocalDef of Evd.side_effects proof_entry | SectionLocalAssum of { typ:types; univs:Univ.ContextSet.t; poly:bool; impl:Glob_term.binding_kind } type 'a constant_entry = - | DefinitionEntry of 'a Proof_global.proof_entry + | DefinitionEntry of 'a proof_entry | ParameterEntry of parameter_entry | PrimitiveEntry of primitive_entry @@ -43,7 +56,7 @@ val declare_variable val definition_entry : ?fix_exn:Future.fix_exn -> ?opaque:bool -> ?inline:bool -> ?types:types -> ?univs:Entries.universes_entry -> - ?eff:Evd.side_effects -> constr -> Evd.side_effects Proof_global.proof_entry + ?eff:Evd.side_effects -> constr -> Evd.side_effects proof_entry type import_status = ImportDefaultBehavior | ImportNeedQualified diff --git a/tactics/eauto.ml b/tactics/eauto.ml index d4e4322bef..2ce32b309a 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -351,13 +351,13 @@ let mk_eauto_dbg d = else Off let pr_info_nop = function - | Info -> Feedback.msg_info (str "idtac.") + | Info -> Feedback.msg_notice (str "idtac.") | _ -> () let pr_dbg_header = function | Off -> () - | Debug -> Feedback.msg_debug (str "(* debug eauto: *)") - | Info -> Feedback.msg_info (str "(* info eauto: *)") + | Debug -> Feedback.msg_notice (str "(* debug eauto: *)") + | Info -> Feedback.msg_notice (str "(* info eauto: *)") let pr_info dbg s = if dbg != Info then () @@ -368,7 +368,7 @@ let pr_info dbg s = | State sp -> let mindepth = loop sp in let indent = String.make (mindepth - sp.depth) ' ' in - Feedback.msg_info (str indent ++ Lazy.force s.last_tactic ++ str "."); + Feedback.msg_notice (str indent ++ Lazy.force s.last_tactic ++ str "."); mindepth in ignore (loop s) diff --git a/tactics/equality.ml b/tactics/equality.ml index 220b9bc475..1f125a3c59 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -255,7 +255,9 @@ let tclNOTSAMEGOAL tac = Proofview.Goal.goals >>= fun gls -> let check accu gl' = gl' >>= fun gl' -> - let accu = accu || Proofview.Progress.goal_equal sigma ev (project gl') (goal gl') in + let accu = accu || Proofview.Progress.goal_equal + ~evd:sigma ~extended_evd:(project gl') ev (goal gl') + in Proofview.tclUNIT accu in Proofview.Monad.List.fold_left check false gls >>= fun has_same -> diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index e2ef05461b..54393dce00 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -124,17 +124,7 @@ let define internal role id c poly univs = let ctx = UState.minimize univs in let c = UnivSubst.nf_evars_and_universes_opt_subst (fun _ -> None) (UState.subst ctx) c in let univs = UState.univ_entry ~poly ctx in - let entry = { - Proof_global.proof_entry_body = - Future.from_val ((c,Univ.ContextSet.empty), - Evd.empty_side_effects); - proof_entry_secctx = None; - proof_entry_type = None; - proof_entry_universes = univs; - proof_entry_opaque = false; - proof_entry_inline_code = false; - proof_entry_feedback = None; - } in + let entry = Declare.definition_entry ~univs c in let kn, eff = Declare.declare_private_constant ~role ~kind:Decls.(IsDefinition Scheme) ~name:id (Declare.DefinitionEntry entry) in let () = match internal with | InternalTacticRequest -> () diff --git a/proofs/pfedit.ml b/tactics/pfedit.ml index 99a254652c..5be7b4fa28 100644 --- a/proofs/pfedit.ml +++ b/tactics/pfedit.ml @@ -124,7 +124,7 @@ let build_constant_by_tactic ~name ctx sign ~poly typ tac = let { entries; universes } = close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pf in match entries with | [entry] -> - let univs = UState.demote_seff_univs entry.Proof_global.proof_entry_universes universes in + let univs = UState.demote_seff_univs entry.Declare.proof_entry_universes universes in entry, status, univs | _ -> CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") @@ -136,7 +136,7 @@ let build_by_tactic ?(side_eff=true) env sigma ~poly typ tac = let name = Id.of_string ("temporary_proof"^string_of_int (next())) in let sign = val_of_named_context (named_context env) in let ce, status, univs = build_constant_by_tactic ~name sigma sign ~poly typ tac in - let body, eff = Future.force ce.Proof_global.proof_entry_body in + let body, eff = Future.force ce.Declare.proof_entry_body in let (cb, ctx) = if side_eff then Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) else body diff --git a/proofs/pfedit.mli b/tactics/pfedit.mli index 0626e40047..30514191fa 100644 --- a/proofs/pfedit.mli +++ b/tactics/pfedit.mli @@ -64,7 +64,7 @@ val build_constant_by_tactic -> poly:bool -> EConstr.types -> unit Proofview.tactic - -> Evd.side_effects Proof_global.proof_entry * bool * UState.t + -> Evd.side_effects Declare.proof_entry * bool * UState.t val build_by_tactic : ?side_eff:bool diff --git a/proofs/proof_global.ml b/tactics/proof_global.ml index 851a3d1135..a2929e45cd 100644 --- a/proofs/proof_global.ml +++ b/tactics/proof_global.ml @@ -24,21 +24,9 @@ module NamedDecl = Context.Named.Declaration (*** Proof Global Environment ***) -type 'a proof_entry = { - proof_entry_body : 'a Entries.const_entry_body; - (* List of section variables *) - proof_entry_secctx : Constr.named_context option; - (* State id on which the completion of type checking is reported *) - proof_entry_feedback : Stateid.t option; - proof_entry_type : Constr.types option; - proof_entry_universes : Entries.universes_entry; - proof_entry_opaque : bool; - proof_entry_inline_code : bool; -} - type proof_object = { name : Names.Id.t - ; entries : Evd.side_effects proof_entry list + ; entries : Evd.side_effects Declare.proof_entry list ; poly : bool ; universes: UState.t ; udecl : UState.universe_decl @@ -223,7 +211,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now let ctx = UState.restrict universes used_univs in let univs = UState.check_univ_decl ~poly ctx udecl in (univs, typ), ((body, Univ.ContextSet.empty), eff) - in + in fun t p -> Future.split2 (Future.chain p (make_body t)) else fun t p -> @@ -250,6 +238,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now let t = EConstr.Unsafe.to_constr t in let univstyp, body = make_body t p in let univs, typ = Future.force univstyp in + let open Declare in { proof_entry_body = body; proof_entry_secctx = section_vars; diff --git a/proofs/proof_global.mli b/tactics/proof_global.mli index 54d5c2087a..d15e23c2cc 100644 --- a/proofs/proof_global.mli +++ b/tactics/proof_global.mli @@ -27,29 +27,11 @@ val get_initial_euctx : t -> UState.t val compact_the_proof : t -> t -(** When a proof is closed, it is reified into a [proof_object], where - [id] is the name of the proof, [entries] the list of the proof terms - (in a form suitable for definitions). Together with the [terminator] - function which takes a [proof_object] together with a [proof_end] - (i.e. an proof ending command) and registers the appropriate - values. *) -type 'a proof_entry = { - proof_entry_body : 'a Entries.const_entry_body; - (* List of section variables *) - proof_entry_secctx : Constr.named_context option; - (* State id on which the completion of type checking is reported *) - proof_entry_feedback : Stateid.t option; - proof_entry_type : Constr.types option; - proof_entry_universes : Entries.universes_entry; - proof_entry_opaque : bool; - proof_entry_inline_code : bool; -} - (** When a proof is closed, it is reified into a [proof_object] *) type proof_object = { name : Names.Id.t (** name of the proof *) - ; entries : Evd.side_effects proof_entry list + ; entries : Evd.side_effects Declare.proof_entry list (** list of the proof terms (in a form suitable for definitions). *) ; poly : bool (** polymorphic status *) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 2d0806b2e0..b93c4a176f 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -546,7 +546,8 @@ module New = struct Proofview.tclOR (Proofview.tclTIMEOUT n t) begin function (e, info) -> match e with - | Proofview.Timeout as e -> Proofview.tclZERO (Refiner.FailError (0,lazy (CErrors.print e))) + | Logic_monad.Tac_Timeout as e -> + Proofview.tclZERO (Refiner.FailError (0,lazy (CErrors.print e))) | e -> Proofview.tclZERO ~info e end diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 6dd749aa0d..c5c7969a09 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -1,4 +1,6 @@ Declare +Proof_global +Pfedit Dnet Dn Btermdn diff --git a/test-suite/.csdp.cache b/test-suite/.csdp.cache Binary files differindex e0324b0232..b3bcb5b056 100644 --- a/test-suite/.csdp.cache +++ b/test-suite/.csdp.cache diff --git a/test-suite/bugs/closed/bug_10757.v b/test-suite/bugs/closed/bug_10757.v new file mode 100644 index 0000000000..a531f6e563 --- /dev/null +++ b/test-suite/bugs/closed/bug_10757.v @@ -0,0 +1,38 @@ +Require Import Program Extraction ExtrOcamlBasic. +Print sig. +Section FIXPOINT. + +Variable A: Type. + +Variable eq: A -> A -> Prop. +Variable beq: A -> A -> bool. +Hypothesis beq_eq: forall x y, beq x y = true -> eq x y. +Hypothesis beq_neq: forall x y, beq x y = false -> ~eq x y. + +Variable le: A -> A -> Prop. +Hypothesis le_trans: forall x y z, le x y -> le y z -> le x z. + +Definition gt (x y: A) := le y x /\ ~eq y x. +Hypothesis gt_wf: well_founded gt. + +Variable F: A -> A. +Hypothesis F_mon: forall x y, le x y -> le (F x) (F y). + +Program Fixpoint iterate + (x: A) (PRE: le x (F x)) (SMALL: forall z, le (F z) z -> le x z) + {wf gt x} + : {y : A | eq y (F y) /\ forall z, le (F z) z -> le y z } := + let x' := F x in + match beq x x' with + | true => x + | false => iterate x' _ _ + end. +Next Obligation. + split. +- auto. +- apply beq_neq. auto. +Qed. + +End FIXPOINT. + +Recursive Extraction iterate. diff --git a/test-suite/bugs/closed/bug_10778.v b/test-suite/bugs/closed/bug_10778.v new file mode 100644 index 0000000000..25d729b7e6 --- /dev/null +++ b/test-suite/bugs/closed/bug_10778.v @@ -0,0 +1,32 @@ +(* Test that fresh avoid the variables of intro patterns but also of + simple intro patterns *) + +Ltac exploit_main t T pat cleanup + := + (lazymatch T with + | ?U1 -> ?U2 => + let H := fresh + in +idtac "H=" H; + assert U1 as H; + [cleanup () | exploit_main (t H) U2 pat ltac:(fun _ => clear H; cleanup ())] + | _ => + pose proof t as pat; + cleanup () + end). + +Tactic Notation "exploit" constr(t) "as" simple_intropattern(pat) + := + exploit_main t ltac:(type of t) pat ltac:(fun _ => idtac). + +Goal (True -> True) -> True. +intro H0. exploit H0 as H. +Abort. + +Tactic Notation "exploit'" constr(t) "as" intropattern(pat) + := + exploit_main t ltac:(type of t) pat ltac:(fun _ => idtac). + +Goal (True -> True) -> True. +intro H0. exploit' H0 as H. +Abort. diff --git a/test-suite/bugs/closed/bug_3481.v b/test-suite/bugs/closed/bug_3481.v index 41e1a8e959..f54810d359 100644 --- a/test-suite/bugs/closed/bug_3481.v +++ b/test-suite/bugs/closed/bug_3481.v @@ -1,7 +1,6 @@ Set Implicit Arguments. -Require Import Logic. Module NonPrim. Local Set Nonrecursive Elimination Schemes. Record prodwithlet (A B : Type) : Type := diff --git a/test-suite/bugs/closed/bug_4498.v b/test-suite/bugs/closed/bug_4498.v index 9b3210860c..ba63b707af 100644 --- a/test-suite/bugs/closed/bug_4498.v +++ b/test-suite/bugs/closed/bug_4498.v @@ -1,6 +1,7 @@ Require Export Coq.Unicode.Utf8. Require Export Coq.Classes.Morphisms. Require Export Coq.Relations.Relation_Definitions. +Require Export Coq.Setoids.Setoid. Set Universe Polymorphism. @@ -17,8 +18,6 @@ Class Category := { Proper (@equiv B C ==> @equiv A B ==> @equiv A C) (@compose A B C); }. -Require Export Coq.Setoids.Setoid. - Add Parametric Morphism `{Category} {A B C} : (@compose _ A B C) with signature equiv ==> equiv ==> equiv as compose_mor. Proof. apply comp_respects. Qed. diff --git a/test-suite/bugs/closed/bug_9294.v b/test-suite/bugs/closed/bug_9294.v new file mode 100644 index 0000000000..a079d672d3 --- /dev/null +++ b/test-suite/bugs/closed/bug_9294.v @@ -0,0 +1,29 @@ +Set Printing Universes. + +Inductive Foo@{i} (A:Type@{i}) : Type := foo : (Set:Type@{i}) -> Foo A. +Arguments foo {_} _. +Print Universes Subgraph (Foo.i). +Definition bar : Foo True -> Set := fun '(foo x) => x. + +Definition foo_bar (n : Foo True) : foo (bar n) = n. +Proof. destruct n;reflexivity. Qed. + +Definition bar_foo (n : Set) : bar (foo n) = n. +Proof. reflexivity. Qed. + +Require Import Hurkens. + +Inductive box (A : Set) : Prop := Box : A -> box A. + +Definition Paradox : False. +Proof. +Fail unshelve refine ( + NoRetractFromSmallPropositionToProp.paradox + (Foo True) + (fun A => foo A) + (fun A => box (bar A)) + _ + _ + False +). +Abort. diff --git a/test-suite/coqchk/inductive_functor_template.v b/test-suite/coqchk/inductive_functor_template.v index bc5cd0fb68..4b6916af55 100644 --- a/test-suite/coqchk/inductive_functor_template.v +++ b/test-suite/coqchk/inductive_functor_template.v @@ -2,7 +2,7 @@ Module Type E. Parameter T : Type. End E. Module F (X:E). - #[universes(template)] Inductive foo := box : X.T -> foo. + Inductive foo := box : X.T -> foo. End F. Module ME. Definition T := nat. End ME. diff --git a/test-suite/failure/Template.v b/test-suite/failure/Template.v new file mode 100644 index 0000000000..75b2a56169 --- /dev/null +++ b/test-suite/failure/Template.v @@ -0,0 +1,32 @@ +(* +Module TestUnsetTemplateCheck. + Unset Template Check. + + Section Foo. + + Context (A : Type). + + Definition cstr := nat : ltac:(let ty := type of A in exact ty). + + Inductive myind := + | cons : A -> myind. + End Foo. + + (* Can only succeed if no template check is performed *) + Check myind True : Prop. + + Print Assumptions myind. + (* + Axioms: + myind is template polymorphic on all its universe parameters. + *) + About myind. +(* +myind : Type@{Top.60} -> Type@{Top.60} + +myind is assumed template universe polymorphic on Top.60 +Argument scope is [type_scope] +Expands to: Inductive Top.TestUnsetTemplateCheck.myind +*) +End TestUnsetTemplateCheck. +*) diff --git a/test-suite/ltac2/constr.v b/test-suite/ltac2/constr.v new file mode 100644 index 0000000000..39601d99a8 --- /dev/null +++ b/test-suite/ltac2/constr.v @@ -0,0 +1,12 @@ +Require Import Ltac2.Constr Ltac2.Init Ltac2.Control. +Import Unsafe. + +Ltac2 Eval match (kind '(nat -> bool)) with + | Prod a b c => a + | _ => throw Match_failure end. + +Set Allow StrictProp. +Axiom something : SProp. +Ltac2 Eval match (kind '(forall x : something, bool)) with + | Prod a b c => a + | _ => throw Match_failure end. diff --git a/test-suite/micromega/bug_9162.v b/test-suite/micromega/bug_9162.v new file mode 100644 index 0000000000..4aedf57faf --- /dev/null +++ b/test-suite/micromega/bug_9162.v @@ -0,0 +1,8 @@ +Require Import ZArith Lia. +Local Open Scope Z_scope. + +Goal Z.of_N (Z.to_N 0) = 0. +Proof. lia. Qed. + +Goal forall q, (Z.of_N (Z.to_N 0) = 0 -> q = 0) -> Z.of_N (Z.to_N 0) = q. +Proof. lia. Qed. diff --git a/test-suite/micromega/non_lin_ci.v b/test-suite/micromega/non_lin_ci.v index ec39209230..2a66cc9a5a 100644 --- a/test-suite/micromega/non_lin_ci.v +++ b/test-suite/micromega/non_lin_ci.v @@ -43,18 +43,18 @@ Proof. Qed. Goal - forall (__x1 __x2 __x3 __x4 __x5 __x6 __x7 __x8 __x9 __x10 __x11 __x12 __x13 - __x14 __x15 __x16 : Z) - (H6 : __x8 < __x10 ^ 2 * __x15 ^ 2 + 2 * __x10 * __x15 * __x14 + __x14 ^ 2) - (H7 : 0 <= __x8) - (H12 : 0 <= __x14) - (H0 : __x8 = __x15 * __x11 + __x9) - (H14 : __x10 ^ 2 * __x15 + __x10 * __x14 < __x16) - (H17 : __x16 <= 0) - (H15 : 0 <= __x9) - (H18 : __x9 < __x15) - (H16 : 0 <= __x12) - (H19 : __x12 < (__x10 * __x15 + __x14) * __x10) + forall (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 + x14 x15 x16 : Z) + (H6 : x8 < x10 ^ 2 * x15 ^ 2 + 2 * x10 * x15 * x14 + x14 ^ 2) + (H7 : 0 <= x8) + (H12 : 0 <= x14) + (H0 : x8 = x15 * x11 + x9) + (H14 : x10 ^ 2 * x15 + x10 * x14 < x16) + (H17 : x16 <= 0) + (H15 : 0 <= x9) + (H18 : x9 < x15) + (H16 : 0 <= x12) + (H19 : x12 < (x10 * x15 + x14) * x10) , False. Proof. intros. diff --git a/test-suite/micromega/rexample.v b/test-suite/micromega/rexample.v index 52dc9ed2e0..354c608e23 100644 --- a/test-suite/micromega/rexample.v +++ b/test-suite/micromega/rexample.v @@ -24,6 +24,16 @@ Proof. lra. Qed. +Goal + forall (a c : R) + (Had : a <> a), + a > c. +Proof. + intros. + lra. +Qed. + + (* Other (simple) examples *) Lemma binomial : forall x y, ((x+y)^2 = x^2 + 2 *x*y + y^2). @@ -32,7 +42,6 @@ Proof. lra. Qed. - Lemma hol_light19 : forall m n, 2 * m + n = (n + m) + m. Proof. intros ; lra. diff --git a/test-suite/micromega/rsyntax.v b/test-suite/micromega/rsyntax.v index f02d93f911..a0afe99181 100644 --- a/test-suite/micromega/rsyntax.v +++ b/test-suite/micromega/rsyntax.v @@ -60,7 +60,6 @@ Proof. lia. (* exponent is a constant expr *) Qed. - Goal (1 / IZR (Z.pow_pos 10 25) = 1 / 10 ^ 25)%R. Proof. lra. diff --git a/test-suite/micromega/zomicron.v b/test-suite/micromega/zomicron.v index 55691f553c..3d99af95ec 100644 --- a/test-suite/micromega/zomicron.v +++ b/test-suite/micromega/zomicron.v @@ -1,5 +1,63 @@ Require Import ZArith. Require Import Lia. + +Section S. + Variables H1 H2 H3 H4 : True. + + Lemma bug_9848 : True. + Proof using. + lia. + Qed. +End S. + +Lemma concl_in_Type : forall (k : nat) + (H : (k < 0)%nat) (F : k < 0 -> Type), + F H. +Proof. + intros. + lia. +Qed. + +Lemma bug_10707 : forall + (T : Type) + (t : nat -> Type) + (k : nat) + (default : T) + (arr : t 0 -> T) + (H : (k < 0)%nat) of_nat_lt, + match k with + | 0 | _ => default + end = arr (of_nat_lt H). +Proof. + intros. + lia. +Qed. + +Axiom decompose_nat : nat -> nat -> nat. +Axiom inleft : forall {P}, {m : nat & P m} -> nat. +Axiom foo : nat. + +Lemma bug_7886 : forall (x x0 : nat) + (e : 0 = x0 + S x) + (H : decompose_nat x 0 = inleft (existT (fun m : nat => 0 = m + S x) x0 e)) + (x1 : nat) + (e0 : 0 = x1 + S (S x)) + (H1 : decompose_nat (S x) 0 = inleft (existT (fun m : nat => 0 = m + S (S x)) x1 e0)), + False. +Proof. + intros. + lia. +Qed. + + +Lemma bug_8898 : forall (p : 0 < 0) (H: p = p), False. +Proof. + intros p H. + lia. +Qed. + + + Open Scope Z_scope. Lemma two_x_eq_1 : forall x, 2 * x = 1 -> False. @@ -34,12 +92,12 @@ Proof. Qed. Lemma compact_proof : forall z, - (z < 0) -> - (z >= 0) -> - (0 >= z \/ 0 < z) -> False. + (z < 0) -> + (z >= 0) -> + (0 >= z \/ 0 < z) -> False. Proof. - intros. - lia. + intros. + lia. Qed. Lemma dummy_ex : exists (x:Z), x = x. @@ -74,9 +132,17 @@ Proof. lia. Qed. + +Lemma fresh1 : forall (__p1 __p2 __p3 __p5:Prop) (x y z:Z), (x = 0 /\ y = 0) /\ z = 0 -> x = 0. +Proof. + intros. + lia. +Qed. + + Class Foo {x : Z} := { T : Type ; dec : T -> Z }. Goal forall bound {F : @Foo bound} (x y : T), 0 <= dec x < bound -> 0 <= dec y -< bound -> dec x + dec y >= bound -> dec x + dec y < 2 * bound. + < bound -> dec x + dec y >= bound -> dec x + dec y < 2 * bound. Proof. intros. lia. @@ -98,7 +164,19 @@ Section S. lia. Qed. - End S. +End S. + +Section S. + Variable x y: Z. + Variable H1 : 1 > 0 -> x = 1. + Variable H2 : x = y. + + Goal x = y. + Proof using H2. + lia. + Qed. + +End S. (* Bug 5073 *) Lemma opp_eq_0_iff a : -a = 0 <-> a = 0. @@ -122,8 +200,50 @@ Goal forall (H5 : - b < r) (H6 : r <= 0) (H2 : 0 <= b), - b = 0 -> False. + b = 0 -> False. Proof. intros b q r. lia. Qed. + + +Section S. + (* From bedrock2, used to be slow *) + Variables (x3 q r q2 r3 : Z) + (H : 2 ^ 2 <> 0 -> r3 + 3 = 2 ^ 2 * q + r) + (H0 : 0 < 2 ^ 2 -> 0 <= r < 2 ^ 2) + (H1 : 2 ^ 2 < 0 -> 2 ^ 2 < r <= 0) + (H2 : 2 ^ 2 = 0 -> q = 0) + (H3 : 2 ^ 2 = 0 -> r = 0) + (q0 r0 : Z) + (H4 : 4 <> 0 -> 0 = 4 * q0 + r0) + (H5 : 0 < 4 -> 0 <= r0 < 4) + (H6 : 4 < 0 -> 4 < r0 <= 0) + (H7 : 4 = 0 -> q0 = 0) + (H8 : 4 = 0 -> r0 = 0) + (q1 r1 : Z) + (H9 : 4 <> 0 -> q + q + (q + q) = 4 * q1 + r1) + (H10 : 0 < 4 -> 0 <= r1 < 4) + (H11 : 4 < 0 -> 4 < r1 <= 0) + (H12 : 4 = 0 -> q1 = 0) + (H13 : 4 = 0 -> r1 = 0) + (r2 : Z) + (H14 : 2 ^ 16 <> 0 -> x3 = 2 ^ 16 * q2 + r2) + (H15 : 0 < 2 ^ 16 -> 0 <= r2 < 2 ^ 16) + (H16 : 2 ^ 16 < 0 -> 2 ^ 16 < r2 <= 0) + (H17 : 2 ^ 16 = 0 -> q2 = 0) + (H18 : 2 ^ 16 = 0 -> r2 = 0) + (q3 : Z) + (H19 : 16383 + 1 <> 0 -> q2 = (16383 + 1) * q3 + r3) + (H20 : 0 < 16383 + 1 -> 0 <= r3 < 16383 + 1) + (H21 : 16383 + 1 < 0 -> 16383 + 1 < r3 <= 0) + (H22 : 16383 + 1 = 0 -> q3 = 0) + (H23 : 16383 + 1 = 0 -> r3 = 0). + + Goal r0 = r1. + Proof using H10 H9 H5 H4. + intros. + lia. + Qed. + +End S. diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 4e949dcb04..a040b69b44 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -84,7 +84,6 @@ Print f. (* Was enhancement request #5142 (error message reported on the most general return clause heuristic) *) -#[universes(template)] Inductive gadt : Type -> Type := | gadtNat : nat -> gadt nat | gadtTy : forall T, T -> gadt T. diff --git a/test-suite/output/Coercions.v b/test-suite/output/Coercions.v index 6976f35a88..0e84bf3966 100644 --- a/test-suite/output/Coercions.v +++ b/test-suite/output/Coercions.v @@ -1,7 +1,7 @@ (* Submitted by Randy Pollack *) -#[universes(template)] Record pred (S : Set) : Type := {sp_pred :> S -> Prop}. -#[universes(template)] Record rel (S : Set) : Type := {sr_rel :> S -> S -> Prop}. +Record pred (S : Set) : Type := {sp_pred :> S -> Prop}. +Record rel (S : Set) : Type := {sr_rel :> S -> S -> Prop}. Section testSection. Variables (S : Set) (P : pred S) (R : rel S) (x : S). diff --git a/test-suite/output/Extraction_matchs_2413.v b/test-suite/output/Extraction_matchs_2413.v index f9398fdca9..1ecd9771eb 100644 --- a/test-suite/output/Extraction_matchs_2413.v +++ b/test-suite/output/Extraction_matchs_2413.v @@ -101,7 +101,7 @@ Section decoder_result. Variable inst : Type. - #[universes(template)] Inductive decoder_result : Type := + Inductive decoder_result : Type := | DecUndefined : decoder_result | DecUnpredictable : decoder_result | DecInst : inst -> decoder_result diff --git a/test-suite/output/Fixpoint.v b/test-suite/output/Fixpoint.v index 9b25c2dbd3..61ae4edbd1 100644 --- a/test-suite/output/Fixpoint.v +++ b/test-suite/output/Fixpoint.v @@ -44,7 +44,7 @@ fix even_pos_odd_pos 2 with (odd_pos_even_pos n (H:odd n) {struct H} : n >= 1). omega. Qed. -#[universes(template)] CoInductive Inf := S { projS : Inf }. +CoInductive Inf := S { projS : Inf }. Definition expand_Inf (x : Inf) := S (projS x). CoFixpoint inf := S inf. Eval compute in inf. diff --git a/test-suite/output/MExtraction.v b/test-suite/output/MExtraction.v index c0ef9b392d..668be1fdbc 100644 --- a/test-suite/output/MExtraction.v +++ b/test-suite/output/MExtraction.v @@ -1,14 +1,65 @@ -Require Import micromega.MExtraction. -Require Import RingMicromega. -Require Import QArith. -Require Import VarMap. +(************************************************************************) +(* * 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) *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +(* Used to generate micromega.ml *) + +Require Extraction. Require Import ZMicromega. Require Import QMicromega. Require Import RMicromega. +Require Import VarMap. +Require Import RingMicromega. +Require Import NArith. +Require Import QArith. + +Extract Inductive prod => "( * )" [ "(,)" ]. +Extract Inductive list => list [ "[]" "(::)" ]. +Extract Inductive bool => bool [ true false ]. +Extract Inductive sumbool => bool [ true false ]. +Extract Inductive option => option [ Some None ]. +Extract Inductive sumor => option [ Some None ]. +(** Then, in a ternary alternative { }+{ }+{ }, + - leftmost choice (Inleft Left) is (Some true), + - middle choice (Inleft Right) is (Some false), + - rightmost choice (Inright) is (None) *) + + +(** To preserve its laziness, andb is normally expanded. + Let's rather use the ocaml && *) +Extract Inlined Constant andb => "(&&)". + +Import Reals.Rdefinitions. + +Extract Constant R => "int". +Extract Constant R0 => "0". +Extract Constant R1 => "1". +Extract Constant Rplus => "( + )". +Extract Constant Rmult => "( * )". +Extract Constant Ropp => "fun x -> - x". +Extract Constant Rinv => "fun x -> 1 / x". +(** In order to avoid annoying build dependencies the actual + extraction is only performed as a test in the test suite. *) Recursive Extraction -Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula - ZMicromega.cnfZ ZMicromega.Zeval_const ZMicromega.bound_problem_fr QMicromega.cnfQ + Tauto.mapX Tauto.foldA Tauto.collect_annot Tauto.ids_of_formula Tauto.map_bformula + Tauto.abst_form + ZMicromega.cnfZ ZMicromega.bound_problem_fr ZMicromega.Zeval_const QMicromega.cnfQ List.map simpl_cone (*map_cone indexes*) denorm Qpower vm_add normZ normQ normQ n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/test-suite/output/NoAxiomFromR.out b/test-suite/output/NoAxiomFromR.out new file mode 100644 index 0000000000..7d7c521343 --- /dev/null +++ b/test-suite/output/NoAxiomFromR.out @@ -0,0 +1 @@ +Closed under the global context diff --git a/test-suite/output/NoAxiomFromR.v b/test-suite/output/NoAxiomFromR.v new file mode 100644 index 0000000000..9cf6879699 --- /dev/null +++ b/test-suite/output/NoAxiomFromR.v @@ -0,0 +1,10 @@ +Require Import Psatz. + +Inductive TT : Set := +| C : nat -> TT. + +Lemma lem4 : forall (n m : nat), +S m <= m -> C (S m) <> C n -> False. +Proof. firstorder. Qed. + +Print Assumptions lem4. diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 29614c032a..aeebc0f98b 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -123,7 +123,7 @@ Check fun n => foo4 n (fun x y z => (fun _ => y=0) z). (**********************************************************************) (* Test printing of #4932 *) -#[universes(template)] Inductive ftele : Type := +Inductive ftele : Type := | fb {T:Type} : T -> ftele | fr {T} : (T -> ftele) -> ftele. diff --git a/test-suite/output/PatternsInBinders.v b/test-suite/output/PatternsInBinders.v index 0c1b08f5a3..d671053c07 100644 --- a/test-suite/output/PatternsInBinders.v +++ b/test-suite/output/PatternsInBinders.v @@ -53,7 +53,7 @@ Module Suboptimal. (** This test shows an example which exposes the [let] introduced by the pattern notation in binders. *) -#[universes(template)] Inductive Fin (n:nat) := Z : Fin n. +Inductive Fin (n:nat) := Z : Fin n. Definition F '(n,p) : Type := (Fin n * Fin p)%type. Definition both_z '(n,p) : F (n,p) := (Z _,Z _). Print both_z. diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index ab4172711e..e788977fb7 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -1,6 +1,6 @@ existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} -existT is template universe polymorphic +existT is template universe polymorphic on sigT.u0 sigT.u1 Argument A is implicit Argument scopes are [type_scope function_scope _ _] Expands to: Constructor Coq.Init.Specif.existT diff --git a/test-suite/output/Projections.v b/test-suite/output/Projections.v index 35f36e87d7..14d63d39c4 100644 --- a/test-suite/output/Projections.v +++ b/test-suite/output/Projections.v @@ -6,7 +6,7 @@ Class HostFunction := host_func : Type. Section store. Context `{HostFunction}. - #[universes(template)] Record store := { store_funcs : host_func }. + Record store := { store_funcs : host_func }. End store. Check (fun (S:@store nat) => S.(store_funcs)). diff --git a/test-suite/output/Record.v b/test-suite/output/Record.v index 4fe7b051f8..d9a649fadc 100644 --- a/test-suite/output/Record.v +++ b/test-suite/output/Record.v @@ -20,12 +20,12 @@ Check {| field := 5 |}. Check build_r 5. Check build_c 5. -#[universes(template)] Record N := C { T : Type; _ : True }. +Record N := C { T : Type; _ : True }. Check fun x:N => let 'C _ p := x in p. Check fun x:N => let 'C T _ := x in T. Check fun x:N => let 'C T p := x in (T,p). -#[universes(template)] Record M := D { U : Type; a := 0; q : True }. +Record M := D { U : Type; a := 0; q : True }. Check fun x:M => let 'D T _ p := x in p. Check fun x:M => let 'D T _ p := x in T. Check fun x:M => let 'D T p := x in (T,p). diff --git a/test-suite/output/ShowMatch.v b/test-suite/output/ShowMatch.v index 99183f2064..9cf6ad35b8 100644 --- a/test-suite/output/ShowMatch.v +++ b/test-suite/output/ShowMatch.v @@ -3,12 +3,12 @@ *) Module A. - #[universes(template)] Inductive foo := f. + Inductive foo := f. Show Match foo. (* no need to disambiguate *) End A. Module B. - #[universes(template)] Inductive foo := f. + Inductive foo := f. (* local foo shadows A.foo, so constructor "f" needs disambiguation *) Show Match A.foo. End B. diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 222a808768..a89fd64999 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -68,9 +68,9 @@ mono The command has indeed failed with message: Universe u already exists. bobmorane = -let tt := Type@{UnivBinders.32} in -let ff := Type@{UnivBinders.34} in tt -> ff - : Type@{max(UnivBinders.31,UnivBinders.33)} +let tt := Type@{UnivBinders.33} in +let ff := Type@{UnivBinders.35} in tt -> ff + : Type@{max(UnivBinders.32,UnivBinders.34)} The command has indeed failed with message: Universe u already bound. foo@{E M N} = @@ -143,16 +143,16 @@ Applied.infunct@{u v} = inmod@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* u v |= *) -axfoo@{i UnivBinders.56 UnivBinders.57} : -Type@{UnivBinders.56} -> Type@{i} -(* i UnivBinders.56 UnivBinders.57 |= *) +axfoo@{i UnivBinders.57 UnivBinders.58} : +Type@{UnivBinders.57} -> Type@{i} +(* i UnivBinders.57 UnivBinders.58 |= *) axfoo is universe polymorphic Argument scope is [type_scope] Expands to: Constant UnivBinders.axfoo -axbar@{i UnivBinders.56 UnivBinders.57} : -Type@{UnivBinders.57} -> Type@{i} -(* i UnivBinders.56 UnivBinders.57 |= *) +axbar@{i UnivBinders.57 UnivBinders.58} : +Type@{UnivBinders.58} -> Type@{i} +(* i UnivBinders.57 UnivBinders.58 |= *) axbar is universe polymorphic Argument scope is [type_scope] diff --git a/test-suite/output/Warnings.v b/test-suite/output/Warnings.v index 0eb5db1733..7465442cab 100644 --- a/test-suite/output/Warnings.v +++ b/test-suite/output/Warnings.v @@ -1,5 +1,5 @@ (* Term in warning was not printed in the right environment at some time *) -#[universes(template)] Record A := { B:Type; b:B->B }. +Record A := { B:Type; b:B->B }. Definition a B := {| B:=B; b:=fun x => x |}. Canonical Structure a. diff --git a/test-suite/output/auto.out b/test-suite/output/auto.out index 2761b87b02..5e81b43504 100644 --- a/test-suite/output/auto.out +++ b/test-suite/output/auto.out @@ -2,18 +2,18 @@ simple apply or_intror (in core). intro. assumption. -Debug: (* debug auto: *) -Debug: * assumption. (*fail*) -Debug: * intro. (*fail*) -Debug: * simple apply or_intror (in core). (*success*) -Debug: ** assumption. (*fail*) -Debug: ** intro. (*success*) -Debug: ** assumption. (*success*) +(* debug auto: *) +* assumption. (*fail*) +* intro. (*fail*) +* simple apply or_intror (in core). (*success*) +** assumption. (*fail*) +** intro. (*success*) +** assumption. (*success*) (* info eauto: *) simple apply or_intror. intro. exact H. -Debug: (* debug eauto: *) +(* debug eauto: *) Debug: 1 depth=5 Debug: 1.1 depth=4 simple apply or_intror Debug: 1.1.1 depth=4 intro diff --git a/test-suite/output/bug7191.out b/test-suite/output/bug7191.out new file mode 100644 index 0000000000..005455e30c --- /dev/null +++ b/test-suite/output/bug7191.out @@ -0,0 +1,9 @@ + +type unit0 = +| Tt + +(** val f : unit0 -> unit0 **) + +let f _ = + assert false (* absurd case *) + diff --git a/test-suite/output/bug7191.v b/test-suite/output/bug7191.v new file mode 100644 index 0000000000..1aa4625b6c --- /dev/null +++ b/test-suite/output/bug7191.v @@ -0,0 +1,3 @@ +Require Extraction. +Definition f (x : False) : unit -> unit := match x with end. +Recursive Extraction f. diff --git a/test-suite/output/bug7348.out b/test-suite/output/bug7348.out new file mode 100644 index 0000000000..325ee95ae2 --- /dev/null +++ b/test-suite/output/bug7348.out @@ -0,0 +1,45 @@ +Extracted code successfully compiled + +type __ = Obj.t + +type unit0 = +| Tt + +type bool = +| True +| False + +module Case1 = + struct + type coq_rec = { f : bool } + + (** val f : bool -> coq_rec -> bool **) + + let f _ r = + r.f + + (** val silly : bool -> coq_rec -> __ **) + + let silly x b = + match x with + | True -> Obj.magic b.f + | False -> Obj.magic Tt + end + +module Case2 = + struct + type coq_rec = { f : (bool -> bool) } + + (** val f : bool -> coq_rec -> bool -> bool **) + + let f _ r = + r.f + + (** val silly : bool -> coq_rec -> __ **) + + let silly x b = + match x with + | True -> Obj.magic b.f False + | False -> Obj.magic Tt + end + diff --git a/test-suite/output/bug7348.v b/test-suite/output/bug7348.v new file mode 100644 index 0000000000..782b27ce96 --- /dev/null +++ b/test-suite/output/bug7348.v @@ -0,0 +1,25 @@ +Require Extraction. + +Extraction Language OCaml. +Set Extraction KeepSingleton. + +Module Case1. + +Record rec (x : bool) := { f : bool }. + +Definition silly x (b : rec x) := + if x return (if x then bool else unit) then f x b else tt. + +End Case1. + +Module Case2. + +Record rec (x : bool) := { f : bool -> bool }. + +Definition silly x (b : rec x) := + if x return (if x then bool else unit) then f x b false else tt. + +End Case2. + +Extraction TestCompile Case1.silly Case2.silly. +Recursive Extraction Case1.silly Case2.silly. diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v index 209fedc343..57a4739e9f 100644 --- a/test-suite/output/inference.v +++ b/test-suite/output/inference.v @@ -21,6 +21,6 @@ Print P. (* Note: exact numbers of evars are not important... *) -#[universes(template)] Inductive T (n:nat) : Type := A : T n. +Inductive T (n:nat) : Type := A : T n. Check fun n (y:=A n:T n) => _ _ : T n. Check fun n => _ _ : T n. diff --git a/test-suite/ssr/bang_rewrite.v b/test-suite/ssr/bang_rewrite.v new file mode 100644 index 0000000000..30e6d57a7a --- /dev/null +++ b/test-suite/ssr/bang_rewrite.v @@ -0,0 +1,13 @@ +Set Universe Polymorphism. + +Require Import ssreflect. + +Axiom mult@{i} : nat -> nat -> nat. +Notation "m * n" := (mult m n). + +Axiom multA : forall a b c, (a * b) * c = a * (b * c). + +(* Previously the following gave a universe error: *) + +Lemma multAA a b c d : ((a * b) * c) * d = a * (b * (c * d)). +Proof. by rewrite !multA. Qed. diff --git a/test-suite/ssr/congr.v b/test-suite/ssr/congr.v index 026f7538e8..f85791b00b 100644 --- a/test-suite/ssr/congr.v +++ b/test-suite/ssr/congr.v @@ -32,3 +32,11 @@ Coercion f : nat >-> Equality.sort. Lemma test4 : forall a b : nat, b = a -> @eq S (b + b) (a + a). Proof. move=> a b Eba; congr (_ + _); exact: Eba. Qed. + +Open Scope type_scope. + +Lemma test5 : forall (P Q Q' : Type) (h : Q = Q'), P * Q = P * Q'. +Proof. move=>*; by congr (_ * _). Qed. + +Lemma test6 : forall (P Q Q' : Type) (h : Q = Q'), P * Q -> P * Q'. +Proof. move=> P Q Q' h; by congr (_ * _). Qed. diff --git a/test-suite/success/Nia.v b/test-suite/success/Nia.v index 62ecece792..2eac9660b4 100644 --- a/test-suite/success/Nia.v +++ b/test-suite/success/Nia.v @@ -4,7 +4,8 @@ Open Scope Z_scope. (** Add [Z.to_euclidean_division_equations] to the end of [zify], just for this file. *) -Ltac zify ::= repeat (zify_nat; zify_positive; zify_N); zify_op; Z.to_euclidean_division_equations. +Require Zify. +Ltac Zify.zify_post_hook ::= Z.to_euclidean_division_equations. Lemma Z_zerop_or x : x = 0 \/ x <> 0. Proof. nia. Qed. Lemma Z_eq_dec_or (x y : Z) : x = y \/ x <> y. Proof. nia. Qed. diff --git a/test-suite/success/Nsatz.v b/test-suite/success/Nsatz.v index e38affd7fa..381fbabe72 100644 --- a/test-suite/success/Nsatz.v +++ b/test-suite/success/Nsatz.v @@ -58,8 +58,8 @@ Section Geometry. https://docs.google.com/fileview?id=0ByhB3nPmbnjTYzFiZmIyNGMtYTkwNC00NWFiLWJiNzEtODM4NmVkYTc2NTVk&hl=fr *) -Require Import List. Require Import Reals. +Require Import List. Record point:Type:={ X:R; diff --git a/test-suite/success/Template.v b/test-suite/success/Template.v index cfc25c3346..656362b8fc 100644 --- a/test-suite/success/Template.v +++ b/test-suite/success/Template.v @@ -46,3 +46,129 @@ Module No. Definition j_lebox (A:Type@{j}) := Box A. Fail Definition box_lti A := Box A : Type@{i}. End No. + +Module DefaultProp. + Inductive identity (A : Type) (a : A) : A -> Type := id_refl : identity A a a. + + (* By default template polymorphism does not interact with inductives + which naturally fall in Prop *) + Check (identity nat 0 0 : Prop). +End DefaultProp. + +Module ExplicitTemplate. + #[universes(template)] + Inductive identity@{i} (A : Type@{i}) (a : A) : A -> Type@{i} := id_refl : identity A a a. + + (* Weird interaction of template polymorphism and inductive types + which naturally fall in Prop: this one is template polymorphic but not on i: + it just lives in any universe *) + Check (identity Type nat nat : Prop). +End ExplicitTemplate. + +Polymorphic Definition f@{i} : Type@{i} := nat. +Polymorphic Definition baz@{i} : Type@{i} -> Type@{i} := fun x => x. + +Section Foo. + Universe u. + Context (A : Type@{u}). + + Inductive Bar := + | bar : A -> Bar. + + Set Universe Minimization ToSet. + Inductive Baz := + | cbaz : A -> baz Baz -> Baz. + + Inductive Baz' := + | cbaz' : A -> baz@{Set} nat -> Baz'. + + (* 2 constructors, at least in Set *) + Inductive Bazset@{v} := + | cbaz1 : A -> baz@{v} Bazset -> Bazset + | cbaz2 : Bazset. + + Eval compute in ltac:(let T := type of A in exact T). + + Inductive Foo : Type := + | foo : A -> f -> Foo. + +End Foo. + +Set Printing Universes. +(* Cannot fall back to Prop or Set anymore as baz is no longer template-polymorphic *) +Fail Check Bar True : Prop. +Fail Check Bar nat : Set. +About Baz. + +Check cbaz True I. + +(** Neither can it be Set *) +Fail Check Baz nat : Set. + +(** No longer possible for Baz' which contains a type in Set *) +Fail Check Baz' True : Prop. +Fail Check Baz' nat : Set. + +Fail Check Bazset True : Prop. +Fail Check Bazset True : Set. + +(** We can force the universe instantiated in [baz Bazset] to be [u], so Bazset lives in max(Set, u). *) +Constraint u = Bazset.v. +(** As u is global it is already > Set, so: *) +Definition bazsetex@{i | i < u} : Type@{u} := Bazset Type@{i}. + +(* Bazset is closed for universes u = u0, cannot be instantiated with Prop *) +Definition bazseetpar (X : Type@{u}) : Type@{u} := Bazset X. + +(** Would otherwise break singleton elimination and extraction. *) +Fail Check Foo True : Prop. +Fail Check Foo True : Set. + +Definition foo_proj {A} (f : Foo A) : nat := + match f with foo _ _ n => n end. + +Definition ex : Foo True := foo _ I 0. +Check foo_proj ex. + +(** See failure/Template.v for a test of the unsafe Unset Template Check usage *) + +Module AutoTemplateTest. +Set Warnings "+auto-template". +Section Foo. + Universe u'. + Context (A : Type@{u'}). + + (* Not failing as Bar cannot be made template polymorphic at all *) + Inductive Bar := + | bar : A -> Bar. +End Foo. +End AutoTemplateTest. + +Module TestTemplateAttribute. + Section Foo. + Universe u. + Context (A : Type@{u}). + + (* Failing as Bar cannot be made template polymorphic at all *) + Fail #[universes(template)] Inductive Bar := + | bar : A -> Bar. + + End Foo. +End TestTemplateAttribute. + +Module SharingWithoutSection. +Inductive Foo A (S:= fun _ => Set : ltac:(let ty := type of A in exact ty)) + := foo : S A -> Foo A. +Fail Check Foo True : Prop. +End SharingWithoutSection. + +Module OkNotCovered. +(* Here it happens that box is safe but we don't see it *) +Section S. +Universe u. +Variable A : Type@{u}. +Inductive box (A:Type@{u}) := Box : A -> box A. +Definition B := Set : Type@{u}. +End S. +Fail Check box True : Prop. +End OkNotCovered. diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 0c0a1897a8..296c253363 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -822,4 +822,4 @@ Defined. Lemma eqb_spec (b b' : bool) : reflect (b = b') (eqb b b'). Proof. destruct b, b'; now constructor. -Qed. +Defined. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 428af5fcfe..69bd1e6c96 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -286,7 +286,6 @@ Local Open Scope list_scope. (** A compact representation of non-dependent arities, with the codomain singled-out. *) (* Note, we do not use [list Type] because it imposes unnecessary universe constraints *) -#[universes(template)] Inductive Tlist : Type := Tnil : Tlist | Tcons : Type -> Tlist -> Tlist. Local Infix "::" := Tcons. diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index 071810acdc..6858706cb3 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -27,7 +27,6 @@ Require Export Coq.Classes.Morphisms. (** A setoid wraps an equivalence. *) -#[universes(template)] Class Setoid A := { equiv : relation A ; setoid_equiv :> Equivalence equiv }. @@ -129,7 +128,6 @@ Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Proper ( (** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *) -#[universes(template)] Class PartialSetoid (A : Type) := { pequiv : relation A ; pequiv_prf :> PER pequiv }. diff --git a/theories/Compat/Coq89.v b/theories/Compat/Coq89.v index 5025bce093..274cb4afd3 100644 --- a/theories/Compat/Coq89.v +++ b/theories/Compat/Coq89.v @@ -14,3 +14,6 @@ Local Set Warnings "-deprecated". Require Export Coq.Compat.Coq810. Unset Private Polymorphic Universes. + +(** Unsafe flag, can hide inconsistencies. *) +Global Unset Template Check. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 801be79ba4..8627ff7353 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -45,20 +45,23 @@ Hint Transparent key : core. (** * Trees *) -Section Elt. - -Variable elt : Type. - (** * Trees The fifth field of [Node] is the height of the tree *) #[universes(template)] -Inductive tree := +Inductive tree {elt : Type} := | Leaf : tree | Node : tree -> key -> elt -> tree -> int -> tree. +Arguments tree : clear implicits. -Notation t := tree. +Section Elt. + +Variable elt : Type. + +Notation t := (tree elt). + +Implicit Types m : t. (** * Basic functions on trees: height and cardinal *) @@ -76,7 +79,7 @@ Fixpoint cardinal (m : t) : nat := (** * Empty Map *) -Definition empty := Leaf. +Definition empty : t := Leaf. (** * Emptyness test *) @@ -236,7 +239,6 @@ Fixpoint join l : key -> elt -> t -> t := - [o] is the result of [find x m]. *) -#[universes(template)] Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }. Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). @@ -293,7 +295,6 @@ Variable cmp : elt->elt->bool. (** ** Enumeration of the elements of a tree *) -#[universes(template)] Inductive enumeration := | End : enumeration | More : key -> elt -> t -> enumeration -> enumeration. @@ -338,6 +339,9 @@ Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End). End Elt. Notation t := tree. +Arguments Leaf : clear implicits. +Arguments Node [elt]. + Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). Notation "t #l" := (t_left t) (at level 9, format "t '#l'"). Notation "t #o" := (t_opt t) (at level 9, format "t '#o'"). diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 2af6e5c6a4..b21d809059 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -1024,7 +1024,6 @@ Module E := X. Definition key := E.t. -#[universes(template)] Record slist (elt:Type) := {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. Definition t (elt:Type) : Type := slist elt. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 0c04437581..b9a8b0a73d 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -868,8 +868,6 @@ Module Make (X: DecidableType) <: WS with Module E:=X. Module E := X. Definition key := E.t. - -#[universes(template)] Record slist (elt:Type) := {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. Definition t (elt:Type) := slist elt. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 1639115cbd..6984a7c2b6 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -243,6 +243,19 @@ Proof. rewrite Hfst; rewrite Hsnd; reflexivity. Qed. +Lemma pair_equal_spec : + forall (A B : Type) (a1 a2 : A) (b1 b2 : B), + (a1, b1) = (a2, b2) <-> a1 = a2 /\ b1 = b2. +Proof with auto. + split; intros. + - split. + + replace a1 with (fst (a1, b1)); replace a2 with (fst (a2, b2))... + rewrite H... + + replace b1 with (snd (a1, b1)); replace b2 with (snd (a2, b2))... + rewrite H... + - destruct H; subst... +Qed. + Definition prod_uncurry (A B C:Type) (f:A * B -> C) (x:A) (y:B) : C := f (x,y). @@ -387,8 +400,10 @@ Proof. intros. apply CompareSpec2Type; assumption. Defined. (** [identity A a] is the family of datatypes on [A] whose sole non-empty member is the singleton datatype [identity A a a] whose sole inhabitant is denoted [identity_refl A a] *) +(** Beware: this inductive actually falls into [Prop], as the sole + constructor has no arguments and [-indices-matter] is not + activated in the standard library. *) -#[universes(template)] Inductive identity (A:Type) (a:A) : A -> Type := identity_refl : identity a a. Hint Resolve identity_refl: core. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 09a32e9483..4d84d61f9f 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -274,6 +274,22 @@ Inductive ex (A:Type) (P:A -> Prop) : Prop := ex_intro : forall x:A, P x -> ex (A:=A) P. Register ex as core.ex.type. +Register ex_intro as core.ex.intro. + +Section Projections. + + Variables (A:Prop) (P:A->Prop). + + Definition ex_proj1 (x:ex P) : A := + match x with ex_intro _ a _ => a end. + + Definition ex_proj2 (x:ex P) : P (ex_proj1 x) := + match x with ex_intro _ _ b => b end. + + Register ex_proj1 as core.ex.proj1. + Register ex_proj2 as core.ex.proj2. + +End Projections. Inductive ex2 (A:Type) (P Q:A -> Prop) : Prop := ex_intro2 : forall x:A, P x -> Q x -> ex2 (A:=A) P Q. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 7f36edf5bb..38723e291f 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -536,6 +536,26 @@ Section Elts. simpl in *. apply IHn. auto with arith. Qed. + (** Results directly relating [nth] and [nth_error] *) + + Lemma nth_error_nth : forall (l : list A) (n : nat) (x d : A), + nth_error l n = Some x -> nth n l d = x. + Proof. + intros l n x d H. + apply nth_error_split in H. destruct H as [l1 [l2 [H H']]]. + subst. rewrite app_nth2; [|auto]. + rewrite Nat.sub_diag. reflexivity. + Qed. + + Lemma nth_error_nth' : forall (l : list A) (n : nat) (d : A), + n < length l -> nth_error l n = Some (nth n l d). + Proof. + intros l n d H. + apply nth_split with (d:=d) in H. destruct H as [l1 [l2 [H H']]]. + subst. rewrite H. rewrite nth_error_app2; [|auto]. + rewrite app_nth2; [| auto]. repeat (rewrite Nat.sub_diag). reflexivity. + Qed. + (*****************) (** ** Remove *) (*****************) @@ -1227,6 +1247,20 @@ End Fold_Right_Recursor. case_eq (f a); intros; simpl; intuition congruence. Qed. + Lemma filter_app (l l':list A) : + filter (l ++ l') = filter l ++ filter l'. + Proof. + induction l as [|x l IH]; simpl; trivial. + destruct (f x); simpl; now rewrite IH. + Qed. + + Lemma concat_filter_map : forall (l : list (list A)), + concat (map filter l) = filter (concat l). + Proof. + induction l as [| v l IHl]; [auto|]. + simpl. rewrite IHl. rewrite filter_app. reflexivity. + Qed. + (** [find] *) Fixpoint find (l:list A) : option A := @@ -1309,6 +1343,55 @@ End Fold_Right_Recursor. End Bool. + (*******************************) + (** ** Further filtering facts *) + (*******************************) + + Section Filtering. + Variables (A : Type). + + Lemma filter_map : forall (f g : A -> bool) (l : list A), + filter f l = filter g l <-> map f l = map g l. + Proof. + induction l as [| a l IHl]; [firstorder|]. + simpl. destruct (f a) eqn:Hfa; destruct (g a) eqn:Hga; split; intros H. + - inversion H. apply IHl in H1. rewrite H1. reflexivity. + - inversion H. apply IHl in H1. rewrite H1. reflexivity. + - assert (Ha : In a (filter g l)). { rewrite <- H. apply in_eq. } + apply filter_In in Ha. destruct Ha as [_ Hga']. rewrite Hga in Hga'. inversion Hga'. + - inversion H. + - assert (Ha : In a (filter f l)). { rewrite H. apply in_eq. } + apply filter_In in Ha. destruct Ha as [_ Hfa']. rewrite Hfa in Hfa'. inversion Hfa'. + - inversion H. + - rewrite IHl in H. rewrite H. reflexivity. + - inversion H. apply IHl. assumption. + Qed. + + Lemma filter_ext_in : forall (f g : A -> bool) (l : list A), + (forall a, In a l -> f a = g a) -> filter f l = filter g l. + Proof. + intros f g l H. rewrite filter_map. apply map_ext_in. auto. + Qed. + + Lemma ext_in_filter : forall (f g : A -> bool) (l : list A), + filter f l = filter g l -> (forall a, In a l -> f a = g a). + Proof. + intros f g l H. rewrite filter_map in H. apply ext_in_map. assumption. + Qed. + + Lemma filter_ext_in_iff : forall (f g : A -> bool) (l : list A), + filter f l = filter g l <-> (forall a, In a l -> f a = g a). + Proof. + split; [apply ext_in_filter | apply filter_ext_in]. + Qed. + + Lemma filter_ext : forall (f g : A -> bool), + (forall a, f a = g a) -> forall l, filter f l = filter g l. + Proof. + intros f g H l. rewrite filter_map. apply map_ext. assumption. + Qed. + + End Filtering. (******************************************************) @@ -1845,6 +1928,56 @@ Section Cutting. End Cutting. +(**************************************************************) +(** ** Combining pairs of lists of possibly-different lengths *) +(**************************************************************) + +Section Combining. + Variables (A B : Type). + + Lemma combine_nil : forall (l : list A), + combine l (@nil B) = @nil (A*B). + Proof. + intros l. + apply length_zero_iff_nil. + rewrite combine_length. simpl. rewrite Nat.min_0_r. + reflexivity. + Qed. + + Lemma combine_firstn_l : forall (l : list A) (l' : list B), + combine l l' = combine l (firstn (length l) l'). + Proof. + induction l as [| x l IHl]; intros l'; [reflexivity|]. + destruct l' as [| x' l']; [reflexivity|]. + simpl. specialize IHl with (l':=l'). rewrite <- IHl. + reflexivity. + Qed. + + Lemma combine_firstn_r : forall (l : list A) (l' : list B), + combine l l' = combine (firstn (length l') l) l'. + Proof. + intros l l'. generalize dependent l. + induction l' as [| x' l' IHl']; intros l. + - simpl. apply combine_nil. + - destruct l as [| x l]; [reflexivity|]. + simpl. specialize IHl' with (l:=l). rewrite <- IHl'. + reflexivity. + Qed. + + Lemma combine_firstn : forall (l : list A) (l' : list B) (n : nat), + firstn n (combine l l') = combine (firstn n l) (firstn n l'). + Proof. + induction l as [| x l IHl]; intros l' n. + - simpl. repeat (rewrite firstn_nil). reflexivity. + - destruct l' as [| x' l']. + + simpl. repeat (rewrite firstn_nil). rewrite combine_nil. reflexivity. + + simpl. destruct n as [| n]; [reflexivity|]. + repeat (rewrite firstn_cons). simpl. + rewrite IHl. reflexivity. + Qed. + +End Combining. + (**********************************************************************) (** ** Predicate for List addition/removal (no need for decidability) *) (**********************************************************************) @@ -1959,6 +2092,15 @@ Section ReDun. | x::xs => if in_dec decA x xs then nodup xs else x::(nodup xs) end. + Lemma nodup_fixed_point : forall (l : list A), + NoDup l -> nodup l = l. + Proof. + induction l as [| x l IHl]; [auto|]. intros H. + simpl. destruct (in_dec decA x l) as [Hx | Hx]; rewrite NoDup_cons_iff in H. + - destruct H as [H' _]. contradiction. + - destruct H as [_ H']. apply IHl in H'. rewrite -> H'. reflexivity. + Qed. + Lemma nodup_In l x : In x (nodup l) <-> In x l. Proof. induction l as [|a l' Hrec]; simpl. diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v index c11a0941fa..4c6520feb3 100644 --- a/theories/Lists/StreamMemo.v +++ b/theories/Lists/StreamMemo.v @@ -73,14 +73,17 @@ End MemoFunction. reused thanks to a temporary hiding of the dependency in a "container" [memo_val]. *) +#[universes(template)] +Inductive memo_val {A : nat -> Type} : Type := + memo_mval: forall n, A n -> memo_val. +Arguments memo_val : clear implicits. + Section DependentMemoFunction. Variable A: nat -> Type. Variable f: forall n, A n. -#[universes(template)] -Inductive memo_val: Type := - memo_mval: forall n, A n -> memo_val. +Notation memo_val := (memo_val A). Fixpoint is_eq (n m : nat) : {n = m} + {True} := match n, m return {n = m} + {True} with diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index 407a7ae45d..0daae0391c 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -12,13 +12,13 @@ Set Implicit Arguments. (** Streams *) -Section Streams. +CoInductive Stream (A : Type) := + Cons : A -> Stream A -> Stream A. -Variable A : Type. +Section Streams. + Variable A : Type. -#[universes(template)] -CoInductive Stream : Type := - Cons : A -> Stream -> Stream. + Notation Stream := (Stream A). Definition hd (x:Stream) := match x with diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v index 6af7b1fe6e..9c47b73193 100644 --- a/theories/Logic/Classical_Prop.v +++ b/theories/Logic/Classical_Prop.v @@ -26,6 +26,8 @@ unfold not; intros; elim (classic p); auto. intro NP; elim (H NP). Qed. +Register NNPP as core.nnpp.type. + (** Peirce's law states [forall P Q:Prop, ((P -> Q) -> P) -> P]. Thanks to [forall P, False -> P], it is equivalent to the following form *) diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index 4442108ffc..8a71158f4c 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -208,7 +208,6 @@ Definition concat s1 s2 := - [present] is [true] if and only if [s] contains [x]. *) -#[universes(template)] Record triple := mktriple { t_left:t; t_in:bool; t_right:t }. Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 37a169b02e..bf6336ae47 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -48,7 +48,6 @@ Module Type Ops (X:OrderedType)(Info:InfoTyp). Definition elt := X.t. Hint Transparent elt : core. -#[universes(template)] Inductive tree : Type := | Leaf : tree | Node : Info.t -> tree -> X.t -> tree -> tree. @@ -168,7 +167,6 @@ end. (** Enumeration of the elements of a tree. This corresponds to the "samefringe" notion in the literature. *) -#[universes(template)] Inductive enumeration := | End : enumeration | More : elt -> tree -> enumeration -> enumeration. diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index 29c84d0d1a..33f6b1050c 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -439,7 +439,6 @@ Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E. Definition elt := E.t. -#[universes(template)] Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}. Definition t := t_. Arguments Mkt this {is_ok}. diff --git a/theories/MSets/MSetRBT.v b/theories/MSets/MSetRBT.v index a3e0ec5884..b5389e9121 100644 --- a/theories/MSets/MSetRBT.v +++ b/theories/MSets/MSetRBT.v @@ -1049,12 +1049,8 @@ Qed. (** ** Filter *) -Lemma filter_app A f (l l':list A) : - List.filter f (l ++ l') = List.filter f l ++ List.filter f l'. -Proof. - induction l as [|x l IH]; simpl; trivial. - destruct (f x); simpl; now rewrite IH. -Qed. +#[deprecated(since="8.11",note="Lemma filter_app has been moved to module List.")] +Notation filter_app := List.filter_app. Lemma filter_aux_elements s f acc : filter_aux f s acc = List.filter f (elements s) ++ acc. @@ -1062,7 +1058,7 @@ Proof. revert acc. induction s as [|c l IHl x r IHr]; trivial. intros acc. - rewrite elements_node, filter_app. simpl. + rewrite elements_node, List.filter_app. simpl. destruct (f x); now rewrite IHl, IHr, app_ass. Qed. diff --git a/theories/Numbers/Cyclic/Abstract/DoubleType.v b/theories/Numbers/Cyclic/Abstract/DoubleType.v index 83e9c29b13..6e08378df4 100644 --- a/theories/Numbers/Cyclic/Abstract/DoubleType.v +++ b/theories/Numbers/Cyclic/Abstract/DoubleType.v @@ -18,46 +18,34 @@ Local Open Scope Z_scope. Definition base digits := Z.pow 2 (Zpos digits). Arguments base digits: simpl never. -Section Carry. +#[universes(template)] +Variant carry (A : Type) := +| C0 : A -> carry A +| C1 : A -> carry A. - Variable A : Type. - - #[universes(template)] - Variant carry := - | C0 : A -> carry - | C1 : A -> carry. - - Definition interp_carry (sign:Z)(B:Z)(interp:A -> Z) c := +Definition interp_carry {A} (sign:Z)(B:Z)(interp:A -> Z) c := match c with | C0 x => interp x | C1 x => sign*B + interp x end. -End Carry. - -Section Zn2Z. - - Variable znz : Type. - - (** From a type [znz] representing a cyclic structure Z/nZ, - we produce a representation of Z/2nZ by pairs of elements of [znz] - (plus a special case for zero). High half of the new number comes - first. +(** From a type [znz] representing a cyclic structure Z/nZ, + we produce a representation of Z/2nZ by pairs of elements of [znz] + (plus a special case for zero). High half of the new number comes + first. *) +#[universes(template)] +Variant zn2z {znz : Type} := +| W0 : zn2z +| WW : znz -> znz -> zn2z. +Arguments zn2z : clear implicits. - #[universes(template)] - Variant zn2z := - | W0 : zn2z - | WW : znz -> znz -> zn2z. - - Definition zn2z_to_Z (wB:Z) (w_to_Z:znz->Z) (x:zn2z) := +Definition zn2z_to_Z znz (wB:Z) (w_to_Z:znz->Z) (x:zn2z znz) := match x with | W0 => 0 | WW xh xl => w_to_Z xh * wB + w_to_Z xl end. -End Zn2Z. - Arguments W0 {znz}. (** From a cyclic representation [w], we iterate the [zn2z] construct diff --git a/theories/Reals/Machin.v b/theories/Reals/Machin.v index 81f8b08c92..08bc38a085 100644 --- a/theories/Reals/Machin.v +++ b/theories/Reals/Machin.v @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +Require Import Omega. Require Import Lra. Require Import Rbase. Require Import Rtrigo1. @@ -18,7 +19,6 @@ Require Import Rseries. Require Import SeqProp. Require Import PartSum. Require Import Ratan. -Require Import Omega. Local Open Scope R_scope. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 75298855b2..3b108b485a 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -1692,7 +1692,6 @@ Proof. exact H. now apply not_INR in H. Qed. -Hint Resolve INR_eq: real. Lemma INR_le : forall n m:nat, INR n <= INR m -> (n <= m)%nat. Proof. diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index 128ee286b8..6da0fe3966 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -137,7 +137,6 @@ Definition IsStepFun (f:R -> R) (a b:R) : Type := { l:Rlist & is_subdivision f a b l }. (** ** Class of step functions *) -#[universes(template)] Record StepFun (a b:R) : Type := mkStepFun {fe :> R -> R; pre : IsStepFun fe a b}. diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index 5443ff68ed..c94a373ca0 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -116,7 +116,6 @@ Qed. (*******************************) (*********) -#[universes(template)] Record Metric_Space : Type := {Base : Type; dist : Base -> Base -> R; diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index cfcc82d765..d21042884e 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -380,7 +380,6 @@ Proof. apply Rinv_0_lt_compat; prove_sup0. Qed. -#[universes(template)] Record family : Type := mkfamily {ind : R -> Prop; f :> R -> R -> Prop; diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index e1d7d37e42..745db25a54 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -100,11 +100,9 @@ Hint Resolve Totally_ordered_definition Upper_Bound_definition Section Specific_orders. Variable U : Type. - #[universes(template)] Record Cpo : Type := Definition_of_cpo {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}. - #[universes(template)] Record Chain : Type := Definition_of_chain {PO_of_chain : PO U; Chain_cond : Totally_ordered U PO_of_chain (@Carrier_of _ PO_of_chain)}. diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index e9233a34e7..6aefcf32c0 100644 --- a/theories/Sets/Multiset.v +++ b/theories/Sets/Multiset.v @@ -22,7 +22,6 @@ Section multiset_defs. Hypothesis eqA_equiv : Equivalence eqA. Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}. - #[universes(template)] Inductive multiset : Type := Bag : (A -> nat) -> multiset. diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index d2fae6db28..e23d9c2f55 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -36,7 +36,6 @@ Section Partial_orders. Definition Rel := Relation U. - #[universes(template)] Record PO : Type := Definition_of_PO { Carrier_of : Ensemble U; Rel_of : Relation U; diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index 76e555ed5a..48a852052e 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -42,7 +42,6 @@ Section defs. Let emptyBag := EmptyBag A. Let singletonBag := SingletonBag _ eqA_dec. - #[universes(template)] Inductive Tree := | Tree_Leaf : Tree | Tree_Node : A -> Tree -> Tree -> Tree. @@ -129,8 +128,7 @@ Section defs. (** ** Merging two sorted lists *) - #[universes(template)] - Inductive merge_lem (l1 l2:list A) : Type := + Inductive merge_lem (l1 l2:list A) : Type := merge_exist : forall l:list A, Sorted leA l -> @@ -203,7 +201,6 @@ Section defs. (** ** Specification of heap insertion *) - #[universes(template)] Inductive insert_spec (a:A) (T:Tree) : Type := insert_exist : forall T1:Tree, @@ -237,7 +234,6 @@ Section defs. (** ** Building a heap from a list *) - #[universes(template)] Inductive build_heap (l:list A) : Type := heap_exist : forall T:Tree, @@ -262,7 +258,6 @@ Section defs. (** ** Building the sorted list *) - #[universes(template)] Inductive flat_spec (T:Tree) : Type := flat_exist : forall l:list A, diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index 20a8581d46..cba4780bd4 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -189,6 +189,16 @@ Fixpoint append {A}{n}{p} (v:t A n) (w:t A p):t A (n+p) := Infix "++" := append. +(** Split a vector into two parts *) +Fixpoint splitat {A} (l : nat) {r : nat} : + t A (l + r) -> t A l * t A r := + match l with + | 0 => fun v => ([], v) + | S l' => fun v => + let (v1, v2) := splitat l' (tl v) in + (hd v::v1, v2) + end. + (** Two definitions of the tail recursive function that appends two lists but reverses the first one *) diff --git a/theories/Vectors/VectorSpec.v b/theories/Vectors/VectorSpec.v index 55a55c0b2f..b27566458e 100644 --- a/theories/Vectors/VectorSpec.v +++ b/theories/Vectors/VectorSpec.v @@ -153,3 +153,37 @@ Proof. - destruct v. inversion le. simpl. apply f_equal. apply IHp. Qed. +Lemma uncons_cons {A} : forall {n : nat} (a : A) (v : t A n), + uncons (a::v) = (a,v). +Proof. reflexivity. Qed. + +Lemma append_comm_cons {A} : forall {n m : nat} (v : t A n) (w : t A m) (a : A), + a :: (v ++ w) = (a :: v) ++ w. +Proof. reflexivity. Qed. + +Lemma splitat_append {A} : forall {n m : nat} (v : t A n) (w : t A m), + splitat n (v ++ w) = (v, w). +Proof with simpl; auto. + intros n m v. + generalize dependent m. + induction v; intros... + rewrite IHv... +Qed. + +Lemma append_splitat {A} : forall {n m : nat} (v : t A n) (w : t A m) (vw : t A (n+m)), + splitat n vw = (v, w) -> + vw = v ++ w. +Proof with auto. + intros n m v. + generalize dependent m. + induction v; intros; inversion H... + destruct (splitat n (tl vw)) as [v' w'] eqn:Heq. + apply pair_equal_spec in H1. + destruct H1; subst. + rewrite <- append_comm_cons. + rewrite (eta vw). + apply cons_inj in H0. + destruct H0; subst. + f_equal... + apply IHv... +Qed. diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v index d747258f56..6ddbc8e214 100644 --- a/theories/Wellfounded/Well_Ordering.v +++ b/theories/Wellfounded/Well_Ordering.v @@ -14,17 +14,18 @@ Require Import Eqdep. +#[universes(template)] +Inductive WO (A : Type) (B : A -> Type) : Type := + sup : forall (a:A) (f:B a -> WO A B), WO A B. + Section WellOrdering. Variable A : Type. Variable B : A -> Type. - #[universes(template)] - Inductive WO : Type := - sup : forall (a:A) (f:B a -> WO), WO. - + Notation WO := (WO A B). Inductive le_WO : WO -> WO -> Prop := - le_sup : forall (a:A) (f:B a -> WO) (v:B a), le_WO (f v) (sup a f). + le_sup : forall (a:A) (f:B a -> WO) (v:B a), le_WO (f v) (sup _ _ a f). Theorem wf_WO : well_founded le_WO. Proof. diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index 577544f971..fee928430c 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -212,7 +212,6 @@ Module MoreInt (Import I:Int). | EZofI : ExprI -> ExprZ | EZraw : Z -> ExprZ. - #[universes(template)] Inductive ExprP : Type := | EPeq : ExprZ -> ExprZ -> ExprP | EPlt : ExprZ -> ExprZ -> ExprP diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index d8a3dbb4bb..3600658e23 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -39,7 +39,7 @@ let load_vernacular opts ~state = if !Flags.beautify then Flags.with_option Flags.beautify_file load_vernac f_in else load_vernac s - ) state (List.rev opts.pre.load_vernacular_list) + ) state opts.pre.load_vernacular_list let load_init_vernaculars opts ~state = let state = load_init_file opts ~state in @@ -108,8 +108,6 @@ let compile opts copts ~echo ~f_in ~f_out = in match copts.compilation_mode with | BuildVo -> - Flags.record_aux_file := true; - let long_f_dot_v, long_f_dot_vo = ensure_exists_with_prefix f_in f_out ".v" ".vo" in @@ -124,8 +122,11 @@ let compile opts copts ~echo ~f_in ~f_out = Aux_file.(start_aux_file ~aux_file:(aux_file_name_for long_f_dot_vo) ~v_file:long_f_dot_v); + + Dumpglob.set_glob_output copts.glob_out; 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 @@ -139,9 +140,6 @@ let compile opts copts ~echo ~f_in ~f_out = Dumpglob.end_dump_glob () | BuildVio -> - Flags.record_aux_file := false; - Dumpglob.noglob (); - let long_f_dot_v, long_f_dot_vio = ensure_exists_with_prefix f_in f_out ".v" ".vio" in @@ -174,9 +172,6 @@ let compile opts copts ~echo ~f_in ~f_out = Stm.reset_task_queue () | Vio2Vo -> - - Flags.record_aux_file := false; - Dumpglob.noglob (); let long_f_dot_vio, long_f_dot_vo = ensure_exists_with_prefix f_in f_out ".vio" ".vo" in let sum, lib, univs, tasks, proofs = @@ -198,7 +193,7 @@ let compile_file opts copts (f_in, echo) = compile opts copts ~echo ~f_in ~f_out let compile_files opts copts = - let compile_list = List.rev copts.compile_list in + let compile_list = copts.compile_list in List.iter (compile_file opts copts) compile_list (******************************************************************************) @@ -210,7 +205,7 @@ let check_vio_tasks copts = let f_in = ensure ".vio" f f in ensure_exists f_in; Vio_checking.check_vio (n,f_in) && acc) - true (List.rev copts.vio_tasks) in + true copts.vio_tasks in if not rc then fatal_error Pp.(str "VIO Task Check failed") (* vio files *) diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 67d70416c8..113b1fb5d7 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -32,6 +32,10 @@ let set_type_in_type () = let typing_flags = Environ.typing_flags (Global.env ()) in Global.set_typing_flags { typing_flags with Declarations.check_universes = false } +let set_no_template_check () = + let typing_flags = Environ.typing_flags (Global.env ()) in + Global.set_typing_flags { typing_flags with Declarations.check_template = false } + (******************************************************************************) type color = [`ON | `AUTO | `EMACS | `OFF] @@ -59,7 +63,6 @@ type coqargs_config = { debug : bool; diffs_set : bool; time : bool; - glob_opt : bool; print_emacs : bool; set_options : (Goptions.option_name * option_command) list; } @@ -125,7 +128,6 @@ let default_config = { debug = false; diffs_set = false; time = false; - glob_opt = false; print_emacs = false; set_options = []; @@ -380,13 +382,6 @@ let parse_args ~help ~init arglist : t * string list = Flags.compat_version := v; add_compat_require oval v - |"-dump-glob" -> - Dumpglob.dump_into_file (next ()); - { oval with config = { oval.config with glob_opt = true }} - - |"-feedback-glob" -> - Dumpglob.feedback_glob (); oval - |"-exclude-dir" -> System.exclude_directory (next ()); oval @@ -524,7 +519,6 @@ let parse_args ~help ~init arglist : t * string list = |"-indices-matter" -> set_logic (fun o -> { o with indices_matter = true }) oval |"-m"|"--memory" -> { oval with post = { oval.post with memory_stat = true }} |"-noinit"|"-nois" -> { oval with pre = { oval.pre with load_init = false }} - |"-no-glob"|"-noglob" -> Dumpglob.noglob (); { oval with config = { oval.config with glob_opt = true }} |"-output-context" -> { oval with post = { oval.post with output_context = true }} |"-profile-ltac" -> Flags.profile_ltac := true; oval |"-q" -> { oval with pre = { oval.pre with load_rcfile = false; }} @@ -535,6 +529,7 @@ let parse_args ~help ~init arglist : t * string list = |"-list-tags" -> set_query oval PrintTags |"-time" -> { oval with config = { oval.config with time = true }} |"-type-in-type" -> set_type_in_type (); oval + |"-no-template-check" -> set_no_template_check (); oval |"-unicode" -> add_vo_require oval "Utf8_core" None (Some false) |"-where" -> set_query oval PrintWhere |"-h"|"-H"|"-?"|"-help"|"--help" -> set_query oval (PrintHelp help) @@ -552,6 +547,23 @@ let parse_args ~help ~init arglist : t * string list = parse init with any -> fatal_error any +(* We need to reverse a few lists *) +let parse_args ~help ~init args = + let opts, extra = parse_args ~help ~init args in + let opts = + { opts with + pre = { opts.pre with + ml_includes = List.rev opts.pre.ml_includes + ; vo_includes = List.rev opts.pre.vo_includes + ; vo_requires = List.rev opts.pre.vo_requires + ; load_vernacular_list = List.rev opts.pre.load_vernacular_list + } + ; config = { opts.config with + set_options = List.rev opts.config.set_options + } ; + } in + opts, extra + (******************************************************************************) (* Startup LoadPath and Modules *) (******************************************************************************) @@ -562,7 +574,7 @@ let require_libs opts = if opts.pre.load_init then prelude_data :: opts.pre.vo_requires else opts.pre.vo_requires let cmdline_load_path opts = - List.rev opts.pre.vo_includes @ List.(rev opts.pre.ml_includes) + opts.pre.ml_includes @ opts.pre.vo_includes let build_load_path opts = Coqinit.libs_init_load_path ~load_init:opts.pre.load_init @ diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index e414888861..26f22386a0 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -35,7 +35,6 @@ type coqargs_config = { debug : bool; diffs_set : bool; time : bool; - glob_opt : bool; print_emacs : bool; set_options : (Goptions.option_name * option_command) list; } diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index 5678acb2b1..7658ad68a5 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -11,13 +11,12 @@ let outputstate opts = Option.iter (fun ostate_file -> let fname = CUnix.make_suffix ostate_file ".coq" in - States.extern_state fname) opts.Coqcargs.outputstate + Library.extern_state fname) opts.Coqcargs.outputstate let coqc_init _copts ~opts = Flags.quiet := true; System.trust_file_cache := true; - Coqtop.init_color opts.Coqargs.config; - if not opts.Coqargs.config.Coqargs.glob_opt then Dumpglob.dump_to_dotglob () + Coqtop.init_color opts.Coqargs.config let coqc_specific_usage = Usage.{ executable_name = "coqc"; @@ -54,7 +53,8 @@ let coqc_main copts ~opts = if opts.Coqargs.post.Coqargs.output_context then begin let sigma, env = let e = Global.env () in Evd.from_env e, e in - Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) + let library_accessor = Library.indirect_accessor in + Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context ~library_accessor env) sigma) ++ fnl ()) end; CProfile.print_profile () diff --git a/toplevel/coqcargs.ml b/toplevel/coqcargs.ml index 5cced2baac..c4e3571281 100644 --- a/toplevel/coqcargs.ml +++ b/toplevel/coqcargs.ml @@ -23,7 +23,8 @@ type t = ; echo : bool - ; outputstate : string option; + ; outputstate : string option + ; glob_out : Dumpglob.glob_output } let default = @@ -40,6 +41,7 @@ let default = ; echo = false ; outputstate = None + ; glob_out = Dumpglob.MultFiles } let depr opt = @@ -187,6 +189,15 @@ let parse arglist : t = | "-outputstate" -> set_outputstate oval (next ()) + (* Glob options *) + |"-no-glob" | "-noglob" -> + { oval with glob_out = Dumpglob.NoGlob } + + |"-dump-glob" -> + let file = next () in + { oval with glob_out = Dumpglob.File file } + + (* Rest *) | s -> extras := s :: !extras; oval @@ -199,3 +210,11 @@ let parse arglist : t = check_compilation_output_name_consistency args; args with any -> fatal_error any + +let parse args = + let opts = parse args in + { opts with + compile_list = List.rev opts.compile_list + ; vio_tasks = List.rev opts.vio_tasks + ; vio_files = List.rev opts.vio_files + } diff --git a/toplevel/coqcargs.mli b/toplevel/coqcargs.mli index b02eeeb9ee..13bea3bf3e 100644 --- a/toplevel/coqcargs.mli +++ b/toplevel/coqcargs.mli @@ -24,6 +24,7 @@ type t = ; echo : bool ; outputstate : string option + ; glob_out : Dumpglob.glob_output } val default : t diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 78640334e2..07466d641e 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -438,19 +438,15 @@ let rec loop ~state = loop ~state (* Default toplevel loop *) -let warning s = Flags.(with_option warn Feedback.msg_warning (strbrk s)) let drop_args = ref None + let loop ~opts ~state = drop_args := Some opts; let open Coqargs in print_emacs := opts.config.print_emacs; (* We initialize the console only if we run the toploop_run *) 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 () - end; let _ = loop ~state in (* Initialise and launch the Ocaml toplevel *) Coqinit.init_ocaml_path(); diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index f09d202edf..eded9f4bcd 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -30,7 +30,7 @@ let get_version_date () = let print_header () = let (ver,rev) = get_version_date () in - Feedback.msg_notice (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); + Feedback.msg_info (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); flush_all () let print_memory_stat () = @@ -87,7 +87,7 @@ let set_options = List.iter set_option let inputstate opts = Option.iter (fun istate_file -> let fname = Loadpath.locate_file (CUnix.make_suffix istate_file ".coq") in - States.intern_state fname) opts.inputstate + Library.intern_state fname) opts.inputstate (******************************************************************************) (* Fatal Errors *) diff --git a/toplevel/usage.ml b/toplevel/usage.ml index cdb2e36fbd..8555d78156 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -82,6 +82,7 @@ let print_usage_common co command = \n -sprop-cumulative make sort SProp cumulative with the rest of the hierarchy\ \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ +\n -no-template-check disable checking of universes constraints on universes parameterizing template polymorphic inductive types\ \n -mangle-names x mangle auto-generated names using prefix x\ \n -set \"Foo Bar\" enable Foo Bar (as Set Foo Bar. in a file)\ \n -set \"Foo Bar=value\" set Foo Bar to value (value is interpreted according to Foo Bar's type)\ diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index e9d8263b85..bca6b48499 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -169,6 +169,6 @@ let beautify_pass ~doc ~comments ~ids ~filename = let load_vernac ~echo ~check ~interactive ~state filename = let ostate, ids, comments = load_vernac_core ~echo ~check ~interactive ~state filename in (* Pass for beautify *) - if !Flags.beautify then beautify_pass ~doc:ostate.State.doc ~comments ~ids:List.(rev ids) ~filename; + if !Flags.beautify then beautify_pass ~doc:ostate.State.doc ~comments ~ids:(List.rev ids) ~filename; (* End pass *) ostate diff --git a/user-contrib/Ltac2/Constr.v b/user-contrib/Ltac2/Constr.v index 34299f3cf9..1e330b06d7 100644 --- a/user-contrib/Ltac2/Constr.v +++ b/user-contrib/Ltac2/Constr.v @@ -16,6 +16,10 @@ Ltac2 @ external type : constr -> constr := "ltac2" "constr_type". Ltac2 @ external equal : constr -> constr -> bool := "ltac2" "constr_equal". (** Strict syntactic equality: only up to α-conversion and evar expansion *) +Ltac2 Type relevance := [ Relevant | Irrelevant ]. + +Ltac2 Type 'a binder_annot := { binder_name : 'a; binder_relevance : relevance }. + Module Unsafe. (** Low-level access to kernel terms. Use with care! *) @@ -29,16 +33,16 @@ Ltac2 Type kind := [ | Evar (evar, constr array) | Sort (sort) | Cast (constr, cast, constr) -| Prod (ident option, constr, constr) -| Lambda (ident option, constr, constr) -| LetIn (ident option, constr, constr, constr) +| Prod (ident option binder_annot, constr, constr) +| Lambda (ident option binder_annot, constr, constr) +| LetIn (ident option binder_annot, constr, constr, constr) | App (constr, constr array) | Constant (constant, instance) | Ind (inductive, instance) | Constructor (constructor, instance) | Case (case, constr, constr, constr array) -| Fix (int array, int, ident option array, constr array, constr array) -| CoFix (int, ident option array, constr array, constr array) +| Fix (int array, int, ident option binder_annot array, constr array, constr array) +| CoFix (int, ident option binder_annot array, constr array, constr array) | Proj (projection, constr) | Uint63 (uint63) ]. diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index a72e43de01..cb034bdff6 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -353,6 +353,8 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in ContextObjectMap.add (Axiom (TypeInType obj, l)) Constr.mkProp accu in - accu - + if not mind.mind_typing_flags.check_template then + let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in + ContextObjectMap.add (Axiom (TemplatePolymorphic m, l)) Constr.mkProp accu + else accu in GlobRef.Map_env.fold fold graph ContextObjectMap.empty diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index d414d57c0d..98fe436a22 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -345,7 +345,7 @@ let build_beq_scheme mode kn = Vars.substl subst cores.(i) in create_input fix), - UState.make (Global.universes ())), + UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ())), !eff let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme @@ -690,7 +690,7 @@ let make_bl_scheme mode mind = let lnonparrec,lnamesparrec = (* TODO subst *) context_chop (nparams-nparrec) mib.mind_params_ctxt in let bl_goal, eff = compute_bl_goal ind lnamesparrec nparrec in - let ctx = UState.make (Global.universes ()) in + let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let bl_goal = EConstr.of_constr bl_goal in let (ans, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ctx bl_goal @@ -820,7 +820,7 @@ let make_lb_scheme mode mind = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in - let ctx = UState.make (Global.universes ()) in + let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let lb_goal = EConstr.of_constr lb_goal in let (ans, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ctx lb_goal @@ -996,7 +996,7 @@ let make_eq_decidability mode mind = let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in let u = Univ.Instance.empty in - let ctx = UState.make (Global.universes ()) in + let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let side_eff = side_effect_of_mode mode in diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 57de719cb4..9745358ba2 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -85,12 +85,12 @@ let do_definition ~program_mode ?hook ~name ~scope ~poly ~kind univdecl bl red_o in if program_mode then let env = Global.env () in - let (c,ctx), sideff = Future.force ce.Proof_global.proof_entry_body in + let (c,ctx), sideff = Future.force ce.Declare.proof_entry_body in assert(Safe_typing.empty_private_constants = sideff.Evd.seff_private); assert(Univ.ContextSet.is_empty ctx); Obligations.check_evars env evd; let c = EConstr.of_constr c in - let typ = match ce.Proof_global.proof_entry_type with + let typ = match ce.Declare.proof_entry_type with | Some t -> EConstr.of_constr t | None -> Retyping.get_type_of env evd c in diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index db0c102e14..01505d0733 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -41,5 +41,5 @@ val interp_definition -> red_expr option -> constr_expr -> constr_expr option - -> Evd.side_effects Proof_global.proof_entry * + -> Evd.side_effects Declare.proof_entry * Evd.evar_map * UState.universe_decl * Impargs.manual_implicits diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index adbe196699..98b869d72e 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -114,20 +114,22 @@ let mk_mltype_data sigma env assums arity indname = inductives which are recognized when a "Type" appears at the end of the conlusion in the source syntax. *) -let rec check_anonymous_type ind = +let rec check_type_conclusion ind = let open Glob_term in match DAst.get ind with - | GSort (UAnonymous {rigid=true}) -> true + | GSort (UAnonymous {rigid=true}) -> (Some true) + | GSort (UNamed _) -> (Some false) | GProd ( _, _, _, e) | GLetIn (_, _, _, e) | GLambda (_, _, _, e) | GApp (e, _) - | GCast (e, _) -> check_anonymous_type e - | _ -> false + | GCast (e, _) -> check_type_conclusion e + | _ -> None -let make_conclusion_flexible sigma = function +let make_anonymous_conclusion_flexible sigma = function | None -> sigma - | Some s -> + | Some (false, _) -> sigma + | Some (true, s) -> (match EConstr.ESorts.kind sigma s with | Type u -> (match Univ.universe_level u with @@ -136,17 +138,23 @@ let make_conclusion_flexible sigma = function | None -> sigma) | _ -> sigma) -let interp_ind_arity env sigma ind = +let intern_ind_arity env sigma ind = let c = intern_gen IsType env sigma ind.ind_arity in let impls = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in + let pseudo_poly = check_type_conclusion c in + (constr_loc ind.ind_arity, c, impls, pseudo_poly) + +let pretype_ind_arity env sigma (loc, c, impls, pseudo_poly) = let sigma,t = understand_tcc env sigma ~expected_type:IsType c in - let pseudo_poly = check_anonymous_type c in match Reductionops.sort_of_arity env sigma t with | exception Invalid_argument _ -> - user_err ?loc:(constr_loc ind.ind_arity) (str "Not an arity") + user_err ?loc (str "Not an arity") | s -> - let concl = if pseudo_poly then Some s else None in - sigma, (t, Retyping.relevance_of_sort s, concl, impls) + let concl = match pseudo_poly with + | Some b -> Some (b, s) + | None -> None + in + sigma, (t, Retyping.relevance_of_sort s, concl, impls) let interp_cstrs env sigma impls mldata arity ind = let cnames,ctyps = List.split ind.ind_lc in @@ -251,7 +259,7 @@ let solve_constraints_system levels level_bounds = done; v -let inductive_levels env evd poly arities inds = +let inductive_levels env evd arities inds = let destarities = List.map (fun x -> x, Reduction.dest_arity env x) arities in let levels = List.map (fun (x,(ctx,a)) -> if Sorts.is_prop a || Sorts.is_sprop a then None @@ -286,7 +294,7 @@ let inductive_levels env evd poly arities inds = CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> if is_impredicative_sort env du then (* Any product is allowed here. *) - evd, arity :: arities + evd, (false, arity) :: arities else (* If in a predicative sort, or asked to infer the type, we take the max of: - indices (if in indices-matter mode) @@ -300,7 +308,6 @@ let inductive_levels env evd poly arities inds = raise (InductiveError LargeNonPropInductiveNotInType) else evd else evd - (* Evd.set_leq_sort env evd (Type cu) du *) in let evd = if len >= 2 && Univ.is_type0m_univ cu then @@ -311,14 +318,14 @@ let inductive_levels env evd poly arities inds = else evd in let duu = Sorts.univ_of_sort du in - let evd = + let template_prop, evd = if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) then - Evd.set_eq_sort env evd Sorts.prop du - else evd - else Evd.set_eq_sort env evd (sort_of_univ cu) du + true, Evd.set_eq_sort env evd Sorts.prop du + else false, evd + else false, Evd.set_eq_sort env evd (sort_of_univ cu) du in - (evd, arity :: arities)) + (evd, (template_prop, arity) :: arities)) (evd,[]) (Array.to_list levels') destarities sizes in evd, List.rev arities @@ -328,6 +335,17 @@ let check_named {CAst.loc;v=na} = match na with let msg = str "Parameters must be named." in user_err ?loc msg +let template_polymorphism_candidate env uctx params concl = + match uctx with + | Entries.Monomorphic_entry uctx -> + let concltemplate = Option.cata (fun s -> not (Sorts.is_small s)) false concl in + if not concltemplate then false + else + let template_check = Environ.check_template env in + let conclu = Option.cata Sorts.univ_of_sort Univ.type0m_univ concl in + let params, conclunivs = IndTyping.template_polymorphic_univs ~template_check uctx params conclu in + not (template_check && Univ.LSet.is_empty conclunivs) + | Entries.Polymorphic_entry _ -> false let check_param = function | CLocalDef (na, _, _) -> check_named na @@ -345,25 +363,46 @@ let restrict_inductive_universes sigma ctx_params arities constructors = let uvars = List.fold_right (fun (_,ctypes,_) -> List.fold_right merge_universes_of_constr ctypes) constructors uvars in Evd.restrict_universe_context sigma uvars -let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) notations ~cumulative ~poly ~private_ind finite = - check_all_names_different indl; - List.iter check_param paramsl; - if not (List.is_empty uparamsl) && not (List.is_empty notations) - then user_err (str "Inductives with uniform parameters may not have attached notations."); - let sigma, udecl = interp_univ_decl_opt env0 udecl in +let interp_params env udecl uparamsl paramsl = + let sigma, udecl = interp_univ_decl_opt env udecl in let sigma, (uimpls, ((env_uparams, ctx_uparams), useruimpls)) = - interp_context_evars ~program_mode:false env0 sigma uparamsl in + interp_context_evars ~program_mode:false env sigma uparamsl in let sigma, (impls, ((env_params, ctx_params), userimpls)) = interp_context_evars ~program_mode:false ~impl_env:uimpls env_uparams sigma paramsl in - let indnames = List.map (fun ind -> ind.ind_name) indl in - (* Names of parameters as arguments of the inductive type (defs removed) *) let assums = List.filter is_local_assum ctx_params in - let params = List.map (RelDecl.get_name %> Name.get_id) assums in + sigma, env_params, (ctx_params, env_uparams, ctx_uparams, + List.map (RelDecl.get_name %> Name.get_id) assums, userimpls, useruimpls, impls, udecl) + +let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) notations ~cumulative ~poly ~private_ind finite = + check_all_names_different indl; + List.iter check_param paramsl; + if not (List.is_empty uparamsl) && not (List.is_empty notations) + then user_err (str "Inductives with uniform parameters may not have attached notations."); + + let indnames = List.map (fun ind -> ind.ind_name) indl in + let sigma, env_params, infos = + interp_params env0 udecl uparamsl paramsl + in (* Interpret the arities *) - let sigma, arities = List.fold_left_map (fun sigma -> interp_ind_arity env_params sigma) sigma indl in + let arities = List.map (intern_ind_arity env_params sigma) indl in + + let sigma, env_params, (ctx_params, env_uparams, ctx_uparams, params, userimpls, useruimpls, impls, udecl), arities, is_template = + let is_template = List.exists (fun (_,_,_,pseudo_poly) -> not (Option.is_empty pseudo_poly)) arities in + if not poly && is_template then + (* In case of template polymorphism, we need to compute more constraints *) + let env0 = Environ.set_universes_lbound env0 Univ.Level.prop in + let sigma, env_params, infos = + interp_params env0 udecl uparamsl paramsl + in + let arities = List.map (intern_ind_arity env_params sigma) indl in + sigma, env_params, infos, arities, is_template + else sigma, env_params, infos, arities, is_template + in + + let sigma, arities = List.fold_left_map (pretype_ind_arity env_params) sigma arities in let arities, relevances, arityconcl, indimpls = List.split4 arities in let fullarities = List.map (fun c -> EConstr.it_mkProd_or_LetIn c ctx_params) arities in @@ -410,31 +449,36 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let nf = Evarutil.nf_evars_universes sigma in let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in let arities = List.map EConstr.(to_constr sigma) arities in - let sigma = List.fold_left make_conclusion_flexible sigma arityconcl in - let sigma, arities = inductive_levels env_ar_params sigma poly arities constructors in + let sigma = List.fold_left make_anonymous_conclusion_flexible sigma arityconcl in + let sigma, arities = inductive_levels env_ar_params sigma arities constructors in let sigma = Evd.minimize_universes sigma in let nf = Evarutil.nf_evars_universes sigma in - let arities = List.map nf arities in + let arities = List.map (fun (template, arity) -> template, nf arity) arities in let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in let ctx_params = List.map Termops.(map_rel_decl (EConstr.to_constr sigma)) ctx_params in - let arityconcl = List.map (Option.map (EConstr.ESorts.kind sigma)) arityconcl in - let sigma = restrict_inductive_universes sigma ctx_params arities constructors in + let arityconcl = List.map (Option.map (fun (anon, s) -> EConstr.ESorts.kind sigma s)) arityconcl in + let sigma = restrict_inductive_universes sigma ctx_params (List.map snd arities) constructors in let uctx = Evd.check_univ_decl ~poly sigma udecl in - List.iter (fun c -> check_evars env_params (Evd.from_env env_params) sigma (EConstr.of_constr c)) arities; + List.iter (fun c -> check_evars env_params (Evd.from_env env_params) sigma (EConstr.of_constr (snd c))) arities; Context.Rel.iter (fun c -> check_evars env0 (Evd.from_env env0) sigma (EConstr.of_constr c)) ctx_params; List.iter (fun (_,ctyps,_) -> List.iter (fun c -> check_evars env_ar_params (Evd.from_env env_ar_params) sigma (EConstr.of_constr c)) ctyps) constructors; (* Build the inductive entries *) - let entries = List.map4 (fun ind arity concl (cnames,ctypes,cimpls) -> + let entries = List.map4 (fun ind (templatearity, arity) concl (cnames,ctypes,cimpls) -> + let template_candidate () = + templatearity || template_polymorphism_candidate env0 uctx ctx_params concl in let template = match template with | Some template -> - if poly && template then user_err Pp.(strbrk "template and polymorphism not compatible"); + if poly && template then user_err + Pp.(strbrk "Template-polymorphism and universe polymorphism are not compatible."); + if template && not (template_candidate ()) then + user_err Pp.(strbrk "Inductive " ++ Id.print ind.ind_name ++ + str" cannot be made template polymorphic."); template | None -> - should_auto_template ind.ind_name (not poly && - Option.cata (fun s -> not (Sorts.is_small s)) false concl) + should_auto_template ind.ind_name (template_candidate ()) in { mind_entry_typename = ind.ind_name; mind_entry_arity = arity; diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 285be8cd51..7587bd165f 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -62,3 +62,17 @@ val should_auto_template : Id.t -> bool -> bool (** [should_auto_template x b] is [true] when [b] is [true] and we automatically use template polymorphism. [x] is the name of the inductive under consideration. *) + +val template_polymorphism_candidate : + Environ.env -> Entries.universes_entry -> Constr.rel_context -> Sorts.t option -> bool +(** [template_polymorphism_candidate env uctx params conclsort] is + [true] iff an inductive with params [params] and conclusion + [conclsort] would be definable as template polymorphic. It should + have at least one universe in its monomorphic universe context that + can be made parametric in its conclusion sort, if one is given. + If the [Template Check] flag is false we just check that the conclusion sort + is not small. *) + +val sign_level : Environ.env -> Evd.evar_map -> Constr.rel_declaration list -> Univ.Universe.t +(** [sign_level env sigma ctx] computes the universe level of the context [ctx] + as the [sup] of its individual assumptions, which should be well-typed in [env] and [sigma] *) diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 3497e6369f..0e17f2b274 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -44,41 +44,68 @@ let mkSubset sigma name typ prop = let make_qref s = qualid_of_string s let lt_ref = make_qref "Init.Peano.lt" +type family = SPropF | PropF | TypeF +let family_of_sort_family = let open Sorts in function + | InSProp -> SPropF + | InProp -> PropF + | InSet | InType -> TypeF + +let get_sigmatypes sigma ~sort ~predsort = + let open EConstr in + let which, sigsort = match predsort, sort with + | SPropF, _ | _, SPropF -> + user_err Pp.(str "SProp arguments not supported by Program Fixpoint yet.") + | PropF, PropF -> "ex", PropF + | PropF, TypeF -> "sig", TypeF + | TypeF, (PropF|TypeF) -> "sigT", TypeF + in + let sigma, ty = Evarutil.new_global sigma (lib_ref ("core."^which^".type")) in + let uinstance = snd (destRef sigma ty) in + let intro = mkRef (lib_ref ("core."^which^".intro"), uinstance) in + let p1 = mkRef (lib_ref ("core."^which^".proj1"), uinstance) in + let p2 = mkRef (lib_ref ("core."^which^".proj2"), uinstance) in + sigma, ty, intro, p1, p2, sigsort + let rec telescope sigma l = let open EConstr in let open Vars in match l with | [] -> assert false - | [LocalAssum (n, t)] -> + | [LocalAssum (n, t), _] -> sigma, t, [LocalDef (n, mkRel 1, t)], mkRel 1 - | LocalAssum (n, t) :: tl -> - let sigma, ty, tys, (k, constr) = + | (LocalAssum (n, t), tsort) :: tl -> + let sigma, ty, _tysort, tys, (k, constr) = List.fold_left - (fun (sigma, ty, tys, (k, constr)) decl -> + (fun (sigma, ty, tysort, tys, (k, constr)) (decl,sort) -> let t = RelDecl.get_type decl in let pred = mkLambda (RelDecl.get_annot decl, t, ty) in - let sigma, ty = Evarutil.new_global sigma (lib_ref "core.sigT.type") in - let sigma, intro = Evarutil.new_global sigma (lib_ref "core.sigT.intro") in + let sigma, ty, intro, p1, p2, sigsort = get_sigmatypes sigma ~predsort:tysort ~sort in let sigty = mkApp (ty, [|t; pred|]) in let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in - (sigma, sigty, pred :: tys, (succ k, intro))) - (sigma, t, [], (2, mkRel 1)) tl + (sigma, sigty, sigsort, (pred, p1, p2) :: tys, (succ k, intro))) + (sigma, t, tsort, [], (2, mkRel 1)) tl in let sigma, last, subst = List.fold_right2 - (fun pred decl (sigma, prev, subst) -> + (fun (pred,p1,p2) (decl,_) (sigma, prev, subst) -> let t = RelDecl.get_type decl in - let sigma, p1 = Evarutil.new_global sigma (lib_ref "core.sigT.proj1") in - let sigma, p2 = Evarutil.new_global sigma (lib_ref "core.sigT.proj2") in let proj1 = applist (p1, [t; pred; prev]) in let proj2 = applist (p2, [t; pred; prev]) in (sigma, lift 1 proj2, LocalDef (get_annot decl, proj1, t) :: subst)) (List.rev tys) tl (sigma, mkRel 1, []) in sigma, ty, (LocalDef (n, last, t) :: subst), constr - | LocalDef (n, b, t) :: tl -> + | (LocalDef (n, b, t), _) :: tl -> let sigma, ty, subst, term = telescope sigma tl in sigma, ty, (LocalDef (n, b, t) :: subst), lift 1 term +let telescope env sigma l = + let l, _ = List.fold_right_map (fun d env -> + let s = Retyping.get_sort_family_of env sigma (RelDecl.get_type d) in + let env = EConstr.push_rel d env in + (d, family_of_sort_family s), env) l env + in + telescope sigma l + let nf_evar_context sigma ctx = List.map (map_constr (fun c -> Evarutil.nf_evar sigma c)) ctx @@ -94,7 +121,7 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let top_env = push_rel_context binders_rel env in let sigma, top_arity = interp_type_evars ~program_mode:true top_env sigma arityc in let full_arity = it_mkProd_or_LetIn top_arity binders_rel in - let sigma, argtyp, letbinders, make = telescope sigma binders_rel in + let sigma, argtyp, letbinders, make = telescope env sigma binders_rel in let argname = Id.of_string "recarg" in let arg = LocalAssum (make_annot (Name argname) Sorts.Relevant, argtyp) in let binders = letbinders @ [arg] in diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 5e4f2dcd34..1926faaf0e 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -44,7 +44,7 @@ end (* Locality stuff *) let declare_definition ~name ~scope ~kind ?hook_data udecl ce imps = - let fix_exn = Future.fix_exn_of ce.Proof_global.proof_entry_body in + let fix_exn = Future.fix_exn_of ce.proof_entry_body in let gr = match scope with | Discharge -> let () = diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 606cfade46..54a0c9a7e8 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -45,7 +45,7 @@ val declare_definition -> kind:Decls.definition_object_kind -> ?hook_data:(Hook.t * UState.t * (Id.t * Constr.t) list) -> UnivNames.universe_binders - -> Evd.side_effects Proof_global.proof_entry + -> Evd.side_effects Declare.proof_entry -> Impargs.manual_implicits -> GlobRef.t @@ -66,7 +66,7 @@ val prepare_definition : allow_evars:bool -> ?opaque:bool -> ?inline:bool -> poly:bool -> Evd.evar_map -> UState.universe_decl -> types:EConstr.t option -> body:EConstr.t -> - Evd.evar_map * Evd.side_effects Proof_global.proof_entry + Evd.evar_map * Evd.side_effects Declare.proof_entry val prepare_parameter : allow_evars:bool -> poly:bool -> Evd.evar_map -> UState.universe_decl -> EConstr.types -> diff --git a/vernac/declareObl.ml b/vernac/declareObl.ml index c5cbb095ca..8fd6bc7eab 100644 --- a/vernac/declareObl.ml +++ b/vernac/declareObl.ml @@ -149,18 +149,8 @@ let declare_obligation prg obl body ty uctx = if get_shrink_obligations () && not poly then shrink_body body ty else ([], body, ty, [||]) in - let body = - ((body, Univ.ContextSet.empty), Evd.empty_side_effects) - in - let ce = - Proof_global.{ proof_entry_body = Future.from_val ~fix_exn:(fun x -> x) body - ; proof_entry_secctx = None - ; proof_entry_type = ty - ; proof_entry_universes = uctx - ; proof_entry_opaque = opaque - ; proof_entry_inline_code = false - ; proof_entry_feedback = None } - in + let ce = Declare.definition_entry ?types:ty ~opaque ~univs:uctx body in + (* ppedrot: seems legit to have obligations as local *) let constant = Declare.declare_constant ~name:obl.obl_name @@ -495,12 +485,11 @@ type obligation_qed_info = } let obligation_terminator entries uctx { name; num; auto } = - let open Proof_global in match entries with | [entry] -> let env = Global.env () in - let ty = entry.proof_entry_type in - let body, eff = Future.force entry.proof_entry_body in + let ty = entry.Declare.proof_entry_type in + let body, eff = Future.force entry.Declare.proof_entry_body in let (body, cstr) = Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) in let sigma = Evd.from_ctx uctx in let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in @@ -514,7 +503,7 @@ let obligation_terminator entries uctx { name; num; auto } = let obls, rem = prg.prg_obligations in let obl = obls.(num) in let status = - match obl.obl_status, entry.proof_entry_opaque with + match obl.obl_status, entry.Declare.proof_entry_opaque with | (_, Evar_kinds.Expand), true -> err_not_transp () | (true, _), true -> err_not_transp () | (false, _), true -> Evar_kinds.Define true @@ -541,7 +530,7 @@ let obligation_terminator entries uctx { name; num; auto } = declares the univs of the constant, each subsequent obligation declares its own additional universes and constraints if any *) - if defined then UState.make (Global.universes ()) + if defined then UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) else ctx in let prg = {prg with prg_ctx} in diff --git a/vernac/declareObl.mli b/vernac/declareObl.mli index 2a8fa734b3..7d8a112cc6 100644 --- a/vernac/declareObl.mli +++ b/vernac/declareObl.mli @@ -76,7 +76,7 @@ type obligation_qed_info = } val obligation_terminator - : Evd.side_effects Proof_global.proof_entry list + : Evd.side_effects Declare.proof_entry list -> UState.t -> obligation_qed_info -> unit (** [obligation_terminator] part 2 of saving an obligation *) diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index cf87646905..a6c577a878 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -98,20 +98,11 @@ let () = (* Util *) -let define ~poly name sigma c t = +let define ~poly name sigma c types = let f = declare_constant ~kind:Decls.(IsDefinition Scheme) in let univs = Evd.univ_entry ~poly sigma in - let open Proof_global in - let kn = f ~name - (DefinitionEntry - { proof_entry_body = c; - proof_entry_secctx = None; - proof_entry_type = t; - proof_entry_universes = univs; - proof_entry_opaque = false; - proof_entry_inline_code = false; - proof_entry_feedback = None; - }) in + let entry = Declare.definition_entry ~univs ?types c in + let kn = f ~name (DefinitionEntry entry) in definition_message name; kn @@ -412,8 +403,7 @@ let do_mutual_induction_scheme ?(force_mutual=false) lnamedepindsort = let declare decl fi lrecref = let decltype = Retyping.get_type_of env0 sigma (EConstr.of_constr decl) in let decltype = EConstr.to_constr sigma decltype in - let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Evd.empty_side_effects) in - let cst = define ~poly fi sigma proof_output (Some decltype) in + let cst = define ~poly fi sigma decl (Some decltype) in GlobRef.ConstRef cst :: lrecref in let _ = List.fold_right2 declare listdecl lrecnames [] in @@ -534,7 +524,6 @@ let do_combined_scheme name schemes = schemes in let sigma,body,typ = build_combined_scheme (Global.env ()) csts in - let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Evd.empty_side_effects) in (* It is possible for the constants to have different universe polymorphism from each other, however that is only when the user manually defined at least one of them (as Scheme would pick the @@ -542,7 +531,7 @@ let do_combined_scheme name schemes = some other polymorphism they can also manually define the combined scheme. *) let poly = Global.is_polymorphic (GlobRef.ConstRef (List.hd csts)) in - ignore (define ~poly name.v sigma proof_output (Some typ)); + ignore (define ~poly name.v sigma body (Some typ)); fixpoint_message None [name.v] (**********************************************************************) diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 7809425a10..42d1a1f3fc 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -383,10 +383,9 @@ let adjust_guardness_conditions const = function | possible_indexes -> (* Try all combinations... not optimal *) let env = Global.env() in - let open Proof_global in { const with - proof_entry_body = - Future.chain const.proof_entry_body + Declare.proof_entry_body = + Future.chain const.Declare.proof_entry_body (fun ((body, ctx), eff) -> match Constr.kind body with | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> @@ -404,10 +403,11 @@ let finish_proved env sigma idopt po info = let name = match idopt with | None -> name | Some { CAst.v = save_id } -> check_anonymity name save_id; save_id in - let fix_exn = Future.fix_exn_of const.proof_entry_body in + let fix_exn = Future.fix_exn_of const.Declare.proof_entry_body in let () = try let const = adjust_guardness_conditions const compute_guard in - let should_suggest = const.proof_entry_opaque && Option.is_empty const.proof_entry_secctx in + let should_suggest = const.Declare.proof_entry_opaque && + Option.is_empty const.Declare.proof_entry_secctx in let open DeclareDef in let r = match scope with | Discharge -> @@ -451,7 +451,7 @@ let finish_derived ~f ~name ~idopt ~entries = in (* The opacity of [f_def] is adjusted to be [false], as it must. Then [f] is declared in the global environment. *) - let f_def = { f_def with Proof_global.proof_entry_opaque = false } in + let f_def = { f_def with Declare.proof_entry_opaque = false } in let f_kind = Decls.(IsDefinition Definition) in let f_def = Declare.DefinitionEntry f_def in let f_kn = Declare.declare_constant ~name:f ~kind:f_kind f_def in @@ -463,17 +463,17 @@ let finish_derived ~f ~name ~idopt ~entries = let substf c = Vars.replace_vars [f,f_kn_term] c in (* Extracts the type of the proof of [suchthat]. *) let lemma_pretype = - match Proof_global.(lemma_def.proof_entry_type) with + match lemma_def.Declare.proof_entry_type with | Some t -> t | None -> assert false (* Proof_global always sets type here. *) in (* The references of [f] are subsituted appropriately. *) let lemma_type = substf lemma_pretype in (* The same is done in the body of the proof. *) - let lemma_body = Future.chain Proof_global.(lemma_def.proof_entry_body) (fun ((b,ctx),fx) -> (substf b, ctx), fx) in - let lemma_def = let open Proof_global in + let lemma_body = Future.chain lemma_def.Declare.proof_entry_body (fun ((b,ctx),fx) -> (substf b, ctx), fx) in + let lemma_def = { lemma_def with - proof_entry_body = lemma_body; + Declare.proof_entry_body = lemma_body; proof_entry_type = Some lemma_type } in let lemma_def = Declare.DefinitionEntry lemma_def in @@ -530,7 +530,7 @@ let save_lemma_admitted_delayed ~proof ~info = let { Info.hook; scope; impargs; other_thms } = info in if List.length entries <> 1 then user_err Pp.(str "Admitted does not support multiple statements"); - let { proof_entry_secctx; proof_entry_type; proof_entry_universes } = List.hd entries in + let { Declare.proof_entry_secctx; proof_entry_type; proof_entry_universes } = List.hd entries in let poly = match proof_entry_universes with | Entries.Monomorphic_entry _ -> false | Entries.Polymorphic_entry (_, _) -> true in diff --git a/library/library.ml b/vernac/library.ml index 0faef7bf84..8125c3de35 100644 --- a/library/library.ml +++ b/vernac/library.ml @@ -13,7 +13,6 @@ open CErrors open Util open Names -open Libnames open Lib open Libobject @@ -85,7 +84,6 @@ type library_disk = { type summary_disk = { md_name : compilation_unit_name; - md_imports : compilation_unit_name array; md_deps : (compilation_unit_name * Safe_typing.vodigest) array; } @@ -96,7 +94,6 @@ type library_t = { library_name : compilation_unit_name; library_data : library_disk delayed; library_deps : (compilation_unit_name * Safe_typing.vodigest) array; - library_imports : compilation_unit_name array; library_digests : Safe_typing.vodigest; library_extra_univs : Univ.ContextSet.t; } @@ -104,7 +101,6 @@ type library_t = { type library_summary = { libsum_name : compilation_unit_name; libsum_digests : Safe_typing.vodigest; - libsum_imports : compilation_unit_name array; } module LibraryOrdered = DirPath @@ -121,8 +117,6 @@ let libraries_filename_table = ref LibraryFilenameMap.empty (* These are the _ordered_ sets of loaded, imported and exported libraries *) let libraries_loaded_list = Summary.ref [] ~name:"LIBRARY-LOAD" -let libraries_imports_list = Summary.ref [] ~name:"LIBRARY-IMPORT" -let libraries_exports_list = Summary.ref [] ~name:"LIBRARY-EXPORT" (* various requests to the tables *) @@ -155,13 +149,6 @@ let library_is_loaded dir = try let _ = find_library dir in true with Not_found -> false -let library_is_opened dir = - List.exists (fun name -> DirPath.equal name dir) !libraries_imports_list - -let loaded_libraries () = !libraries_loaded_list - -let opened_libraries () = !libraries_imports_list - (* If a library is loaded several time, then the first occurrence must be performed first, thus the libraries_loaded_list ... *) @@ -182,87 +169,7 @@ let register_loaded_library m = libraries_loaded_list := aux !libraries_loaded_list; libraries_table := LibraryMap.add libname m !libraries_table - (* ... while if a library is imported/exported several time, then - only the last occurrence is really needed - though the imported - list may differ from the exported list (consider the sequence - Export A; Export B; Import A which results in A;B for exports but - in B;A for imports) *) - -let rec remember_last_of_each l m = - match l with - | [] -> [m] - | m'::l' when DirPath.equal m' m -> remember_last_of_each l' m - | m'::l' -> m' :: remember_last_of_each l' m - -let register_open_library export m = - libraries_imports_list := remember_last_of_each !libraries_imports_list m; - if export then - libraries_exports_list := remember_last_of_each !libraries_exports_list m - -(************************************************************************) -(*s Opening libraries *) - -(* [open_library export explicit m] opens library [m] if not already - opened _or_ if explicitly asked to be (re)opened *) - -let open_library export explicit_libs m = - if - (* Only libraries indirectly to open are not reopen *) - (* Libraries explicitly mentioned by the user are always reopen *) - List.exists (fun m' -> DirPath.equal m m') explicit_libs - || not (library_is_opened m) - then begin - register_open_library export m; - Declaremods.really_import_module (MPfile m) - end - else - if export then - libraries_exports_list := remember_last_of_each !libraries_exports_list m - -(* open_libraries recursively open a list of libraries but opens only once - a library that is re-exported many times *) - -let open_libraries export modl = - let to_open_list = - List.fold_left - (fun l m -> - let subimport = - Array.fold_left - (fun l m -> remember_last_of_each l m) - l m.libsum_imports - in remember_last_of_each subimport m.libsum_name) - [] modl in - let explicit = List.map (fun m -> m.libsum_name) modl in - List.iter (open_library export explicit) to_open_list - - -(**********************************************************************) -(* import and export of libraries - synchronous operations *) -(* at the end similar to import and export of modules except that it *) -(* is optimized: when importing several libraries at the same time *) -(* which themselves indirectly imports the very same modules, these *) -(* ones are imported only ones *) - -let open_import_library i (_,(modl,export)) = - if Int.equal i 1 then - (* even if the library is already imported, we re-import it *) - (* if not (library_is_opened dir) then *) - open_libraries export (List.map try_find_library modl) - -let cache_import_library obj = - open_import_library 1 obj - -let subst_import_library (_,o) = o - -let classify_import_library (_,export as obj) = - if export then Substitute obj else Dispose - -let in_import_library : DirPath.t list * bool -> obj = - declare_object {(default_object "IMPORT LIBRARY") with - cache_function = cache_import_library; - open_function = open_import_library; - subst_function = subst_import_library; - classify_function = classify_import_library } + let loaded_libraries () = !libraries_loaded_list (************************************************************************) (** {6 Tables of opaque proof terms} *) @@ -327,14 +234,12 @@ let mk_library sd md digests univs = library_name = sd.md_name; library_data = md; library_deps = sd.md_deps; - library_imports = sd.md_imports; library_digests = digests; library_extra_univs = univs; } let mk_summary m = { libsum_name = m.library_name; - libsum_imports = m.library_imports; libsum_digests = m.library_digests; } @@ -435,8 +340,7 @@ let load_require _ (_,(needed,modl,_)) = List.iter register_library needed let open_require i (_,(_,modl,export)) = - Option.iter (fun exp -> open_libraries exp (List.map find_library modl)) - export + Option.iter (fun export -> Declaremods.import_modules ~export @@ List.map (fun m -> MPfile m) modl) export (* [needed] is the ordered list of libraries not already loaded *) let cache_require o = @@ -474,50 +378,15 @@ let require_library_from_dirpath ~lib_resolver modrefl export = if Lib.is_module_or_modtype () then begin warn_require_in_module (); - add_anonymous_leaf (in_require (needed,modrefl,None)); - Option.iter (fun exp -> - add_anonymous_leaf (in_import_library (modrefl,exp))) - export + add_anonymous_leaf (in_require (needed,modrefl,None)); + Option.iter (fun export -> + List.iter (fun m -> Declaremods.import_module ~export (MPfile m)) modrefl) + export end else add_anonymous_leaf (in_require (needed,modrefl,export)); () -(* the function called by Vernacentries.vernac_import *) - -let safe_locate_module qid = - try Nametab.locate_module qid - with Not_found -> - user_err ?loc:qid.CAst.loc ~hdr:"safe_locate_module" - (pr_qualid qid ++ str " is not a module") - -let import_module export modl = - (* Optimization: libraries in a raw in the list are imported - "globally". If there is non-library in the list; it breaks the - optimization For instance: "Import Arith MyModule Zarith" will - not be optimized (possibly resulting in redefinitions, but - "Import MyModule Arith Zarith" and "Import Arith Zarith MyModule" - will have the submodules imported by both Arith and ZArith - imported only once *) - let flush = function - | [] -> () - | modl -> add_anonymous_leaf (in_import_library (List.rev modl, export)) in - let rec aux acc = function - | qid :: l -> - let m,acc = - try Nametab.locate_module qid, acc - with Not_found-> flush acc; safe_locate_module qid, [] in - (match m with - | MPfile dir -> aux (dir::acc) l - | mp -> - flush acc; - try Declaremods.import_module export mp; aux [] l - with Not_found -> - user_err ?loc:qid.CAst.loc ~hdr:"import_module" - (pr_qualid qid ++ str " is not a module")) - | [] -> flush acc - in aux [] modl - (************************************************************************) (*s Initializing the compilation of a library. *) @@ -544,10 +413,8 @@ let current_deps () = in List.map map !libraries_loaded_list -let current_reexports () = !libraries_exports_list - let error_recursively_dependent_library dir = - user_err + user_err (strbrk "Unable to use logical name " ++ DirPath.print dir ++ strbrk " to save current library because" ++ strbrk " it already depends on a library of this name.") @@ -591,7 +458,6 @@ let save_library_to ?todo ~output_native_objects dir f otab = let sd = { md_name = dir; md_deps = Array.of_list (current_deps ()); - md_imports = Array.of_list (current_reexports ()); } in let md = { md_compiled = cenv; @@ -640,3 +506,12 @@ let get_used_load_paths () = StringSet.empty !libraries_loaded_list) let _ = Nativelib.get_load_paths := get_used_load_paths + +(* These commands may not be very safe due to ML-side plugin loading + etc... use at your own risk *) +let extern_state s = + System.extern_state Coq_config.state_magic_number s (States.freeze ~marshallable:true) + +let intern_state s = + States.unfreeze (System.with_magic_number_check (System.intern_state Coq_config.state_magic_number) s); + overwrite_library_filenames s diff --git a/library/library.mli b/vernac/library.mli index bb6c42e393..6a32413248 100644 --- a/library/library.mli +++ b/vernac/library.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Libnames (** This module provides functions to load, open and save libraries. Libraries correspond to the subclass of modules that @@ -37,10 +36,6 @@ type seg_univ = (* all_cst, finished? *) Univ.ContextSet.t * bool type seg_proofs = Opaqueproof.opaque_proofterm array -(** Open a module (or a library); if the boolean is true then it's also - an export otherwise just a simple import *) -val import_module : bool -> qualid list -> unit - (** End the compilation of a library and save it to a ".vo" file. [output_native_objects]: when producing vo objects, also compile the native-code version. *) val save_library_to : @@ -56,13 +51,11 @@ val save_library_raw : string -> seg_sum -> seg_lib -> seg_univ -> seg_proofs -> (** {6 Interrogate the status of libraries } *) - (** - Tell if a library is loaded or opened *) + (** - Tell if a library is loaded *) val library_is_loaded : DirPath.t -> bool -val library_is_opened : DirPath.t -> bool - (** - Tell which libraries are loaded or imported *) + (** - Tell which libraries are loaded *) val loaded_libraries : unit -> DirPath.t list -val opened_libraries : unit -> DirPath.t list (** - Return the full filename of a loaded library. *) val library_full_filename : DirPath.t -> string @@ -75,3 +68,7 @@ val native_name_from_filename : string -> string (** {6 Opaque accessors} *) val indirect_accessor : Opaqueproof.indirect_accessor + +(** Low-level state overwriting, not very safe *) +val intern_state : string -> unit +val extern_state : string -> unit diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 37fe0df0ee..da14b6e979 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -423,11 +423,11 @@ let solve_by_tac ?loc name evi t poly ctx = Pfedit.build_constant_by_tactic ~name ~poly ctx evi.evar_hyps evi.evar_concl t in let env = Global.env () in - let (body, eff) = Future.force entry.Proof_global.proof_entry_body in + let (body, eff) = Future.force entry.Declare.proof_entry_body in let body = Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) in let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in Inductiveops.control_only_guard env ctx' (EConstr.of_constr (fst body)); - Some (fst body, entry.Proof_global.proof_entry_type, Evd.evar_universe_context ctx') + Some (fst body, entry.Declare.proof_entry_type, Evd.evar_universe_context ctx') with | Refiner.FailError (_, s) as exn -> let _ = CErrors.push exn in @@ -454,7 +454,7 @@ let obligation_hook prg obl num auto { DeclareDef.Hook.S.uctx = ctx'; dref; _ } if not prg.prg_poly (* Not polymorphic *) then (* The universe context was declared globally, we continue from the new global environment. *) - let ctx = UState.make (Global.universes ()) in + let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let ctx' = UState.merge_subst ctx (UState.subst ctx') in Univ.Instance.empty, ctx' else diff --git a/vernac/proof_using.ml b/vernac/proof_using.ml index 094e2c1184..cfb3248c7b 100644 --- a/vernac/proof_using.ml +++ b/vernac/proof_using.ml @@ -130,7 +130,7 @@ let suggest_common env ppid used ids_typ skip = str "should start with one of the following commands:"++spc()++ v 0 ( prlist_with_sep cut (fun x->str"Proof using " ++x++ str". ") !valid_exprs)); - if !Flags.record_aux_file + if Aux_file.recording () then let s = string_of_ppcmds (prlist_with_sep (fun _ -> str";") (fun x->x) !valid_exprs) in record_proof_using s diff --git a/vernac/record.ml b/vernac/record.ml index 86745212e7..831fb53549 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -85,10 +85,10 @@ let interp_fields_evars env sigma impls_env nots l = let compute_constructor_level evars env l = List.fold_right (fun d (env, univ) -> - let univ = + let univ = if is_local_assum d then let s = Retyping.get_sort_of env evars (RelDecl.get_type d) in - Univ.sup (univ_of_sort s) univ + Univ.sup (univ_of_sort s) univ else univ in (EConstr.push_rel d env, univ)) l (env, Univ.Universe.sprop) @@ -101,8 +101,19 @@ let binder_of_decl = function let binders_of_decls = List.map binder_of_decl +let check_anonymous_type ind = + match ind with + | { CAst.v = CSort (Glob_term.UAnonymous {rigid=true}) } -> true + | _ -> false + let typecheck_params_and_fields finite def poly pl ps records = let env0 = Global.env () in + (* Special case elaboration for template-polymorphic inductives, + lower bound on introduced universes is Prop so that we do not miss + any Set <= i constraint for universes that might actually be instantiated with Prop. *) + let is_template = + List.exists (fun (_, arity, _, _) -> Option.cata check_anonymous_type true arity) records in + let env0 = if not poly && is_template then Environ.set_universes_lbound env0 Univ.Level.prop else env0 in let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env0 pl in let () = let error bk {CAst.loc; v=name} = @@ -111,15 +122,15 @@ let typecheck_params_and_fields finite def poly pl ps records = user_err ?loc ~hdr:"record" (str "Record parameters must be named") | _ -> () in - List.iter + List.iter (function CLocalDef (b, _, _) -> error default_binder_kind b | CLocalAssum (ls, bk, ce) -> List.iter (error bk) ls | CLocalPattern {CAst.loc} -> Loc.raise ?loc (Stream.Error "pattern with quote not allowed in record parameters")) ps - in + in let sigma, (impls_env, ((env1,newps), imps)) = interp_context_evars ~program_mode:false env0 sigma ps in let fold (sigma, template) (_, t, _, _) = match t with - | Some t -> + | Some t -> let env = EConstr.push_rel_context newps env0 in let poly = match t with @@ -138,7 +149,7 @@ let typecheck_params_and_fields finite def poly pl ps records = (sigma, false), (s, s') else (sigma, false), (s, s')) | _ -> user_err ?loc:(constr_loc t) (str"Sort expected.")) - | None -> + | None -> let uvarkind = Evd.univ_flexible_alg in let sigma, s = Evd.new_sort_variable uvarkind sigma in (sigma, template), (EConstr.mkSort s, s) @@ -168,23 +179,23 @@ let typecheck_params_and_fields finite def poly pl ps records = let _, univ = compute_constructor_level sigma env_ar newfs in let univ = if Sorts.is_sprop sort then univ else Univ.Universe.sup univ Univ.type0m_univ in if not def && is_impredicative_sort env0 sort then - sigma, typ + sigma, (univ, typ) else let sigma = Evd.set_leq_sort env_ar sigma (Sorts.sort_of_univ univ) sort in if Univ.is_small_univ univ && Option.cata (Evd.is_flexible_level sigma) false (Evd.is_sort_variable sigma sort) then (* We can assume that the level in aritysort is not constrained and clear it, if it is flexible *) - Evd.set_eq_sort env_ar sigma Sorts.set sort, EConstr.mkSort (Sorts.sort_of_univ univ) - else sigma, typ + Evd.set_eq_sort env_ar sigma Sorts.set sort, (univ, EConstr.mkSort (Sorts.sort_of_univ univ)) + else sigma, (univ, typ) in let (sigma, typs) = List.fold_left2_map fold sigma typs data in let sigma, (newps, ans) = Evarutil.finalize sigma (fun nf -> let newps = List.map (RelDecl.map_constr_het nf) newps in - let map (impls, newfs) typ = + let map (impls, newfs) (univ, typ) = let newfs = List.map (RelDecl.map_constr_het nf) newfs in let typ = nf typ in - (typ, impls, newfs) + (univ, typ, impls, newfs) in let ans = List.map2 map data typs in newps, ans) @@ -295,7 +306,7 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f let x = make_annot (Name binder_name) mip.mind_relevance in let fields = instantiate_possibly_recursive_type (fst indsp) u mib.mind_ntypes paramdecls fields in let lifted_fields = Termops.lift_rel_context 1 fields in - let primitive = + let primitive = match mib.mind_record with | PrimRecord _ -> true | FakeRecord | NotRecord -> false @@ -310,7 +321,7 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f | Anonymous -> (None::sp_projs,i,NoProjection fi::subst) | Name fid -> try - let kn, term = + let kn, term = if is_local_assum decl && primitive then let p = Projection.Repr.make indsp ~proj_npars:mib.mind_nparams @@ -340,26 +351,17 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in try - let open Proof_global in - let entry = { - proof_entry_body = - Future.from_val ((proj, Univ.ContextSet.empty), Evd.empty_side_effects); - proof_entry_secctx = None; - proof_entry_type = Some projtyp; - proof_entry_universes = ctx; - proof_entry_opaque = false; - proof_entry_inline_code = false; - proof_entry_feedback = None } in + let entry = Declare.definition_entry ~univs:ctx ~types:projtyp proj in let kind = Decls.IsDefinition kind in let kn = declare_constant ~name:fid ~kind (Declare.DefinitionEntry entry) in let constr_fip = let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in - applist (mkConstU (kn,u),proj_args) + applist (mkConstU (kn,u),proj_args) in Declare.definition_message fid; kn, constr_fip with Type_errors.TypeError (ctx,te) -> - raise (NotDefinable (BadTypedProj (fid,ctx,te))) + raise (NotDefinable (BadTypedProj (fid,ctx,te))) in let refi = GlobRef.ConstRef kn in Impargs.maybe_declare_manual_implicits false refi impls; @@ -413,29 +415,33 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa let binder_name = match name with | None -> - let map (id, _, _, _, _, _, _) = + let map (id, _, _, _, _, _, _, _) = Id.of_string (Unicode.lowercase_first_char (Id.to_string id)) in Array.map_of_list map record_data | Some n -> n in let ntypes = List.length record_data in - let mk_block i (id, idbuild, arity, _, fields, _, _) = + let mk_block i (id, idbuild, min_univ, arity, _, fields, _, _) = let nfields = List.length fields in let args = Context.Rel.to_extended_list mkRel nfields params in let ind = applist (mkRel (ntypes - i + nparams + nfields), args) in let type_constructor = it_mkProd_or_LetIn ind fields in let template = + let template_candidate () = + ComInductive.template_polymorphism_candidate (Global.env ()) univs params + (Some (Sorts.sort_of_univ min_univ)) + in match template with | Some template, _ -> (* templateness explicitly requested *) if poly && template then user_err Pp.(strbrk "template and polymorphism not compatible"); + if template && not (template_candidate ()) then + user_err Pp.(strbrk "record cannot be made template polymorphic on any universe"); template | None, template -> (* auto detect template *) - ComInductive.should_auto_template id (template && not poly && - let _, s = Reduction.dest_arity (Global.env()) arity in - not (Sorts.is_small s)) + ComInductive.should_auto_template id (template && template_candidate ()) in { mind_entry_typename = id; mind_entry_arity = arity; @@ -446,7 +452,7 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa let blocks = List.mapi mk_block record_data in let primitive = !primitive_flag && - List.for_all (fun (_,_,_,_,fields,_,_) -> List.exists is_local_assum fields) record_data + List.for_all (fun (_,_,_,_,_,fields,_,_) -> List.exists is_local_assum fields) record_data in let mie = { mind_entry_params = params; @@ -463,7 +469,7 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa let kn = ComInductive.declare_mutual_inductive_with_eliminations mie ubinders impls ~primitive_expected:!primitive_flag in - let map i (_, _, _, fieldimpls, fields, is_coe, coers) = + let map i (_, _, _, _, fieldimpls, fields, is_coe, coers) = let rsp = (kn, i) in (* This is ind path of idstruc *) let cstr = (rsp, 1) in let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers fieldimpls fields in @@ -478,7 +484,7 @@ let implicits_of_context ctx = List.map (fun name -> CAst.make (Some (name,true))) (List.rev (Anonymous :: (List.map RelDecl.get_name ctx))) -let declare_class def cumulative ubinders univs id idbuild paramimpls params arity +let declare_class def cumulative ubinders univs id idbuild paramimpls params univ arity template fieldimpls fields ?(kind=Decls.StructureComponent) coers priorities = let fieldimpls = (* Make the class implicit in the projections, and the params if applicable. *) @@ -493,7 +499,7 @@ let declare_class def cumulative ubinders univs id idbuild paramimpls params ari let binder = {binder with binder_name=Name binder_name} in let class_body = it_mkLambda_or_LetIn field params in let class_type = it_mkProd_or_LetIn arity params in - let class_entry = + let class_entry = Declare.definition_entry ~types:class_type ~univs class_body in let cst = Declare.declare_constant ~name:id (DefinitionEntry class_entry) ~kind:Decls.(IsDefinition Definition) @@ -518,18 +524,18 @@ let declare_class def cumulative ubinders univs id idbuild paramimpls params ari Impargs.declare_manual_implicits false (GlobRef.ConstRef proj_cst) (List.hd fieldimpls); Classes.set_typeclass_transparency (EvalConstRef cst) false false; let sub = match List.hd coers with - | Some b -> Some ((if b then Backward else Forward), List.hd priorities) - | None -> None + | Some b -> Some ((if b then Backward else Forward), List.hd priorities) + | None -> None in [cref, [Name proj_name, sub, Some proj_cst]] | _ -> - let record_data = [id, idbuild, arity, fieldimpls, fields, false, + let record_data = [id, idbuild, univ, arity, fieldimpls, fields, false, List.map (fun _ -> { pf_subclass = false ; pf_canonical = true }) fields] in let inds = declare_structure ~cumulative Declarations.BiFinite ubinders univs paramimpls params template ~kind:Decls.Method ~name:[|binder_name|] record_data in - let coers = List.map2 (fun coe pri -> - Option.map (fun b -> + let coers = List.map2 (fun coe pri -> + Option.map (fun b -> if b then Backward, pri else Forward, pri) coe) coers priorities in @@ -584,7 +590,7 @@ let add_constant_class env sigma cst = let ctx, _ = decompose_prod_assum ty in let args = Context.Rel.to_extended_vect Constr.mkRel 0 ctx in let t = mkApp (mkConstU (cst, Univ.make_abstract_instance univs), args) in - let tc = + let tc = { cl_univs = univs; cl_impl = GlobRef.ConstRef cst; cl_context = (List.map (const None) ctx, ctx); @@ -688,24 +694,24 @@ let definition_structure udecl kind ~template ~cumulative ~poly finite records = let template = template, auto_template in match kind with | Class def -> - let (_, id, _, cfs, idbuild, _), (arity, implfs, fields) = match records, data with + let (_, id, _, cfs, idbuild, _), (univ, arity, implfs, fields) = match records, data with | [r], [d] -> r, d | _, _ -> CErrors.user_err (str "Mutual definitional classes are not handled") in let priorities = List.map (fun (_, { rf_priority }) -> {hint_priority = rf_priority ; hint_pattern = None}) cfs in let coers = List.map (fun (_, { rf_subclass }) -> rf_subclass) cfs in declare_class def cumulative ubinders univs id.CAst.v idbuild - implpars params arity template implfs fields coers priorities + implpars params univ arity template implfs fields coers priorities | _ -> let map impls = implpars @ [CAst.make None] @ impls in - let data = List.map (fun (arity, implfs, fields) -> (arity, List.map map implfs, fields)) data in - let map (arity, implfs, fields) (is_coe, id, _, cfs, idbuild, _) = + let data = List.map (fun (univ, arity, implfs, fields) -> (univ, arity, List.map map implfs, fields)) data in + let map (univ, arity, implfs, fields) (is_coe, id, _, cfs, idbuild, _) = let coe = List.map (fun (_, { rf_subclass ; rf_canonical }) -> { pf_subclass = not (Option.is_empty rf_subclass); pf_canonical = rf_canonical }) cfs in - id.CAst.v, idbuild, arity, implfs, fields, is_coe, coe + id.CAst.v, idbuild, univ, arity, implfs, fields, is_coe, coe in let data = List.map2 map data records in let inds = declare_structure ~cumulative finite ubinders univs implpars params template data in diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 20de6b4ff2..cd13f83e96 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -16,6 +16,7 @@ DeclareDef DeclareObl Canonical RecLemmas +Library Lemmas Class Auto_ind_decl diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 4ae9d6d54f..43b58d6d4b 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -171,16 +171,9 @@ let print_loadpath dir = prlist_with_sep fnl Loadpath.pp l let print_modules () = - let opened = Library.opened_libraries () - and loaded = Library.loaded_libraries () in - (* we intersect over opened to preserve the order of opened since *) - (* non-commutative operations (e.g. visibility) are done at import time *) - let loaded_opened = List.intersect DirPath.equal opened loaded - and only_loaded = List.subtract DirPath.equal loaded opened in - str"Loaded and imported library files: " ++ - pr_vertical_list DirPath.print loaded_opened ++ fnl () ++ - str"Loaded and not imported library files: " ++ - pr_vertical_list DirPath.print only_loaded + let loaded = Library.loaded_libraries () in + str"Loaded library files: " ++ + pr_vertical_list DirPath.print loaded let print_module qid = @@ -606,6 +599,24 @@ let vernac_assumption ~atts discharge kind l nl = | DeclareDef.Discharge -> Dumpglob.dump_definition lid true "var") idl) l; ComAssumption.do_assumptions ~poly:atts.polymorphic ~program_mode:atts.program ~scope ~kind nl l +let set_template_check b = + let typing_flags = Environ.typing_flags (Global.env ()) in + Global.set_typing_flags { typing_flags with Declarations.check_template = b } + +let is_template_check () = + let typing_flags = Environ.typing_flags (Global.env ()) in + typing_flags.Declarations.check_template + +let () = + let tccheck = + { optdepr = true; + optname = "Template universe check"; + optkey = ["Template"; "Check"]; + optread = (fun () -> is_template_check ()); + optwrite = (fun b -> set_template_check b)} + in + declare_bool_option tccheck + let is_polymorphic_inductive_cumulativity = declare_bool_option_and_ref ~depr:false ~value:false ~name:"Polymorphic inductive cumulativity" @@ -844,7 +855,12 @@ let vernac_constraint ~poly l = (* Modules *) let vernac_import export refl = - Library.import_module export refl + let import_mod qid = + try Declaremods.import_module ~export @@ Nametab.locate_module qid + with Not_found -> + CErrors.user_err Pp.(str "Cannot find module " ++ pr_qualid qid) + in + List.iter import_mod refl let vernac_declare_module export {loc;v=id} binders_ast mty_ast = (* We check the state of the system (in section, in module type) @@ -1161,11 +1177,11 @@ let vernac_chdir = function let vernac_write_state file = let file = CUnix.make_suffix file ".coq" in - States.extern_state file + Library.extern_state file let vernac_restore_state file = let file = Loadpath.locate_file (CUnix.make_suffix file ".coq") in - States.intern_state file + Library.intern_state file (************) (* Commands *) @@ -1954,9 +1970,9 @@ let vernac_print ~pstate ~atts = function | PrintTypingFlags -> pr_typing_flags (Environ.typing_flags (Global.env ())) | PrintTables -> print_tables () - | PrintFullContext-> print_full_context_typ env sigma - | PrintSectionContext qid -> print_sec_context_typ env sigma qid - | PrintInspect n -> inspect env sigma n + | PrintFullContext-> print_full_context_typ Library.indirect_accessor env sigma + | PrintSectionContext qid -> print_sec_context_typ Library.indirect_accessor env sigma qid + | PrintInspect n -> inspect Library.indirect_accessor env sigma n | PrintGrammar ent -> Metasyntax.pr_grammar ent | PrintCustomGrammar ent -> Metasyntax.pr_custom_grammar ent | PrintLoadPath dir -> (* For compatibility ? *) print_loadpath dir @@ -1969,7 +1985,7 @@ let vernac_print ~pstate ~atts = | PrintDebugGC -> Mltop.print_gc () | PrintName (qid,udecl) -> dump_global qid; - print_name env sigma qid udecl + print_name Library.indirect_accessor env sigma qid udecl | PrintGraph -> Prettyp.print_graph () | PrintClasses -> Prettyp.print_classes() | PrintTypeClasses -> Prettyp.print_typeclasses() @@ -2267,7 +2283,7 @@ let with_fail ~st f = user_err ~hdr:"Fail" (str "The command has not failed!") | Ok msg -> if not !Flags.quiet || !test_mode - then Feedback.msg_info (str "The command has indeed failed with message:" ++ fnl () ++ msg) + then Feedback.msg_notice (str "The command has indeed failed with message:" ++ fnl () ++ msg) let locate_if_not_already ?loc (e, info) = match Loc.get_loc info with @@ -2538,7 +2554,7 @@ let rec translate_vernac ~atts v = let open Vernacextend in match v with VtDefault(fun () -> vernac_hints ~atts dbnames hints) | VernacSyntacticDefinition (id,c,b) -> - VtDefault(fun () -> vernac_syntactic_definition ~atts id c b) + VtDefault(fun () -> vernac_syntactic_definition ~atts id c b) | VernacArguments (qid, args, more_implicits, nargs, bidi, flags) -> VtDefault(fun () -> with_section_locality ~atts (vernac_arguments qid args more_implicits nargs bidi flags)) |