diff options
231 files changed, 15478 insertions, 1940 deletions
diff --git a/.gitattributes b/.gitattributes index 58b1a31d36..260e3f96b6 100644 --- a/.gitattributes +++ b/.gitattributes @@ -54,6 +54,7 @@ dune* whitespace=blank-at-eol,tab-in-indent .gitattributes whitespace=blank-at-eol,tab-in-indent _CoqProject whitespace=blank-at-eol,tab-in-indent Dockerfile whitespace=blank-at-eol,tab-in-indent +00000-title.rst -whitespace # tabs are allowed in Makefiles. Makefile* whitespace=blank-at-eol diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index 73b61ee0d9..3bd3342329 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -16,4 +16,4 @@ Fixes / closes #???? <!-- If this is a feature pull request / breaks compatibility: --> <!-- (Otherwise, remove these lines.) --> - [ ] Corresponding documentation was added / updated (including any warning and error messages added / removed / modified). -- [ ] Entry added in CHANGES.md. +- [ ] Entry added in the changelog (see https://github.com/coq/coq/tree/master/doc/changelog#unreleased-changelog for details). diff --git a/.gitignore b/.gitignore index 8fd9fc614c..5339a0c44d 100644 --- a/.gitignore +++ b/.gitignore @@ -165,7 +165,9 @@ ide/index_urls.txt # coqide generated files (when testing) *.crashcoqide -user-contrib +/user-contrib/* +!/user-contrib/Ltac2 + .*.sw* .#* @@ -183,5 +185,6 @@ plugins/*/dune theories/*/dune theories/*/*/dune theories/*/*/*/dune +/user-contrib/Ltac2/dune *.install !Makefile.install diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 3c24ec28c4..9e96d3602b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -169,9 +169,15 @@ before_script: - not-a-real-job script: - cd _install_ci - - find lib/coq/ -name '*.vo' -print0 > vofiles - - for regexp in 's/.vo//' 's:lib/coq/plugins:Coq:' 's:lib/coq/theories:Coq:' 's:/:.:g'; do sed -z -i "$regexp" vofiles; done - - xargs -0 --arg-file=vofiles bin/coqchk -silent -o -m -coqlib lib/coq/ + - find lib/coq/ -name '*.vo' -fprint0 vofiles + - xargs -0 --arg-file=vofiles bin/coqchk -o -m -coqlib lib/coq/ > ../coqchk.log 2>&1 || touch coqchk.failed + - tail -n 1000 ../coqchk.log # the log is too big for gitlab so pipe to a file and display the tail + - "[ ! -f coqchk.failed ]" # needs quoting for yml syntax reasons + artifacts: + name: "$CI_JOB_NAME.logs" + paths: + - coqchk.log + expire_in: 1 month .ci-template: stage: test @@ -640,9 +646,6 @@ plugin:ci-equations: plugin:ci-fiat_parsers: extends: .ci-template -plugin:ci-ltac2: - extends: .ci-template - plugin:ci-mtac2: extends: .ci-template diff --git a/CHANGES.md b/CHANGES.md deleted file mode 100644 index 2f58bfb825..0000000000 --- a/CHANGES.md +++ /dev/null @@ -1,328 +0,0 @@ -Unreleased changes -================== - -OCaml and dependencies - -- Coq 8.10 requires OCaml >= 4.05.0, bumped from 4.02.3 See the - INSTALL file for more information on dependencies. - -- Coq 8.10 doesn't need Camlp5 to build anymore. It now includes a - fork of the core parsing library that Coq uses, which is a small - subset of the whole Camlp5 distribution. In particular, this subset - doesn't depend on the OCaml AST, allowing easier compilation and - testing on experimental OCaml versions. - - The Coq developers would like to thank Daniel de Rauglaudre for many - years of continued support. - -Coqide - -- CoqIDE now depends on gtk+3 and lablgtk3, rather than gtk+2 and lablgtk2. - -- CoqIDE now properly sets the module name for a given file based on - its path, see -topfile change entry for more details. - -- Preferences from coqide.keys are no longer overridden by modifiers - preferences in coqiderc. - -Coqtop - -- the use of `coqtop` as a compiler has been deprecated, in favor of - `coqc`. Consequently option `-compile` will stop to be accepted in - the next release. `coqtop` is now reserved to interactive - use. (@ejgallego #9095) - -- new option -topfile filename, which will set the current module name - (à la -top) based on the filename passed, taking into account the - proper -R/-Q options. For example, given -R Foo foolib using - -topfile foolib/bar.v will set the module name to Foo.Bar. - -Specification language, type inference - -- Fixing a missing check in interpreting instances of existential - variables that are bound to local definitions might exceptionally - induce an overhead if the cost of checking the conversion of the - corresponding definitions is additionally high (PR #8215). - -- A few improvements in inference of the return clause of `match` can - exceptionally introduce incompatibilities (PR #262). This can be - solved by writing an explicit `return` clause, sometimes even simply - an explicit `return _` clause. - -- Using non-projection values with the projection syntax is not - allowed. For instance "0.(S)" is not a valid way to write "S 0". - Projections from non-primitive (emulated) records are allowed with - warning "nonprimitive-projection-syntax". - -Kernel - -- Added primitive integers - -- Unfolding heuristic in termination checking made more complete. - In particular Coq is now more aggressive in unfolding constants - when it looks for a iota redex. Performance regression may occur - in Fixpoint declarations without an explicit {struct} annotation, - since guessing the decreasing argument can now be more expensive. - (PR #9602) - -Notations - -- New command `Declare Scope` to explicitly declare a scope name - before any use of it. Implicit declaration of a scope at the time of - `Bind Scope`, `Delimit Scope`, `Undelimit Scope`, or `Notation` is - deprecated. - -- New command `String Notation` to register string syntax for custom - inductive types. - -- Numeral notations now parse decimal constants such as 1.02e+01 or - 10.2. Parsers added for Q and R. This should be considered as an - experimental feature currently. - Note: in -- the rare -- case when such numeral notations were used - in a development along with Q or R, they may have to be removed or - deconflicted through explicit scope annotations (1.23%Q, - 45.6%R,...). - -- Various bugs have been fixed (e.g. PR #9214 on removing spurious - parentheses on abbreviations shortening a strict prefix of an application). - -- Numeral Notations now support inductive types in the input to - printing functions (e.g., numeral notations can be defined for terms - containing things like `@cons nat O O`), and parsing functions now - fully normalize terms including parameters of constructors (so that, - e.g., a numeral notation whose parsing function outputs a proof of - `Nat.gcd x y = 1` will no longer fail to parse due to containing the - constant `Nat.gcd` in the parameter-argument of `eq_refl`). See - #9840 for more details. - -- Deprecated compatibility notations have actually been removed. Uses - of these notations are generally easy to fix thanks to the hint - contained in the deprecation warnings. For projects that require - more than a handful of such fixes, there is [a - script](https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py) - that will do it automatically, using the output of coqc. The script - contains documentation on its usage in a comment at the top. - -Plugins - -- The quote plugin (https://coq.inria.fr/distrib/V8.8.1/refman/proof-engine/detailed-tactic-examples.html#quote) - was removed. If some users are interested in maintaining this plugin - externally, the Coq development team can provide assistance for extracting - the plugin and setting up a new repository. - -Tactics - -- Removed the deprecated `romega` tactics. -- Tactic names are no longer allowed to clash, even if they are not defined in - the same section. For example, the following is no longer accepted: - `Ltac foo := idtac. Section S. Ltac foo := fail. End S.` - -- The tactics 'lia','nia','lra','nra' are now using a novel - Simplex-based proof engine. In case of regression, 'Unset Simplex' - to get the venerable Fourier-based engine. - -- Names of existential variables occurring in Ltac functions - (e.g. `?[n]` or `?n` in terms - not in patterns) are now interpreted - the same way as other variable names occurring in Ltac functions. - -- Hint declaration and removal should now specify a database (e.g. `Hint Resolve - foo : database`). When the database name is omitted, the hint is added to the - core database (as previously), but a deprecation warning is emitted. - -- There are now tactics in `PreOmega.v` called - `Z.div_mod_to_equations`, `Z.quot_rem_to_equations`, and - `Z.to_euclidean_division_equations` (which combines the `div_mod` - and `quot_rem` variants) which allow `lia`, `nia`, `romega`, etc to - support `Z.div` and `Z.modulo` (`Z.quot` and `Z.rem`, respectively), - by posing the specifying equation for `Z.div` and `Z.modulo` before - replacing them with atoms. - -- Ltac backtraces can be turned on using the "Ltac Backtrace" option. - -- The syntax of the `autoapply` tactic was fixed to conform with preexisting - documentation: it now takes a `with` clause instead of a `using` clause. - - - -Vernacular commands - -- `Combined Scheme` can now work when inductive schemes are generated in sort - `Type`. It used to be limited to sort `Prop`. - -- Binders for an `Instance` now act more like binders for a `Theorem`. - Names may not be repeated, and may not overlap with section variable names. - -- Removed the deprecated `Implicit Tactic` family of commands. - -- The `Automatic Introduction` option has been removed and is now the - default. - -- `Arguments` now accepts names for arguments provided with `extra_scopes`. - -- The naming scheme for anonymous binders in a `Theorem` has changed to - avoid conflicts with explicitly named binders. - -- Computation of implicit arguments now properly handles local definitions in the - binders for an `Instance`, and can be mixed with implicit binders `{x : T}`. - -- `Declare Instance` now requires an instance name. - -- Option `Refine Instance Mode` has been turned off by default, meaning that - `Instance` no longer opens a proof when a body is provided. - -- `Instance`, when no body is provided, now always opens a proof. This is a - breaking change, as instance of `Instance foo : C.` where `C` is a trivial - class will have to be changed into `Instance foo : C := {}.` or - `Instance foo : C. Proof. Qed.`. - -- Option `Program Mode` now means that the `Program` attribute is enabled - for all commands that support it. In particular, it does not have any effect - on tactics anymore. May cause some incompatibilities. - -- The algorithm computing implicit arguments now behaves uniformly for primitive - projection and application nodes (bug #9508). - -- `Hypotheses` and `Variables` can now take implicit binders inside sections. - -- Removed deprecated option `Automatic Coercions Import`. - -- The `Show Script` command has been deprecated. - -- Option `Refine Instance Mode` has been deprecated and will be removed in - the next version. - -- `Coercion` does not warn ambiguous paths which are obviously convertible with - existing ones. - -- A new flag `Fast Name Printing` has been introduced. It changes the - algorithm used for allocating bound variable names for a faster but less - clever one. - -Tools - -- The `-native-compiler` flag of `coqc` and `coqtop` now takes an argument which can have three values: - - `no` disables native_compute - - `yes` enables native_compute and precompiles `.v` files to native code - - `ondemand` enables native_compute but compiles code only when `native_compute` is called - - The default value is `ondemand`. - - Note that this flag now has priority over the configure flag of the same name. - -- A new `-bytecode-compiler` flag for `coqc` and `coqtop` controls whether - conversion can use the VM. The default value is `yes`. - -- CoqIDE now supports input for Unicode characters. For example, typing - "\alpha" then the "Shift+Space" will insert the greek letter alpha. - In fact, typing the prefix string "\a" is sufficient. - A larger number of default bindings are provided, following the latex - naming convention. Bindings can be customized, either globally, or on a - per-project basis, with the requirement is that keys must begin with a - backslash and contain no space character. Bindings may be assigned custom - priorities, so that prefixes resolve to the most convenient bindings. - The documentation pages for CoqIDE provides further details. - -- The pretty timing diff scripts (flag `TIMING=1` to a - `coq_makefile`-made `Makefile`, also - `tools/make-both-single-timing-files.py`, - `tools/make-both-time-files.py`, and `tools/make-one-time-file.py`) - now correctly support non-UTF-8 characters in the output of - `coqc`/`make` as well as printing to stdout, on both python2 and - python3. - -- Coq options can be set on the command line, eg `-set "Universe Polymorphism=true"` - -- coq_makefile's install target now errors if any file to install is missing. - -Standard Library - -- Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about - the upper bound of number represented by a vector. - Allowed implicit vector length argument in `Ndigits.Bv2N`. - -- Added `Bvector.BVeq` that decides whether two `Bvector`s are equal. - -- Added notations for `BVxor`, `BVand`, `BVor`, `BVeq` and `BVneg`. - -- Added `ByteVector` type that can convert to and from [string]. - -- The prelude used to be automatically Exported and is now only - Imported. This should be relevant only when importing files which - don't use -noinit into files which do. - -- Added `Coq.Structures.OrderedTypeEx.String_as_OT` to make strings an - ordered type (using lexical order). - -- The `Coq.Numbers.Cyclic.Int31` library is deprecated. - -- Added lemmas about `Z.testbit`, `Z.ones`, and `Z.modulo`. - -- Moved the `auto` hints of the `FSet` library into a new - `fset` database. - -Universes - -- Added `Print Universes Subgraph` variant of `Print Universes`. - Try for instance `Print Universes Subgraph(sigT2.u1 sigT_of_sigT2.u1 projT3_eq.u1 eq_sigT2_rect.u1).` - -- Added private universes for opaque polymorphic constants, see doc - for the "Private Polymorphic Universes" option (and Unset it to get - the previous behaviour). - -SProp - -- Added a universe "SProp" for definitionally proof irrelevant - propositions. Use with -allow-sprop. See manual for details. - -Inductives - -- An option and attributes to control the automatic decision to - declare an inductive type as template polymorphic were added. - Warning "auto-template" will trigger when an inductive is - automatically declared template polymorphic without the attribute. - -Funind - -- Inductive types declared by Funind will never be template polymorphic. - -Misc - -- Option "Typeclasses Axioms Are Instances" is deprecated. Use Declare Instance for axioms which should be instances. - -- Removed option "Printing Primitive Projection Compatibility" - -SSReflect - -- New tactic `under` to rewrite under binders, given an extensionality lemma: - - interactive mode: `under lem`, associated terminator: `over` - - one-liner mode: `under lem do [tac1 | ...]` - - It can take occurrence switches, contextual patterns, and intro patterns: - `under {2}[in RHS]eq_big => [i|i ?] do ...`. - - See the reference manual for the actual documentation. - -- New intro patterns: - - temporary introduction: `=> +` - - block introduction: `=> [^ prefix ] [^~ suffix ]` - - fast introduction: `=> >` - - tactics as views: `=> /ltac:mytac` - - replace hypothesis: `=> {}H` - - See the reference manual for the actual documentation. - -- Clear discipline made consistent across the entire proof language. - Whenever a clear switch `{x..}` comes immediately before an existing proof - context entry (used as a view, as a rewrite rule or as name for a new - context entry) then such entry is cleared too. - - E.g. The following sentences are elaborated as follows (when H is an existing - proof context entry): - - `=> {x..} H` -> `=> {x..H} H` - - `=> {x..} /H` -> `=> /v {x..H}` - - `rewrite {x..} H` -> `rewrite E {x..H}` - -Diffs - -- Some error messages that show problems with a pair of non-matching values will now - highlight the differences. @@ -59,10 +59,10 @@ plugins/setoid_ring Assia Mahboubi, Laurent Théry (INRIA-Marelle, 2006) and Bruno Barras (INRIA LogiCal, 2005-2006), plugins/ssreflect - developed by Georges Gonthier (Microsoft Research - Inria Joint Centre, 2007-2011), + developed by Georges Gonthier (Microsoft Research - Inria Joint Centre, 2007-2013, Inria, 2013-now), Assia Mahboubi and Enrico Tassi (Inria, 2011-now). plugins/ssrmatching - developed by Georges Gonthier (Microsoft Research - Inria Joint Centre, 2007-2011), + developed by Georges Gonthier (Microsoft Research - Inria Joint Centre, 2007-2011, Inria, 2013-now), and Enrico Tassi (Inria-Marelle, 2011-now) plugins/subtac developed by Matthieu Sozeau (LRI, 2005-2008) @@ -66,7 +66,7 @@ FIND_SKIP_DIRS:='(' \ ')' -prune -o define find - $(shell find . $(FIND_SKIP_DIRS) '(' -name $(1) ')' -print | sed 's|^\./||') + $(shell find . user-contrib/Ltac2 $(FIND_SKIP_DIRS) '(' -name $(1) ')' -print | sed 's|^\./||') endef define findindir diff --git a/Makefile.build b/Makefile.build index 2a071fd820..034c9ea03c 100644 --- a/Makefile.build +++ b/Makefile.build @@ -158,11 +158,14 @@ endif VDFILE := .vfiles MLDFILE := .mlfiles PLUGMLDFILE := plugins/.mlfiles +USERCONTRIBMLDFILE := user-contrib/.mlfiles MLLIBDFILE := .mllibfiles PLUGMLLIBDFILE := plugins/.mllibfiles +USERCONTRIBMLLIBDFILE := user-contrib/.mllibfiles DEPENDENCIES := \ - $(addsuffix .d, $(MLDFILE) $(MLLIBDFILE) $(PLUGMLDFILE) $(PLUGMLLIBDFILE) $(CFILES) $(VDFILE)) + $(addsuffix .d, $(MLDFILE) $(MLLIBDFILE) $(PLUGMLDFILE) $(PLUGMLLIBDFILE) \ + $(USERCONTRIBMLDFILE) $(USERCONTRIBMLLIBDFILE) $(CFILES) $(VDFILE)) -include $(DEPENDENCIES) @@ -209,12 +212,14 @@ BOOTCOQC=$(TIMER) $(COQC) -coqlib . -q $(COQOPTS) LOCALINCLUDES=$(addprefix -I ,$(SRCDIRS)) MLINCLUDES=$(LOCALINCLUDES) +USERCONTRIBINCLUDES=$(addprefix -I user-contrib/,$(USERCONTRIBDIRS)) + OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) BYTEFLAGS=$(CAMLDEBUG) $(USERFLAGS) OPTFLAGS=$(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) $(FLAMBDA_FLAGS) -DEPFLAGS=$(LOCALINCLUDES) -map gramlib/.pack/gramlib.ml $(if $(filter plugins/%,$@),, -I ide -I ide/protocol) +DEPFLAGS=$(LOCALINCLUDES) -map gramlib/.pack/gramlib.ml $(if $(filter plugins/% user-contrib/%,$@),, -I ide -I ide/protocol) # On MacOS, the binaries are signed, except our private ones ifeq ($(shell which codesign > /dev/null 2>&1 && echo $(ARCH)),Darwin) @@ -442,11 +447,11 @@ tools/coqdep_boot.cmx : tools/coqdep_common.cmx $(COQDEPBOOT): $(call bestobj, $(COQDEPBOOTSRC)) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, -I tools -package unix) + $(HIDE)$(call bestocaml, -I tools -package unix -package str) $(COQDEPBOOTBYTE): $(COQDEPBOOTSRC) $(SHOW)'OCAMLC -o $@' - $(HIDE)$(call ocamlbyte, -I tools -package unix) + $(HIDE)$(call ocamlbyte, -I tools -package unix -package str) $(OCAMLLIBDEP): $(call bestobj, tools/ocamllibdep.cmo) $(SHOW)'OCAMLBEST -o $@' @@ -567,7 +572,7 @@ VALIDOPTS=$(if $(VERBOSE),,-silent) -o -m -coqlib . validate: $(CHICKEN) | $(ALLVO:.$(VO)=.vo) $(SHOW)'COQCHK <theories & plugins>' - $(HIDE)$(CHICKEN) $(VALIDOPTS) $(ALLMODS) + $(HIDE)$(CHICKEN) $(VALIDOPTS) $(ALLVO) $(ALLSTDLIB).v: $(SHOW)'MAKE $(notdir $@)' @@ -743,6 +748,10 @@ plugins/%.cmx: plugins/%.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -c $< +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 @@ -776,8 +785,8 @@ kernel/%.cmx: COND_OPTFLAGS+=-w +a-4-44-50 # Ocamldep is now used directly again (thanks to -ml-synonym in OCaml >= 3.12) OCAMLDEP = $(OCAMLFIND) ocamldep -slash -ml-synonym .mlpack -MAINMLFILES := $(filter-out gramlib/.pack/% checker/% plugins/%, $(MLFILES) $(MLIFILES)) -MAINMLLIBFILES := $(filter-out gramlib/.pack/% checker/% plugins/%, $(MLLIBFILES) $(MLPACKFILES)) +MAINMLFILES := $(filter-out gramlib/.pack/% checker/% plugins/% user-contrib/%, $(MLFILES) $(MLIFILES)) +MAINMLLIBFILES := $(filter-out gramlib/.pack/% checker/% plugins/% user-contrib/%, $(MLLIBFILES) $(MLPACKFILES)) $(MLDFILE).d: $(D_DEPEND_BEFORE_SRC) $(MAINMLFILES) $(D_DEPEND_AFTER_SRC) $(GENFILES) $(GENGRAMFILES) $(SHOW)'OCAMLDEP MLFILES MLIFILES' @@ -796,6 +805,14 @@ $(PLUGMLLIBDFILE).d: $(D_DEPEND_BEFORE_SRC) $(filter plugins/%, $(MLLIBFILES) $( $(SHOW)'OCAMLLIBDEP plugins/MLLIBFILES plugins/MLPACKFILES' $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) $(filter plugins/%, $(MLLIBFILES) $(MLPACKFILES)) $(TOTARGET) +$(USERCONTRIBMLDFILE).d: $(D_DEPEND_BEFORE_SRC) $(filter user-contrib/%, $(MLFILES) $(MLIFILES)) $(D_DEPEND_AFTER_SRC) $(GENFILES) + $(SHOW)'OCAMLDEP user-contrib/MLFILES user-contrib/MLIFILES' + $(HIDE)$(OCAMLDEP) $(DEPFLAGS) $(filter user-contrib/%, $(MLFILES) $(MLIFILES)) $(TOTARGET) + +$(USERCONTRIBMLLIBDFILE).d: $(D_DEPEND_BEFORE_SRC) $(filter user-contrib/%, $(MLLIBFILES) $(MLPACKFILES)) $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) + $(SHOW)'OCAMLLIBDEP user-contrib/MLLIBFILES user-contrib/MLPACKFILES' + $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) $(filter user-contrib/%, $(MLLIBFILES) $(MLPACKFILES)) $(TOTARGET) + ########################################################################### # Compilation of .v files ########################################################################### @@ -861,7 +878,7 @@ endif $(VDFILE).d: $(D_DEPEND_BEFORE_SRC) $(VFILES) $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(SHOW)'COQDEP VFILES' - $(HIDE)$(COQDEPBOOT) -boot $(DYNDEP) $(VFILES) $(TOTARGET) + $(HIDE)$(COQDEPBOOT) -boot $(DYNDEP) -Q user-contrib "" $(USERCONTRIBINCLUDES) $(VFILES) $(TOTARGET) ########################################################################### diff --git a/Makefile.ci b/Makefile.ci index a244c17ef3..95ebd64ba1 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -32,7 +32,6 @@ CI_TARGETS= \ ci-coqhammer \ ci-hott \ ci-iris-lambda-rust \ - ci-ltac2 \ ci-math-classes \ ci-math-comp \ ci-mtac2 \ diff --git a/Makefile.common b/Makefile.common index bd0e19cd00..ee3bfb43c5 100644 --- a/Makefile.common +++ b/Makefile.common @@ -104,10 +104,14 @@ PLUGINDIRS:=\ rtauto nsatz syntax btauto \ ssrmatching ltac ssr +USERCONTRIBDIRS:=\ + Ltac2 + SRCDIRS:=\ $(CORESRCDIRS) \ tools tools/coqdoc \ - $(addprefix plugins/, $(PLUGINDIRS)) + $(addprefix plugins/, $(PLUGINDIRS)) \ + $(addprefix user-contrib/, $(USERCONTRIBDIRS)) COQRUN := coqrun LIBCOQRUN:=kernel/byterun/lib$(COQRUN).a @@ -149,13 +153,14 @@ DERIVECMO:=plugins/derive/derive_plugin.cmo 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 PLUGINSCMO:=$(LTACCMO) $(OMEGACMO) $(MICROMEGACMO) \ $(RINGCMO) \ $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(SYNTAXCMO) \ - $(DERIVECMO) $(SSRMATCHINGCMO) $(SSRCMO) + $(DERIVECMO) $(SSRMATCHINGCMO) $(SSRCMO) $(LTAC2CMO) ifeq ($(HASNATDYNLINK)-$(BEST),false-opt) STATICPLUGINS:=$(PLUGINSCMO) diff --git a/Makefile.doc b/Makefile.doc index 23aa66a1b8..25d146000b 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -66,7 +66,7 @@ SPHINX_DEPS := coq endif # refman-html and refman-latex -refman-%: $(SPHINX_DEPS) +refman-%: $(SPHINX_DEPS) doc/unreleased.rst $(SHOW)'SPHINXBUILD doc/sphinx ($*)' $(HIDE)$(SPHINXENV) $(SPHINXBUILD) -b $* \ $(ALLSPHINXOPTS) doc/sphinx $(SPHINXBUILDDIR)/$* @@ -116,6 +116,12 @@ plugin-tutorial: states tools doc/common/version.tex: config/Makefile printf '\\newcommand{\\coqversion}{$(VERSION)}' > doc/common/version.tex +### Changelog + +doc/unreleased.rst: $(wildcard doc/changelog/00-title.rst doc/changelog/*/*.rst) + $(SHOW)'AGGREGATE $@' + $(HIDE)cat doc/changelog/00-title.rst doc/changelog/*/*.rst > $@ + ###################################################################### # Standard library ###################################################################### diff --git a/Makefile.vofiles b/Makefile.vofiles index a71d68e565..5296ed43ff 100644 --- a/Makefile.vofiles +++ b/Makefile.vofiles @@ -13,7 +13,7 @@ endif ########################################################################### THEORIESVO := $(patsubst %.v,%.$(VO),$(shell find theories -type f -name "*.v")) -PLUGINSVO := $(patsubst %.v,%.$(VO),$(shell find plugins -type f -name "*.v")) +PLUGINSVO := $(patsubst %.v,%.$(VO),$(shell find plugins $(addprefix user-contrib/, $(USERCONTRIBDIRS)) -type f -name "*.v")) ALLVO := $(THEORIESVO) $(PLUGINSVO) VFILES := $(ALLVO:.$(VO)=.v) @@ -24,16 +24,16 @@ THEORIESLIGHTVO:= \ # convert a (stdlib) filename into a module name: # remove .vo, replace theories and plugins by Coq, and replace slashes by dots -vo_to_mod = $(subst /,.,$(patsubst theories/%,Coq.%,$(patsubst plugins/%,Coq.%,$(1:.vo=)))) +vo_to_mod = $(subst /,.,$(patsubst user-contrib/%,%,$(patsubst theories/%,Coq.%,$(patsubst plugins/%,Coq.%,$(1:.vo=))))) ALLMODS:=$(call vo_to_mod,$(ALLVO:.$(VO)=.vo)) # Converting a stdlib filename into native compiler filenames # Used for install targets -vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.cm*))))) +vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst user-contrib/%, N%, $(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.cm*)))))) -vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.o))))) +vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst user-contrib/%, N%, $(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.$(VO)=.o)))))) ifdef QUICK GLOBFILES:= @@ -69,9 +69,12 @@ for additional user-contributed documentation. ## Changes -There is a file named [`CHANGES.md`](CHANGES.md) that explains the differences and the -incompatibilities since last versions. If you upgrade Coq, please read -it carefully. +The [Recent +changes](https://coq.github.io/doc/master/refman/changes.html) chapter +of the reference manual explains the differences and the +incompatibilities of each new version of Coq. If you upgrade Coq, +please read it carefully as it contains important advice on how to +approach some problems you may encounter. ## Questions and discussion diff --git a/azure-pipelines.yml b/azure-pipelines.yml index f09087b172..f2cec1eb19 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -59,8 +59,8 @@ jobs: - script: | set -e export PKG_CONFIG_PATH=/usr/local/opt/libffi/lib/pkgconfig - opam init -a -j "$NJOBS" --compiler=$COMPILER - opam switch set $COMPILER + opam init -a -j "$NJOBS" --compiler=ocaml-base-compiler.$COMPILER + opam switch set ocaml-base-compiler.$COMPILER eval $(opam env) opam update opam install -j "$NJOBS" num ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index b86d491d72..1dd16f1630 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -33,7 +33,8 @@ let check_constant_declaration env kn cb = match Environ.body_of_constant_body env cb with | Some bd -> let j = infer env' (fst bd) in - conv_leq env' j.uj_type ty + (try conv_leq env' j.uj_type ty + with NotConvertible -> Type_errors.error_actual_type env j ty) | None -> () in let env = diff --git a/clib/cSig.mli b/clib/cSig.mli index 859018ca4b..0012bcef17 100644 --- a/clib/cSig.mli +++ b/clib/cSig.mli @@ -68,6 +68,8 @@ sig val remove: key -> 'a t -> 'a t val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val union: + (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val iter: (key -> 'a -> unit) -> 'a t -> unit diff --git a/clib/hMap.ml b/clib/hMap.ml index 09ffb39c21..db59ef47b0 100644 --- a/clib/hMap.ml +++ b/clib/hMap.ml @@ -290,6 +290,14 @@ struct in Int.Map.merge fm s1 s2 + let union f s1 s2 = + let fm h m1 m2 = + let m = Map.union f m1 m2 in + if Map.is_empty m then None + else Some m + in + Int.Map.union fm s1 s2 + let compare f s1 s2 = let fc m1 m2 = Map.compare f m1 m2 in Int.Map.compare fc s1 s2 @@ -25,11 +25,8 @@ depends: [ "num" ] -build-env: [ - [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] -] - build: [ + [ "./configure" "-prefix" prefix "-native-compiler" "no" ] [ "dune" "build" "@vodeps" ] [ "dune" "exec" "coq_dune" "_build/default/.vfiles.d" ] [ "dune" "build" "-p" name "-j" jobs ] diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 4c5bd29236..d737632638 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1316,7 +1316,6 @@ function copy_coq_license { # FIXME: this is not the micromega license # It only applies to code that was copied into one single file! install -D README.md "$PREFIXCOQ/license_readme/coq/ReadMe.md" - install -D CHANGES.md "$PREFIXCOQ/license_readme/coq/Changes.md" install -D INSTALL "$PREFIXCOQ/license_readme/coq/Install.txt" install -D doc/README.md "$PREFIXCOQ/license_readme/coq/ReadMeDoc.md" || true fi @@ -1631,19 +1630,6 @@ function make_addon_ssreflect { fi } -# Ltac-2 plugin -# A new (experimental) tactic language - -function make_addon_ltac2 { - installer_addon_dependency ltac2 - if build_prep_overlay ltac2; then - installer_addon_section ltac2 "Ltac-2" "Coq plugin with the Ltac-2 enhanced tactic language" "" - log1 make $MAKE_OPT all - log2 make install - build_post - fi -} - # UniCoq plugin # An alternative unification algorithm function make_addon_unicoq { diff --git a/dev/ci/appveyor.sh b/dev/ci/appveyor.sh deleted file mode 100644 index f26e0904bc..0000000000 --- a/dev/ci/appveyor.sh +++ /dev/null @@ -1,17 +0,0 @@ -#!/bin/bash - -set -e -x - -APPVEYOR_OPAM_VARIANT=ocaml-variants.4.07.1+mingw64c -NJOBS=2 - -wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.2/opam64.tar.xz -O opam64.tar.xz -tar -xf opam64.tar.xz -bash opam64/install.sh - -opam init default -j $NJOBS -a -y "https://github.com/fdopen/opam-repository-mingw.git#opam2" -c $APPVEYOR_OPAM_VARIANT --disable-sandboxing -eval "$(opam env)" -opam install -j $NJOBS -y num ocamlfind ounit - -# Full regular Coq Build -cd "$APPVEYOR_BUILD_FOLDER" && ./configure -local && make -j $NJOBS && make byte -j $NJOBS && make -j $NJOBS -C test-suite all INTERACTIVE= # && make validate diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 4f5988c59c..95fceb773a 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -81,13 +81,6 @@ : "${coqhammer_CI_ARCHIVEURL:=${coqhammer_CI_GITURL}/archive}" ######################################################################## -# Ltac2 -######################################################################## -: "${ltac2_CI_REF:=master}" -: "${ltac2_CI_GITURL:=https://github.com/ppedrot/ltac2}" -: "${ltac2_CI_ARCHIVEURL:=${ltac2_CI_GITURL}/archive}" - -######################################################################## # GeoCoq ######################################################################## : "${GeoCoq_CI_REF:=master}" @@ -105,7 +98,8 @@ # Coquelicot ######################################################################## : "${coquelicot_CI_REF:=master}" -: "${coquelicot_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot}" +: "${coquelicot_CI_GITURL:=https://gitlab.inria.fr/coquelicot/coquelicot}" +: "${coquelicot_CI_ARCHIVEURL:=${coquelicot_CI_GITURL}/-/archive}" ######################################################################## # CompCert diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh index 33627fd8ef..6cb8dad604 100755 --- a/dev/ci/ci-coquelicot.sh +++ b/dev/ci/ci-coquelicot.sh @@ -5,7 +5,6 @@ ci_dir="$(dirname "$0")" install_ssreflect -FORCE_GIT=1 git_download coquelicot ( cd "${CI_BUILD_DIR}/coquelicot" && ./autogen.sh && ./configure && ./remake "-j${NJOBS}" ) diff --git a/dev/ci/ci-ltac2.sh b/dev/ci/ci-ltac2.sh deleted file mode 100755 index 4df22bf249..0000000000 --- a/dev/ci/ci-ltac2.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -git_download ltac2 - -( cd "${CI_BUILD_DIR}/ltac2" && make && make tests && make install ) diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat index cc1931d13d..6c4ccfc14d 100755 --- a/dev/ci/gitlab.bat +++ b/dev/ci/gitlab.bat @@ -41,7 +41,6 @@ IF "%WINDOWS%" == "enabled_all_addons" ( SET EXTRA_ADDONS=^
-addon=bignums ^
-addon=equations ^
- -addon=ltac2 ^
-addon=mtac2 ^
-addon=mathcomp ^
-addon=menhir ^
diff --git a/dev/ci/nix/coquelicot.nix b/dev/ci/nix/coquelicot.nix new file mode 100644 index 0000000000..d379bfa73d --- /dev/null +++ b/dev/ci/nix/coquelicot.nix @@ -0,0 +1,9 @@ +{ autoconf, automake, ssreflect }: + +{ + buildInputs = [ autoconf automake ]; + coqBuildInputs = [ ssreflect ]; + configure = "./autogen.sh && ./configure"; + make = "./remake"; + clean = "./remake clean"; +} diff --git a/dev/ci/nix/default.nix b/dev/ci/nix/default.nix index 17070e66ee..a9cc91170f 100644 --- a/dev/ci/nix/default.nix +++ b/dev/ci/nix/default.nix @@ -72,6 +72,7 @@ let projects = { CoLoR = callPackage ./CoLoR.nix {}; CompCert = callPackage ./CompCert.nix {}; coq_dpdgraph = callPackage ./coq_dpdgraph.nix {}; + coquelicot = callPackage ./coquelicot.nix {}; Corn = callPackage ./Corn.nix {}; cross_crypto = callPackage ./cross_crypto.nix {}; Elpi = callPackage ./Elpi.nix {}; diff --git a/dev/ci/nix/flocq.nix b/dev/ci/nix/flocq.nix index e153043557..71028ec2dc 100644 --- a/dev/ci/nix/flocq.nix +++ b/dev/ci/nix/flocq.nix @@ -4,4 +4,5 @@ buildInputs = [ autoconf automake ]; configure = "./autogen.sh && ./configure"; make = "./remake"; + clean = "./remake clean"; } diff --git a/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh b/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh new file mode 100644 index 0000000000..9f9cc19e83 --- /dev/null +++ b/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10052" ] || [ "$CI_BRANCH" = "cleanup-logic-convert-hyp" ]; then + + relation_algebra_CI_REF=cleanup-logic-convert-hyp + relation_algebra_CI_GITURL=https://github.com/ppedrot/relation-algebra + +fi diff --git a/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh b/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh new file mode 100644 index 0000000000..0e1449f36c --- /dev/null +++ b/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10069" ] || [ "$CI_BRANCH" = "whd-for-evar-conv-no-stack" ]; then + + unicoq_CI_REF=whd-for-evar-conv-no-stack + unicoq_CI_GITURL=https://github.com/ppedrot/unicoq + +fi diff --git a/dev/doc/MERGING.md b/dev/doc/MERGING.md index 3f1b470878..c9eceb1270 100644 --- a/dev/doc/MERGING.md +++ b/dev/doc/MERGING.md @@ -71,8 +71,9 @@ those external projects should have been prepared (cf. the relevant sub-section in the [CI README](../ci/README.md#Breaking-changes) and the PR can be tested with these fixes thanks to ["overlays"](../ci/user-overlays/README.md). -Moreover the PR must absolutely update the [`CHANGES.md`](../../CHANGES.md) or -the [`dev/doc/changes.md`](changes.md) file. +Moreover the PR author *must* add an entry to the [unreleased +changelog](../../doc/changelog/README.md) or to the +[`dev/doc/changes.md`](changes.md) file. If overlays are missing, ask the author to prepare them and label the PR with the [needs: overlay](https://github.com/coq/coq/labels/needs%3A%20overlay) label. diff --git a/doc/changelog/00-title.rst b/doc/changelog/00-title.rst new file mode 100644 index 0000000000..628d9c8578 --- /dev/null +++ b/doc/changelog/00-title.rst @@ -0,0 +1,2 @@ +Unreleased changes +------------------ diff --git a/doc/changelog/01-kernel/00000-title.rst b/doc/changelog/01-kernel/00000-title.rst new file mode 100644 index 0000000000..f680628a05 --- /dev/null +++ b/doc/changelog/01-kernel/00000-title.rst @@ -0,0 +1,3 @@ + +**Kernel** + diff --git a/doc/changelog/02-specification-language/00000-title.rst b/doc/changelog/02-specification-language/00000-title.rst new file mode 100644 index 0000000000..99bd2c5b44 --- /dev/null +++ b/doc/changelog/02-specification-language/00000-title.rst @@ -0,0 +1,3 @@ + +**Specification language, type inference** + diff --git a/doc/changelog/03-notations/00000-title.rst b/doc/changelog/03-notations/00000-title.rst new file mode 100644 index 0000000000..abc532df11 --- /dev/null +++ b/doc/changelog/03-notations/00000-title.rst @@ -0,0 +1,3 @@ + +**Notations** + diff --git a/doc/changelog/04-tactics/00000-title.rst b/doc/changelog/04-tactics/00000-title.rst new file mode 100644 index 0000000000..3c7802d632 --- /dev/null +++ b/doc/changelog/04-tactics/00000-title.rst @@ -0,0 +1,3 @@ + +**Tactics** + diff --git a/doc/changelog/04-tactics/09996-hint-mode.rst b/doc/changelog/04-tactics/09996-hint-mode.rst new file mode 100644 index 0000000000..06e9059b45 --- /dev/null +++ b/doc/changelog/04-tactics/09996-hint-mode.rst @@ -0,0 +1,5 @@ +- Modes are now taken into account by :tacn:`typeclasses eauto` for + local hypotheses + (`#9996 <https://github.com/coq/coq/pull/9996>`_, + fixes `#5752 <https://github.com/coq/coq/issues/5752>`_, + by Maxime Dénès, review by Pierre-Marie Pédrot). diff --git a/doc/changelog/04-tactics/10059-change-no-check.rst b/doc/changelog/04-tactics/10059-change-no-check.rst new file mode 100644 index 0000000000..987b2a8ccd --- /dev/null +++ b/doc/changelog/04-tactics/10059-change-no-check.rst @@ -0,0 +1,7 @@ +- New variant :tacn:`change_no_check` of :tacn:`change`, usable as a + documented replacement of :tacn:`convert_concl_no_check` + (`#10012 <https://github.com/coq/coq/pull/10012>`_, + `#10017 <https://github.com/coq/coq/pull/10017>`_, + `#10053 <https://github.com/coq/coq/pull/10053>`_, and + `#10059 <https://github.com/coq/coq/pull/10059>`_, + by Hugo Herbelin and Paolo G. Giarrusso). diff --git a/doc/changelog/05-tactic-language/00000-title.rst b/doc/changelog/05-tactic-language/00000-title.rst new file mode 100644 index 0000000000..b34d190298 --- /dev/null +++ b/doc/changelog/05-tactic-language/00000-title.rst @@ -0,0 +1,3 @@ + +**Tactic language** + diff --git a/doc/changelog/06-ssreflect/00000-title.rst b/doc/changelog/06-ssreflect/00000-title.rst new file mode 100644 index 0000000000..2e724627ec --- /dev/null +++ b/doc/changelog/06-ssreflect/00000-title.rst @@ -0,0 +1,3 @@ + +**SSReflect** + diff --git a/doc/changelog/06-ssreflect/09995-notations.rst b/doc/changelog/06-ssreflect/09995-notations.rst new file mode 100644 index 0000000000..3dfc45242d --- /dev/null +++ b/doc/changelog/06-ssreflect/09995-notations.rst @@ -0,0 +1,8 @@ +- `inE` now expands `y \in r x` when `r` is a `simpl_rel`. + New `{pred T}` notation for a `pred T` alias in the `pred_sort` coercion + class, simplified `predType` interface: `pred_class` and `mkPredType` + deprecated, `{pred T}` and `PredType` should be used instead. + `if c return t then ...` now expects `c` to be a variable bound in `t`. + New `nonPropType` interface matching types that do _not_ have sort `Prop`. + New `relpre R f` definition for the preimage of a relation R under f + (`#9995 <https://github.com/coq/coq/pull/9995>`_, by Georges Gonthier). diff --git a/doc/changelog/07-commands-and-options/00000-title.rst b/doc/changelog/07-commands-and-options/00000-title.rst new file mode 100644 index 0000000000..1a0272983e --- /dev/null +++ b/doc/changelog/07-commands-and-options/00000-title.rst @@ -0,0 +1,3 @@ + +**Commands and options** + diff --git a/doc/changelog/08-tools/00000-title.rst b/doc/changelog/08-tools/00000-title.rst new file mode 100644 index 0000000000..bf462744fb --- /dev/null +++ b/doc/changelog/08-tools/00000-title.rst @@ -0,0 +1,3 @@ + +**Tools** + diff --git a/doc/changelog/09-coqide/00000-title.rst b/doc/changelog/09-coqide/00000-title.rst new file mode 100644 index 0000000000..0fc27cf380 --- /dev/null +++ b/doc/changelog/09-coqide/00000-title.rst @@ -0,0 +1,3 @@ + +**CoqIDE** + diff --git a/doc/changelog/10-standard-library/00000-title.rst b/doc/changelog/10-standard-library/00000-title.rst new file mode 100644 index 0000000000..d517a0e709 --- /dev/null +++ b/doc/changelog/10-standard-library/00000-title.rst @@ -0,0 +1,3 @@ + +**Standard library** + diff --git a/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst b/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst new file mode 100644 index 0000000000..732c088f45 --- /dev/null +++ b/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst @@ -0,0 +1,3 @@ +- Added :g:`Coq.Structures.EqualitiesFacts.PairUsualDecidableTypeFull` + (`#9984 <https://github.com/coq/coq/pull/9984>`_, + by Jean-Christophe Léchenet and Oliver Nash). diff --git a/doc/changelog/11-infrastructure-and-dependencies/00000-title.rst b/doc/changelog/11-infrastructure-and-dependencies/00000-title.rst new file mode 100644 index 0000000000..6b301f59d3 --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/00000-title.rst @@ -0,0 +1,3 @@ + +**Infrastructure and dependencies** + diff --git a/doc/changelog/12-misc/00000-title.rst b/doc/changelog/12-misc/00000-title.rst new file mode 100644 index 0000000000..5e709e2b27 --- /dev/null +++ b/doc/changelog/12-misc/00000-title.rst @@ -0,0 +1,3 @@ + +**Miscellaneous** + diff --git a/doc/changelog/12-misc/09964-changes.rst b/doc/changelog/12-misc/09964-changes.rst new file mode 100644 index 0000000000..1113782180 --- /dev/null +++ b/doc/changelog/12-misc/09964-changes.rst @@ -0,0 +1,13 @@ +- Changelog has been moved from a specific file `CHANGES.md` to the + reference manual; former Credits chapter of the reference manual has + been split in two parts: a History chapter which was enriched with + additional historical information about Coq versions 1 to 5, and a + Changes chapter which was enriched with the content formerly in + `CHANGES.md` and `COMPATIBILITY` + (`#9133 <https://github.com/coq/coq/pull/9133>`_, + `#9668 <https://github.com/coq/coq/pull/9668>`_, + `#9939 <https://github.com/coq/coq/pull/9939>`_, + `#9964 <https://github.com/coq/coq/pull/9964>`_, + by Théo Zimmermann, + with help and ideas from Emilio Jesús Gallego Arias, + Clément Pit-Claudel, Matthieu Sozeau, and Enrico Tassi). diff --git a/doc/changelog/README.md b/doc/changelog/README.md new file mode 100644 index 0000000000..2891eb207e --- /dev/null +++ b/doc/changelog/README.md @@ -0,0 +1,41 @@ +# Unreleased changelog # + +## When to add an entry? ## + +All new features, user-visible changes to features, user-visible or +otherwise important infrastructure changes, and important bug fixes +should get a changelog entry. + +Compatibility-breaking changes should always get a changelog entry, +which should explain what compatibility-breakage is to expect. + +Pull requests changing the ML API in significant ways should add an +entry in [`dev/doc/changes.md`](../../dev/doc/changes.md). + +## How to add an entry? ## + +You should create a file in one of the sub-directories. The name of +the file should be `NNNNN-identifier.rst` where `NNNNN` is the number +of the pull request on five digits and `identifier` is whatever you +want. + +This file should use the same format as the reference manual (as it +will be copied in there). You may reference the documentation you just +added with `:ref:`, `:tacn:`, `:cmd:`, `:opt:`, `:token:`, etc. See +the [documentation of the Sphinx format](../sphinx/README.rst) of the +manual for details. + +The entry should be written using the following structure: + +``` rst +- Description of the changes, with possible link to + :ref:`relevant-section` of the updated documentation + (`#PRNUM <https://github.com/coq/coq/pull/PRNUM>`_, + [fixes `#ISSUE1 <https://github.com/coq/coq/issues/ISSUE1>`_ + [ and `#ISSUE2 <https://github.com/coq/coq/issues/ISSUE2>`_],] + by Full Name[, with help / review of Full Name]). +``` + +The description should be kept rather short and the only additional +required meta-information are the link to the pull request and the +full name of the author. @@ -11,6 +11,7 @@ (package coq) (source_tree sphinx) (source_tree tools) + unreleased.rst (env_var SPHINXWARNOPT)) (action (run env COQLIB=%{project_root} sphinx-build -j4 %{env:SPHINXWARNOPT=-W} -b html -d sphinx_build/doctrees sphinx sphinx_build/html))) @@ -19,6 +20,11 @@ (name refman-html) (deps sphinx_build)) +(rule + (targets unreleased.rst) + (deps (source_tree changelog)) + (action (with-stdout-to %{targets} (bash "cat changelog/00-title.rst changelog/*/*.rst")))) + ; The install target still needs more work. ; (install ; (section doc) diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index 23f8fbe888..3c0355c92d 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -1,17 +1,8 @@ -(* Ideally coq/coq#8811 would get merged and then this function could be much simpler. *) let edeclare ?hook ~ontop ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps = - let sigma = Evd.minimize_universes sigma in - let body = EConstr.to_constr sigma body in - let tyopt = Option.map (EConstr.to_constr sigma) tyopt in - let uvars_fold uvars c = - Univ.LSet.union uvars (Vars.universes_of_constr c) in - let uvars = List.fold_left uvars_fold Univ.LSet.empty - (Option.List.cons tyopt [body]) in - let sigma = Evd.restrict_universe_context sigma uvars in - let univs = Evd.check_univ_decl ~poly sigma udecl in + let sigma, ce = DeclareDef.prepare_definition ~allow_evars:false + ~opaque ~poly sigma udecl ~types:tyopt ~body in let uctx = Evd.evar_universe_context sigma in let ubinders = Evd.universe_binders sigma in - let ce = Declare.definition_entry ?types:tyopt ~univs body in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in DeclareDef.declare_definition ~ontop ident k ce ubinders imps ?hook_data diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index c0c8c2d79c..8935ba27e3 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -10,9 +10,9 @@ SProp (proof irrelevant propositions) This section describes the extension of |Coq| with definitionally proof irrelevant propositions (types in the sort :math:`\SProp`, also known as strict propositions). To use :math:`\SProp` you must pass -``-allow-sprop`` to the |Coq| program or use :opt:`Allow StrictProp`. +``-allow-sprop`` to the |Coq| program or use :flag:`Allow StrictProp`. -.. opt:: Allow StrictProp +.. flag:: Allow StrictProp :name: Allow StrictProp Allows using :math:`\SProp` when set and forbids it when unset. The @@ -201,10 +201,10 @@ This means that some errors will be delayed until ``Qed``: Abort. -.. opt:: Elaboration StrictProp Cumulativity +.. flag:: Elaboration StrictProp Cumulativity :name: Elaboration StrictProp Cumulativity - Unset this option (it's on by default) to be strict with regard to + Unset this flag (it is on by default) to be strict with regard to :math:`\SProp` cumulativity during elaboration. The implementation of proof irrelevance uses inferred "relevance" diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index a5e9023732..77a6ee79cc 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -405,6 +405,8 @@ few other commands related to typeclasses. resolution with the local hypotheses use full conversion during unification. + + When considering local hypotheses, we use the union of all the modes + declared in the given databases. .. cmdv:: typeclasses eauto @num diff --git a/doc/sphinx/biblio.bib b/doc/sphinx/biblio.bib index 0467852b19..85b02013d8 100644 --- a/doc/sphinx/biblio.bib +++ b/doc/sphinx/biblio.bib @@ -551,3 +551,20 @@ the Calculus of Inductive Constructions}}, biburl = {http://dblp.uni-trier.de/rec/bib/conf/cpp/BoespflugDG11}, bibsource = {dblp computer science bibliography, http://dblp.org} } + +@inproceedings{MilnerPrincipalTypeSchemes, + author = {Damas, Luis and Milner, Robin}, + title = {Principal Type-schemes for Functional Programs}, + booktitle = {Proceedings of the 9th ACM SIGPLAN-SIGACT Symposium on Principles of Programming Languages}, + series = {POPL '82}, + year = {1982}, + isbn = {0-89791-065-6}, + location = {Albuquerque, New Mexico}, + pages = {207--212}, + numpages = {6}, + url = {http://doi.acm.org/10.1145/582153.582176}, + doi = {10.1145/582153.582176}, + acmid = {582176}, + publisher = {ACM}, + address = {New York, NY, USA}, +} diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 57b9e45342..5704587ae0 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -2,6 +2,542 @@ Recent changes -------------- +.. include:: ../unreleased.rst + +Version 8.10 +------------ + +Summary of changes +~~~~~~~~~~~~~~~~~~ + +|Coq| version 8.10 contains two major new features: support for a native +fixed-precision integer type and a new sort :math:`\SProp` of strict +propositions. It is also the result of refinements and stabilization of +previous features, deprecations or removals of deprecated features, +cleanups of the internals of the system and API, and many documentation improvements. +This release includes many user-visible changes, including deprecations that are +documented in the next subsection, and new features that are documented in the +reference manual. Here are the most important user-visible changes: + +- Kernel: + + - A notion of primitive object was added to the calculus. Its first + instance is primitive cyclic unsigned integers, axiomatized in + module :g:`UInt63`. See Section :ref:`primitive-integers`. + The `Coq.Numbers.Cyclic.Int31` library is deprecated + (`#6914 <https://github.com/coq/coq/pull/6914>`_, by Maxime Dénès, + Benjamin Grégoire and Vincent Laporte, + with help and reviews from many others). + + - The :math:`\SProp` sort of definitionally proof-irrelevant propositions was + introduced. :math:`\SProp` allows to mark proof + terms as irrelevant for conversion, and is treated like :math:`\Prop` + during extraction. It is enabled using the `-allow-sprop` + command-line flag or the :flag:`Allow StrictProp` flag. + See Chapter :ref:`sprop` + (`#8817 <https://github.com/coq/coq/pull/8817>`_, by Gaëtan Gilbert). + + - The unfolding heuristic in termination checking was made more + complete, allowing more constants to be unfolded to discover valid + recursive calls. Performance regression may occur in Fixpoint + declarations without an explicit ``{struct}`` annotation, since + guessing the decreasing argument can now be more expensive + (`#9602 <https://github.com/coq/coq/pull/9602>`_, by Enrico Tassi). + +- Universes: + + - Added :cmd:`Print Universes Subgraph` variant of :cmd:`Print Universes`. + Try for instance + :g:`Print Universes Subgraph(sigT2.u1 sigT_of_sigT2.u1 projT3_eq.u1).` + (`#8451 <https://github.com/coq/coq/pull/8451>`_, by Gaëtan Gilbert). + + - Added private universes for opaque polymorphic constants, see the + documentation for the :flag:`Private Polymorphic Universes` flag, + and unset it to get the previous behaviour + (`#8850 <https://github.com/coq/coq/pull/8850>`_, by Gaëtan Gilbert). + +- Notations: + + - New command :cmd:`String Notation` to register string syntax for custom + inductive types + (`#8965 <https://github.com/coq/coq/pull/8965>`_, by Jason Gross). + + - Experimental: :ref:`Numeral Notations <numeral-notations>` now parse decimal + constants such as ``1.02e+01`` or ``10.2``. Parsers added for :g:`Q` and :g:`R`. + In the rare case when such numeral notations were used + in a development along with :g:`Q` or :g:`R`, they may have to be removed or + disambiguated through explicit scope annotations + (`#8764 <https://github.com/coq/coq/pull/8764>`_, by Pierre Roux). + +- Ltac backtraces can be turned on using the :flag:`Ltac Backtrace` + flag, which is off by default + (`#9142 <https://github.com/coq/coq/pull/9142>`_, + fixes `#7769 <https://github.com/coq/coq/issues/7769>`_ + and `#7385 <https://github.com/coq/coq/issues/7385>`_, + by Pierre-Marie Pédrot). + +- The tactics :tacn:`lia`, :tacn:`nia`, :tacn:`lra`, :tacn:`nra` are now using a novel + Simplex-based proof engine. In case of regression, unset :flag:`Simplex` + to get the venerable Fourier-based engine + (`#8457 <https://github.com/coq/coq/pull/8457>`_, by Fréderic Besson). + +- SSReflect: + + - New intro patterns: + + - temporary introduction: `=> +` + - block introduction: `=> [^ prefix ] [^~ suffix ]` + - fast introduction: `=> >` + - tactics as views: `=> /ltac:mytac` + - replace hypothesis: `=> {}H` + + See Section :ref:`introduction_ssr` + (`#6705 <https://github.com/coq/coq/pull/6705>`_, by Enrico Tassi, + with help from Maxime Dénès, + ideas coming from various users). + + - New tactic :tacn:`under` to rewrite under binders, given an + extensionality lemma: + + - interactive mode: :n:`under @term`, associated terminator: :tacn:`over` + - one-liner mode: `under @term do [@tactic | ...]` + + It can take occurrence switches, contextual patterns, and intro patterns: + :g:`under {2}[in RHS]eq_big => [i|i ?] do ...` + (`#9651 <https://github.com/coq/coq/pull/9651>`_, + by Erik Martin-Dorel and Enrico Tassi). + +- :cmd:`Combined Scheme` now works when inductive schemes are generated in sort + :math:`\Type`. It used to be limited to sort `Prop` + (`#7634 <https://github.com/coq/coq/pull/7634>`_, by Théo Winterhalter). + +- A new registration mechanism for reference from ML code to Coq + constructs has been added + (`#186 <https://github.com/coq/coq/pull/186>`_, + by Emilio Jesús Gallego Arias, Maxime Dénès and Vincent Laporte). + +- CoqIDE: + + - CoqIDE now depends on gtk+3 and lablgtk3 instead of gtk+2 and lablgtk2 + (`#9279 <https://github.com/coq/coq/pull/9279>`_, + by Hugo Herbelin, with help from Jacques Garrigue, + Emilio Jesús Gallego Arias, Michael Sogetrop and Vincent Laporte). + + - Smart input for Unicode characters. For example, typing + ``\alpha`` then ``Shift+Space`` will insert the greek letter alpha. + A larger number of default bindings are provided, following the latex + naming convention. Bindings can be customized, either globally, or on a + per-project basis. See Section :ref:`coqide-unicode` for details + (`#8560 <https://github.com/coq/coq/pull/8560>`_, by Arthur Charguéraud). + +- Infrastructure and dependencies: + + - Coq 8.10 requires OCaml >= 4.05.0, bumped from 4.02.3 See the + `INSTALL` file for more information on dependencies + (`#7522 <https://github.com/coq/coq/pull/7522>`_, by Emilio Jesús Gallego Arías). + + - Coq 8.10 doesn't need Camlp5 to build anymore. It now includes a + fork of the core parsing library that Coq uses, which is a small + subset of the whole Camlp5 distribution. In particular, this subset + doesn't depend on the OCaml AST, allowing easier compilation and + testing on experimental OCaml versions. Coq also ships a new parser + `coqpp` that plugin authors must switch to + (`#7902 <https://github.com/coq/coq/pull/7902>`_, + `#7979 <https://github.com/coq/coq/pull/7979>`_, + `#8161 <https://github.com/coq/coq/pull/8161>`_, + `#8667 <https://github.com/coq/coq/pull/8667>`_, + and `#8945 <https://github.com/coq/coq/pull/8945>`_, + by Pierre-Marie Pédrot and Emilio Jesús Gallego Arias). + + The Coq developers would like to thank Daniel de Rauglaudre for many + years of continued support. + + - Coq now supports building with Dune, in addition to the traditional + Makefile which is scheduled for deprecation + (`#6857 <https://github.com/coq/coq/pull/6857>`_, + by Emilio Jesús Gallego Arias, with help from Rudi Grinberg). + + Experimental support for building Coq projects has been integrated + in Dune at the same time, providing an `improved experience + <https://coq.discourse.group/t/a-guide-to-building-your-coq-libraries-and-plugins-with-dune/>`_ + for plugin developers. We thank the Dune team for their work + supporting Coq. + +Version 8.10 also comes with a bunch of smaller-scale changes and +improvements regarding the different components of the system, including +many additions to the standard library (see the next subsection for details). + +On the implementation side, the ``dev/doc/changes.md`` file documents +the numerous changes to the implementation and improvements of +interfaces. The file provides guidelines on porting a plugin to the new +version and a plugin development tutorial originally made by Yves Bertot +is now in `doc/plugin_tutorial`. The ``dev/doc/critical-bugs`` file +documents the known critical bugs of |Coq| and affected releases. + +The efficiency of the whole system has seen improvements thanks to +contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, and Maxime Dénès. + +Maxime Dénès, Emilio Jesús Gallego Arias, Gaëtan Gilbert, Michael +Soegtrop, Théo Zimmermann worked on maintaining and improving the +continuous integration system and package building infrastructure. +Coq is now continuously tested against OCaml trunk, in addition to the +oldest supported and latest OCaml releases. + +Coq's documentation for the development branch is now deployed +continously at https://coq.github.io/doc/master/api (documentation of +the ML API), https://coq.github.io/doc/master/refman (reference +manual), and https://coq.github.io/doc/master/stdlib (documentation of +the standard library). Similar links exist for the `v8.10` branch. + +The OPAM repository for |Coq| packages has been maintained by Guillaume +Melquiond, Matthieu Sozeau, Enrico Tassi (who migrated it to opam 2) +with contributions from many users. A list of packages is available at +https://coq.inria.fr/opam/www/. + +The 61 contributors to this version are David A. Dalrymple, Tanaka +Akira, Benjamin Barenblat, Yves Bertot, Frédéric Besson, Lasse +Blaauwbroek, Martin Bodin, Joachim Breitner, Tej Chajed, Frédéric +Chapoton, Arthur Charguéraud, Cyril Cohen, Lukasz Czajka, Christian +Doczkal, Maxime Dénès, Andres Erbsen, Jim Fehrle, Gaëtan Gilbert, Matěj +Grabovský, Simon Gregersen, Jason Gross, Samuel Gruetter, Hugo Herbelin, +Jasper Hugunin, Mirai Ikebuchi, Emilio Jesus Gallego Arias, Chantal +Keller, Matej Košík, Vincent Laporte, Olivier Laurent, Larry Darryl Lee +Jr, Pierre Letouzey, Nick Lewycky, Yao Li, Yishuai Li, Xia Li-yao, Assia +Mahboubi, Simon Marechal, Erik Martin-Dorel, Thierry Martinez, Guillaume +Melquiond, Kayla Ngan, Sam Pablo Kuper, Karl Palmskog, Clément +Pit-Claudel, Pierre-Marie Pédrot, Pierre Roux, Kazuhiko Sakaguchi, Ryan +Scott, Vincent Semeria, Gan Shen, Michael Soegtrop, Matthieu Sozeau, +Enrico Tassi, Laurent Théry, Kamil Trzciński, whitequark, Théo +Winterhalter, Beta Ziliani and Théo Zimmermann. + +Many power users helped to improve the design of the new features via +the issue and pull request system, the |Coq| development mailing list, +the coq-club@inria.fr mailing list or the new Discourse forum. It would +be impossible to mention exhaustively the names of everybody who to some +extent influenced the development. + +Version 8.10 is the fifth release of |Coq| developed on a time-based +development cycle. Its development spanned 6 months from the release of +|Coq| 8.9. Vincent Laporte is the release manager and maintainer of this +release. This release is the result of ~2500 commits and ~650 PRs merged, +closing 150+ issues. + +| Santiago de Chile, April 2019, +| Matthieu Sozeau for the |Coq| development team +| + +Other changes in 8.10+beta1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +- Command-line tools and options: + + - The use of `coqtop` as a compiler has been deprecated, in favor of + `coqc`. Consequently option `-compile` will stop to be accepted in + the next release. `coqtop` is now reserved to interactive + use + (`#9095 <https://github.com/coq/coq/pull/9095>`_, + by Emilio Jesús Gallego Arias). + + - New option ``-topfile filename``, which will set the current module name + (*à la* ``-top``) based on the filename passed, taking into account the + proper ``-R``/``-Q`` options. For example, given ``-R Foo foolib`` using + ``-topfile foolib/bar.v`` will set the module name to ``Foo.Bar``. + CoqIDE now properly sets the module name for a given file based on + its path + (`#8991 <https://github.com/coq/coq/pull/8991>`_, + closes `#8989 <https://github.com/coq/coq/issues/8989>`_, + by Gaëtan Gilbert). + + - Experimental: Coq flags and options can now be set on the + command-line, e.g. ``-set "Universe Polymorphism=true"`` + (`#9876 <https://github.com/coq/coq/pull/9876>`_, by Gaëtan Gilbert). + + - The `-native-compiler` flag of `coqc` and `coqtop` now takes an + argument which can have three values: + + - `no` disables native_compute + - `yes` enables native_compute and precompiles `.v` files to + native code + - `ondemand` enables native_compute but compiles code only when + `native_compute` is called + + The default value is `ondemand`. Note that this flag now has + priority over the configure flag of the same name. + + A new `-bytecode-compiler` flag for `coqc` and `coqtop` controls + whether conversion can use the VM. The default value is `yes`. + + (`#8870 <https://github.com/coq/coq/pull/8870>`_, by Maxime Dénès) + + - The pretty timing diff scripts (flag `TIMING=1` to a + `coq_makefile`\-made `Makefile`, also + `tools/make-both-single-timing-files.py`, + `tools/make-both-time-files.py`, and `tools/make-one-time-file.py`) + now correctly support non-UTF-8 characters in the output of + `coqc` / `make` as well as printing to stdout, on both python2 and + python3 + (`#9872 <https://github.com/coq/coq/pull/9872>`_, + closes `#9767 <https://github.com/coq/coq/issues/9767>`_ + and `#9705 <https://github.com/coq/coq/issues/9705>`_, + by Jason Gross) + + - coq_makefile's install target now errors if any file to install is missing + (`#9906 <https://github.com/coq/coq/pull/9906>`_, by Gaëtan Gilbert). + + - Preferences from ``coqide.keys`` are no longer overridden by + modifiers preferences in ``coqiderc`` + (`#10014 <https://github.com/coq/coq/pull/10014>`_, by Hugo Herbelin). + +- Specification language, type inference: + + - Fixing a missing check in interpreting instances of existential + variables that are bound to local definitions. Might exceptionally + induce an overhead if the cost of checking the conversion of the + corresponding definitions is additionally high + (`#8217 <https://github.com/coq/coq/pull/8217>`_, + closes `#8215 <https://github.com/coq/coq/issues/8215>`_, + by Hugo Herbelin). + + - A few improvements in inference of the return clause of `match` that + can exceptionally introduce incompatibilities. This can be + solved by writing an explicit `return` clause, sometimes even simply + an explicit `return _` clause + (`#262 <https://github.com/coq/coq/pull/262>`_, by Hugo Herbelin). + + - Using non-projection values with the projection syntax is not + allowed. For instance :g:`0.(S)` is not a valid way to write :g:`S 0`. + Projections from non-primitive (emulated) records are allowed with + warning "nonprimitive-projection-syntax" + (`#8829 <https://github.com/coq/coq/pull/8829>`_, by Gaëtan Gilbert). + + - An option and attributes to control the automatic decision to declare + an inductive type as template polymorphic were added. Warning + "auto-template" (off by default) can trigger when an inductive is + automatically declared template polymorphic without the attribute. + + Inductive types declared by Funind will never be template polymorphic. + + (`#8488 <https://github.com/coq/coq/pull/8488>`_, by Gaëtan Gilbert) + +- Notations: + + - New command :cmd:`Declare Scope` to explicitly declare a scope name + before any use of it. Implicit declaration of a scope at the time of + :cmd:`Bind Scope`, :cmd:`Delimit Scope`, :cmd:`Undelimit Scope`, + or :cmd:`Notation` is deprecated + (`#7135 <https://github.com/coq/coq/pull/7135>`_, by Hugo Herbelin). + + - Various bugs have been fixed (e.g. `#9214 + <https://github.com/coq/coq/pull/9214>`_ on removing spurious + parentheses on abbreviations shortening a strict prefix of an + application, by Hugo Herbelin). + + - :cmd:`Numeral Notation` now support inductive types in the input to + printing functions (e.g., numeral notations can be defined for terms + containing things like :g:`@cons nat O O`), and parsing functions now + fully normalize terms including parameters of constructors (so that, + e.g., a numeral notation whose parsing function outputs a proof of + :g:`Nat.gcd x y = 1` will no longer fail to parse due to containing the + constant :g:`Nat.gcd` in the parameter-argument of :g:`eq_refl`) + (`#9874 <https://github.com/coq/coq/pull/9840>`_, + closes `#9840 <https://github.com/coq/coq/issues/9840>`_ + and `#9844 <https://github.com/coq/coq/issues/9844>`_, + by Jason Gross). + + - Deprecated compatibility notations have actually been + removed. Uses of these notations are generally easy to fix thanks + to the hint contained in the deprecation warning emitted by Coq + 8.8 and 8.9. For projects that require more than a handful of + such fixes, there is `a script + <https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py>`_ + that will do it automatically, using the output of ``coqc`` + (`#8638 <https://github.com/coq/coq/pull/8638>`_, by Jason Gross). + +- The `quote plugin + <https://coq.inria.fr/distrib/V8.9.0/refman/proof-engine/detailed-tactic-examples.html#quote>`_ + was removed. If some users are interested in maintaining this plugin + externally, the Coq development team can provide assistance for + extracting the plugin and setting up a new repository + (`#7894 <https://github.com/coq/coq/pull/7894>`_, by Maxime Dénès). + +- Ltac: + + - Tactic names are no longer allowed to clash, even if they are not defined in + the same section. For example, the following is no longer accepted: + :g:`Ltac foo := idtac. Section S. Ltac foo := fail. End S.` + (`#8555 <https://github.com/coq/coq/pull/8555>`_, by Maxime Dénès). + + - Names of existential variables occurring in Ltac functions + (e.g. :g:`?[n]` or :g:`?n` in terms - not in patterns) are now interpreted + the same way as other variable names occurring in Ltac functions + (`#7309 <https://github.com/coq/coq/pull/7309>`_, by Hugo Herbelin). + +- Tactics: + + - Removed the deprecated `romega` tactic + (`#8419 <https://github.com/coq/coq/pull/8419>`_, + by Maxime Dénès and Vincent Laporte). + + - Hint declaration and removal should now specify a database (e.g. `Hint Resolve + foo : database`). When the database name is omitted, the hint is added to the + `core` database (as previously), but a deprecation warning is emitted + (`#8987 <https://github.com/coq/coq/pull/8987>`_, by Maxime Dénès). + + - There are now tactics in `PreOmega.v` called + `Z.div_mod_to_equations`, `Z.quot_rem_to_equations`, and + `Z.to_euclidean_division_equations` (which combines the `div_mod` + and `quot_rem` variants) which allow :tacn:`lia`, :tacn:`nia`, etc to + support `Z.div` and `Z.modulo` (`Z.quot` and `Z.rem`, respectively), + by posing the specifying equation for `Z.div` and `Z.modulo` before + replacing them with atoms + (`#8062 <https://github.com/coq/coq/pull/8062>`_, by Jason Gross). + + - The syntax of the :tacn:`autoapply` tactic was fixed to conform with preexisting + documentation: it now takes a `with` clause instead of a `using` clause + (`#9524 <https://github.com/coq/coq/pull/9524>`_, + closes `#7632 <https://github.com/coq/coq/issues/7632>`_, + by Théo Zimmermann). + + - SSReflect clear discipline made consistent across the entire proof language. + Whenever a clear switch `{x..}` comes immediately before an existing proof + context entry (used as a view, as a rewrite rule or as name for a new + context entry) then such entry is cleared too. + + E.g. The following sentences are elaborated as follows (when H is an existing + proof context entry): + + - `=> {x..} H` -> `=> {x..H} H` + - `=> {x..} /H` -> `=> /v {x..H}` + - `rewrite {x..} H` -> `rewrite E {x..H}` + + (`#9341 <https://github.com/coq/coq/pull/9341>`_, by Enrico Tassi). + +- Vernacular commands: + + - Binders for an :cmd:`Instance` now act more like binders for a :cmd:`Theorem`. + Names may not be repeated, and may not overlap with section variable names + (`#8820 <https://github.com/coq/coq/pull/8820>`_, + closes `#8791 <https://github.com/coq/coq/issues/8791>`_, + by Jasper Hugunin). + + - Removed the deprecated `Implicit Tactic` family of commands + (`#8779 <https://github.com/coq/coq/pull/8779>`_, by Pierre-Marie Pédrot). + + - The `Automatic Introduction` option has been removed and is now the + default + (`#9001 <https://github.com/coq/coq/pull/9001>`_, + by Emilio Jesús Gallego Arias). + + - `Arguments` now accepts names for arguments provided with `extra_scopes` + (`#9117 <https://github.com/coq/coq/pull/9117>`_, by Maxime Dénès). + + - The naming scheme for anonymous binders in a `Theorem` has changed to + avoid conflicts with explicitly named binders + (`#9160 <https://github.com/coq/coq/pull/9160>`_, + closes `#8819 <https://github.com/coq/coq/issues/8819>`_, + by Jasper Hugunin). + + - Computation of implicit arguments now properly handles local definitions in the + binders for an `Instance`, and can be mixed with implicit binders `{x : T}` + (`#9307 <https://github.com/coq/coq/pull/9307>`_, + closes `#9300 <https://github.com/coq/coq/issues/9300>`_, + by Jasper Hugunin). + + - :cmd:`Declare Instance` now requires an instance name. + + The flag :flag:`Refine Instance Mode` has been turned off by default, + meaning that :cmd:`Instance` no longer opens a proof when a body is + provided. The flag has been deprecated and will be removed in the next + version. + + (`#9270 <https://github.com/coq/coq/pull/9270>`_, + and `#9825 <https://github.com/coq/coq/pull/9825>`_, + by Maxime Dénès) + + - Command :cmd:`Instance`, when no body is provided, now always opens + a proof. This is a breaking change, as instance of :n:`Instance + @ident__1 : @ident__2.` where :n:`@ident__2` is a trivial class will + have to be changed into :n:`Instance @ident__1 : @ident__2 := {}.` + or :n:`Instance @ident__1 : @ident__2. Proof. Qed.` + (`#9274 <https://github.com/coq/coq/pull/9274>`_, by Maxime Dénès). + + - The flag :flag:`Program Mode` now means that the `Program` attribute is enabled + for all commands that support it. In particular, it does not have any effect + on tactics anymore. May cause some incompatibilities + (`#9410 <https://github.com/coq/coq/pull/9410>`_, by Maxime Dénès). + + - The algorithm computing implicit arguments now behaves uniformly for primitive + projection and application nodes + (`#9509 <https://github.com/coq/coq/pull/9509>`_, + closes `#9508 <https://github.com/coq/coq/issues/9508>`_, + by Pierre-Marie Pédrot). + + - :cmd:`Hypotheses` and :cmd:`Variables` can now take implicit + binders inside sections + (`#9364 <https://github.com/coq/coq/pull/9364>`_, + closes `#9363 <https://github.com/coq/coq/issues/9363>`_, + by Jasper Hugunin). + + - Removed deprecated option `Automatic Coercions Import` + (`#8094 <https://github.com/coq/coq/pull/8094>`_, by Maxime Dénès). + + - The ``Show Script`` command has been deprecated + (`#9829 <https://github.com/coq/coq/pull/9829>`_, by Vincent Laporte). + + - :cmd:`Coercion` does not warn ambiguous paths which are obviously + convertible with existing ones + (`#9743 <https://github.com/coq/coq/pull/9743>`_, + closes `#3219 <https://github.com/coq/coq/issues/3219>`_, + by Kazuhiko Sakaguchi). + + - A new flag :flag:`Fast Name Printing` has been introduced. It changes the + algorithm used for allocating bound variable names for a faster but less + clever one + (`#9078 <https://github.com/coq/coq/pull/9078>`_, by Pierre-Marie Pédrot). + + - Option ``Typeclasses Axioms Are Instances`` (compatibility option + introduced in the previous version) is deprecated. Use :cmd:`Declare + Instance` for axioms which should be instances + (`#8920 <https://github.com/coq/coq/pull/8920>`_, by Gaëtan Gilbert). + + - Removed option `Printing Primitive Projection Compatibility` + (`#9306 <https://github.com/coq/coq/pull/9306>`_, by Gaëtan Gilbert). + +- Standard Library: + + - Added `Bvector.BVeq` that decides whether two `Bvector`\s are equal. + Added notations for `BVxor`, `BVand`, `BVor`, `BVeq` and `BVneg` + (`#8171 <https://github.com/coq/coq/pull/8171>`_, by Yishuai Li). + + - Added `ByteVector` type that can convert to and from `string` + (`#8365 <https://github.com/coq/coq/pull/8365>`_, by Yishuai Li). + + - Added lemmas about monotonicity of `N.double` and `N.succ_double`, and about + the upper bound of number represented by a vector. + Allowed implicit vector length argument in `Ndigits.Bv2N` + (`#8815 <https://github.com/coq/coq/pull/8815>`_, by Yishuai Li). + + - The prelude used to be automatically Exported and is now only + Imported. This should be relevant only when importing files which + don't use `-noinit` into files which do + (`#9013 <https://github.com/coq/coq/pull/9013>`_, by Gaëtan Gilert). + + - Added `Coq.Structures.OrderedTypeEx.String_as_OT` to make strings an + ordered type, using lexical order + (`#7221 <https://github.com/coq/coq/pull/7221>`_, by Li Yao). + + - Added lemmas about `Z.testbit`, `Z.ones`, and `Z.modulo` + (`#9425 <https://github.com/coq/coq/pull/9425>`_, by Andres Erbsen). + + - Moved the `auto` hints of the `FSet` library into a new + `fset` database + (`#9725 <https://github.com/coq/coq/pull/9725>`_, by Frédéric Besson). + +- Some error messages that show problems with a pair of non-matching + values will now highlight the differences + (`#8669 <https://github.com/coq/coq/pull/8669>`_, by Jim Fehrle). + + Version 8.9 ----------- @@ -12,7 +548,7 @@ Summary of changes of features and deprecations or removals of deprecated features, cleanups of the internals of the system and API along with a few new features. This release includes many user-visible changes, including -deprecations that are documented in ``CHANGES.md`` and new features that +deprecations that are documented in the next subsection and new features that are documented in the reference manual. Here are the most important changes: @@ -26,7 +562,7 @@ changes: manual). - Deprecated notations of the standard library will be removed in the - next version of |Coq|, see the ``CHANGES.md`` file for a script to + next version of |Coq|, see the next subsection for a script to ease porting, by Jason Gross and Jean-Christophe Léchenet. - Added the :cmd:`Numeral Notation` command for registering decimal @@ -79,7 +615,7 @@ changes: - Library: additions and changes in the ``VectorDef``, ``Ascii``, and ``String`` libraries. Syntax notations are now available only when using ``Import`` of libraries and not merely ``Require``, by various - contributors (source of incompatibility, see ``CHANGES.md`` for details). + contributors (source of incompatibility, see the next subsection for details). - Toplevels: ``coqtop`` and ``coqide`` can now display diffs between proof steps in color, using the :opt:`Diffs` option, by Jim Fehrle. @@ -96,7 +632,7 @@ changes: Version 8.9 also comes with a bunch of smaller-scale changes and improvements regarding the different components of the system. Most -important ones are documented in the ``CHANGES.md`` file. +important ones are documented in the next subsection file. On the implementation side, the ``dev/doc/changes.md`` file documents the numerous changes to the implementation and improvements of @@ -152,8 +688,8 @@ engineer working with Maxime Dénès in the |Coq| consortium. | Matthieu Sozeau for the |Coq| development team | -Details of changes -~~~~~~~~~~~~~~~~~~ +Details of changes in 8.9+beta1 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Kernel @@ -167,16 +703,12 @@ Notations - Deprecated compatibility notations will actually be removed in the next version of Coq. Uses of these notations are generally easy to fix thanks to the hint contained in the deprecation warnings. For - projects that require more than a handful of such fixes, there is [a - script](https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py) - that will do it automatically, using the output of coqc. The script + projects that require more than a handful of such fixes, there is `a + script + <https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py>`_ + that will do it automatically, using the output of ``coqc``. The script contains documentation on its usage in a comment at the top. -- When several notations are available for the same expression, - priority is given to latest notations defined in the scopes being - opened, in order, rather than to the latest notations defined - independently of whether they are in an opened scope or not. - Tactics - Added toplevel goal selector `!` which expects a single focused goal. @@ -260,7 +792,7 @@ Standard Library `Require Import Coq.Compat.Coq88` will make these notations available. Users wishing to port their developments automatically may download `fix.py` from - <https://gist.github.com/JasonGross/5d4558edf8f5c2c548a3d96c17820169> + https://gist.github.com/JasonGross/5d4558edf8f5c2c548a3d96c17820169 and run a command like `while true; do make -Okj 2>&1 | /path/to/fix.py; done` and get a cup of coffee. (This command must be manually interrupted once the build finishes all the way though. @@ -284,8 +816,8 @@ Tools If you would like to maintain this tool externally, please contact us. - Removed the Emacs modes distributed with Coq. You are advised to - use [Proof-General](https://proofgeneral.github.io/) (and optionally - [Company-Coq](https://github.com/cpitclaudel/company-coq)) instead. + use `Proof-General <https://proofgeneral.github.io/>`_ (and optionally + `Company-Coq <https://github.com/cpitclaudel/company-coq>`_) instead. If your use case is not covered by these alternative Emacs modes, please open an issue. We can help set up external maintenance as part of Proof-General, or independently as part of coq-community. @@ -428,7 +960,7 @@ version. Version 8.8 also comes with a bunch of smaller-scale changes and improvements regarding the different components of the system. -Most important ones are documented in the ``CHANGES.md`` file. +Most important ones are documented in the next subsection file. The efficiency of the whole system has seen improvements thanks to contributions from Gaëtan Gilbert, Pierre-Marie Pédrot, Maxime Dénès and @@ -788,7 +1320,7 @@ of integers and real constants are now represented using ``IZR`` (work by Guillaume Melquiond). Standard library additions and improvements by Jason Gross, Pierre Letouzey and -others, documented in the ``CHANGES.md`` file. +others, documented in the next subsection file. The mathematical proof language/declarative mode plugin was removed from the archive. diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 48ad60c6dd..972a53ae36 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -47,7 +47,7 @@ with open("refman-preamble.rst") as s: # -- General configuration ------------------------------------------------ # If your documentation needs a minimal Sphinx version, state it here. -#needs_sphinx = '1.0' +needs_sphinx = '1.7.8' # Add any Sphinx extension module names here, as strings. They can be # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom diff --git a/doc/sphinx/index.html.rst b/doc/sphinx/index.html.rst index a91c6a9c5f..0a20d1c47b 100644 --- a/doc/sphinx/index.html.rst +++ b/doc/sphinx/index.html.rst @@ -42,6 +42,7 @@ Contents proof-engine/proof-handling proof-engine/tactics proof-engine/ltac + proof-engine/ltac2 proof-engine/detailed-tactic-examples proof-engine/ssreflect-proof-language diff --git a/doc/sphinx/index.latex.rst b/doc/sphinx/index.latex.rst index 708820fff7..5562736997 100644 --- a/doc/sphinx/index.latex.rst +++ b/doc/sphinx/index.latex.rst @@ -41,6 +41,7 @@ The proof engine proof-engine/proof-handling proof-engine/tactics proof-engine/ltac + proof-engine/ltac2 proof-engine/detailed-tactic-examples proof-engine/ssreflect-proof-language diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 695dea222f..5308330820 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -2244,6 +2244,7 @@ Printing universes unspecified if `string` doesn’t end in ``.dot`` or ``.gv``. .. cmdv:: Print Universes Subgraph(@names) + :name: Print Universes Subgraph Prints the graph restricted to the requested names (adjusting constraints to preserve the implied transitive constraints between diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index d3d75dddd8..efb5df720a 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -259,6 +259,8 @@ use antialiased fonts or not, by setting the environment variable `GDK_USE_XFT` to 1 or 0 respectively. +.. _coqide-unicode: + Bindings for input of Unicode symbols ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 35231610fe..554f6bf230 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -909,13 +909,15 @@ Command line options :--coqlib url: Set base URL for the Coq standard library (default is `<http://coq.inria.fr/library/>`_). This is equivalent to ``--external url Coq``. - :-R dir coqdir: Map physical directory dir to |Coq| logical + :-R dir coqdir: Recursively map physical directory dir to |Coq| logical directory ``coqdir`` (similarly to |Coq| option ``-R``). + :-Q dir coqdir: Map physical directory dir to |Coq| logical + directory ``coqdir`` (similarly to |Coq| option ``-Q``). .. note:: - option ``-R`` only has - effect on the files *following* it on the command line, so you will + options ``-R`` and ``-Q`` only have + effect on the files *following* them on the command line, so you will probably need to put this option first. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 0322b43694..d3562b52c5 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -1,7 +1,7 @@ .. _ltac: -The tactic language -=================== +Ltac +==== This chapter gives a compact documentation of |Ltac|, the tactic language available in |Coq|. We start by giving the syntax, and next, we present the diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst new file mode 100644 index 0000000000..6e33862b39 --- /dev/null +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -0,0 +1,992 @@ +.. _ltac2: + +.. coqtop:: none + + From Ltac2 Require Import Ltac2. + +Ltac2 +===== + +The Ltac tactic language is probably one of the ingredients of the success of +Coq, yet it is at the same time its Achilles' heel. Indeed, Ltac: + +- has often unclear semantics +- is very non-uniform due to organic growth +- lacks expressivity (data structures, combinators, types, ...) +- is slow +- is error-prone and fragile +- has an intricate implementation + +Following the need of users that start developing huge projects relying +critically on Ltac, we believe that we should offer a proper modern language +that features at least the following: + +- at least informal, predictable semantics +- a typing system +- standard programming facilities (i.e. datatypes) + +This new language, called Ltac2, is described in this chapter. It is still +experimental but we encourage nonetheless users to start testing it, +especially wherever an advanced tactic language is needed. The previous +implementation of Ltac, described in the previous chapter, will be referred to +as Ltac1. + +.. _ltac2_design: + +General design +-------------- + +There are various alternatives to Ltac1, such that Mtac or Rtac for instance. +While those alternatives can be quite distinct from Ltac1, we designed +Ltac2 to be closest as reasonably possible to Ltac1, while fixing the +aforementioned defects. + +In particular, Ltac2 is: + +- a member of the ML family of languages, i.e. + + * a call-by-value functional language + * with effects + * together with Hindley-Milner type system + +- a language featuring meta-programming facilities for the manipulation of + Coq-side terms +- a language featuring notation facilities to help writing palatable scripts + +We describe more in details each point in the remainder of this document. + +ML component +------------ + +Overview +~~~~~~~~ + +Ltac2 is a member of the ML family of languages, in the sense that it is an +effectful call-by-value functional language, with static typing à la +Hindley-Milner (see :cite:`MilnerPrincipalTypeSchemes`). It is commonly accepted +that ML constitutes a sweet spot in PL design, as it is relatively expressive +while not being either too lax (unlike dynamic typing) nor too strict +(unlike, say, dependent types). + +The main goal of Ltac2 is to serve as a meta-language for Coq. As such, it +naturally fits in the ML lineage, just as the historical ML was designed as +the tactic language for the LCF prover. It can also be seen as a general-purpose +language, by simply forgetting about the Coq-specific features. + +Sticking to a standard ML type system can be considered somewhat weak for a +meta-language designed to manipulate Coq terms. In particular, there is no +way to statically guarantee that a Coq term resulting from an Ltac2 +computation will be well-typed. This is actually a design choice, motivated +by retro-compatibility with Ltac1. Instead, well-typedness is deferred to +dynamic checks, allowing many primitive functions to fail whenever they are +provided with an ill-typed term. + +The language is naturally effectful as it manipulates the global state of the +proof engine. This allows to think of proof-modifying primitives as effects +in a straightforward way. Semantically, proof manipulation lives in a monad, +which allows to ensure that Ltac2 satisfies the same equations as a generic ML +with unspecified effects would do, e.g. function reduction is substitution +by a value. + +Type Syntax +~~~~~~~~~~~ + +At the level of terms, we simply elaborate on Ltac1 syntax, which is quite +close to e.g. the one of OCaml. Types follow the simply-typed syntax of OCaml. + +The non-terminal :production:`lident` designates identifiers starting with a +lowercase. + +.. productionlist:: coq + ltac2_type : ( `ltac2_type`, ... , `ltac2_type` ) `ltac2_typeconst` + : ( `ltac2_type` * ... * `ltac2_type` ) + : `ltac2_type` -> `ltac2_type` + : `ltac2_typevar` + ltac2_typeconst : ( `modpath` . )* `lident` + ltac2_typevar : '`lident` + ltac2_typeparams : ( `ltac2_typevar`, ... , `ltac2_typevar` ) + +The set of base types can be extended thanks to the usual ML type +declarations such as algebraic datatypes and records. + +Built-in types include: + +- ``int``, machine integers (size not specified, in practice inherited from OCaml) +- ``string``, mutable strings +- ``'a array``, mutable arrays +- ``exn``, exceptions +- ``constr``, kernel-side terms +- ``pattern``, term patterns +- ``ident``, well-formed identifiers + +Type declarations +~~~~~~~~~~~~~~~~~ + +One can define new types by the following commands. + +.. cmd:: Ltac2 Type @ltac2_typeparams @lident + :name: Ltac2 Type + + This command defines an abstract type. It has no use for the end user and + is dedicated to types representing data coming from the OCaml world. + +.. cmdv:: Ltac2 Type {? rec} @ltac2_typeparams @lident := @ltac2_typedef + + This command defines a type with a manifest. There are four possible + kinds of such definitions: alias, variant, record and open variant types. + + .. productionlist:: coq + ltac2_typedef : `ltac2_type` + : [ `ltac2_constructordef` | ... | `ltac2_constructordef` ] + : { `ltac2_fielddef` ; ... ; `ltac2_fielddef` } + : [ .. ] + ltac2_constructordef : `uident` [ ( `ltac2_type` , ... , `ltac2_type` ) ] + ltac2_fielddef : [ mutable ] `ident` : `ltac2_type` + + Aliases are just a name for a given type expression and are transparently + unfoldable to it. They cannot be recursive. The non-terminal + :production:`uident` designates identifiers starting with an uppercase. + + Variants are sum types defined by constructors and eliminated by + pattern-matching. They can be recursive, but the `rec` flag must be + explicitly set. Pattern-maching must be exhaustive. + + Records are product types with named fields and eliminated by projection. + Likewise they can be recursive if the `rec` flag is set. + + .. cmdv:: Ltac2 Type @ltac2_typeparams @ltac2_qualid := [ @ltac2_constructordef ] + + Open variants are a special kind of variant types whose constructors are not + statically defined, but can instead be extended dynamically. A typical example + is the standard `exn` type. Pattern-matching must always include a catch-all + clause. They can be extended by this command. + +Term Syntax +~~~~~~~~~~~ + +The syntax of the functional fragment is very close to the one of Ltac1, except +that it adds a true pattern-matching feature, as well as a few standard +constructions from ML. + +.. productionlist:: coq + ltac2_var : `lident` + ltac2_qualid : ( `modpath` . )* `lident` + ltac2_constructor: `uident` + ltac2_term : `ltac2_qualid` + : `ltac2_constructor` + : `ltac2_term` `ltac2_term` ... `ltac2_term` + : fun `ltac2_var` => `ltac2_term` + : let `ltac2_var` := `ltac2_term` in `ltac2_term` + : let rec `ltac2_var` := `ltac2_term` in `ltac2_term` + : match `ltac2_term` with `ltac2_branch` ... `ltac2_branch` end + : `int` + : `string` + : `ltac2_term` ; `ltac2_term` + : [| `ltac2_term` ; ... ; `ltac2_term` |] + : ( `ltac2_term` , ... , `ltac2_term` ) + : { `ltac2_field` `ltac2_field` ... `ltac2_field` } + : `ltac2_term` . ( `ltac2_qualid` ) + : `ltac2_term` . ( `ltac2_qualid` ) := `ltac2_term` + : [; `ltac2_term` ; ... ; `ltac2_term` ] + : `ltac2_term` :: `ltac2_term` + : ... + ltac2_branch : `ltac2_pattern` => `ltac2_term` + ltac2_pattern : `ltac2_var` + : _ + : ( `ltac2_pattern` , ... , `ltac2_pattern` ) + : `ltac2_constructor` `ltac2_pattern` ... `ltac2_pattern` + : [ ] + : `ltac2_pattern` :: `ltac2_pattern` + ltac2_field : `ltac2_qualid` := `ltac2_term` + +In practice, there is some additional syntactic sugar that allows e.g. to +bind a variable and match on it at the same time, in the usual ML style. + +There is a dedicated syntax for list and array literals. + +.. note:: + + For now, deep pattern matching is not implemented. + +Ltac Definitions +~~~~~~~~~~~~~~~~ + +.. cmd:: Ltac2 {? mutable} {? rec} @lident := @ltac2_term + :name: Ltac2 + + This command defines a new global Ltac2 value. + + For semantic reasons, the body of the Ltac2 definition must be a syntactical + value, i.e. a function, a constant or a pure constructor recursively applied to + values. + + If ``rec`` is set, the tactic is expanded into a recursive binding. + + If ``mutable`` is set, the definition can be redefined at a later stage (see below). + +.. cmd:: Ltac2 Set @qualid := @ltac2_term + :name: Ltac2 Set + + This command redefines a previous ``mutable`` definition. + Mutable definitions act like dynamic binding, i.e. at runtime, the last defined + value for this entry is chosen. This is useful for global flags and the like. + +Reduction +~~~~~~~~~ + +We use the usual ML call-by-value reduction, with an otherwise unspecified +evaluation order. This is a design choice making it compatible with OCaml, +if ever we implement native compilation. The expected equations are as follows:: + + (fun x => t) V ≡ t{x := V} (βv) + + let x := V in t ≡ t{x := V} (let) + + match C V₀ ... Vₙ with ... | C x₀ ... xₙ => t | ... end ≡ t {xᵢ := Vᵢ} (ι) + + (t any term, V values, C constructor) + +Note that call-by-value reduction is already a departure from Ltac1 which uses +heuristics to decide when evaluating an expression. For instance, the following +expressions do not evaluate the same way in Ltac1. + +:n:`foo (idtac; let x := 0 in bar)` + +:n:`foo (let x := 0 in bar)` + +Instead of relying on the :n:`idtac` idiom, we would now require an explicit thunk +not to compute the argument, and :n:`foo` would have e.g. type +:n:`(unit -> unit) -> unit`. + +:n:`foo (fun () => let x := 0 in bar)` + +Typing +~~~~~~ + +Typing is strict and follows Hindley-Milner system. Unlike Ltac1, there +are no type casts at runtime, and one has to resort to conversion +functions. See notations though to make things more palatable. + +In this setting, all usual argument-free tactics have type :n:`unit -> unit`, but +one can return as well a value of type :n:`t` thanks to terms of type :n:`unit -> t`, +or take additional arguments. + +Effects +~~~~~~~ + +Effects in Ltac2 are straightforward, except that instead of using the +standard IO monad as the ambient effectful world, Ltac2 is going to use the +tactic monad. + +Note that the order of evaluation of application is *not* specified and is +implementation-dependent, as in OCaml. + +We recall that the `Proofview.tactic` monad is essentially a IO monad together +with backtracking state representing the proof state. + +Intuitively a thunk of type :n:`unit -> 'a` can do the following: + +- It can perform non-backtracking IO like printing and setting mutable variables +- It can fail in a non-recoverable way +- It can use first-class backtrack. The proper way to figure that is that we + morally have the following isomorphism: + :n:`(unit -> 'a) ~ (unit -> exn + ('a * (exn -> 'a)))` + i.e. thunks can produce a lazy list of results where each + tail is waiting for a continuation exception. +- It can access a backtracking proof state, made out amongst other things of + the current evar assignation and the list of goals under focus. + +We describe more thoroughly the various effects existing in Ltac2 hereafter. + +Standard IO ++++++++++++ + +The Ltac2 language features non-backtracking IO, notably mutable data and +printing operations. + +Mutable fields of records can be modified using the set syntax. Likewise, +built-in types like `string` and `array` feature imperative assignment. See +modules `String` and `Array` respectively. + +A few printing primitives are provided in the `Message` module, allowing to +display information to the user. + +Fatal errors +++++++++++++ + +The Ltac2 language provides non-backtracking exceptions, also known as *panics*, +through the following primitive in module `Control`.:: + + val throw : exn -> 'a + +Unlike backtracking exceptions from the next section, this kind of error +is never caught by backtracking primitives, that is, throwing an exception +destroys the stack. This is materialized by the following equation, where `E` +is an evaluation context.:: + + E[throw e] ≡ throw e + + (e value) + +There is currently no way to catch such an exception and it is a design choice. +There might be at some future point a way to catch it in a brutal way, +destroying all backtrack and return values. + +Backtrack ++++++++++ + +In Ltac2, we have the following backtracking primitives, defined in the +`Control` module.:: + + Ltac2 Type 'a result := [ Val ('a) | Err (exn) ]. + + val zero : exn -> 'a + val plus : (unit -> 'a) -> (exn -> 'a) -> 'a + val case : (unit -> 'a) -> ('a * (exn -> 'a)) result + +If one sees thunks as lazy lists, then `zero` is the empty list and `plus` is +list concatenation, while `case` is pattern-matching. + +The backtracking is first-class, i.e. one can write +:n:`plus (fun () => "x") (fun _ => "y") : string` producing a backtracking string. + +These operations are expected to satisfy a few equations, most notably that they +form a monoid compatible with sequentialization.:: + + plus t zero ≡ t () + plus (fun () => zero e) f ≡ f e + plus (plus t f) g ≡ plus t (fun e => plus (f e) g) + + case (fun () => zero e) ≡ Err e + case (fun () => plus (fun () => t) f) ≡ Val (t,f) + + let x := zero e in u ≡ zero e + let x := plus t f in u ≡ plus (fun () => let x := t in u) (fun e => let x := f e in u) + + (t, u, f, g, e values) + +Goals ++++++ + +A goal is given by the data of its conclusion and hypotheses, i.e. it can be +represented as `[Γ ⊢ A]`. + +The tactic monad naturally operates over the whole proofview, which may +represent several goals, including none. Thus, there is no such thing as +*the current goal*. Goals are naturally ordered, though. + +It is natural to do the same in Ltac2, but we must provide a way to get access +to a given goal. This is the role of the `enter` primitive, that applies a +tactic to each currently focused goal in turn.:: + + val enter : (unit -> unit) -> unit + +It is guaranteed that when evaluating `enter f`, `f` is called with exactly one +goal under focus. Note that `f` may be called several times, or never, depending +on the number of goals under focus before the call to `enter`. + +Accessing the goal data is then implicit in the Ltac2 primitives, and may panic +if the invariants are not respected. The two essential functions for observing +goals are given below.:: + + val hyp : ident -> constr + val goal : unit -> constr + +The two above functions panic if there is not exactly one goal under focus. +In addition, `hyp` may also fail if there is no hypothesis with the +corresponding name. + +Meta-programming +---------------- + +Overview +~~~~~~~~ + +One of the major implementation issues of Ltac1 is the fact that it is +never clear whether an object refers to the object world or the meta-world. +This is an incredible source of slowness, as the interpretation must be +aware of bound variables and must use heuristics to decide whether a variable +is a proper one or referring to something in the Ltac context. + +Likewise, in Ltac1, constr parsing is implicit, so that ``foo 0`` is +not ``foo`` applied to the Ltac integer expression ``0`` (Ltac does have a +notion of integers, though it is not first-class), but rather the Coq term +:g:`Datatypes.O`. + +The implicit parsing is confusing to users and often gives unexpected results. +Ltac2 makes these explicit using quoting and unquoting notation, although there +are notations to do it in a short and elegant way so as not to be too cumbersome +to the user. + +Generic Syntax for Quotations +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In general, quotations can be introduced in terms using the following syntax, where +:production:`quotentry` is some parsing entry. + +.. prodn:: + ltac2_term += @ident : ( @quotentry ) + +Built-in quotations ++++++++++++++++++++ + +The current implementation recognizes the following built-in quotations: + +- ``ident``, which parses identifiers (type ``Init.ident``). +- ``constr``, which parses Coq terms and produces an-evar free term at runtime + (type ``Init.constr``). +- ``open_constr``, which parses Coq terms and produces a term potentially with + holes at runtime (type ``Init.constr`` as well). +- ``pattern``, which parses Coq patterns and produces a pattern used for term + matching (type ``Init.pattern``). +- ``reference``, which parses either a :n:`@qualid` or :n:`& @ident`. Qualified names + are globalized at internalization into the corresponding global reference, + while ``&id`` is turned into ``Std.VarRef id``. This produces at runtime a + ``Std.reference``. + +The following syntactic sugar is provided for two common cases. + +- ``@id`` is the same as ``ident:(id)`` +- ``'t`` is the same as ``open_constr:(t)`` + +Strict vs. non-strict mode +++++++++++++++++++++++++++ + +Depending on the context, quotations producing terms (i.e. ``constr`` or +``open_constr``) are not internalized in the same way. There are two possible +modes, respectively called the *strict* and the *non-strict* mode. + +- In strict mode, all simple identifiers appearing in a term quotation are + required to be resolvable statically. That is, they must be the short name of + a declaration which is defined globally, excluding section variables and + hypotheses. If this doesn't hold, internalization will fail. To work around + this error, one has to specifically use the ``&`` notation. +- In non-strict mode, any simple identifier appearing in a term quotation which + is not bound in the global context is turned into a dynamic reference to a + hypothesis. That is to say, internalization will succeed, but the evaluation + of the term at runtime will fail if there is no such variable in the dynamic + context. + +Strict mode is enforced by default, e.g. for all Ltac2 definitions. Non-strict +mode is only set when evaluating Ltac2 snippets in interactive proof mode. The +rationale is that it is cumbersome to explicitly add ``&`` interactively, while it +is expected that global tactics enforce more invariants on their code. + +Term Antiquotations +~~~~~~~~~~~~~~~~~~~ + +Syntax +++++++ + +One can also insert Ltac2 code into Coq terms, similarly to what is possible in +Ltac1. + +.. prodn:: + term += ltac2:( @ltac2_term ) + +Antiquoted terms are expected to have type ``unit``, as they are only evaluated +for their side-effects. + +Semantics ++++++++++ + +Interpretation of a quoted Coq term is done in two phases, internalization and +evaluation. + +- Internalization is part of the static semantics, i.e. it is done at Ltac2 + typing time. +- Evaluation is part of the dynamic semantics, i.e. it is done when + a term gets effectively computed by Ltac2. + +Note that typing of Coq terms is a *dynamic* process occurring at Ltac2 +evaluation time, and not at Ltac2 typing time. + +Static semantics +**************** + +During internalization, Coq variables are resolved and antiquotations are +type-checked as Ltac2 terms, effectively producing a ``glob_constr`` in Coq +implementation terminology. Note that although it went through the +type-checking of **Ltac2**, the resulting term has not been fully computed and +is potentially ill-typed as a runtime **Coq** term. + +.. example:: + + The following term is valid (with type `unit -> constr`), but will fail at runtime: + + .. coqtop:: in + + Ltac2 myconstr () := constr:(nat -> 0). + +Term antiquotations are type-checked in the enclosing Ltac2 typing context +of the corresponding term expression. + +.. example:: + + The following will type-check, with type `constr`. + + .. coqdoc:: + + let x := '0 in constr:(1 + ltac2:(exact x)) + +Beware that the typing environment of antiquotations is **not** +expanded by the Coq binders from the term. + + .. example:: + + The following Ltac2 expression will **not** type-check:: + + `constr:(fun x : nat => ltac2:(exact x))` + `(* Error: Unbound variable 'x' *)` + +There is a simple reason for that, which is that the following expression would +not make sense in general. + +`constr:(fun x : nat => ltac2:(clear @x; exact x))` + +Indeed, a hypothesis can suddenly disappear from the runtime context if some +other tactic pulls the rug from under you. + +Rather, the tactic writer has to resort to the **dynamic** goal environment, +and must write instead explicitly that she is accessing a hypothesis, typically +as follows. + +`constr:(fun x : nat => ltac2:(exact (hyp @x)))` + +This pattern is so common that we provide dedicated Ltac2 and Coq term notations +for it. + +- `&x` as an Ltac2 expression expands to `hyp @x`. +- `&x` as a Coq constr expression expands to + `ltac2:(Control.refine (fun () => hyp @x))`. + +Dynamic semantics +***************** + +During evaluation, a quoted term is fully evaluated to a kernel term, and is +in particular type-checked in the current environment. + +Evaluation of a quoted term goes as follows. + +- The quoted term is first evaluated by the pretyper. +- Antiquotations are then evaluated in a context where there is exactly one goal + under focus, with the hypotheses coming from the current environment extended + with the bound variables of the term, and the resulting term is fed into the + quoted term. + +Relative orders of evaluation of antiquotations and quoted term are not +specified. + +For instance, in the following example, `tac` will be evaluated in a context +with exactly one goal under focus, whose last hypothesis is `H : nat`. The +whole expression will thus evaluate to the term :g:`fun H : nat => H`. + +`let tac () := hyp @H in constr:(fun H : nat => ltac2:(tac ()))` + +Many standard tactics perform type-checking of their argument before going +further. It is your duty to ensure that terms are well-typed when calling +such tactics. Failure to do so will result in non-recoverable exceptions. + +**Trivial Term Antiquotations** + +It is possible to refer to a variable of type `constr` in the Ltac2 environment +through a specific syntax consistent with the antiquotations presented in +the notation section. + +.. prodn:: term += $@lident + +In a Coq term, writing :g:`$x` is semantically equivalent to +:g:`ltac2:(Control.refine (fun () => x))`, up to re-typechecking. It allows to +insert in a concise way an Ltac2 variable of type :n:`constr` into a Coq term. + +Match over terms +~~~~~~~~~~~~~~~~ + +Ltac2 features a construction similar to Ltac1 :n:`match` over terms, although +in a less hard-wired way. + +.. productionlist:: coq + ltac2_term : match! `ltac2_term` with `constrmatching` .. `constrmatching` end + : lazy_match! `ltac2_term` with `constrmatching` .. `constrmatching` end + : multi_match! `ltac2_term` with `constrmatching` .. `constrmatching` end + constrmatching : | `constrpattern` => `ltac2_term` + constrpattern : `term` + : context [ `term` ] + : context `lident` [ `term` ] + +This construction is not primitive and is desugared at parsing time into +calls to term matching functions from the `Pattern` module. Internally, it is +implemented thanks to a specific scope accepting the :n:`@constrmatching` syntax. + +Variables from the :n:`@constrpattern` are statically bound in the body of the branch, to +values of type `constr` for the variables from the :n:`@constr` pattern and to a +value of type `Pattern.context` for the variable :n:`@lident`. + +Note that unlike Ltac, only lowercase identifiers are valid as Ltac2 +bindings, so that there will be a syntax error if one of the bound variables +starts with an uppercase character. + +The semantics of this construction is otherwise the same as the corresponding +one from Ltac1, except that it requires the goal to be focused. + +Match over goals +~~~~~~~~~~~~~~~~ + +Similarly, there is a way to match over goals in an elegant way, which is +just a notation desugared at parsing time. + +.. productionlist:: coq + ltac2_term : match! [ reverse ] goal with `goalmatching` ... `goalmatching` end + : lazy_match! [ reverse ] goal with `goalmatching` ... `goalmatching` end + : multi_match! [ reverse ] goal with `goalmatching` ... `goalmatching` end + goalmatching : | [ `hypmatching` ... `hypmatching` |- `constrpattern` ] => `ltac2_term` + hypmatching : `lident` : `constrpattern` + : _ : `constrpattern` + +Variables from :n:`@hypmatching` and :n:`@constrpattern` are bound in the body of the +branch. Their types are: + +- ``constr`` for pattern variables appearing in a :n:`@term` +- ``Pattern.context`` for variables binding a context +- ``ident`` for variables binding a hypothesis name. + +The same identifier caveat as in the case of matching over constr applies, and +this features has the same semantics as in Ltac1. In particular, a ``reverse`` +flag can be specified to match hypotheses from the more recently introduced to +the least recently introduced one. + +Notations +--------- + +Notations are the crux of the usability of Ltac1. We should be able to recover +a feeling similar to the old implementation by using and abusing notations. + +Scopes +~~~~~~ + +A scope is a name given to a grammar entry used to produce some Ltac2 expression +at parsing time. Scopes are described using a form of S-expression. + +.. prodn:: + ltac2_scope ::= @string %| @integer %| @lident ({+, @ltac2_scope}) + +A few scopes contain antiquotation features. For sake of uniformity, all +antiquotations are introduced by the syntax :n:`$@lident`. + +The following scopes are built-in. + +- :n:`constr`: + + + parses :n:`c = @term` and produces :n:`constr:(c)` + +- :n:`ident`: + + + parses :n:`id = @ident` and produces :n:`ident:(id)` + + parses :n:`$(x = @ident)` and produces the variable :n:`x` + +- :n:`list0(@ltac2_scope)`: + + + if :n:`@ltac2_scope` parses :production:`entry`, parses :n:`(@entry__0, ..., @entry__n)` and produces + :n:`[@entry__0; ...; @entry__n]`. + +- :n:`list0(@ltac2_scope, sep = @string__sep)`: + + + if :n:`@ltac2_scope` parses :n:`@entry`, parses :n:`(@entry__0 @string__sep ... @string__sep @entry__n)` + and produces :n:`[@entry__0; ...; @entry__n]`. + +- :n:`list1`: same as :n:`list0` (with or without separator) but parses :n:`{+ @entry}` instead + of :n:`{* @entry}`. + +- :n:`opt(@ltac2_scope)` + + + if :n:`@ltac2_scope` parses :n:`@entry`, parses :n:`{? @entry}` and produces either :n:`None` or + :n:`Some x` where :n:`x` is the parsed expression. + +- :n:`self`: + + + parses a Ltac2 expression at the current level and return it as is. + +- :n:`next`: + + + parses a Ltac2 expression at the next level and return it as is. + +- :n:`tactic(n = @integer)`: + + + parses a Ltac2 expression at the provided level :n:`n` and return it as is. + +- :n:`thunk(@ltac2_scope)`: + + + parses the same as :n:`scope`, and if :n:`e` is the parsed expression, returns + :n:`fun () => e`. + +- :n:`STRING`: + + + parses the corresponding string as an identifier and returns :n:`()`. + +- :n:`keyword(s = @string)`: + + + parses the string :n:`s` as a keyword and returns `()`. + +- :n:`terminal(s = @string)`: + + + parses the string :n:`s` as a keyword, if it is already a + keyword, otherwise as an :n:`@ident`. Returns `()`. + +- :n:`seq(@ltac2_scope__1, ..., @ltac2_scope__2)`: + + + parses :n:`scope__1`, ..., :n:`scope__n` in this order, and produces a tuple made + out of the parsed values in the same order. As an optimization, all + subscopes of the form :n:`STRING` are left out of the returned tuple, instead + of returning a useless unit value. It is forbidden for the various + subscopes to refer to the global entry using self or next. + +A few other specific scopes exist to handle Ltac1-like syntax, but their use is +discouraged and they are thus not documented. + +For now there is no way to declare new scopes from Ltac2 side, but this is +planned. + +Notations +~~~~~~~~~ + +The Ltac2 parser can be extended by syntactic notations. + +.. cmd:: Ltac2 Notation {+ @lident (@ltac2_scope) %| @string } {? : @integer} := @ltac2_term + :name: Ltac2 Notation + + A Ltac2 notation adds a parsing rule to the Ltac2 grammar, which is expanded + to the provided body where every token from the notation is let-bound to the + corresponding generated expression. + + .. example:: + + Assume we perform: + + .. coqdoc:: + + Ltac2 Notation "foo" c(thunk(constr)) ids(list0(ident)) := Bar.f c ids. + + Then the following expression + + `let y := @X in foo (nat -> nat) x $y` + + will expand at parsing time to + + `let y := @X in` + `let c := fun () => constr:(nat -> nat) with ids := [@x; y] in Bar.f c ids` + + Beware that the order of evaluation of multiple let-bindings is not specified, + so that you may have to resort to thunking to ensure that side-effects are + performed at the right time. + +Abbreviations +~~~~~~~~~~~~~ + +.. cmdv:: Ltac2 Notation @lident := @ltac2_term + + This command introduces a special kind of notations, called abbreviations, + that is designed so that it does not add any parsing rules. It is similar in + spirit to Coq abbreviations, insofar as its main purpose is to give an + absolute name to a piece of pure syntax, which can be transparently referred + by this name as if it were a proper definition. + + The abbreviation can then be manipulated just as a normal Ltac2 definition, + except that it is expanded at internalization time into the given expression. + Furthermore, in order to make this kind of construction useful in practice in + an effectful language such as Ltac2, any syntactic argument to an abbreviation + is thunked on-the-fly during its expansion. + +For instance, suppose that we define the following. + +:n:`Ltac2 Notation foo := fun x => x ().` + +Then we have the following expansion at internalization time. + +:n:`foo 0 ↦ (fun x => x ()) (fun _ => 0)` + +Note that abbreviations are not typechecked at all, and may result in typing +errors after expansion. + +Evaluation +---------- + +Ltac2 features a toplevel loop that can be used to evaluate expressions. + +.. cmd:: Ltac2 Eval @ltac2_term + :name: Ltac2 Eval + + This command evaluates the term in the current proof if there is one, or in the + global environment otherwise, and displays the resulting value to the user + together with its type. This command is pure in the sense that it does not + modify the state of the proof, and in particular all side-effects are discarded. + +Debug +----- + +.. opt:: Ltac2 Backtrace + + When this option is set, toplevel failures will be printed with a backtrace. + +Compatibility layer with Ltac1 +------------------------------ + +Ltac1 from Ltac2 +~~~~~~~~~~~~~~~~ + +Simple API +++++++++++ + +One can call Ltac1 code from Ltac2 by using the :n:`ltac1` quotation. It parses +a Ltac1 expression, and semantics of this quotation is the evaluation of the +corresponding code for its side effects. In particular, it cannot return values, +and the quotation has type :n:`unit`. + +Beware, Ltac1 **cannot** access variables from the Ltac2 scope. One is limited +to the use of standalone function calls. + +Low-level API ++++++++++++++ + +There exists a lower-level FFI into Ltac1 that is not recommended for daily use, +which is available in the `Ltac2.Ltac1` module. This API allows to directly +manipulate dynamically-typed Ltac1 values, either through the function calls, +or using the `ltac1val` quotation. The latter parses the same as `ltac1`, but +has type `Ltac2.Ltac1.t` instead of `unit`, and dynamically behaves as an Ltac1 +thunk, i.e. `ltac1val:(foo)` corresponds to the tactic closure that Ltac1 +would generate from `idtac; foo`. + +Due to intricate dynamic semantics, understanding when Ltac1 value quotations +focus is very hard. This is why some functions return a continuation-passing +style value, as it can dispatch dynamically between focused and unfocused +behaviour. + +Ltac2 from Ltac1 +~~~~~~~~~~~~~~~~ + +Same as above by switching Ltac1 by Ltac2 and using the `ltac2` quotation +instead. + +Note that the tactic expression is evaluated eagerly, if one wants to use it as +an argument to a Ltac1 function, she has to resort to the good old +:n:`idtac; ltac2:(foo)` trick. For instance, the code below will fail immediately +and won't print anything. + +.. coqtop:: in + + From Ltac2 Require Import Ltac2. + Set Default Proof Mode "Classic". + +.. coqtop:: all + + Ltac mytac tac := idtac "wow"; tac. + + Goal True. + Proof. + Fail mytac ltac2:(fail). + +Transition from Ltac1 +--------------------- + +Owing to the use of a lot of notations, the transition should not be too +difficult. In particular, it should be possible to do it incrementally. That +said, we do *not* guarantee you it is going to be a blissful walk either. +Hopefully, owing to the fact Ltac2 is typed, the interactive dialogue with Coq +will help you. + +We list the major changes and the transition strategies hereafter. + +Syntax changes +~~~~~~~~~~~~~~ + +Due to conflicts, a few syntactic rules have changed. + +- The dispatch tactical :n:`tac; [foo|bar]` is now written :n:`tac > [foo|bar]`. +- Levels of a few operators have been revised. Some tacticals now parse as if + they were a normal function, i.e. one has to put parentheses around the + argument when it is complex, e.g an abstraction. List of affected tacticals: + :n:`try`, :n:`repeat`, :n:`do`, :n:`once`, :n:`progress`, :n:`time`, :n:`abstract`. +- :n:`idtac` is no more. Either use :n:`()` if you expect nothing to happen, + :n:`(fun () => ())` if you want a thunk (see next section), or use printing + primitives from the :n:`Message` module if you want to display something. + +Tactic delay +~~~~~~~~~~~~ + +Tactics are not magically delayed anymore, neither as functions nor as +arguments. It is your responsibility to thunk them beforehand and apply them +at the call site. + +A typical example of a delayed function: + +:n:`Ltac foo := blah.` + +becomes + +:n:`Ltac2 foo () := blah.` + +All subsequent calls to `foo` must be applied to perform the same effect as +before. + +Likewise, for arguments: + +:n:`Ltac bar tac := tac; tac; tac.` + +becomes + +:n:`Ltac2 bar tac := tac (); tac (); tac ().` + +We recommend the use of syntactic notations to ease the transition. For +instance, the first example can alternatively be written as: + +:n:`Ltac2 foo0 () := blah.` +:n:`Ltac2 Notation foo := foo0 ().` + +This allows to keep the subsequent calls to the tactic as-is, as the +expression `foo` will be implicitly expanded everywhere into `foo0 ()`. Such +a trick also works for arguments, as arguments of syntactic notations are +implicitly thunked. The second example could thus be written as follows. + +:n:`Ltac2 bar0 tac := tac (); tac (); tac ().` +:n:`Ltac2 Notation bar := bar0.` + +Variable binding +~~~~~~~~~~~~~~~~ + +Ltac1 relies on complex dynamic trickery to be able to tell apart bound +variables from terms, hypotheses, etc. There is no such thing in Ltac2, +as variables are recognized statically and other constructions do not live in +the same syntactic world. Due to the abuse of quotations, it can sometimes be +complicated to know what a mere identifier represents in a tactic expression. We +recommend tracking the context and letting the compiler print typing errors to +understand what is going on. + +We list below the typical changes one has to perform depending on the static +errors produced by the typechecker. + +In Ltac expressions ++++++++++++++++++++ + +.. exn:: Unbound ( value | constructor ) X + + * if `X` is meant to be a term from the current stactic environment, replace + the problematic use by `'X`. + * if `X` is meant to be a hypothesis from the goal context, replace the + problematic use by `&X`. + +In quotations ++++++++++++++ + +.. exn:: The reference X was not found in the current environment + + * if `X` is meant to be a tactic expression bound by a Ltac2 let or function, + replace the problematic use by `$X`. + * if `X` is meant to be a hypothesis from the goal context, replace the + problematic use by `&X`. + +Exception catching +~~~~~~~~~~~~~~~~~~ + +Ltac2 features a proper exception-catching mechanism. For this reason, the +Ltac1 mechanism relying on `fail` taking integers, and tacticals decreasing it, +has been removed. Now exceptions are preserved by all tacticals, and it is +your duty to catch them and reraise them depending on your use. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 8d9e99b9d5..0f78a9b84a 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3863,9 +3863,9 @@ The general command to add a hint to some databases :n:`{+ @ident}` is terms and input heads *must not* contain existential variables or be existential variables respectively, while outputs can be any term. Multiple modes can be declared for a single identifier, in that case only one mode - needs to match the arguments for the hints to be applied.The head of a term + needs to match the arguments for the hints to be applied. The head of a term is understood here as the applicative head, or the match or projection - scrutinee’s head, recursively, casts being ignored. ``Hint Mode`` is + scrutinee’s head, recursively, casts being ignored. :cmd:`Hint Mode` is especially useful for typeclasses, when one does not want to support default instances and avoid ambiguity in general. Setting a parameter of a class as an input forces proof-search to be driven by that index of the class, with ``!`` @@ -3874,8 +3874,14 @@ The general command to add a hint to some databases :n:`{+ @ident}` is .. note:: - One can use an ``Extern`` hint with no pattern to do pattern matching on - hypotheses using ``match goal with`` inside the tactic. + + One can use a :cmd:`Hint Extern` with no pattern to do + pattern matching on hypotheses using ``match goal with`` + inside the tactic. + + + If you want to add hints such as :cmd:`Hint Transparent`, + :cmd:`Hint Cut`, or :cmd:`Hint Mode`, for typeclass + resolution, do not forget to put them in the + ``typeclass_instances`` hint database. Hint databases defined in the Coq standard library @@ -4811,3 +4817,103 @@ references to automatically generated names. :name: Mangle Names Prefix Specifies the prefix to use when generating names. + +Performance-oriented tactic variants +------------------------------------ + +.. tacn:: change_no_check @term + :name: change_no_check + + For advanced usage. Similar to :n:`change @term`, but as an optimization, + it skips checking that :n:`@term` is convertible to the goal. + + Recall that the Coq kernel typechecks proofs again when they are concluded to + ensure safety. Hence, using :tacn:`change` checks convertibility twice + overall, while :tacn:`change_no_check` can produce ill-typed terms, + but checks convertibility only once. + Hence, :tacn:`change_no_check` can be useful to speed up certain proof + scripts, especially if one knows by construction that the argument is + indeed convertible to the goal. + + In the following example, :tacn:`change_no_check` replaces :g:`False` by + :g:`True`, but :g:`Qed` then rejects the proof, ensuring consistency. + + .. example:: + + .. coqtop:: all abort + + Goal False. + change_no_check True. + exact I. + Fail Qed. + + :tacn:`change_no_check` supports all of `change`'s variants. + + .. tacv:: change_no_check @term with @term’ + :undocumented: + + .. tacv:: change_no_check @term at {+ @num} with @term’ + :undocumented: + + .. tacv:: change_no_check @term {? {? at {+ @num}} with @term} in @ident + + .. example:: + + .. coqtop:: all abort + + Goal True -> False. + intro H. + change_no_check False in H. + exact H. + Fail Qed. + + .. tacv:: convert_concl_no_check @term + :name: convert_concl_no_check + + Deprecated old name for :tacn:`change_no_check`. Does not support any of its + variants. + +.. tacn:: exact_no_check @term + :name: exact_no_check + + For advanced usage. Similar to :n:`exact @term`, but as an optimization, + it skips checking that :n:`@term` has the goal's type, relying on the kernel + check instead. See :tacn:`change_no_check` for more explanations. + + .. example:: + + .. coqtop:: all abort + + Goal False. + exact_no_check I. + Fail Qed. + + .. tacv:: vm_cast_no_check @term + :name: vm_cast_no_check + + For advanced usage. Similar to :n:`exact_no_check @term`, but additionally + instructs the kernel to use :tacn:`vm_compute` to compare the + goal's type with the :n:`@term`'s type. + + .. example:: + + .. coqtop:: all abort + + Goal False. + vm_cast_no_check I. + Fail Qed. + + .. tacv:: native_cast_no_check @term + :name: native_cast_no_check + + for advanced usage. similar to :n:`exact_no_check @term`, but additionally + instructs the kernel to use :tacn:`native_compute` to compare the goal's + type with the :n:`@term`'s type. + + .. example:: + + .. coqtop:: all abort + + Goal False. + native_cast_no_check I. + Fail Qed. diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 3ca1dda4d6..ac079ea7d5 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1376,6 +1376,8 @@ Abbreviations denoted expression is performed at definition time. Type checking is done only at the time of use of the abbreviation. +.. _numeral-notations: + Numeral notations ----------------- @@ -18,8 +18,9 @@ (targets .vfiles.d) (deps (source_tree theories) - (source_tree plugins)) - (action (with-stdout-to .vfiles.d (bash "%{bin:coqdep} -dyndep both -noglob -boot `find theories plugins -type f -name *.v`")))) + (source_tree plugins) + (source_tree user-contrib)) + (action (with-stdout-to .vfiles.d (bash "%{bin:coqdep} -dyndep both -noglob -boot `find theories plugins user-contrib -type f -name *.v`")))) (alias (name vodeps) diff --git a/engine/uState.ml b/engine/uState.ml index 6f4f40e2c5..aa14f66df6 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -85,7 +85,7 @@ let union ctx ctx' = let declarenew g = LSet.fold (fun u g -> UGraph.add_universe u false g) newus g in - let names_rev = LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in + let names_rev = LMap.lunion (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); uctx_local = local; uctx_seff_univs = seff; diff --git a/engine/univMinim.ml b/engine/univMinim.ml index 46ff6340b4..fcbf305f9d 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -203,7 +203,7 @@ let minimize_univ_variables ctx us algs left right cstrs = (acc, [], LMap.empty, LMap.empty) l in let left = CList.uniquize (List.filter (not_lower lower) left) in - (acc, left, LMap.union newlow lower) + (acc, left, LMap.lunion newlow lower) in let instantiate_lbound lbound = let alg = LSet.mem u algs in diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml index d554bebdd3..82a5e9cdf6 100644 --- a/ide/gtk_parsing.ml +++ b/ide/gtk_parsing.ml @@ -10,11 +10,11 @@ let underscore = Glib.Utf8.to_unichar "_" ~pos:(ref 0) let prime = Glib.Utf8.to_unichar "'" ~pos:(ref 0) - +let dot = Glib.Utf8.to_unichar "." ~pos:(ref 0) (* TODO: avoid num and prime at the head of a word *) let is_word_char c = - Glib.Unichar.isalnum c || c = underscore || c = prime + Glib.Unichar.isalnum c || c = underscore || c = prime || c = dot let starts_word (it:GText.iter) = diff --git a/ide/idetop.ml b/ide/idetop.ml index 38839f3488..ce00ba6d8c 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -64,7 +64,7 @@ let is_known_option cmd = match Vernacprop.under_control cmd with (** Check whether a command is forbidden in the IDE *) -let ide_cmd_checks ~last_valid {CAst.loc;v=ast} = +let ide_cmd_checks ~last_valid ({ CAst.loc; _ } as cmd) = let user_error s = try CErrors.user_err ?loc ~hdr:"IDE" (str s) with e -> @@ -72,14 +72,14 @@ let ide_cmd_checks ~last_valid {CAst.loc;v=ast} = let info = Stateid.add info ~valid:last_valid Stateid.dummy in Exninfo.raise ~info e in - if is_debug ast then + if is_debug cmd then user_error "Debug mode not available in the IDE" -let ide_cmd_warns ~id {CAst.loc;v=ast} = +let ide_cmd_warns ~id ({ CAst.loc; _ } as cmd) = let warn msg = Feedback.(feedback ~id (Message (Warning, loc, strbrk msg))) in - if is_known_option ast then + if is_known_option cmd then warn "Set this option from the IDE menu instead"; - if is_navigation_vernac ast || is_undo ast then + if is_navigation_vernac cmd || is_undo cmd then warn "Use IDE navigation instead" (** Interpretation (cf. [Ide_intf.interp]) *) @@ -137,7 +137,7 @@ let annotate phrase = | None -> Richpp.richpp_of_pp 78 (Pp.mt ()) | Some ast -> (* XXX: Width should be a parameter of annotate... *) - Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast.CAst.v) + Richpp.richpp_of_pp 78 (Ppvernac.pr_vernac ast) (** Goal display *) diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 2293ae9dfd..1b348ae777 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -29,13 +29,6 @@ #include "coq_uint63_emul.h" #endif -/* spiwack: I append here a few macros for value/number manipulation */ -#define uint32_of_value(val) (((uint32_t)(val)) >> 1) -#define value_of_uint32(i) ((value)((((uint32_t)(i)) << 1) | 1)) -#define UI64_of_uint32(lo) ((uint64_t)((uint32_t)(lo))) -#define UI64_of_value(val) (UI64_of_uint32(uint32_of_value(val))) -/* /spiwack */ - /* Registers for the abstract machine: @@ -1298,12 +1291,6 @@ value coq_interprete /*returns the multiplication on a pair */ print_instr("MULCINT63"); CheckInt2(); - /*accu = 2v+1, *sp=2w+1 ==> p = 2v*w */ - /* TODO: implement - p = I64_mul (UI64_of_value (accu), UI64_of_uint32 ((*sp++)^1)); - AllocPair(); */ - /* Field(accu, 0) = (value)(I64_lsr(p,31)|1) ; */ /*higher part*/ - /* Field(accu, 1) = (value)(I64_to_int32(p)|1); */ /*lower part*/ Uint63_mulc(accu, *sp, sp); *--sp = accu; AllocPair(); @@ -1374,40 +1361,11 @@ value coq_interprete Instruct (CHECKDIV21INT63) { print_instr("DIV21INT63"); CheckInt3(); - /* spiwack: takes three int31 (the two first ones represent an - int62) and performs the euclidian division of the - int62 by the int31 */ - /* TODO: implement this - bigint = UI64_of_value(accu); - bigint = I64_or(I64_lsl(bigint, 31),UI64_of_value(*sp++)); - uint64 divisor; - divisor = UI64_of_value(*sp++); - Alloc_small(accu, 2, 1); */ /* ( _ , arity, tag ) */ - /* if (I64_is_zero (divisor)) { - Field(accu, 0) = 1; */ /* 2*0+1 */ - /* Field(accu, 1) = 1; */ /* 2*0+1 */ - /* } - else { - uint64 quo, mod; - I64_udivmod(bigint, divisor, &quo, &mod); - Field(accu, 0) = value_of_uint32(I64_to_int32(quo)); - Field(accu, 1) = value_of_uint32(I64_to_int32(mod)); - } */ - int b; - Uint63_eq0(b, sp[1]); - if (b) { - AllocPair(); - Field(accu, 0) = sp[1]; - Field(accu, 1) = sp[1]; - } - else { - Uint63_div21(accu, sp[0], sp[1], sp); - sp[1] = sp[0]; - Swap_accu_sp; - AllocPair(); - Field(accu, 0) = sp[1]; - Field(accu, 1) = sp[0]; - } + Uint63_div21(accu, sp[0], sp[1], &(sp[1])); + Swap_accu_sp; + AllocPair(); + Field(accu, 0) = sp[1]; + Field(accu, 1) = sp[0]; sp += 2; Next; } @@ -1616,7 +1574,7 @@ value coq_push_vstack(value stk, value max_stack_size) { print_instr("push_vstack");print_int(len); for(i = 0; i < len; i++) coq_sp[i] = Field(stk,i); sp = coq_sp; - CHECK_STACK(uint32_of_value(max_stack_size)); + CHECK_STACK(uint_of_value(max_stack_size)); return Val_unit; } diff --git a/kernel/byterun/coq_uint63_emul.h b/kernel/byterun/coq_uint63_emul.h index d982f67566..528cc6fc1f 100644 --- a/kernel/byterun/coq_uint63_emul.h +++ b/kernel/byterun/coq_uint63_emul.h @@ -6,6 +6,8 @@ #define Is_uint63(v) (Tag_val(v) == Custom_tag) +#define uint_of_value(val) (((uint32_t)(val)) >> 1) + # define DECLARE_NULLOP(name) \ value uint63_##name() { \ static value* cb = 0; \ diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h index d431dc1e5c..1fdafc9d8f 100644 --- a/kernel/byterun/coq_uint63_native.h +++ b/kernel/byterun/coq_uint63_native.h @@ -1,5 +1,6 @@ #define Is_uint63(v) (Is_long(v)) +#define uint_of_value(val) (((uint64_t)(val)) >> 1) #define uint63_of_value(val) ((uint64_t)(val) >> 1) /* 2^63 * y + x as a value */ @@ -109,37 +110,56 @@ value uint63_mulc(value x, value y, value* h) { #define lt128(xh,xl,yh,yl) (uint63_lt(xh,yh) || (uint63_eq(xh,yh) && uint63_lt(xl,yl))) #define le128(xh,xl,yh,yl) (uint63_lt(xh,yh) || (uint63_eq(xh,yh) && uint63_leq(xl,yl))) -value uint63_div21(value xh, value xl, value y, value* q) { - xh = (uint64_t)xh >> 1; - xl = ((uint64_t)xl >> 1) | ((uint64_t)xh << 63); - xh = (uint64_t)xh >> 1; +#define maxuint63 ((uint64_t)0x7FFFFFFFFFFFFFFF) +/* precondition: y <> 0 */ +/* outputs r and sets ql to q % 2^63 s.t. x = q * y + r, r < y */ +static value uint63_div21_aux(value xh, value xl, value y, value* ql) { + xh = uint63_of_value(xh); + xl = uint63_of_value(xl); + y = uint63_of_value(y); uint64_t maskh = 0; uint64_t maskl = 1; uint64_t dh = 0; - uint64_t dl = (uint64_t)y >> 1; + uint64_t dl = y; int cmp = 1; - while (dh >= 0 && cmp) { + /* int n = 0 */ + /* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0, d < 2^(2*63) */ + while (!(dh >> (63 - 1)) && cmp) { + dh = (dh << 1) | (dl >> (63 - 1)); + dl = (dl << 1) & maxuint63; + maskh = (maskh << 1) | (maskl >> (63 - 1)); + maskl = (maskl << 1) & maxuint63; + /* ++n */ cmp = lt128(dh,dl,xh,xl); - dh = (dh << 1) | (dl >> 63); - dl = dl << 1; - maskh = (maskh << 1) | (maskl >> 63); - maskl = maskl << 1; } uint64_t remh = xh; uint64_t reml = xl; - uint64_t quotient = 0; + /* uint64_t quotienth = 0; */ + uint64_t quotientl = 0; + /* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, + mask = floor(2^n), d = mask * y, n >= -1 */ while (maskh | maskl) { - if (le128(dh,dl,remh,reml)) { - quotient = quotient | maskl; - if (uint63_lt(reml,dl)) {remh = remh - dh - 1;} else {remh = remh - dh;} + if (le128(dh,dl,remh,reml)) { /* if rem >= d, add one bit and subtract d */ + /* quotienth = quotienth | maskh */ + quotientl = quotientl | maskl; + remh = (uint63_lt(reml,dl)) ? (remh - dh - 1) : (remh - dh); reml = reml - dl; } - maskl = (maskl >> 1) | (maskh << 63); + maskl = (maskl >> 1) | ((maskh << (63 - 1)) & maxuint63); maskh = maskh >> 1; - dl = (dl >> 1) | (dh << 63); + dl = (dl >> 1) | ((dh << (63 - 1)) & maxuint63); dh = dh >> 1; + /* decr n */ } - *q = Val_int(quotient); + *ql = Val_int(quotientl); return Val_int(reml); } +value uint63_div21(value xh, value xl, value y, value* ql) { + if (uint63_of_value(y) == 0) { + *ql = Val_int(0); + return Val_int(0); + } else { + return uint63_div21_aux(xh, xl, y, ql); + } +} #define Uint63_div21(xh, xl, y, q) (accu = uint63_div21(xh, xl, y, q)) diff --git a/kernel/uint63.mli b/kernel/uint63.mli index b5f40ca804..f25f24512d 100644 --- a/kernel/uint63.mli +++ b/kernel/uint63.mli @@ -40,6 +40,10 @@ val rem : t -> t -> t (* Specific arithmetic operations *) val mulc : t -> t -> t * t val addmuldiv : t -> t -> t -> t + +(** [div21 xh xl y] returns [q % 2^63, r] + s.t. [xh * 2^63 + xl = q * y + r] and [r < y]. + When [y] is [0], returns [0, 0]. *) val div21 : t -> t -> t -> t * t (* comparison *) diff --git a/kernel/uint63_amd64.ml b/kernel/uint63_amd64.ml index 010b594de8..2d4d685775 100644 --- a/kernel/uint63_amd64.ml +++ b/kernel/uint63_amd64.ml @@ -102,26 +102,35 @@ let le128 xh xl yh yl = lt xh yh || (xh = yh && le xl yl) (* division of two numbers by one *) +(* precondition: y <> 0 *) +(* outputs: q % 2^63, r s.t. x = q * y + r, r < y *) let div21 xh xl y = let maskh = ref 0 in let maskl = ref 1 in let dh = ref 0 in let dl = ref y in let cmp = ref true in - while !dh >= 0 && !cmp do - cmp := lt128 !dh !dl xh xl; + (* n = ref 0 *) + (* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0 *) + while !dh >= 0 && !cmp do (* dh >= 0 tests that dh highest bit is zero *) (* We don't use addmuldiv below to avoid checks on 1 *) dh := (!dh lsl 1) lor (!dl lsr (uint_size - 1)); dl := !dl lsl 1; maskh := (!maskh lsl 1) lor (!maskl lsr (uint_size - 1)); - maskl := !maskl lsl 1 - done; (* mask = 2^N, d = 2^N * d, d >= x *) + maskl := !maskl lsl 1; + (* incr n *) + cmp := lt128 !dh !dl xh xl; + done; (* mask = 2^n, d = 2^n * y, 2 * d > x *) let remh = ref xh in let reml = ref xl in - let quotient = ref 0 in + (* quotienth = ref 0 *) + let quotientl = ref 0 in + (* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, + mask = floor(2^n), d = mask * y, n >= -1 *) while !maskh lor !maskl <> 0 do if le128 !dh !dl !remh !reml then begin (* if rem >= d, add one bit and subtract d *) - quotient := !quotient lor !maskl; + (* quotienth := !quotienth lor !maskh *) + quotientl := !quotientl lor !maskl; remh := if lt !reml !dl then !remh - !dh - 1 else !remh - !dh; reml := !reml - !dl; end; @@ -129,8 +138,11 @@ let div21 xh xl y = maskh := !maskh lsr 1; dl := (!dl lsr 1) lor (!dh lsl (uint_size - 1)); dh := !dh lsr 1; + (* decr n *) done; - !quotient, !reml + !quotientl, !reml + +let div21 xh xl y = if y = 0 then 0, 0 else div21 xh xl y (* exact multiplication *) (* TODO: check that none of these additions could be a logical or *) diff --git a/kernel/uint63_x86.ml b/kernel/uint63_x86.ml index 461184c432..fa45c90241 100644 --- a/kernel/uint63_x86.ml +++ b/kernel/uint63_x86.ml @@ -94,26 +94,35 @@ let le128 xh xl yh yl = lt xh yh || (xh = yh && le xl yl) (* division of two numbers by one *) +(* precondition: y <> 0 *) +(* outputs: q % 2^63, r s.t. x = q * y + r, r < y *) let div21 xh xl y = let maskh = ref zero in let maskl = ref one in let dh = ref zero in let dl = ref y in let cmp = ref true in - while le zero !dh && !cmp do - cmp := lt128 !dh !dl xh xl; + (* n = ref 0 *) + (* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0 *) + while Int64.equal (l_sr !dh (of_int (uint_size - 1))) zero && !cmp do (* We don't use addmuldiv below to avoid checks on 1 *) dh := l_or (l_sl !dh one) (l_sr !dl (of_int (uint_size - 1))); dl := l_sl !dl one; maskh := l_or (l_sl !maskh one) (l_sr !maskl (of_int (uint_size - 1))); - maskl := l_sl !maskl one - done; (* mask = 2^N, d = 2^N * d, d >= x *) + maskl := l_sl !maskl one; + (* incr n *) + cmp := lt128 !dh !dl xh xl; + done; (* mask = 2^n, d = 2^n * d, 2 * d > x *) let remh = ref xh in let reml = ref xl in - let quotient = ref zero in + (* quotienth = ref 0 *) + let quotientl = ref zero in + (* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, + mask = floor(2^n), d = mask * y, n >= -1 *) while not (Int64.equal (l_or !maskh !maskl) zero) do if le128 !dh !dl !remh !reml then begin (* if rem >= d, add one bit and subtract d *) - quotient := l_or !quotient !maskl; + (* quotienth := !quotienth lor !maskh *) + quotientl := l_or !quotientl !maskl; remh := if lt !reml !dl then sub (sub !remh !dh) one else sub !remh !dh; reml := sub !reml !dl end; @@ -121,9 +130,11 @@ let div21 xh xl y = maskh := l_sr !maskh one; dl := l_or (l_sr !dl one) (l_sl !dh (of_int (uint_size - 1))); dh := l_sr !dh one + (* decr n *) done; - !quotient, !reml + !quotientl, !reml +let div21 xh xl y = if Int64.equal y zero then zero, zero else div21 xh xl y (* exact multiplication *) let mulc x y = diff --git a/kernel/univ.ml b/kernel/univ.ml index 8263c68bf5..b1bbc25fe6 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -231,18 +231,15 @@ module LMap = struct module M = HMap.Make (Level) include M - let union l r = - merge (fun _k l r -> - match l, r with - | Some _, _ -> l - | _, _ -> r) l r + let lunion l r = + union (fun _k l _r -> Some l) l r - let subst_union l r = - merge (fun _k l r -> + let subst_union l r = + union (fun _k l r -> match l, r with - | Some (Some _), _ -> l - | Some None, None -> l - | _, _ -> r) l r + | Some _, _ -> Some l + | None, None -> Some l + | _, _ -> Some r) l r let diff ext orig = fold (fun u v acc -> diff --git a/kernel/univ.mli b/kernel/univ.mli index 5543c35741..db178c4bb0 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -223,8 +223,8 @@ module LMap : sig include CMap.ExtS with type key = Level.t and module Set := LSet - val union : 'a t -> 'a t -> 'a t - (** [union x y] favors the bindings in the first map. *) + val lunion : 'a t -> 'a t -> 'a t + (** [lunion x y] favors the bindings in the first map. *) val diff : 'a t -> 'a t -> 'a t (** [diff x y] removes bindings from x that appear in y (whatever the value). *) diff --git a/library/goptions.ml b/library/goptions.ml index b9c1802a72..f4b8ce9465 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -42,13 +42,12 @@ let error_undeclared_key key = (****************************************************************************) (* 1- Tables *) -class type ['a] table_of_A = -object - method add : 'a -> unit - method remove : 'a -> unit - method mem : 'a -> unit - method print : unit -end +type 'a table_of_A = { + add : Environ.env -> 'a -> unit; + remove : Environ.env -> 'a -> unit; + mem : Environ.env -> 'a -> unit; + print : unit -> unit; +} module MakeTable = functor @@ -109,18 +108,17 @@ module MakeTable = (fun a b -> spc () ++ printer a ++ b) table (mt ()) ++ str "." ++ fnl ()))) - class table_of_A () = - object - method add x = add_option (A.encode (Global.env()) x) - method remove x = remove_option (A.encode (Global.env()) x) - method mem x = - let y = A.encode (Global.env()) x in + let table_of_A = { + add = (fun env x -> add_option (A.encode env x)); + remove = (fun env x -> remove_option (A.encode env x)); + mem = (fun env x -> + let y = A.encode env x in let answer = MySet.mem y !t in - Feedback.msg_info (A.member_message y answer) - method print = print_table A.title A.printer !t - end + Feedback.msg_info (A.member_message y answer)); + print = (fun () -> print_table A.title A.printer !t); + } - let _ = A.table := (nick,new table_of_A ())::!A.table + let _ = A.table := (nick, table_of_A)::!A.table let active c = MySet.mem c !t let elements () = MySet.elements !t end diff --git a/library/goptions.mli b/library/goptions.mli index 2e593e9d9e..381ba4d34a 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -76,7 +76,7 @@ end (** The functor [MakeRefTable] declares a new table of objects of type [A.t] practically denoted by [reference]; the encoding function - [encode : reference -> A.t] is typically a globalization function, + [encode : env -> reference -> A.t] is typically a globalization function, possibly with some restriction checks; the function [member_message] say what to print when invoking the "Test Toto Titi foo." command; at the end [title] is the table name printed @@ -139,19 +139,17 @@ val declare_bool_option_and_ref : depr:bool -> name:string -> key:option_name -> module OptionMap : CSig.MapS with type key = option_name -val get_string_table : - option_name -> - < add : string -> unit; - remove : string -> unit; - mem : string -> unit; - print : unit > +type 'a table_of_A = { + add : Environ.env -> 'a -> unit; + remove : Environ.env -> 'a -> unit; + mem : Environ.env -> 'a -> unit; + print : unit -> unit; +} +val get_string_table : + option_name -> string table_of_A val get_ref_table : - option_name -> - < add : qualid -> unit; - remove : qualid -> unit; - mem : qualid -> unit; - print : unit > + option_name -> qualid table_of_A (** The first argument is a locality flag. *) val set_int_option_value_gen : ?locality:option_locality -> option_name -> int option -> unit diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index a3973732ad..dbfc0fc91d 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -185,7 +185,7 @@ VERNAC COMMAND EXTEND Function | _,((_,None,_,_,_),_) -> false) recsl in match Vernac_classifier.classify_vernac - (Vernacexpr.(VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) + (Vernacexpr.(CAst.make @@ VernacExpr([], VernacFixpoint(Decl_kinds.NoDischarge, List.map snd recsl)))) with | Vernacextend.VtSideff ids, _ when hard -> Vernacextend.(VtStartProof (GuaranteesOpacity, ids), VtLater) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 45a4e61846..e15e167ff3 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1518,7 +1518,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac Vernacexpr.(CAst.make @@ VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ msg in @@ -1533,7 +1533,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac Vernacexpr.(CAst.make @@ VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) ++ fnl () ++ CErrors.print reraise in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 3c2b03dfe0..3dd3a430e8 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -701,7 +701,7 @@ let mkDestructEq : let changefun patvars env sigma = pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) in - Proofview.V82.of_tactic (change_in_concl None changefun) g2); + Proofview.V82.of_tactic (change_in_concl ~check:true None changefun) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index ec5e46d89b..e59076bd63 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -182,9 +182,18 @@ TACTIC EXTEND unify } END +{ +let deprecated_convert_concl_no_check = + CWarnings.create + ~name:"convert_concl_no_check" ~category:"deprecated" + (fun () -> Pp.str "The syntax [convert_concl_no_check] is deprecated. Use [change_no_check] instead.") +} TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> { Tactics.convert_concl ~check:false x DEFAULTcast } +| ["convert_concl_no_check" constr(x) ] -> { + deprecated_convert_concl_no_check (); + Tactics.convert_concl ~check:false x DEFAULTcast + } END { diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index a2dd51643b..c23240b782 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -703,7 +703,11 @@ GRAMMAR EXTEND Gram | IDENT "change"; c = conversion; cl = clause_dft_concl -> { let (oc, c) = c in let p,cl = merge_occurrences loc cl oc in - TacAtom (CAst.make ~loc @@ TacChange (p,c,cl)) } + TacAtom (CAst.make ~loc @@ TacChange (true,p,c,cl)) } + | IDENT "change_no_check"; c = conversion; cl = clause_dft_concl -> + { let (oc, c) = c in + let p,cl = merge_occurrences loc cl oc in + TacAtom (CAst.make ~loc @@ TacChange (false,p,c,cl)) } ] ] ; END diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 80070a7493..79f0f521cc 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -833,9 +833,10 @@ let pr_goal_selector ~toplevel s = pr_red_expr r ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h ) - | TacChange (op,c,h) -> + | TacChange (check,op,c,h) -> + let name = if check then "change_no_check" else "change" in hov 1 ( - primitive "change" ++ brk (1,1) + primitive name ++ brk (1,1) ++ ( match op with None -> diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 99a9c1ab9a..a68efa4713 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1574,8 +1574,8 @@ let newfail n s = let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let open Proofview.Notations in (* For compatibility *) - let beta = Tactics.reduct_in_concl (Reductionops.nf_betaiota, DEFAULTcast) in - let beta_hyp id = Tactics.reduct_in_hyp Reductionops.nf_betaiota (id, InHyp) in + let beta = Tactics.reduct_in_concl ~check:false (Reductionops.nf_betaiota, DEFAULTcast) in + let beta_hyp id = Tactics.reduct_in_hyp ~check:false ~reorder:false Reductionops.nf_betaiota (id, InHyp) in let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") @@ -1596,7 +1596,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) | Some id, None -> Proofview.Unsafe.tclEVARS undef <*> - convert_hyp ~check:false (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> + convert_hyp ~check:false ~reorder:false (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> beta_hyp id | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 30e316b36d..0eb7726a18 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -34,6 +34,7 @@ type rec_flag = bool (* true = recursive false = not recursive *) type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) +type check_flag = bool (* true = check false = do not check *) type ('c,'d,'id) inversion_strength = | NonDepInversion of @@ -125,7 +126,7 @@ type 'a gen_atomic_tactic_expr = (* Conversion *) | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr - | TacChange of 'pat option * 'dtrm * 'nam clause_expr + | TacChange of check_flag * 'pat option * 'dtrm * 'nam clause_expr (* Equality and inversion *) | TacRewrite of evars_flag * diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 8b6b14322b..fd303f5d94 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -34,6 +34,7 @@ type rec_flag = bool (* true = recursive false = not recursive *) type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) +type check_flag = bool (* true = check false = do not check *) type ('c,'d,'id) inversion_strength = | NonDepInversion of @@ -124,7 +125,7 @@ type 'a gen_atomic_tactic_expr = (* Conversion *) | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr - | TacChange of 'pat option * 'dtrm * 'nam clause_expr + | TacChange of check_flag * 'pat option * 'dtrm * 'nam clause_expr (* Equality and inversion *) | TacRewrite of evars_flag * diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 543d4de0fe..c1f7fab123 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -551,7 +551,7 @@ let rec intern_atomic lf ist x = | TacReduce (r,cl) -> dump_glob_red_expr r; TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl) - | TacChange (None,c,cl) -> + | TacChange (check,None,c,cl) -> let is_onhyps = match cl.onhyps with | None | Some [] -> true | _ -> false @@ -560,17 +560,17 @@ let rec intern_atomic lf ist x = | AtLeastOneOccurrence | AllOccurrences | NoOccurrences -> true | _ -> false in - TacChange (None, + TacChange (check,None, (if is_onhyps && is_onconcl then intern_type ist c else intern_constr ist c), clause_app (intern_hyp_location ist) cl) - | TacChange (Some p,c,cl) -> + | TacChange (check,Some p,c,cl) -> let { ltacvars } = ist in let metas,pat = intern_typed_pattern ist ~as_type:false ~ltacvars p in let fold accu x = Id.Set.add x accu in let ltacvars = List.fold_left fold ltacvars metas in let ist' = { ist with ltacvars } in - TacChange (Some pat,intern_constr ist' c, + TacChange (check,Some pat,intern_constr ist' c, clause_app (intern_hyp_location ist) cl) (* Equality and inversion *) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 4398fb14ab..800be2565d 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -1770,7 +1770,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl)) end - | TacChange (None,c,cl) -> + | TacChange (check,None,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<change>") begin Proofview.Goal.enter begin fun gl -> @@ -1792,10 +1792,10 @@ and interp_atomic ist tac : unit Proofview.tactic = then interp_type ist env sigma c else interp_constr ist env sigma c in - Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl) + Tactics.change ~check None c_interp (interp_clause ist (pf_env gl) (project gl) cl) end end - | TacChange (Some op,c,cl) -> + | TacChange (check,Some op,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun _ _ -> Pp.str"<change>") begin Proofview.Goal.enter begin fun gl -> @@ -1815,7 +1815,7 @@ and interp_atomic ist tac : unit Proofview.tactic = with e when to_catch e (* Hack *) -> user_err (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") in - Tactics.change (Some op) c_interp (interp_clause ist env sigma cl) + Tactics.change ~check (Some op) c_interp (interp_clause ist env sigma cl) end end diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index e617f3d45e..a3eeca2267 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -158,8 +158,8 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Conversion *) | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) - | TacChange (op,c,cl) -> - TacChange (Option.map (subst_glob_constr_or_pattern subst) op, + | TacChange (check,op,c,cl) -> + TacChange (check,Option.map (subst_glob_constr_or_pattern subst) op, subst_glob_constr subst c, cl) (* Equality and inversion *) diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index f3bc791b8d..ffc3506a1f 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1849,12 +1849,12 @@ let destructure_hyps = match destructurate_type env sigma typ with | Kapp(Nat,_) -> (tclTHEN - (Tactics.convert_hyp ~check:false (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) + (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) decl)) (loop lit)) | Kapp(Z,_) -> (tclTHEN - (Tactics.convert_hyp ~check:false (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) + (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) decl)) (loop lit)) | _ -> loop lit diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index 813c521ab0..ad2ee821b3 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -1235,12 +1235,19 @@ Notation ring_correct := (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th). (* simplify a field expression into a fraction *) -(* TODO: simplify when den is constant... *) Definition display_linear l num den := - NPphi_dev l num / NPphi_dev l den. + let lnum := NPphi_dev l num in + match den with + | Pc c => if ceqb c cI then lnum else lnum / NPphi_dev l den + | _ => lnum / NPphi_dev l den + end. Definition display_pow_linear l num den := - NPphi_pow l num / NPphi_pow l den. + let lnum := NPphi_pow l num in + match den with + | Pc c => if ceqb c cI then lnum else lnum / NPphi_pow l den + | _ => lnum / NPphi_pow l den + end. Theorem Field_rw_correct n lpe l : Ninterp_PElist l lpe -> @@ -1252,7 +1259,18 @@ Theorem Field_rw_correct n lpe l : Proof. intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. rewrite (Fnorm_FEeval_PEeval _ _ H). - unfold display_linear; apply rdiv_ext; + unfold display_linear. + destruct (Nnorm _ _ _) as [c | | ] eqn: HN; + try ( apply rdiv_ext; + eapply ring_rw_correct; eauto). + destruct (ceqb_spec c cI). + set (nnum := NPphi_dev _ _). + apply eq_trans with (nnum / NPphi_dev l (Pc c)). + apply rdiv_ext; + eapply ring_rw_correct; eauto. + rewrite Pphi_dev_ok; try eassumption. + now simpl; rewrite H0, phi_1, <- rdiv1. + apply rdiv_ext; eapply ring_rw_correct; eauto. Qed. @@ -1266,8 +1284,19 @@ Theorem Field_rw_pow_correct n lpe l : Proof. intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. rewrite (Fnorm_FEeval_PEeval _ _ H). - unfold display_pow_linear; apply rdiv_ext; - eapply ring_rw_pow_correct;eauto. + unfold display_pow_linear. + destruct (Nnorm _ _ _) as [c | | ] eqn: HN; + try ( apply rdiv_ext; + eapply ring_rw_pow_correct; eauto). + destruct (ceqb_spec c cI). + set (nnum := NPphi_pow _ _). + apply eq_trans with (nnum / NPphi_pow l (Pc c)). + apply rdiv_ext; + eapply ring_rw_pow_correct; eauto. + rewrite Pphi_pow_ok; try eassumption. + now simpl; rewrite H0, phi_1, <- rdiv1. + apply rdiv_ext; + eapply ring_rw_pow_correct; eauto. Qed. Theorem Field_correct n l lpe fe1 fe2 : diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 3f69701bd3..b02b97f656 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -89,10 +89,10 @@ let protect_red map env sigma c0 = EConstr.of_constr (eval 0 c) let protect_tac map = - Tactics.reduct_option (protect_red map,DEFAULTcast) None + Tactics.reduct_option ~check:false (protect_red map,DEFAULTcast) None let protect_tac_in map id = - Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp)) + Tactics.reduct_option ~check:false (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp)) (****************************************************************************) diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index d6b7371647..49d729bd6c 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -94,20 +94,31 @@ Require Import ssreflect ssrfun. like terms from boolean equalities (can fail). This file provides a theory of boolean predicates and relations: pred T == the type of bool predicates (:= T -> bool). - simpl_pred T == the type of simplifying bool predicates, using - the simpl_fun from ssrfun.v. + simpl_pred T == the type of simplifying bool predicates, based on + the simpl_fun type from ssrfun.v. + mem_pred T == a specialized form of simpl_pred for "collective" + predicates (see below). rel T == the type of bool relations. := T -> pred T or T -> T -> bool. simpl_rel T == type of simplifying relations. + := T -> simpl_pred T predType == the generic predicate interface, supported for for lists and sets. - pred_class == a coercion class for the predType projection to - pred; declaring a coercion to pred_class is an - alternative way of equipping a type with a - predType structure, which interoperates better - with coercion subtyping. This is used, e.g., - for finite sets, so that finite groups inherit - the membership operation by coercing to sets. + pred_sort == the predType >-> Type projection; pred_sort is + itself a Coercion target class. Declaring a + coercion to pred_sort is an alternative way of + equiping a type with a predType structure, which + interoperates better with coercion subtyping. + This is used, e.g., for finite sets, so that finite + groups inherit the membership operation by + coercing to sets. + {pred T} == a type convertible to pred T, but whose head + constant is pred_sort. This type should be used + for parameters that can be used as collective + predicates (see below), as this will allow passing + in directly collections that implement predType + by coercion as described above, e.g., finite sets. + := pred_sort (predPredType T) If P is a predicate the proposition "x satisfies P" can be written applicatively as (P x), or using an explicit connective as (x \in P); in the latter case we say that P is a "collective" predicate. We use A, B @@ -119,8 +130,14 @@ Require Import ssreflect ssrfun. pred T value of one type needs to be passed as the other the following conversions should be used explicitly: SimplPred P == a (simplifying) applicative equivalent of P. - mem A == an applicative equivalent of A: - mem A x simplifies to x \in A. + mem A == an applicative equivalent of collective predicate A: + mem A x simplifies to x \in A, as mem A has in + fact type mem_pred T. + --> In user notation collective predicates _only_ occur as arguments to mem: + A only appears as (mem A). This is hidden by notation, e.g., + x \in A := in_mem x (mem A) here, enum A := enum_mem (mem A) in fintype. + This makes it possible to unify the various ways in which A can be + interpreted as a predicate, for both pattern matching and display. Alternatively one can use the syntax for explicit simplifying predicates and relations (in the following x is bound in E): #[#pred x | E#]# == simplifying (see ssrfun) predicate x => E. @@ -135,11 +152,11 @@ Require Import ssreflect ssrfun. #[#predD A & B#]# == difference of collective predicates A and B. #[#predC A#]# == complement of the collective predicate A. #[#preim f of A#]# == preimage under f of the collective predicate A. - predU P Q, ... == union, etc of applicative predicates. - pred0 == the empty predicate. - predT == the total (always true) predicate. - if T : predArgType, then T coerces to predT. - {: T} == T cast to predArgType (e.g., {: bool * nat}) + predU P Q, ..., preim f P == union, etc of applicative predicates. + pred0 == the empty predicate. + predT == the total (always true) predicate. + if T : predArgType, then T coerces to predT. + {: T} == T cast to predArgType (e.g., {: bool * nat}). In the following, x and y are bound in E: #[#rel x y | E#]# == simplifying relation x, y => E. #[#rel x y : T | E#]# == simplifying relation with arguments cast. @@ -147,7 +164,9 @@ Require Import ssreflect ssrfun. #[#rel x y in A & B#]# == #[#rel x y | (x \in A) && (y \in B) #]#. #[#rel x y in A | E#]# == #[#rel x y in A & A | E#]#. #[#rel x y in A#]# == #[#rel x y in A & A#]#. - relU R S == union of relations R and S. + relU R S == union of relations R and S. + relpre f R == preimage of relation R under f. + xpredU, ..., xrelpre == lambda terms implementing predU, ..., etc. Explicit values of type pred T (i.e., lamdba terms) should always be used applicatively, while values of collection types implementing the predType interface, such as sequences or sets should always be used as collective @@ -177,7 +196,7 @@ Require Import ssreflect ssrfun. applicative and collective styles. Purely for aesthetics, we provide a subtype of collective predicates: qualifier q T == a pred T pretty-printing wrapper. An A : qualifier q T - coerces to pred_class and thus behaves as a collective + coerces to pred_sort and thus behaves as a collective predicate, but x \in A and x \notin A are displayed as: x \is A and x \isn't A when q = 0, x \is a A and x \isn't a A when q = 1, @@ -189,11 +208,11 @@ Require Import ssreflect ssrfun. We provide an internal interface to support attaching properties (such as being multiplicative) to predicates: pred_key p == phantom type that will serve as a support for properties - to be attached to p : pred_class; instances should be + to be attached to p : {pred _}; instances should be created with Fact/Qed so as to be opaque. KeyedPred k_p == an instance of the interface structure that attaches (k_p : pred_key P) to P; the structure projection is a - coercion to pred_class. + coercion to pred_sort. KeyedQualifier k_q == an instance of the interface structure that attaches (k_q : pred_key q) to (q : qualifier n T). DefaultPredKey p == a default value for pred_key p; the vernacular command @@ -235,17 +254,20 @@ Require Import ssreflect ssrfun. {in A &, P2} <-> forall x y, x \in A -> y \in A -> Qxy. {in A1 & A2 & A3, Q3} <-> forall x y z, x \in A1 -> y \in A2 -> z \in A3 -> Qxyz. - {in A1 & A2 &, Q3} == {in A1 & A2 & A2, Q3}. - {in A1 && A3, Q3} == {in A1 & A1 & A3, Q3}. - {in A &&, Q3} == {in A & A & A, Q3}. - {in A, bijective f} == f has a right inverse in A. - {on C, P1} == forall x, (f x) \in C -> Qx - when P1 is also convertible to Pf f. + {in A1 & A2 &, Q3} := {in A1 & A2 & A2, Q3}. + {in A1 && A3, Q3} := {in A1 & A1 & A3, Q3}. + {in A &&, Q3} := {in A & A & A, Q3}. + {in A, bijective f} <-> f has a right inverse in A. + {on C, P1} <-> forall x, (f x) \in C -> Qx + when P1 is also convertible to Pf f, e.g., + {on C, involutive f}. {on C &, P2} == forall x y, f x \in C -> f y \in C -> Qxy - when P2 is also convertible to Pf f. + when P2 is also convertible to Pf f, e.g., + {on C &, injective f}. {on C, P1' & g} == forall x, (f x) \in cd -> Qx when P1' is convertible to Pf f - and P1' g is convertible to forall x, Qx. + and P1' g is convertible to forall x, Qx, e.g., + {on C, cancel f & g}. {on C, bijective f} == f has a right inverse on C. This file extends the lemma name suffix conventions of ssrfun as follows: A -- associativity, as in andbA : associative andb. @@ -282,13 +304,119 @@ Notation ReflectF := Bool.ReflectF. Reserved Notation "~~ b" (at level 35, right associativity). Reserved Notation "b ==> c" (at level 55, right associativity). -Reserved Notation "b1 (+) b2" (at level 50, left associativity). -Reserved Notation "x \in A" - (at level 70, format "'[hv' x '/ ' \in A ']'", no associativity). -Reserved Notation "x \notin A" - (at level 70, format "'[hv' x '/ ' \notin A ']'", no associativity). -Reserved Notation "p1 =i p2" - (at level 70, format "'[hv' p1 '/ ' =i p2 ']'", no associativity). +Reserved Notation "b1 (+) b2" (at level 50, left associativity). + +Reserved Notation "x \in A" (at level 70, no associativity, + format "'[hv' x '/ ' \in A ']'"). +Reserved Notation "x \notin A" (at level 70, no associativity, + format "'[hv' x '/ ' \notin A ']'"). +Reserved Notation "x \is A" (at level 70, no associativity, + format "'[hv' x '/ ' \is A ']'"). +Reserved Notation "x \isn't A" (at level 70, no associativity, + format "'[hv' x '/ ' \isn't A ']'"). +Reserved Notation "x \is 'a' A" (at level 70, no associativity, + format "'[hv' x '/ ' \is 'a' A ']'"). +Reserved Notation "x \isn't 'a' A" (at level 70, no associativity, + format "'[hv' x '/ ' \isn't 'a' A ']'"). +Reserved Notation "x \is 'an' A" (at level 70, no associativity, + format "'[hv' x '/ ' \is 'an' A ']'"). +Reserved Notation "x \isn't 'an' A" (at level 70, no associativity, + format "'[hv' x '/ ' \isn't 'an' A ']'"). +Reserved Notation "p1 =i p2" (at level 70, no associativity, + format "'[hv' p1 '/ ' =i p2 ']'"). +Reserved Notation "{ 'subset' A <= B }" (at level 0, A, B at level 69, + format "'[hv' { 'subset' A '/ ' <= B } ']'"). + +Reserved Notation "{ : T }" (at level 0, format "{ : T }"). +Reserved Notation "{ 'pred' T }" (at level 0, format "{ 'pred' T }"). +Reserved Notation "[ 'predType' 'of' T ]" (at level 0, + format "[ 'predType' 'of' T ]"). + +Reserved Notation "[ 'pred' : T | E ]" (at level 0, + format "'[hv' [ 'pred' : T | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x | E ]" (at level 0, x ident, + format "'[hv' [ 'pred' x | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x : T | E ]" (at level 0, x ident, + format "'[hv' [ 'pred' x : T | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x | E1 & E2 ]" (at level 0, x ident, + format "'[hv' [ 'pred' x | '/ ' E1 & '/ ' E2 ] ']'"). +Reserved Notation "[ 'pred' x : T | E1 & E2 ]" (at level 0, x ident, + format "'[hv' [ 'pred' x : T | '/ ' E1 & E2 ] ']'"). +Reserved Notation "[ 'pred' x 'in' A ]" (at level 0, x ident, + format "'[hv' [ 'pred' x 'in' A ] ']'"). +Reserved Notation "[ 'pred' x 'in' A | E ]" (at level 0, x ident, + format "'[hv' [ 'pred' x 'in' A | '/ ' E ] ']'"). +Reserved Notation "[ 'pred' x 'in' A | E1 & E2 ]" (at level 0, x ident, + format "'[hv' [ 'pred' x 'in' A | '/ ' E1 & '/ ' E2 ] ']'"). + +Reserved Notation "[ 'qualify' x | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' x | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' x : T | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' x : T | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'a' x | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'a' x | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'a' x : T | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'a' x : T | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'an' x | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'an' x | '/ ' P ] ']'"). +Reserved Notation "[ 'qualify' 'an' x : T | P ]" (at level 0, x at level 99, + format "'[hv' [ 'qualify' 'an' x : T | '/ ' P ] ']'"). + +Reserved Notation "[ 'rel' x y | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y : T | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y : T | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A & B | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A & B | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A & B ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A & B ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A | E ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A | '/ ' E ] ']'"). +Reserved Notation "[ 'rel' x y 'in' A ]" (at level 0, x ident, y ident, + format "'[hv' [ 'rel' x y 'in' A ] ']'"). + +Reserved Notation "[ 'mem' A ]" (at level 0, format "[ 'mem' A ]"). +Reserved Notation "[ 'predI' A & B ]" (at level 0, + format "[ 'predI' A & B ]"). +Reserved Notation "[ 'predU' A & B ]" (at level 0, + format "[ 'predU' A & B ]"). +Reserved Notation "[ 'predD' A & B ]" (at level 0, + format "[ 'predD' A & B ]"). +Reserved Notation "[ 'predC' A ]" (at level 0, + format "[ 'predC' A ]"). +Reserved Notation "[ 'preim' f 'of' A ]" (at level 0, + format "[ 'preim' f 'of' A ]"). + +Reserved Notation "\unless C , P" (at level 200, C at level 100, + format "'[hv' \unless C , '/ ' P ']'"). + +Reserved Notation "{ 'for' x , P }" (at level 0, + format "'[hv' { 'for' x , '/ ' P } ']'"). +Reserved Notation "{ 'in' d , P }" (at level 0, + format "'[hv' { 'in' d , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & d2 , P }" (at level 0, + format "'[hv' { 'in' d1 & d2 , '/ ' P } ']'"). +Reserved Notation "{ 'in' d & , P }" (at level 0, + format "'[hv' { 'in' d & , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & d2 & d3 , P }" (at level 0, + format "'[hv' { 'in' d1 & d2 & d3 , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & & d3 , P }" (at level 0, + format "'[hv' { 'in' d1 & & d3 , '/ ' P } ']'"). +Reserved Notation "{ 'in' d1 & d2 & , P }" (at level 0, + format "'[hv' { 'in' d1 & d2 & , '/ ' P } ']'"). +Reserved Notation "{ 'in' d & & , P }" (at level 0, + format "'[hv' { 'in' d & & , '/ ' P } ']'"). +Reserved Notation "{ 'on' cd , P }" (at level 0, + format "'[hv' { 'on' cd , '/ ' P } ']'"). +Reserved Notation "{ 'on' cd & , P }" (at level 0, + format "'[hv' { 'on' cd & , '/ ' P } ']'"). +Reserved Notation "{ 'on' cd , P & g }" (at level 0, g at level 8, + format "'[hv' { 'on' cd , '/ ' P & g } ']'"). +Reserved Notation "{ 'in' d , 'bijective' f }" (at level 0, f at level 8, + format "'[hv' { 'in' d , '/ ' 'bijective' f } ']'"). +Reserved Notation "{ 'on' cd , 'bijective' f }" (at level 0, f at level 8, + format "'[hv' { 'on' cd , '/ ' 'bijective' f } ']'"). + (** We introduce a number of n-ary "list-style" notations that share a common @@ -335,18 +463,6 @@ Reserved Notation "[ ==> b1 => c ]" (at level 0, only parsing). Reserved Notation "[ ==> b1 , b2 , .. , bn => c ]" (at level 0, format "'[hv' [ ==> '[' b1 , '/' b2 , '/' .. , '/' bn ']' '/' => c ] ']'"). -Reserved Notation "[ 'pred' : T => E ]" (at level 0, format - "'[hv' [ 'pred' : T => '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x => E ]" (at level 0, x at level 8, format - "'[hv' [ 'pred' x => '/ ' E ] ']'"). -Reserved Notation "[ 'pred' x : T => E ]" (at level 0, x at level 8, format - "'[hv' [ 'pred' x : T => '/ ' E ] ']'"). - -Reserved Notation "[ 'rel' x y => E ]" (at level 0, x, y at level 8, format - "'[hv' [ 'rel' x y => '/ ' E ] ']'"). -Reserved Notation "[ 'rel' x y : T => E ]" (at level 0, x, y at level 8, format - "'[hv' [ 'rel' x y : T => '/ ' E ] ']'"). - (** Shorter delimiter **) Delimit Scope bool_scope with B. Open Scope bool_scope. @@ -622,9 +738,7 @@ Hint View for apply/ impliesPn|2 impliesP|2. Definition unless condition property : Prop := forall goal : Prop, (condition -> goal) -> (property -> goal) -> goal. -Notation "\unless C , P" := (unless C P) - (at level 200, C at level 100, - format "'[' \unless C , '/ ' P ']'") : type_scope. +Notation "\unless C , P" := (unless C P) : type_scope. Lemma unlessL C P : implies C (\unless C, P). Proof. by split=> hC G /(_ hC). Qed. @@ -1002,8 +1116,7 @@ Ltac bool_congr := Moreover these infix forms are convertible to their prefix counterpart (e.g., predI P Q x which in turn simplifies to P x && Q x). The converse is not true, however; collective predicate types cannot, in general, be - general, be used applicatively, because of the "uniform inheritance" - restriction on implicit coercions. + used applicatively, because of restrictions on implicit coercions. However, we do define an explicit generic coercion - mem : forall (pT : predType), pT -> mem_pred T where mem_pred T is a variant of simpl_pred T that preserves the infix @@ -1019,319 +1132,391 @@ Ltac bool_congr := not to use it applicatively; this avoids the burden of having to declare a different predicate type for each predicate parameter of each section or lemma. - This trick is made possible by the fact that the constructor of the - mem_pred T type aligns the unification process, forcing a generic - "collective" predicate A : pred T to unify with the actual collective B, - which mem has coerced to pred T via an internal, hidden implicit coercion, - supplied by the predType structure for B. Users should take care not to - inadvertently "strip" (mem B) down to the coerced B, since this will - expose the internal coercion: Coq will display a term B x that cannot be - typed as such. The topredE lemma can be used to restore the x \in B - syntax in this case. While -topredE can conversely be used to change - x \in P into P x, it is safer to use the inE and memE lemmas instead, as - they do not run the risk of exposing internal coercions. As a consequence - it is better to explicitly cast a generic applicative pred T to simpl_pred - using the SimplPred constructor, when it is used as a collective predicate - (see, e.g., Lemma eq_big in bigop). + In detail, we ensure that the head normal form of mem A is always of the + eta-long MemPred (fun x => pA x) form, where pA is the pred interpretation of + A following its predType pT, i.e., the _expansion_ of topred A. For a pred T + evar ?P, (mem ?P) converts MemPred (fun x => ?P x), whose argument is a Miller + pattern and therefore always unify: unifying (mem A) with (mem ?P) always + yields ?P = pA, because the rigid constant MemPred aligns the unification. + Furthermore, we ensure pA is always either A or toP .... A where toP ... is + the expansion of @topred T pT, and toP is declared as a Coercion, so pA will + _display_ as A in either case, and the instances of @mem T (predPredType T) pA + appearing in the premises or right-hand side of a generic lemma parametrized + by ?P will be indistinguishable from @mem T pT A. + Users should take care not to inadvertently "strip" (mem A) down to the + coerced A, since this will expose the internal toP coercion: Coq could then + display terms A x that cannot be typed as such. The topredE lemma can be used + to restore the x \in A syntax in this case. While -topredE can conversely be + used to change x \in P into P x for an applicative P, it is safer to use the + inE, unfold_in or and memE lemmas instead, as they do not run the risk of + exposing internal coercions. As a consequence it is better to explicitly + cast a generic applicative predicate to simpl_pred using the SimplPred + constructor when it is used as a collective predicate (see, e.g., + Lemma eq_big in bigop). We also sometimes "instantiate" the predType structure by defining a - coercion to the sort of the predPredType structure. This works better for - types such as {set T} that have subtypes that coerce to them, since the - same coercion will be inserted by the application of mem. It also lets us - turn any Type aT : predArgType into the total predicate over that type, - i.e., fun _: aT => true. This allows us to write, e.g., ##|'I_n| for the - cardinal of the (finite) type of integers less than n. - Collective predicates have a specific extensional equality, - - A =i B, - while applicative predicates use the extensional equality of functions, - - P =1 Q - The two forms are convertible, however. - We lift boolean operations to predicates, defining: - - predU (union), predI (intersection), predC (complement), - predD (difference), and preim (preimage, i.e., composition) - For each operation we define three forms, typically: - - predU : pred T -> pred T -> simpl_pred T - - #[#predU A & B#]#, a Notation for predU (mem A) (mem B) - - xpredU, a Notation for the lambda-expression inside predU, - which is mostly useful as an argument of =1, since it exposes the head - head constant of the expression to the ssreflect matching algorithm. - The syntax for the preimage of a collective predicate A is - - #[#preim f of A#]# - Finally, the generic syntax for defining a simpl_pred T is - - #[#pred x : T | P(x) #]#, #[#pred x | P(x) #]#, #[#pred x in A | P(x) #]#, etc. - We also support boolean relations, but only the applicative form, with - types - - rel T, an alias for T -> pred T - - simpl_rel T, an auto-simplifying version, and syntax - #[#rel x y | P(x,y) #]#, #[#rel x y in A & B | P(x,y) #]#, etc. - The notation #[#rel of fA#]# can be used to coerce a function returning a - collective predicate to one returning pred T. - Finally, note that there is specific support for ambivalent predicates - that can work in either style, as per this file's head descriptor. **) - + coercion to the sort of the predPredType structure, conveniently denoted + {pred T}. This works better for types such as {set T} that have subtypes that + coerce to them, since the same coercion will be inserted by the application + of mem, or of any lemma that expects a generic collective predicates with + type {pred T} := pred_sort (predPredType T) = pred T; thus {pred T} should be + the preferred type for generic collective predicate parameters. + This device also lets us turn any Type aT : predArgType into the total + predicate over that type, i.e., fun _: aT => true. This allows us to write, + e.g., ##|'I_n| for the cardinal of the (finite) type of integers less than n. + **) + +(** Boolean predicates. *) Definition pred T := T -> bool. - Identity Coercion fun_of_pred : pred >-> Funclass. -Definition rel T := T -> pred T. +Definition subpred T (p1 p2 : pred T) := forall x : T, p1 x -> p2 x. -Identity Coercion fun_of_rel : rel >-> Funclass. +(* Notation for some manifest predicates. *) -Notation xpred0 := (fun _ => false). -Notation xpredT := (fun _ => true). +Notation xpred0 := (fun=> false). +Notation xpredT := (fun=> true). Notation xpredI := (fun (p1 p2 : pred _) x => p1 x && p2 x). Notation xpredU := (fun (p1 p2 : pred _) x => p1 x || p2 x). Notation xpredC := (fun (p : pred _) x => ~~ p x). Notation xpredD := (fun (p1 p2 : pred _) x => ~~ p2 x && p1 x). Notation xpreim := (fun f (p : pred _) x => p (f x)). -Notation xrelU := (fun (r1 r2 : rel _) x y => r1 x y || r2 x y). -Section Predicates. +(** The packed class interface for pred-like types. **) -Variables T : Type. - -Definition subpred (p1 p2 : pred T) := forall x, p1 x -> p2 x. - -Definition subrel (r1 r2 : rel T) := forall x y, r1 x y -> r2 x y. - -Definition simpl_pred := simpl_fun T bool. -Definition applicative_pred := pred T. -Definition collective_pred := pred T. +#[universes(template)] +Structure predType T := + PredType {pred_sort :> Type; topred : pred_sort -> pred T}. + +Definition clone_pred T U := + fun pT & @pred_sort T pT -> U => + fun toP (pT' := @PredType T U toP) & phant_id pT' pT => pT'. +Notation "[ 'predType' 'of' T ]" := (@clone_pred _ T _ id _ id) : form_scope. + +Canonical predPredType T := PredType (@id (pred T)). +Canonical boolfunPredType T := PredType (@id (T -> bool)). + +(** The type of abstract collective predicates. + While {pred T} is contertible to pred T, it presents the pred_sort coercion + class, which crucially does _not_ coerce to Funclass. Term whose type P coerces + to {pred T} cannot be applied to arguments, but they _can_ be used as if P + had a canonical predType instance, as the coercion will be inserted if the + unification P =~= pred_sort ?pT fails, changing the problem into the trivial + {pred T} =~= pred_sort ?pT (solution ?pT := predPredType P). + Additional benefits of this approach are that any type coercing to P will + also inherit this behaviour, and that the coercion will be apparent in the + elaborated expression. The latter may be important if the coercion is also + a canonical structure projector - see mathcomp/fingroup/fingroup.v. The + main drawback of implementing predType by coercion in this way is that the + type of the value must be known when the unification constraint is imposed: + if we only register the constraint and then later discover later that the + expression had type P it will be too late of insert a coercion, whereas a + canonical instance of predType fo P would have solved the deferred constraint. + Finally, definitions, lemmas and sections should use type {pred T} for + their generic collective type parameters, as this will make it possible to + apply such definitions and lemmas directly to values of types that implement + predType by coercion to {pred T} (values of types that implement predType + without coercing to {pred T} will have to be coerced explicitly using topred). +**) +Notation "{ 'pred' T }" := (pred_sort (predPredType T)) : type_scope. + +(** The type of self-simplifying collective predicates. **) +Definition simpl_pred T := simpl_fun T bool. +Definition SimplPred {T} (p : pred T) : simpl_pred T := SimplFun p. + +(** Some simpl_pred constructors. **) + +Definition pred0 {T} := @SimplPred T xpred0. +Definition predT {T} := @SimplPred T xpredT. +Definition predI {T} (p1 p2 : pred T) := SimplPred (xpredI p1 p2). +Definition predU {T} (p1 p2 : pred T) := SimplPred (xpredU p1 p2). +Definition predC {T} (p : pred T) := SimplPred (xpredC p). +Definition predD {T} (p1 p2 : pred T) := SimplPred (xpredD p1 p2). +Definition preim {aT rT} (f : aT -> rT) (d : pred rT) := SimplPred (xpreim f d). + +Notation "[ 'pred' : T | E ]" := (SimplPred (fun _ : T => E%B)) : fun_scope. +Notation "[ 'pred' x | E ]" := (SimplPred (fun x => E%B)) : fun_scope. +Notation "[ 'pred' x | E1 & E2 ]" := [pred x | E1 && E2 ] : fun_scope. +Notation "[ 'pred' x : T | E ]" := + (SimplPred (fun x : T => E%B)) (only parsing) : fun_scope. +Notation "[ 'pred' x : T | E1 & E2 ]" := + [pred x : T | E1 && E2 ] (only parsing) : fun_scope. + +(** Coercions for simpl_pred. + As simpl_pred T values are used both applicatively and collectively we + need simpl_pred to coerce to both pred T _and_ {pred T}. However it is + undesireable to have two distinct constants for what are essentially identical + coercion functions, as this confuses the SSReflect keyed matching algorithm. + While the Coq Coercion declarations appear to disallow such Coercion aliasing, + it is possible to work around this limitation with a combination of modules + and functors, which we do below. + In addition we also give a predType instance for simpl_pred, which will + be preferred to the {pred T} coercion to solve simpl_pred T =~= pred_sort ?pT + constraints; not however that the pred_of_simpl coercion _will_ be used + when a simpl_pred T is passed as a {pred T}, since the simplPredType T + structure for simpl_pred T is _not_ convertible to predPredType T. **) + +Module PredOfSimpl. +Definition coerce T (sp : simpl_pred T) : pred T := fun_of_simpl sp. +End PredOfSimpl. +Notation pred_of_simpl := PredOfSimpl.coerce. +Coercion pred_of_simpl : simpl_pred >-> pred. +Canonical simplPredType T := PredType (@pred_of_simpl T). + +Module Type PredSortOfSimplSignature. +Parameter coerce : forall T, simpl_pred T -> {pred T}. +End PredSortOfSimplSignature. +Module DeclarePredSortOfSimpl (PredSortOfSimpl : PredSortOfSimplSignature). +Coercion PredSortOfSimpl.coerce : simpl_pred >-> pred_sort. +End DeclarePredSortOfSimpl. +Module Export PredSortOfSimplCoercion := DeclarePredSortOfSimpl PredOfSimpl. + +(** Type to pred coercion. + This lets us use types of sort predArgType as a synonym for their universal + predicate. We define this predicate as a simpl_pred T rather than a pred T or + a {pred T} so that /= and inE reduce (T x) and x \in T to true, respectively. + Unfortunately, this can't be used for existing types like bool whose sort + is already fixed (at least, not without redefining bool, true, false and + all bool operations and lemmas); we provide syntax to recast a given type + in predArgType as a workaround. **) +Definition predArgType := Type. +Bind Scope type_scope with predArgType. +Identity Coercion sort_of_predArgType : predArgType >-> Sortclass. +Coercion pred_of_argType (T : predArgType) : simpl_pred T := predT. +Notation "{ : T }" := (T%type : predArgType) : type_scope. -Definition SimplPred (p : pred T) : simpl_pred := SimplFun p. +(** Boolean relations. + Simplifying relations follow the coding pattern of 2-argument simplifying + functions: the simplifying type constructor is applied to the _last_ + argument. This design choice will let the in_simpl componenent of inE expand + membership in simpl_rel as well. We provide an explicit coercion to rel T + to avoid eta-expansion during coercion; this coercion self-simplifies so it + should be invisible. + **) -Coercion pred_of_simpl (p : simpl_pred) : pred T := fun_of_simpl p. -Coercion applicative_pred_of_simpl (p : simpl_pred) : applicative_pred := - fun_of_simpl p. -Coercion collective_pred_of_simpl (p : simpl_pred) : collective_pred := - fun x => (let: SimplFun f := p in fun _ => f x) x. -(** - Note: applicative_of_simpl is convertible to pred_of_simpl, while - collective_of_simpl is not. **) +Definition rel T := T -> pred T. +Identity Coercion fun_of_rel : rel >-> Funclass. -Definition pred0 := SimplPred xpred0. -Definition predT := SimplPred xpredT. -Definition predI p1 p2 := SimplPred (xpredI p1 p2). -Definition predU p1 p2 := SimplPred (xpredU p1 p2). -Definition predC p := SimplPred (xpredC p). -Definition predD p1 p2 := SimplPred (xpredD p1 p2). -Definition preim rT f (d : pred rT) := SimplPred (xpreim f d). +Definition subrel T (r1 r2 : rel T) := forall x y : T, r1 x y -> r2 x y. -Definition simpl_rel := simpl_fun T (pred T). +Definition simpl_rel T := T -> simpl_pred T. -Definition SimplRel (r : rel T) : simpl_rel := [fun x => r x]. +Coercion rel_of_simpl T (sr : simpl_rel T) : rel T := fun x : T => sr x. +Arguments rel_of_simpl {T} sr x /. -Coercion rel_of_simpl_rel (r : simpl_rel) : rel T := fun x y => r x y. +Notation xrelU := (fun (r1 r2 : rel _) x y => r1 x y || r2 x y). +Notation xrelpre := (fun f (r : rel _) x y => r (f x) (f y)). -Definition relU r1 r2 := SimplRel (xrelU r1 r2). +Definition SimplRel {T} (r : rel T) : simpl_rel T := fun x => SimplPred (r x). +Definition relU {T} (r1 r2 : rel T) := SimplRel (xrelU r1 r2). +Definition relpre {aT rT} (f : aT -> rT) (r : rel rT) := SimplRel (xrelpre f r). -Lemma subrelUl r1 r2 : subrel r1 (relU r1 r2). -Proof. by move=> *; apply/orP; left. Qed. +Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) : fun_scope. +Notation "[ 'rel' x y : T | E ]" := + (SimplRel (fun x y : T => E%B)) (only parsing) : fun_scope. -Lemma subrelUr r1 r2 : subrel r2 (relU r1 r2). -Proof. by move=> *; apply/orP; right. Qed. +Lemma subrelUl T (r1 r2 : rel T) : subrel r1 (relU r1 r2). +Proof. by move=> x y r1xy; apply/orP; left. Qed. -#[universes(template)] -Variant mem_pred := Mem of pred T. +Lemma subrelUr T (r1 r2 : rel T) : subrel r2 (relU r1 r2). +Proof. by move=> x y r2xy; apply/orP; right. Qed. -Definition isMem pT topred mem := mem = (fun p : pT => Mem [eta topred p]). +(** Variant of simpl_pred specialised to the membership operator. **) #[universes(template)] -Structure predType := PredType { - pred_sort :> Type; - topred : pred_sort -> pred T; - _ : {mem | isMem topred mem} -}. - -Definition mkPredType pT toP := PredType (exist (@isMem pT toP) _ (erefl _)). - -Canonical predPredType := Eval hnf in @mkPredType (pred T) id. -Canonical simplPredType := Eval hnf in mkPredType pred_of_simpl. -Canonical boolfunPredType := Eval hnf in @mkPredType (T -> bool) id. - -Coercion pred_of_mem mp : pred_sort predPredType := let: Mem p := mp in [eta p]. -Canonical memPredType := Eval hnf in mkPredType pred_of_mem. - -Definition clone_pred U := - fun pT & pred_sort pT -> U => - fun a mP (pT' := @PredType U a mP) & phant_id pT' pT => pT'. - -End Predicates. - -Arguments pred0 {T}. -Arguments predT {T}. -Prenex Implicits pred0 predT predI predU predC predD preim relU. - -Notation "[ 'pred' : T | E ]" := (SimplPred (fun _ : T => E%B)) - (at level 0, format "[ 'pred' : T | E ]") : fun_scope. -Notation "[ 'pred' x | E ]" := (SimplPred (fun x => E%B)) - (at level 0, x ident, format "[ 'pred' x | E ]") : fun_scope. -Notation "[ 'pred' x | E1 & E2 ]" := [pred x | E1 && E2 ] - (at level 0, x ident, format "[ 'pred' x | E1 & E2 ]") : fun_scope. -Notation "[ 'pred' x : T | E ]" := (SimplPred (fun x : T => E%B)) - (at level 0, x ident, only parsing) : fun_scope. -Notation "[ 'pred' x : T | E1 & E2 ]" := [pred x : T | E1 && E2 ] - (at level 0, x ident, only parsing) : fun_scope. -Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) - (at level 0, x ident, y ident, format "[ 'rel' x y | E ]") : fun_scope. -Notation "[ 'rel' x y : T | E ]" := (SimplRel (fun x y : T => E%B)) - (at level 0, x ident, y ident, only parsing) : fun_scope. - -Notation "[ 'predType' 'of' T ]" := (@clone_pred _ T _ id _ _ id) - (at level 0, format "[ 'predType' 'of' T ]") : form_scope. +Variant mem_pred T := Mem of pred T. (** - This redundant coercion lets us "inherit" the simpl_predType canonical - instance by declaring a coercion to simpl_pred. This hack is the only way - to put a predType structure on a predArgType. We use simpl_pred rather - than pred to ensure that /= removes the identity coercion. Note that the - coercion will never be used directly for simpl_pred, since the canonical - instance should always be resolved. **) - -Notation pred_class := (pred_sort (predPredType _)). -Coercion sort_of_simpl_pred T (p : simpl_pred T) : pred_class := p : pred T. + We mainly declare pred_of_mem as a coercion so that it is not displayed. + Similarly to pred_of_simpl, it will usually not be inserted by type + inference, as all mem_pred mp =~= pred_sort ?pT unification problems will + be solve by the memPredType instance below; pred_of_mem will however + be used if a mem_pred T is used as a {pred T}, which is desireable as it + will avoid a redundant mem in a collective, e.g., passing (mem A) to a lemma + expection a generic collective predicate p : {pred T} and premise x \in P + will display a subgoal x \in A rathere than x \in mem A. + Conversely, pred_of_mem will _not_ if it is used id (mem A) is used + applicatively or as a pred T; there the simpl_of_mem coercion defined below + will be used, resulting in a subgoal that displays as mem A x by simplifies + to x \in A. + **) +Coercion pred_of_mem {T} mp : {pred T} := let: Mem p := mp in [eta p]. +Canonical memPredType T := PredType (@pred_of_mem T). + +Definition in_mem {T} (x : T) mp := pred_of_mem mp x. +Definition eq_mem {T} mp1 mp2 := forall x : T, in_mem x mp1 = in_mem x mp2. +Definition sub_mem {T} mp1 mp2 := forall x : T, in_mem x mp1 -> in_mem x mp2. + +Arguments in_mem {T} x mp : simpl never. +Typeclasses Opaque eq_mem. +Typeclasses Opaque sub_mem. -(** - This lets us use some types as a synonym for their universal predicate. - Unfortunately, this won't work for existing types like bool, unless we - redefine bool, true, false and all bool ops. **) -Definition predArgType := Type. -Bind Scope type_scope with predArgType. -Identity Coercion sort_of_predArgType : predArgType >-> Sortclass. -Coercion pred_of_argType (T : predArgType) : simpl_pred T := predT. +(** The [simpl_of_mem; pred_of_simpl] path provides a new mem_pred >-> pred + coercion, but does _not_ override the pred_of_mem : mem_pred >-> pred_sort + explicit coercion declaration above. + **) +Coercion simpl_of_mem {T} mp := SimplPred (fun x : T => in_mem x mp). -Notation "{ : T }" := (T%type : predArgType) - (at level 0, format "{ : T }") : type_scope. +Lemma sub_refl T (mp : mem_pred T) : sub_mem mp mp. Proof. by []. Qed. +Arguments sub_refl {T mp} [x] mp_x. (** - These must be defined outside a Section because "cooking" kills the - nosimpl tag. **) - + It is essential to interlock the production of the Mem constructor inside + the branch of the predType match, to ensure that unifying mem A with + Mem [eta ?p] sets ?p := toP A (or ?p := P if toP = id and A = [eta P]), + rather than topred pT A, had we put mem A := Mem (topred A). +**) Definition mem T (pT : predType T) : pT -> mem_pred T := - nosimpl (let: @PredType _ _ _ (exist _ mem _) := pT return pT -> _ in mem). -Definition in_mem T x mp := nosimpl pred_of_mem T mp x. - -Prenex Implicits mem. - -Coercion pred_of_mem_pred T mp := [pred x : T | in_mem x mp]. - -Definition eq_mem T p1 p2 := forall x : T, in_mem x p1 = in_mem x p2. -Definition sub_mem T p1 p2 := forall x : T, in_mem x p1 -> in_mem x p2. - -Typeclasses Opaque eq_mem. - -Lemma sub_refl T (p : mem_pred T) : sub_mem p p. Proof. by []. Qed. -Arguments sub_refl {T p}. + let: PredType toP := pT in fun A => Mem [eta toP A]. +Arguments mem {T pT} A : rename, simpl never. Notation "x \in A" := (in_mem x (mem A)) : bool_scope. Notation "x \in A" := (in_mem x (mem A)) : bool_scope. Notation "x \notin A" := (~~ (x \in A)) : bool_scope. Notation "A =i B" := (eq_mem (mem A) (mem B)) : type_scope. -Notation "{ 'subset' A <= B }" := (sub_mem (mem A) (mem B)) - (at level 0, A, B at level 69, - format "{ '[hv' 'subset' A '/ ' <= B ']' }") : type_scope. -Notation "[ 'mem' A ]" := (pred_of_simpl (pred_of_mem_pred (mem A))) - (at level 0, only parsing) : fun_scope. -Notation "[ 'rel' 'of' fA ]" := (fun x => [mem (fA x)]) - (at level 0, format "[ 'rel' 'of' fA ]") : fun_scope. -Notation "[ 'predI' A & B ]" := (predI [mem A] [mem B]) - (at level 0, format "[ 'predI' A & B ]") : fun_scope. -Notation "[ 'predU' A & B ]" := (predU [mem A] [mem B]) - (at level 0, format "[ 'predU' A & B ]") : fun_scope. -Notation "[ 'predD' A & B ]" := (predD [mem A] [mem B]) - (at level 0, format "[ 'predD' A & B ]") : fun_scope. -Notation "[ 'predC' A ]" := (predC [mem A]) - (at level 0, format "[ 'predC' A ]") : fun_scope. -Notation "[ 'preim' f 'of' A ]" := (preim f [mem A]) - (at level 0, format "[ 'preim' f 'of' A ]") : fun_scope. - -Notation "[ 'pred' x 'in' A ]" := [pred x | x \in A] - (at level 0, x ident, format "[ 'pred' x 'in' A ]") : fun_scope. -Notation "[ 'pred' x 'in' A | E ]" := [pred x | x \in A & E] - (at level 0, x ident, format "[ 'pred' x 'in' A | E ]") : fun_scope. -Notation "[ 'pred' x 'in' A | E1 & E2 ]" := [pred x | x \in A & E1 && E2 ] - (at level 0, x ident, - format "[ 'pred' x 'in' A | E1 & E2 ]") : fun_scope. +Notation "{ 'subset' A <= B }" := (sub_mem (mem A) (mem B)) : type_scope. + +Notation "[ 'mem' A ]" := + (pred_of_simpl (simpl_of_mem (mem A))) (only parsing) : fun_scope. + +Notation "[ 'predI' A & B ]" := (predI [mem A] [mem B]) : fun_scope. +Notation "[ 'predU' A & B ]" := (predU [mem A] [mem B]) : fun_scope. +Notation "[ 'predD' A & B ]" := (predD [mem A] [mem B]) : fun_scope. +Notation "[ 'predC' A ]" := (predC [mem A]) : fun_scope. +Notation "[ 'preim' f 'of' A ]" := (preim f [mem A]) : fun_scope. +Notation "[ 'pred' x 'in' A ]" := [pred x | x \in A] : fun_scope. +Notation "[ 'pred' x 'in' A | E ]" := [pred x | x \in A & E] : fun_scope. +Notation "[ 'pred' x 'in' A | E1 & E2 ]" := + [pred x | x \in A & E1 && E2 ] : fun_scope. + Notation "[ 'rel' x y 'in' A & B | E ]" := - [rel x y | (x \in A) && (y \in B) && E] - (at level 0, x ident, y ident, - format "[ 'rel' x y 'in' A & B | E ]") : fun_scope. -Notation "[ 'rel' x y 'in' A & B ]" := [rel x y | (x \in A) && (y \in B)] - (at level 0, x ident, y ident, - format "[ 'rel' x y 'in' A & B ]") : fun_scope. -Notation "[ 'rel' x y 'in' A | E ]" := [rel x y in A & A | E] - (at level 0, x ident, y ident, - format "[ 'rel' x y 'in' A | E ]") : fun_scope. -Notation "[ 'rel' x y 'in' A ]" := [rel x y in A & A] - (at level 0, x ident, y ident, - format "[ 'rel' x y 'in' A ]") : fun_scope. - -Section simpl_mem. - -Variables (T : Type) (pT : predType T). -Implicit Types (x : T) (p : pred T) (sp : simpl_pred T) (pp : pT). + [rel x y | (x \in A) && (y \in B) && E] : fun_scope. +Notation "[ 'rel' x y 'in' A & B ]" := + [rel x y | (x \in A) && (y \in B)] : fun_scope. +Notation "[ 'rel' x y 'in' A | E ]" := [rel x y in A & A | E] : fun_scope. +Notation "[ 'rel' x y 'in' A ]" := [rel x y in A & A] : fun_scope. + +(** Aliases of pred T that let us tag intances of simpl_pred as applicative + or collective, via bespoke coercions. This tagging will give control over + the simplification behaviour of inE and othe rewriting lemmas below. + For this control to work it is crucial that collective_of_simpl _not_ + be convertible to either applicative_of_simpl or pred_of_simpl. Indeed + they differ here by a commutattive conversion (of the match and lambda). + **) +Definition applicative_pred T := pred T. +Definition collective_pred T := pred T. +Coercion applicative_pred_of_simpl T (sp : simpl_pred T) : applicative_pred T := + fun_of_simpl sp. +Coercion collective_pred_of_simpl T (sp : simpl_pred T) : collective_pred T := + let: SimplFun p := sp in p. + +(** Explicit simplification rules for predicate application and membership. **) +Section PredicateSimplification. + +Variables T : Type. + +Implicit Types (p : pred T) (pT : predType T) (sp : simpl_pred T). +Implicit Types (mp : mem_pred T). (** - Bespoke structures that provide fine-grained control over matching the - various forms of the \in predicate; note in particular the different forms - of hoisting that are used. We had to work around several bugs in the - implementation of unification, notably improper expansion of telescope - projections and overwriting of a variable assignment by a later - unification (probably due to conversion cache cross-talk). **) + The following four bespoke structures provide fine-grained control over + matching the various predicate forms. While all four follow a common pattern + of using a canonical projection to match a particular form of predicate + (in pred T, simpl_pred, mem_pred and mem_pred, respectively), and display + the matched predicate in the structure type, each is in fact used for a + different, specific purpose: + - registered_applicative_pred: this user-facing structure is used to + declare values of type pred T meant to be used applicatively. The + structure parameter merely displays this same value, and is used to avoid + undesireable, visible occurrence of the structure in the right hand side + of rewrite rules such as app_predE. + There is a canonical instance of registered_applicative_pred for values + of the applicative_of_simpl coercion, which handles the + Definition Apred : applicative_pred T := [pred x | ...] idiom. + This instance is mainly intended for the in_applicative component of inE, + in conjunction with manifest_mem_pred and applicative_mem_pred. + - manifest_simpl_pred: the only instance of this structure matches manifest + simpl_pred values of the form SimplPred p, displaying p in the structure + type. This structure is used in in_simpl to detect and selectively expand + collective predicates of this form. An explicit SimplPred p pattern would + _NOT_ work for this purpose, as then the left-hand side of in_simpl would + reduce to in_mem ?x (Mem [eta ?p]) and would thus match _any_ instance + of \in, not just those arising from a manifest simpl_pred. + - manifest_mem_pred: similar to manifest_simpl_pred, the one instance of this + structure matches manifest mem_pred values of the form Mem [eta ?p]. The + purpose is different however: to match and display in ?p the actual + predicate appearing in an ... \in ... expression matched by the left hand + side of the in_applicative component of inE; then + - applicative_mem_pred is a telescope refinement of manifest_mem_pred p with + a default constructor that checks that the predicate p is the value of a + registered_applicative_pred; any unfolding occurring during this check + does _not_ affect the value of p passed to in_applicative, since that + has been fixed earlier by the manifest_mem_pred match. In particular the + definition of a predicate using the applicative_pred_of_simpl idiom above + will not be expanded - this very case is the reason in_applicative uses + a mem_pred telescope in its left hand side. The more straighforward + ?x \in applicative_pred_value ?ap (equivalent to in_mem ?x (Mem ?ap)) + with ?ap : registered_applicative_pred ?p would set ?p := [pred x | ...] + rather than ?p := Apred in the example above. + Also note that the in_applicative component of inE must be come before the + in_simpl one, as the latter also matches terms of the form x \in Apred. + Finally, no component of inE matches x \in Acoll, when + Definition Acoll : collective_pred T := [pred x | ...]. + as the collective_pred_of_simpl is _not_ convertible to pred_of_simpl. **) + #[universes(template)] -Structure manifest_applicative_pred p := ManifestApplicativePred { - manifest_applicative_pred_value :> pred T; - _ : manifest_applicative_pred_value = p +Structure registered_applicative_pred p := RegisteredApplicativePred { + applicative_pred_value :> pred T; + _ : applicative_pred_value = p }. -Definition ApplicativePred p := ManifestApplicativePred (erefl p). +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 { - manifest_simpl_pred_value :> simpl_pred T; - _ : manifest_simpl_pred_value = SimplPred p + 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 { - manifest_mem_pred_value :> mem_pred T; - _ : manifest_mem_pred_value= Mem [eta p] + mem_pred_value :> mem_pred T; + _ : mem_pred_value = Mem [eta p] }. -Canonical expose_mem_pred p := @ManifestMemPred p _ (erefl _). +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 : manifest_applicative_pred p) mp := - @ApplicativeMemPred ap mp. +Canonical check_applicative_mem_pred p (ap : registered_applicative_pred p) := + [eta @ApplicativeMemPred ap]. -Lemma mem_topred (pp : pT) : mem (topred pp) = mem pp. -Proof. by rewrite /mem; case: pT pp => T1 app1 [mem1 /= ->]. Qed. +Lemma mem_topred pT (pp : pT) : mem (topred pp) = mem pp. +Proof. by case: pT pp. Qed. -Lemma topredE x (pp : pT) : topred pp x = (x \in pp). +Lemma topredE pT x (pp : pT) : topred pp x = (x \in pp). Proof. by rewrite -mem_topred. Qed. -Lemma app_predE x p (ap : manifest_applicative_pred p) : ap x = (x \in p). +Lemma app_predE x p (ap : registered_applicative_pred p) : ap x = (x \in p). Proof. by case: ap => _ /= ->. Qed. Lemma in_applicative x p (amp : applicative_mem_pred p) : in_mem x amp = p x. -Proof. by case: amp => [[_ /= ->]]. Qed. +Proof. by case: amp => -[_ /= ->]. Qed. Lemma in_collective x p (msp : manifest_simpl_pred p) : (x \in collective_pred_of_simpl msp) = p x. Proof. by case: msp => _ /= ->. Qed. Lemma in_simpl x p (msp : manifest_simpl_pred p) : - in_mem x (Mem [eta fun_of_simpl (msp : simpl_pred T)]) = p x. + in_mem x (Mem [eta pred_of_simpl msp]) = p x. Proof. by case: msp => _ /= ->. Qed. (** Because of the explicit eta expansion in the left-hand side, this lemma - should only be used in a right-to-left direction. The 8.3 hack allowing - partial right-to-left use does not work with the improved expansion - heuristics in 8.4. **) + should only be used in the left-to-right direction. + **) Lemma unfold_in x p : (x \in ([eta p] : pred T)) = p x. Proof. by []. Qed. @@ -1345,55 +1530,39 @@ Proof. by []. Qed. Definition memE := mem_simpl. (* could be extended *) -Lemma mem_mem (pp : pT) : (mem (mem pp) = mem pp) * (mem [mem pp] = mem pp). -Proof. by rewrite -mem_topred. Qed. +Lemma mem_mem mp : + (mem mp = mp) * (mem (mp : simpl_pred T) = mp) * (mem (mp : pred T) = mp). +Proof. by case: mp. Qed. -End simpl_mem. +End PredicateSimplification. (** Qualifiers and keyed predicates. **) #[universes(template)] -Variant qualifier (q : nat) T := Qualifier of predPredType T. +Variant qualifier (q : nat) T := Qualifier of {pred T}. -Coercion has_quality n T (q : qualifier n T) : pred_class := +Coercion has_quality n T (q : qualifier n T) : {pred T} := fun x => let: Qualifier _ p := q in p x. Arguments has_quality n {T}. Lemma qualifE n T p x : (x \in @Qualifier n T p) = p x. Proof. by []. Qed. -Notation "x \is A" := (x \in has_quality 0 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \is A ']'") : bool_scope. -Notation "x \is 'a' A" := (x \in has_quality 1 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \is 'a' A ']'") : bool_scope. -Notation "x \is 'an' A" := (x \in has_quality 2 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \is 'an' A ']'") : bool_scope. -Notation "x \isn't A" := (x \notin has_quality 0 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \isn't A ']'") : bool_scope. -Notation "x \isn't 'a' A" := (x \notin has_quality 1 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \isn't 'a' A ']'") : bool_scope. -Notation "x \isn't 'an' A" := (x \notin has_quality 2 A) - (at level 70, no associativity, - format "'[hv' x '/ ' \isn't 'an' A ']'") : bool_scope. -Notation "[ 'qualify' x | P ]" := (Qualifier 0 (fun x => P%B)) - (at level 0, x at level 99, - format "'[hv' [ 'qualify' x | '/ ' P ] ']'") : form_scope. -Notation "[ 'qualify' x : T | P ]" := (Qualifier 0 (fun x : T => P%B)) - (at level 0, x at level 99, only parsing) : form_scope. -Notation "[ 'qualify' 'a' x | P ]" := (Qualifier 1 (fun x => P%B)) - (at level 0, x at level 99, - format "'[hv' [ 'qualify' 'a' x | '/ ' P ] ']'") : form_scope. -Notation "[ 'qualify' 'a' x : T | P ]" := (Qualifier 1 (fun x : T => P%B)) - (at level 0, x at level 99, only parsing) : form_scope. -Notation "[ 'qualify' 'an' x | P ]" := (Qualifier 2 (fun x => P%B)) - (at level 0, x at level 99, - format "'[hv' [ 'qualify' 'an' x | '/ ' P ] ']'") : form_scope. -Notation "[ 'qualify' 'an' x : T | P ]" := (Qualifier 2 (fun x : T => P%B)) - (at level 0, x at level 99, only parsing) : form_scope. +Notation "x \is A" := (x \in has_quality 0 A) : bool_scope. +Notation "x \is 'a' A" := (x \in has_quality 1 A) : bool_scope. +Notation "x \is 'an' A" := (x \in has_quality 2 A) : bool_scope. +Notation "x \isn't A" := (x \notin has_quality 0 A) : bool_scope. +Notation "x \isn't 'a' A" := (x \notin has_quality 1 A) : bool_scope. +Notation "x \isn't 'an' A" := (x \notin has_quality 2 A) : bool_scope. +Notation "[ 'qualify' x | P ]" := (Qualifier 0 (fun x => P%B)) : form_scope. +Notation "[ 'qualify' x : T | P ]" := + (Qualifier 0 (fun x : T => P%B)) (only parsing) : form_scope. +Notation "[ 'qualify' 'a' x | P ]" := (Qualifier 1 (fun x => P%B)) : form_scope. +Notation "[ 'qualify' 'a' x : T | P ]" := + (Qualifier 1 (fun x : T => P%B)) (only parsing) : form_scope. +Notation "[ 'qualify' 'an' x | P ]" := + (Qualifier 2 (fun x => P%B)) : form_scope. +Notation "[ 'qualify' 'an' x : T | P ]" := + (Qualifier 2 (fun x : T => P%B)) (only parsing) : form_scope. (** Keyed predicates: support for property-bearing predicate interfaces. **) @@ -1401,12 +1570,12 @@ Section KeyPred. Variable T : Type. #[universes(template)] -Variant pred_key (p : predPredType T) := DefaultPredKey. +Variant pred_key (p : {pred T}) := DefaultPredKey. -Variable p : predPredType T. +Variable p : {pred T}. #[universes(template)] Structure keyed_pred (k : pred_key p) := - PackKeyedPred {unkey_pred :> pred_class; _ : unkey_pred =i p}. + PackKeyedPred {unkey_pred :> {pred T}; _ : unkey_pred =i p}. Variable k : pred_key p. Definition KeyedPred := @PackKeyedPred k p (frefl _). @@ -1418,10 +1587,10 @@ Lemma keyed_predE : k_p =i p. Proof. by case: k_p. Qed. Instances that strip the mem cast; the first one has "pred_of_mem" as its projection head value, while the second has "pred_of_simpl". The latter has the side benefit of preempting accidental misdeclarations. - Note: pred_of_mem is the registered mem >-> pred_class coercion, while - simpl_of_mem; pred_of_simpl is the mem >-> pred >=> Funclass coercion. We + Note: pred_of_mem is the registered mem >-> pred_sort coercion, while + [simpl_of_mem; pred_of_simpl] is the mem >-> pred >=> Funclass coercion. We must write down the coercions explicitly as the Canonical head constant - computation does not strip casts !! **) + computation does not strip casts. **) Canonical keyed_mem := @PackKeyedPred k (pred_of_mem (mem k_p)) keyed_predE. Canonical keyed_mem_simpl := @@ -1429,8 +1598,8 @@ Canonical keyed_mem_simpl := End KeyPred. -Notation "x \i 'n' S" := (x \in @unkey_pred _ S _ _) - (at level 70, format "'[hv' x '/ ' \i 'n' S ']'") : bool_scope. +Local Notation in_unkey x S := (x \in @unkey_pred _ S _ _) (only parsing). +Notation "x \in S" := (in_unkey x S) (only printing) : bool_scope. Section KeyedQualifier. @@ -1447,12 +1616,12 @@ Canonical keyed_qualifier_keyed := PackKeyedPred k keyed_qualifier_suproof. End KeyedQualifier. -Notation "x \i 's' A" := (x \i n has_quality 0 A) - (at level 70, format "'[hv' x '/ ' \i 's' A ']'") : bool_scope. -Notation "x \i 's' 'a' A" := (x \i n has_quality 1 A) - (at level 70, format "'[hv' x '/ ' \i 's' 'a' A ']'") : bool_scope. -Notation "x \i 's' 'an' A" := (x \i n has_quality 2 A) - (at level 70, format "'[hv' x '/ ' \i 's' 'an' A ']'") : bool_scope. +Notation "x \is A" := + (in_unkey x (has_quality 0 A)) (only printing) : bool_scope. +Notation "x \is 'a' A" := + (in_unkey x (has_quality 1 A)) (only printing) : bool_scope. +Notation "x \is 'an' A" := + (in_unkey x (has_quality 2 A)) (only printing) : bool_scope. Module DefaultKeying. @@ -1592,7 +1761,7 @@ Definition prop_on2 Pf P & phantom T3 (Pf f) & ph {all2 P} := End LocalProperties. Definition inPhantom := Phantom Prop. -Definition onPhantom T P (x : T) := Phantom Prop (P x). +Definition onPhantom {T} P (x : T) := Phantom Prop (P x). Definition bijective_in aT rT (d : mem_pred aT) (f : aT -> rT) := exists2 g, prop_in1 d (inPhantom (cancel f g)) @@ -1602,59 +1771,30 @@ Definition bijective_on aT rT (cd : mem_pred rT) (f : aT -> rT) := exists2 g, prop_on1 cd (Phantom _ (cancel f)) (onPhantom (cancel f) g) & prop_in1 cd (inPhantom (cancel g f)). -Notation "{ 'for' x , P }" := - (prop_for x (inPhantom P)) - (at level 0, format "{ 'for' x , P }") : type_scope. - -Notation "{ 'in' d , P }" := - (prop_in1 (mem d) (inPhantom P)) - (at level 0, format "{ 'in' d , P }") : type_scope. - +Notation "{ 'for' x , P }" := (prop_for x (inPhantom P)) : type_scope. +Notation "{ 'in' d , P }" := (prop_in1 (mem d) (inPhantom P)) : type_scope. Notation "{ 'in' d1 & d2 , P }" := - (prop_in11 (mem d1) (mem d2) (inPhantom P)) - (at level 0, format "{ 'in' d1 & d2 , P }") : type_scope. - -Notation "{ 'in' d & , P }" := - (prop_in2 (mem d) (inPhantom P)) - (at level 0, format "{ 'in' d & , P }") : type_scope. - + (prop_in11 (mem d1) (mem d2) (inPhantom P)) : type_scope. +Notation "{ 'in' d & , P }" := (prop_in2 (mem d) (inPhantom P)) : type_scope. Notation "{ 'in' d1 & d2 & d3 , P }" := - (prop_in111 (mem d1) (mem d2) (mem d3) (inPhantom P)) - (at level 0, format "{ 'in' d1 & d2 & d3 , P }") : type_scope. - + (prop_in111 (mem d1) (mem d2) (mem d3) (inPhantom P)) : type_scope. Notation "{ 'in' d1 & & d3 , P }" := - (prop_in21 (mem d1) (mem d3) (inPhantom P)) - (at level 0, format "{ 'in' d1 & & d3 , P }") : type_scope. - + (prop_in21 (mem d1) (mem d3) (inPhantom P)) : type_scope. Notation "{ 'in' d1 & d2 & , P }" := - (prop_in12 (mem d1) (mem d2) (inPhantom P)) - (at level 0, format "{ 'in' d1 & d2 & , P }") : type_scope. - -Notation "{ 'in' d & & , P }" := - (prop_in3 (mem d) (inPhantom P)) - (at level 0, format "{ 'in' d & & , P }") : type_scope. - + (prop_in12 (mem d1) (mem d2) (inPhantom P)) : type_scope. +Notation "{ 'in' d & & , P }" := (prop_in3 (mem d) (inPhantom P)) : type_scope. Notation "{ 'on' cd , P }" := - (prop_on1 (mem cd) (inPhantom P) (inPhantom P)) - (at level 0, format "{ 'on' cd , P }") : type_scope. + (prop_on1 (mem cd) (inPhantom P) (inPhantom P)) : type_scope. Notation "{ 'on' cd & , P }" := - (prop_on2 (mem cd) (inPhantom P) (inPhantom P)) - (at level 0, format "{ 'on' cd & , P }") : type_scope. - -Local Arguments onPhantom {_%type_scope} _ _. + (prop_on2 (mem cd) (inPhantom P) (inPhantom P)) : type_scope. +Local Arguments onPhantom : clear scopes. Notation "{ 'on' cd , P & g }" := - (prop_on1 (mem cd) (Phantom (_ -> Prop) P) (onPhantom P g)) - (at level 0, format "{ 'on' cd , P & g }") : type_scope. - -Notation "{ 'in' d , 'bijective' f }" := (bijective_in (mem d) f) - (at level 0, f at level 8, - format "{ 'in' d , 'bijective' f }") : type_scope. - -Notation "{ 'on' cd , 'bijective' f }" := (bijective_on (mem cd) f) - (at level 0, f at level 8, - format "{ 'on' cd , 'bijective' f }") : type_scope. + (prop_on1 (mem cd) (Phantom (_ -> Prop) P) (onPhantom P g)) : type_scope. +Notation "{ 'in' d , 'bijective' f }" := (bijective_in (mem d) f) : type_scope. +Notation "{ 'on' cd , 'bijective' f }" := + (bijective_on (mem cd) f) : type_scope. (** Weakening and monotonicity lemmas for localized predicates. @@ -1666,7 +1806,7 @@ Notation "{ 'on' cd , 'bijective' f }" := (bijective_on (mem cd) f) Section LocalGlobal. Variables T1 T2 T3 : predArgType. -Variables (D1 : pred T1) (D2 : pred T2) (D3 : pred T3). +Variables (D1 : {pred T1}) (D2 : {pred T2}) (D3 : {pred T3}). Variables (d1 d1' : mem_pred T1) (d2 d2' : mem_pred T2) (d3 d3' : mem_pred T3). Variables (f f' : T1 -> T2) (g : T2 -> T1) (h : T3). Variables (P1 : T1 -> Prop) (P2 : T1 -> T2 -> Prop). @@ -1850,7 +1990,7 @@ End MonoHomoMorphismTheory. Section MonoHomoMorphismTheory_in. Variables (aT rT sT : predArgType) (f : aT -> rT) (g : rT -> aT). -Variable (aD : pred aT). +Variable (aD : {pred aT}). Variable (aP : pred aT) (rP : pred rT) (aR : rel aT) (rR : rel rT). Notation rD := [pred x | g x \in aD]. diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index a4caeb403c..56f17703ff 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -427,7 +427,7 @@ let mk_anon_id t gl_ids = Id.of_string_soft (Bytes.to_string (loop (n - 1))) let convert_concl_no_check t = Tactics.convert_concl ~check:false t DEFAULTcast -let convert_concl t = Tactics.convert_concl t DEFAULTcast +let convert_concl ~check t = Tactics.convert_concl ~check t DEFAULTcast let rename_hd_prod orig_name_ref gl = match EConstr.kind (project gl) (pf_concl gl) with @@ -799,7 +799,7 @@ let discharge_hyp (id', (id, mode)) gl = | NamedDecl.LocalDef (_, v, t), _ -> let id' = {(NamedDecl.get_annot decl) with binder_name = Name id'} in Proofview.V82.of_tactic - (convert_concl (EConstr.of_constr (mkLetIn (id', v, t, cl')))) gl + (convert_concl ~check:true (EConstr.of_constr (mkLetIn (id', v, t, cl')))) gl (* wildcard names *) let clear_wilds wilds gl = @@ -1170,7 +1170,7 @@ let gentac gen gl = ppdebug(lazy(str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c)); let gl = pf_merge_uc ucst gl in if conv - then tclTHEN (Proofview.V82.of_tactic (convert_concl cl)) (old_cleartac clr) gl + then tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl)) (old_cleartac clr) gl else genclrtac cl [c] clr gl let genstac (gens, clr) = @@ -1215,7 +1215,7 @@ let unprotecttac gl = let prot, _ = EConstr.destConst (project gl) c in Tacticals.onClause (fun idopt -> let hyploc = Option.map (fun id -> id, InHyp) idopt in - Proofview.V82.of_tactic (Tactics.reduct_option + Proofview.V82.of_tactic (Tactics.reduct_option ~check:false (Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fBETA; @@ -1282,10 +1282,10 @@ let clr_of_wgen gen clrs = match gen with | clr, _ -> old_cleartac clr :: clrs -let reduct_in_concl t = Tactics.reduct_in_concl (t, DEFAULTcast) +let reduct_in_concl ~check t = Tactics.reduct_in_concl ~check (t, DEFAULTcast) let unfold cl = let module R = Reductionops in let module F = CClosure.RedFlags in - reduct_in_concl (R.clos_norm_flags (F.mkflags + reduct_in_concl ~check:false (R.clos_norm_flags (F.mkflags (List.map (fun c -> F.fCONST (fst (destConst (EConstr.Unsafe.to_constr c)))) cl @ [F.fBETA; F.fMATCH; F.fFIX; F.fCOFIX]))) diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 58ce84ecb3..575f016014 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -252,7 +252,7 @@ val ssrevaltac : Tacinterp.interp_sign -> Tacinterp.Value.t -> unit Proofview.tactic val convert_concl_no_check : EConstr.t -> unit Proofview.tactic -val convert_concl : EConstr.t -> unit Proofview.tactic +val convert_concl : check:bool -> EConstr.t -> unit Proofview.tactic val red_safe : Reductionops.reduction_function -> diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index 6c74ac1960..5e3e8ce5fb 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -28,6 +28,11 @@ Declare ML Module "ssreflect_plugin". argumentType c == the T such that c : forall x : T, P x. returnType c == the R such that c : T -> R. {type of c for s} == P s where c : forall x : T, P x. + nonPropType == an interface for non-Prop Types: a nonPropType coerces + to a Type, and only types that do _not_ have sort + Prop are canonical nonPropType instances. This is + useful for applied views (see mid-file comment). + notProp T == the nonPropType instance for type T. phantom T v == singleton type with inhabitant Phantom T v. phant T == singleton type with inhabitant Phant v. =^~ r == the converse of rewriting rule r (e.g., in a @@ -57,8 +62,6 @@ Declare ML Module "ssreflect_plugin". More information about these definitions and their use can be found in the ssreflect manual, and in specific comments below. **) - - Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. @@ -77,7 +80,8 @@ Reserved Notation "(* 69 *)" (at level 69). (** Non ambiguous keyword to check if the SsrSyntax module is imported **) Reserved Notation "(* Use to test if 'SsrSyntax_is_Imported' *)" (at level 8). -Reserved Notation "<hidden n >" (at level 200). +Reserved Notation "<hidden n >" (at level 0, n at level 0, + format "<hidden n >"). Reserved Notation "T (* n *)" (at level 200, format "T (* n *)"). End SsrSyntax. @@ -85,6 +89,39 @@ End SsrSyntax. Export SsrMatchingSyntax. Export SsrSyntax. +(** Save primitive notation that will be overloaded. **) +Local Notation CoqGenericIf c vT vF := (if c then vT else vF) (only parsing). +Local Notation CoqGenericDependentIf c x R vT vF := + (if c as x return R then vT else vF) (only parsing). +Local Notation CoqCast x T := (x : T) (only parsing). + +(** Reserve notation that introduced in this file. **) +Reserved Notation "'if' c 'then' vT 'else' vF" (at level 200, + c, vT, vF at level 200, only parsing). +Reserved Notation "'if' c 'return' R 'then' vT 'else' vF" (at level 200, + c, R, vT, vF at level 200, only parsing). +Reserved Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" (at level 200, + c, R, vT, vF at level 200, x ident, only parsing). + +Reserved Notation "x : T" (at level 100, right associativity, + format "'[hv' x '/ ' : T ']'"). +Reserved Notation "T : 'Type'" (at level 100, format "T : 'Type'"). +Reserved Notation "P : 'Prop'" (at level 100, format "P : 'Prop'"). + +Reserved Notation "[ 'the' sT 'of' v 'by' f ]" (at level 0, + format "[ 'the' sT 'of' v 'by' f ]"). +Reserved Notation "[ 'the' sT 'of' v ]" (at level 0, + format "[ 'the' sT 'of' v ]"). +Reserved Notation "{ 'type' 'of' c 'for' s }" (at level 0, + format "{ 'type' 'of' c 'for' s }"). + +Reserved Notation "=^~ r" (at level 100, format "=^~ r"). + +Reserved Notation "[ 'unlockable' 'of' C ]" (at level 0, + format "[ 'unlockable' 'of' C ]"). +Reserved Notation "[ 'unlockable' 'fun' C ]" (at level 0, + format "[ 'unlockable' 'fun' C ]"). + (** To define notations for tactic in intro patterns. When "=> /t" is parsed, "t:%ssripat" is actually interpreted. **) @@ -100,32 +137,28 @@ Delimit Scope ssripat_scope with ssripat. Declare Scope general_if_scope. Delimit Scope general_if_scope with GEN_IF. -Notation "'if' c 'then' v1 'else' v2" := - (if c then v1 else v2) - (at level 200, c, v1, v2 at level 200, only parsing) : general_if_scope. +Notation "'if' c 'then' vT 'else' vF" := + (CoqGenericIf c vT vF) (only parsing) : general_if_scope. -Notation "'if' c 'return' t 'then' v1 'else' v2" := - (if c return t then v1 else v2) - (at level 200, c, t, v1, v2 at level 200, only parsing) : general_if_scope. +Notation "'if' c 'return' R 'then' vT 'else' vF" := + (CoqGenericDependentIf c c R vT vF) (only parsing) : general_if_scope. -Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := - (if c as x return t then v1 else v2) - (at level 200, c, t, v1, v2 at level 200, x ident, only parsing) - : general_if_scope. +Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" := + (CoqGenericDependentIf c x R vT vF) (only parsing) : general_if_scope. (** Force boolean interpretation of simple if expressions. **) Declare Scope boolean_if_scope. Delimit Scope boolean_if_scope with BOOL_IF. -Notation "'if' c 'return' t 'then' v1 'else' v2" := - (if c%bool is true in bool return t then v1 else v2) : boolean_if_scope. +Notation "'if' c 'return' R 'then' vT 'else' vF" := + (if c is true as c in bool return R then vT else vF) : boolean_if_scope. -Notation "'if' c 'then' v1 'else' v2" := - (if c%bool is true in bool return _ then v1 else v2) : boolean_if_scope. +Notation "'if' c 'then' vT 'else' vF" := + (if c%bool is true as _ in bool return _ then vT else vF) : boolean_if_scope. -Notation "'if' c 'as' x 'return' t 'then' v1 'else' v2" := - (if c%bool is true as x in bool return t then v1 else v2) : boolean_if_scope. +Notation "'if' c 'as' x 'return' R 'then' vT 'else' vF" := + (if c%bool is true as x in bool return R then vT else vF) : boolean_if_scope. Open Scope boolean_if_scope. @@ -149,19 +182,15 @@ Open Scope form_scope. precedence of the notation, which binds less tightly than application), and put printing boxes that print the type of a long definition on a separate line rather than force-fit it at the right margin. **) -Notation "x : T" := (x : T) - (at level 100, right associativity, - format "'[hv' x '/ ' : T ']'") : core_scope. +Notation "x : T" := (CoqCast x T) : core_scope. (** Allow the casual use of notations like nat * nat for explicit Type declarations. Note that (nat * nat : Type) is NOT equivalent to (nat * nat)%%type, whose inferred type is legacy type "Set". **) -Notation "T : 'Type'" := (T%type : Type) - (at level 100, only parsing) : core_scope. +Notation "T : 'Type'" := (CoqCast T%type Type) (only parsing) : core_scope. (** Allow similarly Prop annotation for, e.g., rewrite multirules. **) -Notation "P : 'Prop'" := (P%type : Prop) - (at level 100, only parsing) : core_scope. +Notation "P : 'Prop'" := (CoqCast P%type Prop) (only parsing) : core_scope. (** Constants for abstract: and #[#: name #]# intro pattern **) Definition abstract_lock := unit. @@ -170,8 +199,10 @@ Definition abstract_key := tt. Definition abstract (statement : Type) (id : nat) (lock : abstract_lock) := let: tt := lock in statement. -Notation "<hidden n >" := (abstract _ n _). -Notation "T (* n *)" := (abstract T n abstract_key). +Declare Scope ssr_scope. +Notation "<hidden n >" := (abstract _ n _) : ssr_scope. +Notation "T (* n *)" := (abstract T n abstract_key) : ssr_scope. +Open Scope ssr_scope. Register abstract_lock as plugins.ssreflect.abstract_lock. Register abstract_key as plugins.ssreflect.abstract_key. @@ -222,28 +253,27 @@ Local Arguments get_by _%type_scope _%type_scope _ _ _ _. Notation "[ 'the' sT 'of' v 'by' f ]" := (@get_by _ sT f _ _ ((fun v' (s : sT) => Put v' (f s) s) v _)) - (at level 0, only parsing) : form_scope. + (only parsing) : form_scope. -Notation "[ 'the' sT 'of' v ]" := (get ((fun s : sT => Put v (*coerce*)s s) _)) - (at level 0, only parsing) : form_scope. +Notation "[ 'the' sT 'of' v ]" := (get ((fun s : sT => Put v (*coerce*) s s) _)) + (only parsing) : form_scope. (** - The following are "format only" versions of the above notations. Since Coq - doesn't provide this facility, we fake it by splitting the "the" keyword. + The following are "format only" versions of the above notations. We need to do this to prevent the formatter from being be thrown off by application collapsing, coercion insertion and beta reduction in the right hand side of the notations above. **) -Notation "[ 'th' 'e' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) - (at level 0, format "[ 'th' 'e' sT 'of' v 'by' f ]") : form_scope. +Notation "[ 'the' sT 'of' v 'by' f ]" := (@get_by _ sT f v _ _) + (only printing) : form_scope. -Notation "[ 'th' 'e' sT 'of' v ]" := (@get _ sT v _ _) - (at level 0, format "[ 'th' 'e' sT 'of' v ]") : form_scope. +Notation "[ 'the' sT 'of' v ]" := (@get _ sT v _ _) + (only printing) : form_scope. (** We would like to recognize -Notation " #[# 'th' 'e' sT 'of' v : 'Type' #]#" := (@get Type sT v _ _) - (at level 0, format " #[# 'th' 'e' sT 'of' v : 'Type' #]#") : form_scope. +Notation " #[# 'the' sT 'of' v : 'Type' #]#" := (@get Type sT v _ _) + (at level 0, format " #[# 'the' sT 'of' v : 'Type' #]#") : form_scope. **) (** @@ -278,8 +308,7 @@ Definition argumentType T P & forall x : T, P x := T. Definition dependentReturnType T P & forall x : T, P x := P. Definition returnType aT rT & aT -> rT := rT. -Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) - (at level 0, format "{ 'type' 'of' c 'for' s }") : type_scope. +Notation "{ 'type' 'of' c 'for' s }" := (dependentReturnType c s) : type_scope. (** A generic "phantom" type (actually, a unit type with a phantom parameter). @@ -330,7 +359,7 @@ Notation unkeyed x := (let flex := x in flex). (** Ssreflect converse rewrite rule rule idiom. **) Definition ssr_converse R (r : R) := (Logic.I, r). -Notation "=^~ r" := (ssr_converse r) (at level 100) : form_scope. +Notation "=^~ r" := (ssr_converse r) : form_scope. (** Term tagging (user-level). @@ -397,11 +426,11 @@ Ltac ssrdone0 := Structure unlockable T v := Unlockable {unlocked : T; _ : unlocked = v}. Lemma unlock T x C : @unlocked T x C = x. Proof. by case: C. Qed. -Notation "[ 'unlockable' 'of' C ]" := (@Unlockable _ _ C (unlock _)) - (at level 0, format "[ 'unlockable' 'of' C ]") : form_scope. +Notation "[ 'unlockable' 'of' C ]" := + (@Unlockable _ _ C (unlock _)) : form_scope. -Notation "[ 'unlockable' 'fun' C ]" := (@Unlockable _ (fun _ => _) C (unlock _)) - (at level 0, format "[ 'unlockable' 'fun' C ]") : form_scope. +Notation "[ 'unlockable' 'fun' C ]" := + (@Unlockable _ (fun _ => _) C (unlock _)) : form_scope. (** Generic keyed constant locking. **) @@ -418,7 +447,7 @@ Proof. by case: k. Qed. Canonical locked_with_unlockable T k x := @Unlockable T x (locked_with k x) (locked_withE k x). -(** More accurate variant of unlock, and safer alternative to locked_withE. **) +(** More accurate variant of unlock, and safer alternative to locked_withE. **) Lemma unlock_with T k x : unlocked (locked_with_unlockable k x) = x :> T. Proof. exact: unlock. Qed. @@ -597,3 +626,102 @@ Ltac over := | apply: Under_iff.under_iff_done | rewrite over ]. + +(** An interface for non-Prop types; used to avoid improper instantiation + of polymorphic lemmas with on-demand implicits when they are used as views. + For example: Some_inj {T} : forall x y : T, Some x = Some y -> x = y. + Using move/Some_inj on a goal of the form Some n = Some 0 will fail: + SSReflect will interpret the view as @Some_inj ?T _top_assumption_ + since this is the well-typed application of the view with the minimal + number of inserted evars (taking ?T := Some n = Some 0), and then will + later complain that it cannot erase _top_assumption_ after having + abstracted the viewed assumption. Making x and y maximal implicits + would avoid this and force the intended @Some_inj nat x y _top_assumption_ + interpretation, but is undesireable as it makes it harder to use Some_inj + with the many SSReflect and MathComp lemmas that have an injectivity + premise. Specifying {T : nonPropType} solves this more elegantly, as then + (?T : Type) no longer unifies with (Some n = Some 0), which has sort Prop. + **) + +Module NonPropType. + +(** Implementation notes: + We rely on three interface Structures: + - test_of r, the middle structure, performs the actual check: it has two + canonical instances whose 'condition' projection are maybeProj (?P : Prop) + and tt, and which set r := true and r := false, respectively. Unifying + condition (?t : test_of ?r) with maybeProj T will thus set ?r to true if + T is in Prop as the test_Prop T instance will apply, and otherwise simplify + maybeProp T to tt and use the test_negative instance and set ?r to false. + - call_of c r sets up a call to test_of on condition c with expected result r. + It has a default instance for its 'callee' projection to Type, which + sets c := maybeProj T and r := false whe unifying with a type T. + - type is a telescope on call_of c r, which checks that unifying test_of ?r1 + with c indeed sets ?r1 := r; the type structure bundles the 'test' instance + and its 'result' value along with its call_of c r projection. The default + instance essentially provides eta-expansion for 'type'. This is only + essential for the first 'result' projection to bool; using the instance + for other projection merely avoids spurrious delta expansions that would + spoil the notProp T notation. + In detail, unifying T =~= ?S with ?S : nonPropType, i.e., + (1) T =~= @callee (@condition (result ?S) (test ?S)) (result ?S) (frame ?S) + first uses the default call instance with ?T := T to reduce (1) to + (2a) @condition (result ?S) (test ?S) =~= maybeProp T + (3) result ?S =~= false + (4) frame ?S =~= call T + along with some trivial universe-related checks which are irrelevant here. + Then the unification tries to use the test_Prop instance to reduce (2a) to + (6a) result ?S =~= true + (7a) ?P =~= T with ?P : Prop + (8a) test ?S =~= test_Prop ?P + Now the default 'check' instance with ?result := true resolves (6a) as + (9a) ?S := @check true ?test ?frame + Then (7a) can be solved precisely if T has sort at most (hence exactly) Prop, + and then (8a) is solved by the check instance, yielding ?test := test_Prop T, + and completing the solution of (2a), and _committing_ to it. But now (3) is + inconsistent with (9a), and this makes the entire problem (1) fails. + If on the othe hand T does not have sort Prop then (7a) fails and the + unification resorts to delta expanding (2a), which gives + (2b) @condition (result ?S) (test ?S) =~= tt + which is then reduced, using the test_negative instance, to + (6b) result ?S =~= false + (8b) test ?S =~= test_negative + Both are solved using the check default instance, as in the (2a) branch, giving + (9b) ?S := @check false test_negative ?frame + Then (3) and (4) are similarly soved using check, giving the final assignment + (9) ?S := notProp T + Observe that we _must_ perform the actual test unification on the arguments + of the initial canonical instance, and not on the instance itself as we do + in mathcomp/matrix and mathcomp/vector, because we want the unification to + fail when T has sort Prop. If both the test_of _and_ the result check + unifications were done as part of the structure telescope then the latter + would be a sub-problem of the former, and thus failing the check would merely + make the test_of unification backtrack and delta-expand and we would not get + failure. + **) + +Structure call_of (condition : unit) (result : bool) := Call {callee : Type}. +Definition maybeProp (T : Type) := tt. +Definition call T := Call (maybeProp T) false T. + +Structure test_of (result : bool) := Test {condition :> unit}. +Definition test_Prop (P : Prop) := Test true (maybeProp P). +Definition test_negative := Test false tt. + +Structure type := + Check {result : bool; test : test_of result; frame : call_of test result}. +Definition check result test frame := @Check result test frame. + +Module Exports. +Canonical call. +Canonical test_Prop. +Canonical test_negative. +Canonical check. +Notation nonPropType := type. +Coercion callee : call_of >-> Sortclass. +Coercion frame : type >-> call_of. +Notation notProp T := (@check false test_negative (call T)). +End Exports. + +End NonPropType. +Export NonPropType.Exports. diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index ad20113320..e349031952 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -118,7 +118,7 @@ let newssrcongrtac arg ist gl = match try Some (pf_unify_HO gl_c (pf_concl gl) c) with exn when CErrors.noncritical exn -> None with | Some gl_c -> - tclTHEN (Proofview.V82.of_tactic (convert_concl (fs gl_c c))) + tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true (fs gl_c c))) (t_ok (proj gl_c)) gl | None -> t_fail () gl in let mk_evar gl ty = @@ -276,7 +276,7 @@ let unfoldintac occ rdx t (kt,_) gl = try beta env0 (EConstr.of_constr (eval_pattern env0 sigma0 concl0 rdx occ unfold)) with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_econstr_pat env0 sigma t) in let _ = conclude () in - Proofview.V82.of_tactic (convert_concl concl) gl + Proofview.V82.of_tactic (convert_concl ~check:true concl) gl ;; let foldtac occ rdx ft gl = @@ -303,7 +303,7 @@ let foldtac occ rdx ft gl = let concl0 = EConstr.Unsafe.to_constr concl0 in let concl = eval_pattern env0 sigma0 concl0 rdx occ fold in let _ = conclude () in - Proofview.V82.of_tactic (convert_concl (EConstr.of_constr concl)) gl + Proofview.V82.of_tactic (convert_concl ~check:true (EConstr.of_constr concl)) gl ;; let converse_dir = function L2R -> R2L | R2L -> L2R @@ -406,7 +406,7 @@ let rwcltac ?under ?map_redex cl rdx dir sr gl = let cl' = EConstr.mkApp (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdxt cl, [|rdx|]) in let sigma, _ = Typing.type_of env sigma cl' in let gl = pf_merge_uc_of sigma gl in - Proofview.V82.of_tactic (convert_concl cl'), rewritetac ?under dir r', gl + Proofview.V82.of_tactic (convert_concl ~check:true cl'), rewritetac ?under dir r', gl else let dc, r2 = EConstr.decompose_lam_n_assum (project gl) n r' in let r3, _, r3t = @@ -644,7 +644,7 @@ let unfoldtac occ ko t kt gl = let cl' = EConstr.Vars.subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref env (project gl) c] gl c) cl in let f = if ko = None then CClosure.betaiotazeta else CClosure.betaiota in Proofview.V82.of_tactic - (convert_concl (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl + (convert_concl ~check:true (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl let unlocktac ist args gl = let utac (occ, gt) gl = diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index b51ffada0c..46af775296 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -219,25 +219,113 @@ Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -Declare Scope fun_scope. -Delimit Scope fun_scope with FUN. -Open Scope fun_scope. +(** Parsing / printing declarations. *) +Reserved Notation "p .1" (at level 2, left associativity, format "p .1"). +Reserved Notation "p .2" (at level 2, left associativity, format "p .2"). +Reserved Notation "f ^~ y" (at level 10, y at level 8, no associativity, + format "f ^~ y"). +Reserved Notation "@^~ x" (at level 10, x at level 8, no associativity, + format "@^~ x"). +Reserved Notation "[ 'eta' f ]" (at level 0, format "[ 'eta' f ]"). +Reserved Notation "'fun' => E" (at level 200, format "'fun' => E"). + +Reserved Notation "[ 'fun' : T => E ]" (at level 0, + format "'[hv' [ 'fun' : T => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x => E ]" (at level 0, + x ident, format "'[hv' [ 'fun' x => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x : T => E ]" (at level 0, + x ident, format "'[hv' [ 'fun' x : T => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x y => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' x y => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x y : T => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' x y : T => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' ( x : T ) y => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' ( x : T ) y => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' x ( y : T ) => E ]" (at level 0, + x ident, y ident, format "'[hv' [ 'fun' x ( y : T ) => '/ ' E ] ']'"). +Reserved Notation "[ 'fun' ( x : T ) ( y : U ) => E ]" (at level 0, + x ident, y ident, format "[ 'fun' ( x : T ) ( y : U ) => E ]" ). + +Reserved Notation "f =1 g" (at level 70, no associativity). +Reserved Notation "f =1 g :> A" (at level 70, g at next level, A at level 90). +Reserved Notation "f =2 g" (at level 70, no associativity). +Reserved Notation "f =2 g :> A" (at level 70, g at next level, A at level 90). +Reserved Notation "f \o g" (at level 50, format "f \o '/ ' g"). +Reserved Notation "f \; g" (at level 60, right associativity, + format "f \; '/ ' g"). + +Reserved Notation "{ 'morph' f : x / a >-> r }" (at level 0, f at level 99, + x ident, format "{ 'morph' f : x / a >-> r }"). +Reserved Notation "{ 'morph' f : x / a }" (at level 0, f at level 99, + x ident, format "{ 'morph' f : x / a }"). +Reserved Notation "{ 'morph' f : x y / a >-> r }" (at level 0, f at level 99, + x ident, y ident, format "{ 'morph' f : x y / a >-> r }"). +Reserved Notation "{ 'morph' f : x y / a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'morph' f : x y / a }"). +Reserved Notation "{ 'homo' f : x / a >-> r }" (at level 0, f at level 99, + x ident, format "{ 'homo' f : x / a >-> r }"). +Reserved Notation "{ 'homo' f : x / a }" (at level 0, f at level 99, + x ident, format "{ 'homo' f : x / a }"). +Reserved Notation "{ 'homo' f : x y / a >-> r }" (at level 0, f at level 99, + x ident, y ident, format "{ 'homo' f : x y / a >-> r }"). +Reserved Notation "{ 'homo' f : x y / a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'homo' f : x y / a }"). +Reserved Notation "{ 'homo' f : x y /~ a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'homo' f : x y /~ a }"). +Reserved Notation "{ 'mono' f : x / a >-> r }" (at level 0, f at level 99, + x ident, format "{ 'mono' f : x / a >-> r }"). +Reserved Notation "{ 'mono' f : x / a }" (at level 0, f at level 99, + x ident, format "{ 'mono' f : x / a }"). +Reserved Notation "{ 'mono' f : x y / a >-> r }" (at level 0, f at level 99, + x ident, y ident, format "{ 'mono' f : x y / a >-> r }"). +Reserved Notation "{ 'mono' f : x y / a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'mono' f : x y / a }"). +Reserved Notation "{ 'mono' f : x y /~ a }" (at level 0, f at level 99, + x ident, y ident, format "{ 'mono' f : x y /~ a }"). + +Reserved Notation "@ 'id' T" (at level 10, T at level 8, format "@ 'id' T"). +Reserved Notation "@ 'sval'" (at level 10, format "@ 'sval'"). -(** Notations for argument transpose **) -Notation "f ^~ y" := (fun x => f x y) - (at level 10, y at level 8, no associativity, format "f ^~ y") : fun_scope. -Notation "@^~ x" := (fun f => f x) - (at level 10, x at level 8, no associativity, format "@^~ x") : fun_scope. +(** + Syntax for defining auxiliary recursive function. + Usage: + Section FooDefinition. + Variables (g1 : T1) (g2 : T2). (globals) + Fixoint foo_auxiliary (a3 : T3) ... := + body, using #[#rec e3, ... #]# for recursive calls + where " #[# 'rec' a3 , a4 , ... #]#" := foo_auxiliary. + Definition foo x y .. := #[#rec e1, ... #]#. + + proofs about foo + End FooDefinition. **) + +Reserved Notation "[ 'rec' a ]" (at level 0, + format "[ 'rec' a ]"). +Reserved Notation "[ 'rec' a , b ]" (at level 0, + format "[ 'rec' a , b ]"). +Reserved Notation "[ 'rec' a , b , c ]" (at level 0, + format "[ 'rec' a , b , c ]"). +Reserved Notation "[ 'rec' a , b , c , d ]" (at level 0, + format "[ 'rec' a , b , c , d ]"). +Reserved Notation "[ 'rec' a , b , c , d , e ]" (at level 0, + format "[ 'rec' a , b , c , d , e ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g , h ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h , i ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g , h , i ]"). +Reserved Notation "[ 'rec' a , b , c , d , e , f , g , h , i , j ]" (at level 0, + format "[ 'rec' a , b , c , d , e , f , g , h , i , j ]"). Declare Scope pair_scope. Delimit Scope pair_scope with PAIR. Open Scope pair_scope. (** Notations for pair/conjunction projections **) -Notation "p .1" := (fst p) - (at level 2, left associativity, format "p .1") : pair_scope. -Notation "p .2" := (snd p) - (at level 2, left associativity, format "p .2") : pair_scope. +Notation "p .1" := (fst p) : pair_scope. +Notation "p .2" := (snd p) : pair_scope. Coercion pair_of_and P Q (PandQ : P /\ Q) := (proj1 PandQ, proj2 PandQ). @@ -291,41 +379,13 @@ Canonical wrap T x := @Wrap T x. Prenex Implicits unwrap wrap Wrap. -(** - Syntax for defining auxiliary recursive function. - Usage: - Section FooDefinition. - Variables (g1 : T1) (g2 : T2). (globals) - Fixoint foo_auxiliary (a3 : T3) ... := - body, using #[#rec e3, ... #]# for recursive calls - where " #[# 'rec' a3 , a4 , ... #]#" := foo_auxiliary. - Definition foo x y .. := #[#rec e1, ... #]#. - + proofs about foo - End FooDefinition. **) +Declare Scope fun_scope. +Delimit Scope fun_scope with FUN. +Open Scope fun_scope. -Reserved Notation "[ 'rec' a0 ]" - (at level 0, format "[ 'rec' a0 ]"). -Reserved Notation "[ 'rec' a0 , a1 ]" - (at level 0, format "[ 'rec' a0 , a1 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 ]" - (at level 0, format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 ]" - (at level 0, - format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 ]" - (at level 0, - format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 ]"). -Reserved Notation "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]" - (at level 0, - format "[ 'rec' a0 , a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ]"). +(** Notations for argument transpose **) +Notation "f ^~ y" := (fun x => f x y) : fun_scope. +Notation "@^~ x" := (fun f => f x) : fun_scope. (** Definitions and notation for explicit functions with simplification, @@ -344,33 +404,19 @@ Coercion fun_of_simpl : simpl_fun >-> Funclass. End SimplFun. -Notation "[ 'fun' : T => E ]" := (SimplFun (fun _ : T => E)) - (at level 0, - format "'[hv' [ 'fun' : T => '/ ' E ] ']'") : fun_scope. - -Notation "[ 'fun' x => E ]" := (SimplFun (fun x => E)) - (at level 0, x ident, - format "'[hv' [ 'fun' x => '/ ' E ] ']'") : fun_scope. - +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. Notation "[ 'fun' x : T => E ]" := (SimplFun (fun x : T => E)) - (at level 0, x ident, only parsing) : fun_scope. - -Notation "[ 'fun' x y => E ]" := (fun x => [fun y => E]) - (at level 0, x ident, y ident, - format "'[hv' [ 'fun' x y => '/ ' E ] ']'") : fun_scope. - + (only parsing) : fun_scope. Notation "[ 'fun' x y : T => E ]" := (fun x : T => [fun y : T => E]) - (at level 0, x ident, y ident, only parsing) : fun_scope. - + (only parsing) : fun_scope. Notation "[ 'fun' ( x : T ) y => E ]" := (fun x : T => [fun y => E]) - (at level 0, x ident, y ident, only parsing) : fun_scope. - + (only parsing) : fun_scope. Notation "[ 'fun' x ( y : T ) => E ]" := (fun x => [fun y : T => E]) - (at level 0, x ident, y ident, only parsing) : fun_scope. - -Notation "[ 'fun' ( x : xT ) ( y : yT ) => E ]" := - (fun x : xT => [fun y : yT => E]) - (at level 0, x ident, y ident, only parsing) : fun_scope. + (only parsing) : fun_scope. +Notation "[ 'fun' ( x : T ) ( y : U ) => E ]" := (fun x : T => [fun y : U => E]) + (only parsing) : fun_scope. (** For delta functions in eqtype.v. **) Definition SimplFunDelta aT rT (f : aT -> aT -> rT) := [fun z => f z z]. @@ -402,51 +448,38 @@ Typeclasses Opaque eqrel. Hint Resolve frefl rrefl : core. -Notation "f1 =1 f2" := (eqfun f1 f2) - (at level 70, no associativity) : fun_scope. -Notation "f1 =1 f2 :> A" := (f1 =1 (f2 : A)) - (at level 70, f2 at next level, A at level 90) : fun_scope. -Notation "f1 =2 f2" := (eqrel f1 f2) - (at level 70, no associativity) : fun_scope. -Notation "f1 =2 f2 :> A" := (f1 =2 (f2 : A)) - (at level 70, f2 at next level, A at level 90) : fun_scope. +Notation "f1 =1 f2" := (eqfun f1 f2) : fun_scope. +Notation "f1 =1 f2 :> A" := (f1 =1 (f2 : A)) : fun_scope. +Notation "f1 =2 f2" := (eqrel f1 f2) : fun_scope. +Notation "f1 =2 f2 :> A" := (f1 =2 (f2 : A)) : fun_scope. Section Composition. Variables A B C : Type. -Definition funcomp u (f : B -> A) (g : C -> B) x := let: tt := u in f (g x). -Definition catcomp u g f := funcomp u f g. -Local Notation comp := (funcomp tt). - +Definition comp (f : B -> A) (g : C -> B) x := f (g x). +Definition catcomp g f := comp f g. Definition pcomp (f : B -> option A) (g : C -> option B) x := obind f (g x). Lemma eq_comp f f' g g' : f =1 f' -> g =1 g' -> comp f g =1 comp f' g'. -Proof. by move=> eq_ff' eq_gg' x; rewrite /= eq_gg' eq_ff'. Qed. +Proof. by move=> eq_ff' eq_gg' x; rewrite /comp eq_gg' eq_ff'. Qed. End Composition. -Notation comp := (funcomp tt). -Notation "@ 'comp'" := (fun A B C => @funcomp A B C tt). -Notation "f1 \o f2" := (comp f1 f2) - (at level 50, format "f1 \o '/ ' f2") : fun_scope. -Notation "f1 \; f2" := (catcomp tt f1 f2) - (at level 60, right associativity, format "f1 \; '/ ' f2") : fun_scope. +Arguments comp {A B C} f g x /. +Arguments catcomp {A B C} g f x /. +Notation "f1 \o f2" := (comp f1 f2) : fun_scope. +Notation "f1 \; f2" := (catcomp f1 f2) : fun_scope. -Notation "[ 'eta' f ]" := (fun x => f x) - (at level 0, format "[ 'eta' f ]") : fun_scope. +Notation "[ 'eta' f ]" := (fun x => f x) : fun_scope. -Notation "'fun' => E" := (fun _ => E) (at level 200, only parsing) : fun_scope. +Notation "'fun' => E" := (fun _ => E) : fun_scope. Notation id := (fun x => x). -Notation "@ 'id' T" := (fun x : T => x) - (at level 10, T at level 8, only parsing) : fun_scope. +Notation "@ 'id' T" := (fun x : T => x) (only parsing) : fun_scope. -Definition id_head T u x : T := let: tt := u in x. -Definition explicit_id_key := tt. -Notation idfun := (id_head tt). -Notation "@ 'idfun' T " := (@id_head T explicit_id_key) - (at level 10, T at level 8, format "@ 'idfun' T") : fun_scope. +Definition idfun T x : T := x. +Arguments idfun {T} x /. Definition phant_id T1 T2 v1 v2 := phantom T1 v1 -> phantom T2 v2. @@ -542,74 +575,33 @@ Definition monomorphism_2 (aR rR : _ -> _ -> sT) := End Morphism. Notation "{ 'morph' f : x / a >-> r }" := - (morphism_1 f (fun x => a) (fun x => r)) - (at level 0, f at level 99, x ident, - format "{ 'morph' f : x / a >-> r }") : type_scope. - + (morphism_1 f (fun x => a) (fun x => r)) : type_scope. Notation "{ 'morph' f : x / a }" := - (morphism_1 f (fun x => a) (fun x => a)) - (at level 0, f at level 99, x ident, - format "{ 'morph' f : x / a }") : type_scope. - + (morphism_1 f (fun x => a) (fun x => a)) : type_scope. Notation "{ 'morph' f : x y / a >-> r }" := - (morphism_2 f (fun x y => a) (fun x y => r)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'morph' f : x y / a >-> r }") : type_scope. - + (morphism_2 f (fun x y => a) (fun x y => r)) : type_scope. Notation "{ 'morph' f : x y / a }" := - (morphism_2 f (fun x y => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'morph' f : x y / a }") : type_scope. - + (morphism_2 f (fun x y => a) (fun x y => a)) : type_scope. Notation "{ 'homo' f : x / a >-> r }" := - (homomorphism_1 f (fun x => a) (fun x => r)) - (at level 0, f at level 99, x ident, - format "{ 'homo' f : x / a >-> r }") : type_scope. - + (homomorphism_1 f (fun x => a) (fun x => r)) : type_scope. Notation "{ 'homo' f : x / a }" := - (homomorphism_1 f (fun x => a) (fun x => a)) - (at level 0, f at level 99, x ident, - format "{ 'homo' f : x / a }") : type_scope. - + (homomorphism_1 f (fun x => a) (fun x => a)) : type_scope. Notation "{ 'homo' f : x y / a >-> r }" := - (homomorphism_2 f (fun x y => a) (fun x y => r)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'homo' f : x y / a >-> r }") : type_scope. - + (homomorphism_2 f (fun x y => a) (fun x y => r)) : type_scope. Notation "{ 'homo' f : x y / a }" := - (homomorphism_2 f (fun x y => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'homo' f : x y / a }") : type_scope. - + (homomorphism_2 f (fun x y => a) (fun x y => a)) : type_scope. Notation "{ 'homo' f : x y /~ a }" := - (homomorphism_2 f (fun y x => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'homo' f : x y /~ a }") : type_scope. - + (homomorphism_2 f (fun y x => a) (fun x y => a)) : type_scope. Notation "{ 'mono' f : x / a >-> r }" := - (monomorphism_1 f (fun x => a) (fun x => r)) - (at level 0, f at level 99, x ident, - format "{ 'mono' f : x / a >-> r }") : type_scope. - + (monomorphism_1 f (fun x => a) (fun x => r)) : type_scope. Notation "{ 'mono' f : x / a }" := - (monomorphism_1 f (fun x => a) (fun x => a)) - (at level 0, f at level 99, x ident, - format "{ 'mono' f : x / a }") : type_scope. - + (monomorphism_1 f (fun x => a) (fun x => a)) : type_scope. Notation "{ 'mono' f : x y / a >-> r }" := - (monomorphism_2 f (fun x y => a) (fun x y => r)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'mono' f : x y / a >-> r }") : type_scope. - + (monomorphism_2 f (fun x y => a) (fun x y => r)) : type_scope. Notation "{ 'mono' f : x y / a }" := - (monomorphism_2 f (fun x y => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'mono' f : x y / a }") : type_scope. - + (monomorphism_2 f (fun x y => a) (fun x y => a)) : type_scope. Notation "{ 'mono' f : x y /~ a }" := - (monomorphism_2 f (fun y x => a) (fun x y => a)) - (at level 0, f at level 99, x ident, y ident, - format "{ 'mono' f : x y /~ a }") : type_scope. + (monomorphism_2 f (fun y x => a) (fun x y => a)) : type_scope. (** In an intuitionistic setting, we have two degrees of injectivity. The @@ -620,9 +612,6 @@ Notation "{ 'mono' f : x y /~ a }" := Section Injections. -(** - rT must come first so we can use @ to mitigate the Coq 1st order - unification bug (e..g., Coq can't infer rT from a "cancel" lemma). **) Variables (rT aT : Type) (f : aT -> rT). Definition injective := forall x1 x2, f x1 = f x2 -> x1 = x2. @@ -650,10 +639,8 @@ Proof. by move=> fK <-. Qed. End Injections. -Lemma Some_inj {T} : injective (@Some T). Proof. by move=> x y []. Qed. - -(** Force implicits to use as a view. **) -Prenex Implicits Some_inj. +Lemma Some_inj {T : nonPropType} : injective (@Some T). +Proof. by move=> x y []. Qed. (** cancellation lemmas for dependent type casts. **) Lemma esymK T x y : cancel (@esym T x y) (@esym T y x). diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 01d71aa96a..4d4400a0f8 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -56,7 +56,7 @@ let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) | _ -> c, pfe_type_of gl c in let cl' = EConstr.mkLetIn (make_annot (Name id) Sorts.Relevant, c, cty, cl) in - Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl cl')) (introid id) gl + Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl')) (introid id) gl open Util @@ -161,7 +161,7 @@ let havetac ist let gl, ty = pfe_type_of gl t in let ctx, _ = EConstr.decompose_prod_n_assum (project gl) 1 ty in let assert_is_conv gl = - try Proofview.V82.of_tactic (convert_concl (EConstr.it_mkProd_or_LetIn concl ctx)) gl + try Proofview.V82.of_tactic (convert_concl ~check:true (EConstr.it_mkProd_or_LetIn concl ctx)) gl with _ -> errorstrm (str "Given proof term is not of type " ++ pr_econstr_env (pf_env gl) (project gl) (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) Sorts.Relevant concl)) in gl, ty, Tacticals.tclTHEN assert_is_conv (Proofview.V82.of_tactic (Tactics.apply t)), id, itac_c @@ -471,7 +471,7 @@ let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = if hint = nohint then Proofview.tclUNIT () else - let betaiota = Tactics.reduct_in_concl (Reductionops.nf_betaiota, DEFAULTcast) in + let betaiota = Tactics.reduct_in_concl ~check:false (Reductionops.nf_betaiota, DEFAULTcast) in (* Usefulness of check_numgoals: tclDISPATCH would be enough, except for the error message w.r.t. the number of provided/expected tactics, as the last one is implied *) diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index 17e4114958..91ff432364 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -110,7 +110,7 @@ let endclausestac id_map clseq gl_id cl0 gl = | _ -> EConstr.map (project gl) unmark c in let utac hyp = Proofview.V82.of_tactic - (Tactics.convert_hyp ~check:false (NamedDecl.map_constr unmark hyp)) in + (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.map_constr unmark hyp)) in let utacs = List.map utac (pf_hyps gl) in let ugtac gl' = Proofview.V82.of_tactic diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 1deb935d5c..4e0866a0c5 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -1299,7 +1299,7 @@ let ssrpatterntac _ist arg gl = let concl_x = EConstr.of_constr concl_x in let gl, tty = pf_type_of gl t in let concl = EConstr.mkLetIn (make_annot (Name (Id.of_string "selected")) Sorts.Relevant, t, tty, concl_x) in - Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl + Proofview.V82.of_tactic (convert_concl ~check:true concl DEFAULTcast) gl (* Register "ssrpattern" tactic *) let () = diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index baa4ae0306..0f0f3953da 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -16,18 +16,17 @@ open Notation open Numeral open Pp open Names -open Ltac_plugin open Stdarg open Pcoq.Prim -let pr_numnot_option _ _ _ = function +let pr_numnot_option = function | Nop -> mt () | Warning n -> str "(warning after " ++ str n ++ str ")" | Abstract n -> str "(abstract after " ++ str n ++ str ")" } -ARGUMENT EXTEND numnotoption +VERNAC ARGUMENT EXTEND numnotoption PRINTED BY { pr_numnot_option } | [ ] -> { Nop } | [ "(" "warning" "after" bigint(waft) ")" ] -> { Warning waft } diff --git a/plugins/syntax/plugin_base.dune b/plugins/syntax/plugin_base.dune index aac46338ea..7a23581768 100644 --- a/plugins/syntax/plugin_base.dune +++ b/plugins/syntax/plugin_base.dune @@ -3,7 +3,7 @@ (public_name coq.plugins.numeral_notation) (synopsis "Coq numeral notation plugin") (modules g_numeral numeral) - (libraries coq.plugins.ltac)) + (libraries coq.vernac)) (library (name string_notation_plugin) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 0ccc4fd9f9..99013a19c9 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -146,8 +146,8 @@ let flex_kind_of_term flags env evd c sk = let apprec_nohdbeta flags env evd c = let (t,sk as appr) = Reductionops.whd_nored_state evd (c, []) in if flags.modulo_betaiota && Stack.not_purely_applicative sk - then Stack.zip evd (fst (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env evd Cst_stack.empty appr)) + then Stack.zip evd (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env evd appr) else c let position_problem l2r = function @@ -496,8 +496,8 @@ let rec evar_conv_x flags env evd pbty term1 term2 = let term2 = apprec_nohdbeta flags env evd term2 in let default () = evar_eqappr_x flags env evd pbty - (whd_nored_state evd (term1,Stack.empty), Cst_stack.empty) - (whd_nored_state evd (term2,Stack.empty), Cst_stack.empty) + (whd_nored_state evd (term1,Stack.empty)) + (whd_nored_state evd (term2,Stack.empty)) in begin match EConstr.kind evd term1, EConstr.kind evd term2 with | Evar ev, _ when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> @@ -525,7 +525,7 @@ let rec evar_conv_x flags env evd pbty term1 term2 = end and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty - ((term1,sk1 as appr1),csts1) ((term2,sk2 as appr2),csts2) = + (term1, sk1 as appr1) (term2, sk2 as appr2) = let quick_fail i = (* not costly, loses info *) UnifFailure (i, NotSameHead) in @@ -555,8 +555,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let c = nf_evar evd c1 in let env' = push_rel (RelDecl.LocalAssum (na,c)) env in let out1 = whd_betaiota_deltazeta_for_iota_state - flags.open_ts env' evd Cst_stack.empty (c'1, Stack.empty) in - let out2 = whd_nored_state evd + flags.open_ts env' evd (c'1, Stack.empty) in + let out2, _ = whd_nored_state evd (lift 1 (Stack.zip evd (term', sk')), Stack.append_app [|EConstr.mkRel 1|] Stack.empty), Cst_stack.empty in if onleft then evar_eqappr_x flags env' evd CONV out1 out2 @@ -636,11 +636,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty else quick_fail i) ev lF tM i in - let flex_maybeflex on_left ev ((termF,skF as apprF),cstsF) ((termM, skM as apprM),cstsM) vM = + let flex_maybeflex on_left ev (termF,skF as apprF) (termM, skM as apprM) vM = let switch f a b = if on_left then f a b else f b a in let delta i = - switch (evar_eqappr_x flags env i pbty) (apprF,cstsF) - (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i cstsM (vM,skM)) + switch (evar_eqappr_x flags env i pbty) apprF + (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (vM,skM)) in let default i = ise_try i [miller on_left ev apprF apprM; consume on_left apprF apprM; @@ -658,11 +658,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let f = try let termM' = Retyping.expand_projection env evd p c [] in - let apprM', cstsM' = - whd_betaiota_deltazeta_for_iota_state flags.open_ts env evd cstsM (termM',skM) + let apprM' = + whd_betaiota_deltazeta_for_iota_state flags.open_ts env evd (termM',skM) in let delta' i = - switch (evar_eqappr_x flags env i pbty) (apprF,cstsF) (apprM',cstsM') + switch (evar_eqappr_x flags env i pbty) apprF apprM' in fun i -> ise_try i [miller on_left ev apprF apprM'; consume on_left apprF apprM'; delta'] @@ -718,7 +718,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (position_problem true pbty,destEvar i' ev1',term2) else evar_eqappr_x flags env evd pbty - ((ev1', sk1), csts1) ((term2, sk2), csts2) + (ev1', sk1) (term2, sk2) | Some (r,[]), Success i' -> (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *) (* we now unify r[?ev1] and ?ev2 *) @@ -728,7 +728,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (position_problem false pbty,destEvar i' ev2',Stack.zip i' (term1,r)) else evar_eqappr_x flags env evd pbty - ((ev2', sk1), csts1) ((term2, sk2), csts2) + (ev2', sk1) (term2, sk2) | Some ([],r), Success i' -> (* Symmetrically *) (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *) @@ -738,7 +738,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty solve_simple_eqn (conv_fun evar_conv_x) flags env i' (position_problem true pbty,destEvar i' ev1',Stack.zip i' (term2,r)) else evar_eqappr_x flags env evd pbty - ((ev1', sk1), csts1) ((term2, sk2), csts2) + (ev1', sk1) (term2, sk2) | None, (UnifFailure _ as x) -> (* sk1 and sk2 have no common outer part *) if Stack.not_purely_applicative sk2 then @@ -808,10 +808,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty ise_try evd [f1; f2; f3; f4; f5] | Flexible ev1, MaybeFlexible v2 -> - flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) v2 + flex_maybeflex true ev1 appr1 appr2 v2 | MaybeFlexible v1, Flexible ev2 -> - flex_maybeflex false ev2 (appr2,csts2) (appr1,csts1) v1 + flex_maybeflex false ev2 appr2 appr1 v1 | MaybeFlexible v1, MaybeFlexible v2 -> begin match EConstr.kind evd term1, EConstr.kind evd term2 with @@ -829,8 +829,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty evar_conv_x flags (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] and f2 i = - let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts1 (v1,sk1) - and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts2 (v2,sk2) + let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2,sk2) in evar_eqappr_x flags env i pbty out1 out2 in ise_try evd [f1; f2] @@ -841,8 +841,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty [(fun i -> evar_conv_x flags env i CONV c c'); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] and f2 i = - let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts1 (v1,sk1) - and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts2 (v2,sk2) + let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2,sk2) in evar_eqappr_x flags env i pbty out1 out2 in ise_try evd [f1; f2] @@ -855,8 +855,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in (match res with | Some (f1,args1) -> - evar_eqappr_x flags env evd pbty ((f1,Stack.append_app args1 sk1),csts1) - (appr2,csts2) + evar_eqappr_x flags env evd pbty (f1,Stack.append_app args1 sk1) + appr2 | None -> UnifFailure (evd,NotSameHead)) | Const (p,u), Proj (p',c') when Constant.equal p (Projection.constant p') -> @@ -866,7 +866,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in (match res with | Some (f2,args2) -> - evar_eqappr_x flags env evd pbty (appr1,csts1) ((f2,Stack.append_app args2 sk2),csts2) + evar_eqappr_x flags env evd pbty appr1 (f2,Stack.append_app args2 sk2) | None -> UnifFailure (evd,NotSameHead)) | _, _ -> @@ -906,16 +906,16 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (* false (* immediate solution without Canon Struct *)*) | Lambda _ -> assert (match args with [] -> true | _ -> false); true | LetIn (_,b,_,c) -> is_unnamed - (fst (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i Cst_stack.empty (subst1 b c, args))) + (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env i (subst1 b c, args)) | Fix _ -> true (* Partially applied fix can be the result of a whd call *) | Proj (p, _) -> Projection.unfolded p || Stack.not_purely_applicative args | Case _ | App _| Cast _ -> assert false in let rhs_is_stuck_and_unnamed () = let applicative_stack = fst (Stack.strip_app sk2) in is_unnamed - (fst (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i Cst_stack.empty (v2, applicative_stack))) in + (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env i (v2, applicative_stack)) in let rhs_is_already_stuck = rhs_is_already_stuck || rhs_is_stuck_and_unnamed () in @@ -923,12 +923,12 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty && (not (Stack.not_purely_applicative sk1)) then evar_eqappr_x ~rhs_is_already_stuck flags env i pbty (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) - (appr2,csts2) + flags.open_ts env i(v1,sk1)) + appr2 else - evar_eqappr_x flags env i pbty (appr1,csts1) + evar_eqappr_x flags env i pbty appr1 (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + flags.open_ts env i (v2,sk2)) in ise_try evd [f1; f2; f3] end @@ -957,8 +957,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty and f4 i = evar_eqappr_x flags env i pbty (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) - (appr2,csts2) + flags.open_ts env i (v1,sk1)) + appr2 in ise_try evd [f3; f4] @@ -969,9 +969,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty else conv_record flags env i (check_conv_record env i appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = - evar_eqappr_x flags env i pbty (appr1,csts1) + evar_eqappr_x flags env i pbty appr1 (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + flags.open_ts env i (v2,sk2)) in ise_try evd [f3; f4] diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 0fe47c2a48..bf83f5e88f 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -144,7 +144,7 @@ val evar_unify : Evarsolve.unifier (* For debugging *) val evar_eqappr_x : ?rhs_is_already_stuck:bool -> unify_flags -> env -> evar_map -> - conv_pb -> state * Cst_stack.t -> state * Cst_stack.t -> + conv_pb -> state -> state -> Evarsolve.unification_result val occur_rigidly : Evarsolve.unify_flags -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 48d981082c..f2b8671a48 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -380,7 +380,7 @@ let orelse_name name name' = match name with | Anonymous -> name' | _ -> name -let pretype_id pretype k0 loc env sigma id = +let pretype_id pretype loc env sigma id = (* Look for the binder of [id] *) try let (n,_,typ) = lookup_rel_id id (rel_context !!env) in @@ -475,10 +475,10 @@ let mark_obligation_evar sigma k evc = (* in environment [env], with existential variables [sigma] and *) (* the type constraint tycon *) -let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = +let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc in - let pretype_type = pretype_type ~program_mode ~poly k0 resolve_tc in - let pretype = pretype ~program_mode ~poly k0 resolve_tc in + let pretype_type = pretype_type ~program_mode ~poly resolve_tc in + let pretype = pretype ~program_mode ~poly resolve_tc in let open Context.Rel.Declaration in let loc = t.CAst.loc in match DAst.get t with @@ -487,7 +487,7 @@ let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env inh_conv_coerce_to_tycon ?loc env sigma t_ref tycon | GVar id -> - let sigma, t_id = pretype_id (fun e r t -> pretype tycon e r t) k0 loc env sigma id in + let sigma, t_id = pretype_id (fun e r t -> pretype tycon e r t) loc env sigma id in inh_conv_coerce_to_tycon ?loc env sigma t_id tycon | GEvar (id, inst) -> @@ -498,7 +498,7 @@ let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env try Evd.evar_key id sigma with Not_found -> error_evar_not_found ?loc !!env sigma id in let hyps = evar_filtered_context (Evd.find sigma evk) in - let sigma, args = pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk inst in + let sigma, args = pretype_instance ~program_mode ~poly resolve_tc env sigma loc hyps evk inst in let c = mkEvar (evk, args) in let j = Retyping.get_judgment_of !!env sigma c in inh_conv_coerce_to_tycon ?loc env sigma j tycon @@ -984,7 +984,7 @@ let rec pretype ~program_mode ~poly k0 resolve_tc (tycon : type_constraint) (env in inh_conv_coerce_to_tycon ?loc env sigma resj tycon -and pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk update = +and pretype_instance ~program_mode ~poly resolve_tc env sigma loc hyps evk update = let f decl (subst,update,sigma) = let id = NamedDecl.get_id decl in let b = Option.map (replace_vars subst) (NamedDecl.get_value decl) in @@ -1016,7 +1016,7 @@ and pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk up let sigma, c, update = try let c = List.assoc id update in - let sigma, c = pretype ~program_mode ~poly k0 resolve_tc (mk_tycon t) env sigma c in + let sigma, c = pretype ~program_mode ~poly resolve_tc (mk_tycon t) env sigma c in check_body sigma id (Some c.uj_val); sigma, c.uj_val, List.remove_assoc id update with Not_found -> @@ -1041,7 +1041,7 @@ and pretype_instance ~program_mode ~poly k0 resolve_tc env sigma loc hyps evk up sigma, Array.map_of_list snd subst (* [pretype_type valcon env sigma c] coerces [c] into a type *) -and pretype_type ~program_mode ~poly k0 resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with +and pretype_type ~program_mode ~poly resolve_tc valcon (env : GlobEnv.t) sigma c = match DAst.get c with | GHole (knd, naming, None) -> let loc = loc_of_glob_constr c in (match valcon with @@ -1068,7 +1068,7 @@ and pretype_type ~program_mode ~poly k0 resolve_tc valcon (env : GlobEnv.t) sigm let sigma = if program_mode then mark_obligation_evar sigma knd utj_val else sigma in sigma, { utj_val; utj_type = s}) | _ -> - let sigma, j = pretype ~program_mode ~poly k0 resolve_tc empty_tycon env sigma c in + let sigma, j = pretype ~program_mode ~poly resolve_tc empty_tycon env sigma c in let loc = loc_of_glob_constr c in let sigma, tj = Coercion.inh_coerce_to_sort ?loc !!env sigma j in match valcon with @@ -1088,16 +1088,15 @@ let ise_pretype_gen flags env sigma lvar kind c = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let env = GlobEnv.make ~hypnaming env sigma lvar in - let k0 = Context.Rel.length (rel_context !!env) in let sigma', c', c'_ty = match kind with | WithoutTypeConstraint -> - let sigma, j = pretype ~program_mode ~poly k0 flags.use_typeclasses empty_tycon env sigma c in + let sigma, j = pretype ~program_mode ~poly flags.use_typeclasses empty_tycon env sigma c in sigma, j.uj_val, j.uj_type | OfType exptyp -> - let sigma, j = pretype ~program_mode ~poly k0 flags.use_typeclasses (mk_tycon exptyp) env sigma c in + let sigma, j = pretype ~program_mode ~poly flags.use_typeclasses (mk_tycon exptyp) env sigma c in sigma, j.uj_val, j.uj_type | IsType -> - let sigma, tj = pretype_type ~program_mode ~poly k0 flags.use_typeclasses empty_valcon env sigma c in + let sigma, tj = pretype_type ~program_mode ~poly flags.use_typeclasses empty_valcon env sigma c in sigma, tj.utj_val, mkSort tj.utj_type in process_inference_flags flags !!env sigma (sigma',c',c'_ty) diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 1feb8acd5f..d69824a256 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -191,41 +191,33 @@ let warn_projection_no_head_constant = (* Intended to always succeed *) let compute_canonical_projections env ~warn (con,ind) = - let ctx = Environ.constant_context env con in - let u = Univ.make_abstract_instance ctx in - let v = (mkConstU (con,u)) in + let o_CTX = Environ.constant_context env con in + let u = Univ.make_abstract_instance o_CTX in + let o_DEF = mkConstU (con, u) in let c = Environ.constant_value_in env (con,u) in let sign,t = Reductionops.splay_lam env (Evd.from_env env) (EConstr.of_constr c) in let sign = List.map (on_snd EConstr.Unsafe.to_constr) sign in let t = EConstr.Unsafe.to_constr t in - let lt = List.rev_map snd sign in + let o_TABS = List.rev_map snd sign in let args = snd (decompose_app t) in let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in - let params, projs = List.chop p args in + let o_TPARAMS, projs = List.chop p args in + let o_NPARAMS = List.length o_TPARAMS in let lpj = keep_true_projections lpj kl in - let lps = List.combine lpj projs in let nenv = Termops.push_rels_assum sign env in - let comp = - List.fold_left - (fun l (spopt,t) -> (* comp=components *) - match spopt with - | Some proji_sp -> - begin - try - let patt, n , args = cs_pattern_of_constr nenv t in - ((ConstRef proji_sp, patt, t, n, args) :: l) - with Not_found -> - if warn then warn_projection_no_head_constant (sign,env,t,con,proji_sp); - l - end - | _ -> l) - [] lps in - List.map (fun (refi,c,t,inj,argj) -> - (refi,(c,t)), - {o_DEF=v; o_CTX=ctx; o_INJ=inj; o_TABS=lt; - o_TPARAMS=params; o_NPARAMS=List.length params; o_TCOMPS=argj}) - comp + List.fold_left2 (fun acc spopt t -> + Option.cata (fun proji_sp -> + match cs_pattern_of_constr nenv t with + | patt, o_INJ, o_TCOMPS -> + ((ConstRef proji_sp, (patt, t)), + { o_DEF ; o_CTX ; o_INJ ; o_TABS ; o_TPARAMS ; o_NPARAMS ; o_TCOMPS }) + :: acc + | exception Not_found -> + if warn then warn_projection_no_head_constant (sign, env, t, con, proji_sp); + acc + ) acc spopt + ) [] lpj projs let pr_cs_pattern = function Const_cs c -> Nametab.pr_global_env Id.Set.empty c diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 1871609e18..85e6f51387 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -90,48 +90,43 @@ module ReductionBehaviour = struct open Names open Libobject - type t = { - b_nargs: int; - b_recargs: int list; - b_dont_expose_case: bool; - } + type t = NeverUnfold | UnfoldWhen of when_flags | UnfoldWhenNoMatch of when_flags + and when_flags = { recargs : int list ; nargs : int option } + + let more_args_when k { recargs; nargs } = + { nargs = Option.map ((+) k) nargs; + recargs = List.map ((+) k) recargs; + } + + let more_args k = function + | NeverUnfold -> NeverUnfold + | UnfoldWhen x -> UnfoldWhen (more_args_when k x) + | UnfoldWhenNoMatch x -> UnfoldWhenNoMatch (more_args_when k x) let table = Summary.ref (GlobRef.Map.empty : t GlobRef.Map.t) ~name:"reductionbehaviour" - type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ] - type req = - | ReqLocal - | ReqGlobal of GlobRef.t * (int list * int * flag list) - let load _ (_,(_,(r, b))) = table := GlobRef.Map.add r b !table let cache o = load 1 o - let classify = function - | ReqLocal, _ -> Dispose - | ReqGlobal _, _ as o -> Substitute o + let classify (local,_ as o) = if local then Dispose else Substitute o - let subst (subst, (_, (r,o as orig))) = - ReqLocal, - let r' = fst (subst_global subst r) in if r==r' then orig else (r',o) + let subst (subst, (local, (r,o) as orig)) = + let r' = subst_global_reference subst r in if r==r' then orig + else (local,(r',o)) let discharge = function - | _,(ReqGlobal (ConstRef c as gr, req), (_, b)) -> + | _,(false, (gr, b)) -> let b = if Lib.is_in_section gr then let vars = Lib.variable_section_segment_of_reference gr in let extra = List.length vars in - let nargs' = - if b.b_nargs = max_int then max_int - else if b.b_nargs < 0 then b.b_nargs - else b.b_nargs + extra in - let recargs' = List.map ((+) extra) b.b_recargs in - { b with b_nargs = nargs'; b_recargs = recargs' } + more_args extra b else b in - Some (ReqGlobal (gr, req), (ConstRef c, b)) + Some (false, (gr, b)) | _ -> None let rebuild = function @@ -148,55 +143,45 @@ module ReductionBehaviour = struct rebuild_function = rebuild; } - let set local r (recargs, nargs, flags as req) = - let nargs = if List.mem `ReductionNeverUnfold flags then max_int else nargs in - let behaviour = { - b_nargs = nargs; b_recargs = recargs; - b_dont_expose_case = List.mem `ReductionDontExposeCase flags } in - let req = if local then ReqLocal else ReqGlobal (r, req) in - Lib.add_anonymous_leaf (inRedBehaviour (req, (r, behaviour))) - ;; + let set ~local r b = + Lib.add_anonymous_leaf (inRedBehaviour (local, (r, b))) - let get r = - try - let b = GlobRef.Map.find r !table in - let flags = - if Int.equal b.b_nargs max_int then [`ReductionNeverUnfold] - else if b.b_dont_expose_case then [`ReductionDontExposeCase] else [] in - Some (b.b_recargs, (if Int.equal b.b_nargs max_int then -1 else b.b_nargs), flags) - with Not_found -> None + let get r = GlobRef.Map.find_opt r !table let print ref = let open Pp in let pr_global = Nametab.pr_global_env Id.Set.empty in match get ref with | None -> mt () - | Some (recargs, nargs, flags) -> - let never = List.mem `ReductionNeverUnfold flags in - let nomatch = List.mem `ReductionDontExposeCase flags in - let pp_nomatch = spc() ++ if nomatch then - str "but avoid exposing match constructs" else str"" in - let pp_recargs = spc() ++ str "when the " ++ + | Some b -> + let pp_nomatch = spc () ++ str "but avoid exposing match constructs" in + let pp_recargs recargs = spc() ++ str "when the " ++ pr_enum (fun x -> pr_nth (x+1)) recargs ++ str (String.plural (List.length recargs) " argument") ++ str (String.plural (if List.length recargs >= 2 then 1 else 2) " evaluate") ++ str " to a constructor" in - let pp_nargs = - spc() ++ str "when applied to " ++ int nargs ++ - str (String.plural nargs " argument") in - hov 2 (str "The reduction tactics " ++ - match recargs, nargs, never with - | _,_, true -> str "never unfold " ++ pr_global ref - | [], 0, _ -> str "always unfold " ++ pr_global ref - | _::_, n, _ when n < 0 -> - str "unfold " ++ pr_global ref ++ pp_recargs ++ pp_nomatch - | _::_, n, _ when n > List.fold_left max 0 recargs -> - str "unfold " ++ pr_global ref ++ pp_recargs ++ - str " and" ++ pp_nargs ++ pp_nomatch - | _::_, _, _ -> - str "unfold " ++ pr_global ref ++ pp_recargs ++ pp_nomatch - | [], n, _ when n > 0 -> - str "unfold " ++ pr_global ref ++ pp_nargs ++ pp_nomatch - | _ -> str "unfold " ++ pr_global ref ++ pp_nomatch ) + let pp_nargs nargs = + spc() ++ str "when applied to " ++ int nargs ++ + str (String.plural nargs " argument") in + let pp_when = function + | { recargs = []; nargs = Some 0 } -> + str "always unfold " ++ pr_global ref + | { recargs = []; nargs = Some n } -> + str "unfold " ++ pr_global ref ++ pp_nargs n + | { recargs = []; nargs = None } -> + str "unfold " ++ pr_global ref + | { recargs; nargs = Some n } when n > List.fold_left max 0 recargs -> + str "unfold " ++ pr_global ref ++ pp_recargs recargs ++ + str " and" ++ pp_nargs n + | { recargs; nargs = _ } -> + str "unfold " ++ pr_global ref ++ pp_recargs recargs + in + let pp_behavior = function + | NeverUnfold -> str "never unfold " ++ pr_global ref + | UnfoldWhen x -> pp_when x + | UnfoldWhenNoMatch x -> pp_when x ++ pp_nomatch + in + hov 2 (str "The reduction tactics " ++ pp_behavior b) + end (** Machinery about stack of unfolded constants *) @@ -928,6 +913,7 @@ let equal_stacks sigma (x, l) (y, l') = let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let open Context.Named.Declaration in + let open ReductionBehaviour in let rec whrec cst_l (x, stack) = let () = if !debug_RAKAM then let open Pp in @@ -974,37 +960,42 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = else (* Looks for ReductionBehaviour *) match ReductionBehaviour.get (Globnames.ConstRef c) with | None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) - | Some (recargs, nargs, flags) -> - if (List.mem `ReductionNeverUnfold flags - || (nargs > 0 && Stack.args_size stack < nargs)) - then fold () - else (* maybe unfolds *) - if List.mem `ReductionDontExposeCase flags then - let app_sk,sk = Stack.strip_app stack in - let (tm',sk'),cst_l' = - whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) - in - let rec is_case x = match EConstr.kind sigma x with - | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x - | App (hd, _) -> is_case hd - | Case _ -> true - | _ -> false in - if equal_stacks sigma (x, app_sk) (tm', sk') - || Stack.will_expose_iota sk' - || is_case tm' - then fold () - else whrec cst_l' (tm', sk' @ sk) - else match recargs with - |[] -> (* if nargs has been specified *) - (* CAUTION : the constant is NEVER refold - (even when it hides a (co)fix) *) - whrec cst_l (body, stack) - |curr::remains -> match Stack.strip_n_app curr stack with - | None -> fold () - | Some (bef,arg,s') -> - whrec Cst_stack.empty - (arg,Stack.Cst(Stack.Cst_const (fst const, u'),curr,remains,bef,cst_l)::s') - end + | Some behavior -> + begin match behavior with + | NeverUnfold -> fold () + | (UnfoldWhen { nargs = Some n } | + UnfoldWhenNoMatch { nargs = Some n } ) + when Stack.args_size stack < n -> + fold () + | UnfoldWhenNoMatch { recargs } -> (* maybe unfolds *) + let app_sk,sk = Stack.strip_app stack in + let (tm',sk'),cst_l' = + whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) + in + let rec is_case x = match EConstr.kind sigma x with + | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x + | App (hd, _) -> is_case hd + | Case _ -> true + | _ -> false in + if equal_stacks sigma (x, app_sk) (tm', sk') + || Stack.will_expose_iota sk' + || is_case tm' + then fold () + else whrec cst_l' (tm', sk' @ sk) + | UnfoldWhen { recargs } -> (* maybe unfolds *) + begin match recargs with + |[] -> (* if nargs has been specified *) + (* CAUTION : the constant is NEVER refold + (even when it hides a (co)fix) *) + whrec cst_l (body, stack) + |curr::remains -> match Stack.strip_n_app curr stack with + | None -> fold () + | Some (bef,arg,s') -> + whrec Cst_stack.empty + (arg,Stack.Cst(Stack.Cst_const (fst const, u'),curr,remains,bef,cst_l)::s') + end + end + end | exception NotEvaluableConst (IsPrimitive p) when Stack.check_native_args p stack -> let kargs = CPrimitives.kind p in let (kargs,o) = Stack.get_next_primitive_args kargs stack in @@ -1015,41 +1006,45 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = else fold () | Proj (p, c) when CClosure.RedFlags.red_projection flags p -> (let npars = Projection.npars p in - if not tactic_mode then - let stack' = (c, Stack.Proj (p, Cst_stack.empty (*cst_l*)) :: stack) in - whrec Cst_stack.empty stack' - else match ReductionBehaviour.get (Globnames.ConstRef (Projection.constant p)) with - | None -> + if not tactic_mode then + let stack' = (c, Stack.Proj (p, Cst_stack.empty (*cst_l*)) :: stack) in + whrec Cst_stack.empty stack' + else match ReductionBehaviour.get (Globnames.ConstRef (Projection.constant p)) with + | None -> let stack' = (c, Stack.Proj (p, cst_l) :: stack) in - let stack'', csts = whrec Cst_stack.empty stack' in - if equal_stacks sigma stack' stack'' then fold () - else stack'', csts - | Some (recargs, nargs, flags) -> - if (List.mem `ReductionNeverUnfold flags - || (nargs > 0 && Stack.args_size stack < (nargs - (npars + 1)))) - then fold () - else - let recargs = List.map_filter (fun x -> - let idx = x - npars in - if idx < 0 then None else Some idx) recargs - in - match recargs with - |[] -> (* if nargs has been specified *) - (* CAUTION : the constant is NEVER refold - (even when it hides a (co)fix) *) + let stack'', csts = whrec Cst_stack.empty stack' in + if equal_stacks sigma stack' stack'' then fold () + else stack'', csts + | Some behavior -> + begin match behavior with + | NeverUnfold -> fold () + | (UnfoldWhen { nargs = Some n } + | UnfoldWhenNoMatch { nargs = Some n }) + when Stack.args_size stack < n - (npars + 1) -> fold () + | UnfoldWhen { recargs } + | UnfoldWhenNoMatch { recargs }-> (* maybe unfolds *) + let recargs = List.map_filter (fun x -> + let idx = x - npars in + if idx < 0 then None else Some idx) recargs + in + match recargs with + |[] -> (* if nargs has been specified *) + (* CAUTION : the constant is NEVER refold + (even when it hides a (co)fix) *) let stack' = (c, Stack.Proj (p, cst_l) :: stack) in - whrec Cst_stack.empty(* cst_l *) stack' - | curr::remains -> - if curr == 0 then (* Try to reduce the record argument *) - whrec Cst_stack.empty - (c, Stack.Cst(Stack.Cst_proj p,curr,remains,Stack.empty,cst_l)::stack) - else - match Stack.strip_n_app curr stack with - | None -> fold () - | Some (bef,arg,s') -> - whrec Cst_stack.empty - (arg,Stack.Cst(Stack.Cst_proj p,curr,remains, - Stack.append_app [|c|] bef,cst_l)::s')) + whrec Cst_stack.empty(* cst_l *) stack' + | curr::remains -> + if curr == 0 then (* Try to reduce the record argument *) + whrec Cst_stack.empty + (c, Stack.Cst(Stack.Cst_proj p,curr,remains,Stack.empty,cst_l)::stack) + else + match Stack.strip_n_app curr stack with + | None -> fold () + | Some (bef,arg,s') -> + whrec Cst_stack.empty + (arg,Stack.Cst(Stack.Cst_proj p,curr,remains, + Stack.append_app [|c|] bef,cst_l)::s') + end) | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fZETA -> apply_subst (fun _ -> whrec) [b] sigma refold cst_l c stack @@ -1675,7 +1670,7 @@ let is_sort env sigma t = (* reduction to head-normal-form allowing delta/zeta only in argument of case/fix (heuristic used by evar_conv) *) -let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = +let whd_betaiota_deltazeta_for_iota_state ts env sigma s = let refold = false in let tactic_mode = false in let rec whrec csts s = @@ -1696,7 +1691,8 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = whrec Cst_stack.empty (Stack.nth stack_o (Projection.npars p + Projection.arg p), stack'') else s,csts' |_, ((Stack.App _|Stack.Cst _|Stack.Primitive _) :: _|[]) -> s,csts' - in whrec csts s + in + fst (whrec Cst_stack.empty s) let find_conclusion env sigma = let rec decrec env c = diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 5938d9b367..aa39921ea2 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -21,13 +21,12 @@ exception Elimconst (** Machinery to customize the behavior of the reduction *) module ReductionBehaviour : sig - type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ] -(** [set is_local ref (recargs, nargs, flags)] *) - val set : - bool -> GlobRef.t -> (int list * int * flag list) -> unit - val get : - GlobRef.t -> (int list * int * flag list) option + type t = NeverUnfold | UnfoldWhen of when_flags | UnfoldWhenNoMatch of when_flags + and when_flags = { recargs : int list ; nargs : int option } + + val set : local:bool -> GlobRef.t -> t -> unit + val get : GlobRef.t -> t option val print : GlobRef.t -> Pp.t end @@ -312,8 +311,7 @@ val betazetaevar_applist : evar_map -> int -> constr -> constr list -> constr (** {6 Heuristic for Conversion with Evar } *) val whd_betaiota_deltazeta_for_iota_state : - TransparentState.t -> Environ.env -> Evd.evar_map -> Cst_stack.t -> state -> - state * Cst_stack.t + TransparentState.t -> Environ.env -> Evd.evar_map -> state -> state (** {6 Meta-related reduction functions } *) val meta_instance : evar_map -> constr freelisted -> constr diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index bcc20a41b4..231219c9de 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -664,18 +664,38 @@ let whd_nothing_for_iota env sigma s = it fails if no redex is around *) let rec red_elim_const env sigma ref u largs = + let open ReductionBehaviour in let nargs = List.length largs in let largs, unfold_anyway, unfold_nonelim, nocase = match recargs ref with | None -> largs, false, false, false - | Some (_,n,f) when nargs < n || List.mem `ReductionNeverUnfold f -> raise Redelimination - | Some (x::l,_,_) when nargs <= List.fold_left max x l -> raise Redelimination - | Some (l,n,f) -> - let is_empty = match l with [] -> true | _ -> false in - reduce_params env sigma largs l, - n >= 0 && is_empty && nargs >= n, - n >= 0 && not is_empty && nargs >= n, - List.mem `ReductionDontExposeCase f + | Some NeverUnfold -> raise Redelimination + | Some (UnfoldWhen { nargs = Some n } | UnfoldWhenNoMatch { nargs = Some n }) + when nargs < n -> raise Redelimination + | Some (UnfoldWhen { recargs = x::l } | UnfoldWhenNoMatch { recargs = x::l }) + when nargs <= List.fold_left max x l -> raise Redelimination + | Some (UnfoldWhen { recargs; nargs = None }) -> + reduce_params env sigma largs recargs, + false, + false, + false + | Some (UnfoldWhenNoMatch { recargs; nargs = None }) -> + reduce_params env sigma largs recargs, + false, + false, + true + | Some (UnfoldWhen { recargs; nargs = Some n }) -> + let is_empty = List.is_empty recargs in + reduce_params env sigma largs recargs, + is_empty && nargs >= n, + not is_empty && nargs >= n, + false + | Some (UnfoldWhenNoMatch { recargs; nargs = Some n }) -> + let is_empty = List.is_empty recargs in + reduce_params env sigma largs recargs, + is_empty && nargs >= n, + not is_empty && nargs >= n, + true in try match reference_eval env sigma ref with | EliminationCases n when nargs >= n -> @@ -737,6 +757,7 @@ and reduce_params env sigma stack l = a reducible iota/fix/cofix redex (the "simpl" tactic) *) and whd_simpl_stack env sigma = + let open ReductionBehaviour in let rec redrec s = let (x, stack) = decompose_app_vect sigma s in let stack = Array.to_list stack in @@ -761,30 +782,30 @@ and whd_simpl_stack env sigma = with Redelimination -> s') | Proj (p, c) -> - (try - let unf = Projection.unfolded p in - if unf || is_evaluable env (EvalConstRef (Projection.constant p)) then - let npars = Projection.npars p in - (match unf, ReductionBehaviour.get (ConstRef (Projection.constant p)) with - | false, Some (l, n, f) when List.mem `ReductionNeverUnfold f -> - (* simpl never *) s' - | false, Some (l, n, f) when not (List.is_empty l) -> - let l' = List.map_filter (fun i -> - let idx = (i - (npars + 1)) in - if idx < 0 then None else Some idx) l in - let stack = reduce_params env sigma stack l' in - (match reduce_projection env sigma p ~npars - (whd_construct_stack env sigma c) stack - with - | Reduced s' -> redrec (applist s') - | NotReducible -> s') - | _ -> - match reduce_projection env sigma p ~npars (whd_construct_stack env sigma c) stack with - | Reduced s' -> redrec (applist s') - | NotReducible -> s') - else s' - with Redelimination -> s') - + (try + let unf = Projection.unfolded p in + if unf || is_evaluable env (EvalConstRef (Projection.constant p)) then + let npars = Projection.npars p in + (match unf, get (ConstRef (Projection.constant p)) with + | false, Some NeverUnfold -> s' + | false, Some (UnfoldWhen { recargs } | UnfoldWhenNoMatch { recargs }) + when not (List.is_empty recargs) -> + let l' = List.map_filter (fun i -> + let idx = (i - (npars + 1)) in + if idx < 0 then None else Some idx) recargs in + let stack = reduce_params env sigma stack l' in + (match reduce_projection env sigma p ~npars + (whd_construct_stack env sigma c) stack + with + | Reduced s' -> redrec (applist s') + | NotReducible -> s') + | _ -> + match reduce_projection env sigma p ~npars (whd_construct_stack env sigma c) stack with + | Reduced s' -> redrec (applist s') + | NotReducible -> s') + else s' + with Redelimination -> s') + | _ -> match match_eval_ref env sigma x stack with | Some (ref, u) -> diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 9ba51dcfa9..d134c7319f 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -489,8 +489,8 @@ let unfold_projection env p stk = let expand_key ts env sigma = function | Some (IsKey k) -> Option.map EConstr.of_constr (expand_table_key env k) | Some (IsProj (p, c)) -> - let red = Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma - Cst_stack.empty (c, unfold_projection env p []))) + let red = Stack.zip sigma (whd_betaiota_deltazeta_for_iota_state ts env sigma + (c, unfold_projection env p [])) in if EConstr.eq_constr sigma (EConstr.mkProj (p, c)) red then None else Some red | None -> None @@ -597,8 +597,8 @@ let constr_cmp pb env sigma flags t u = None let do_reduce ts (env, nb) sigma c = - Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state - ts env sigma Cst_stack.empty (c, Stack.empty))) + Stack.zip sigma (whd_betaiota_deltazeta_for_iota_state + ts env sigma (c, Stack.empty)) let isAllowedEvar sigma flags c = match EConstr.kind sigma c with | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars) diff --git a/proofs/logic.ml b/proofs/logic.ml index a01ddf2388..b79e1e6024 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -78,14 +78,6 @@ let error_no_such_hypothesis env sigma id = raise (RefinerError (env, sigma, NoS let check = ref false let with_check = Flags.with_option check -(* [apply_to_hyp sign id f] splits [sign] into [tail::[id,_,_]::head] and - returns [tail::(f head (id,_,_) (rev tail))] *) -let apply_to_hyp env sigma check sign id f = - try apply_to_hyp sign id f - with Hyp_not_found -> - if check then error_no_such_hypothesis env sigma id - else sign - let check_typability env sigma c = if !check then let _ = unsafe_type_of env sigma (EConstr.of_constr c) in () @@ -161,12 +153,14 @@ let reorder_context env sigma sign ord = step ord ords sign mt_q [] let reorder_val_context env sigma sign ord = +match ord with +| [] | [_] -> + (* Single variable-free definitions need not be reordered *) + sign +| _ :: _ :: _ -> let open EConstr in val_of_named_context (reorder_context env sigma (named_context_of_val sign) ord) - - - let check_decl_position env sigma sign d = let open EConstr in let x = NamedDecl.get_id d in @@ -556,25 +550,25 @@ and treat_case sigma goal ci lbrty lf acc' = (lacc,sigma,fi::bacc)) (acc',sigma,[]) lbrty lf ci.ci_pp_info.cstr_tags -let convert_hyp check sign sigma d = +let convert_hyp ~check ~reorder env sigma d = let id = NamedDecl.get_id d in let b = NamedDecl.get_value d in - let env = Global.env () in - let reorder = ref [] in - let sign' = - apply_to_hyp env sigma check sign id - (fun _ d' _ -> - let c = Option.map EConstr.of_constr (NamedDecl.get_value d') in - let env = Global.env_of_context sign in - if check && not (is_conv env sigma (NamedDecl.get_type d) (EConstr.of_constr (NamedDecl.get_type d'))) then - user_err ~hdr:"Logic.convert_hyp" - (str "Incorrect change of the type of " ++ Id.print id ++ str "."); - if check && not (Option.equal (is_conv env sigma) b c) then - user_err ~hdr:"Logic.convert_hyp" - (str "Incorrect change of the body of "++ Id.print id ++ str "."); - if check then reorder := check_decl_position env sigma sign d; - map_named_decl EConstr.Unsafe.to_constr d) in - reorder_val_context env sigma sign' !reorder + let sign = Environ.named_context_val env in + match lookup_named_ctxt id sign with + | exception Not_found -> + if check then error_no_such_hypothesis env sigma id + else sign + | d' -> + let c = Option.map EConstr.of_constr (NamedDecl.get_value d') in + if check && not (is_conv env sigma (NamedDecl.get_type d) (EConstr.of_constr (NamedDecl.get_type d'))) then + user_err ~hdr:"Logic.convert_hyp" + (str "Incorrect change of the type of " ++ Id.print id ++ str "."); + if check && not (Option.equal (is_conv env sigma) b c) then + user_err ~hdr:"Logic.convert_hyp" + (str "Incorrect change of the body of "++ Id.print id ++ str "."); + let sign' = apply_to_hyp sign id (fun _ _ _ -> EConstr.Unsafe.to_named_decl d) in + if reorder then reorder_val_context env sigma sign' (check_decl_position env sigma sign d) + else sign' (************************************************************************) (************************************************************************) diff --git a/proofs/logic.mli b/proofs/logic.mli index f99076db23..406fe57985 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -62,7 +62,7 @@ type 'id move_location = val pr_move_location : ('a -> Pp.t) -> 'a move_location -> Pp.t -val convert_hyp : bool -> Environ.named_context_val -> evar_map -> +val convert_hyp : check:bool -> reorder:bool -> Environ.env -> evar_map -> EConstr.named_declaration -> Environ.named_context_val val move_hyp_in_named_context : Environ.env -> Evd.evar_map -> Id.t -> Id.t move_location -> diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index d13763cdec..2b32838964 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -99,7 +99,7 @@ let dynamic_bullet doc { dynamic_switch = id; carry_on_data = b } = `ValidBlock { base_state = id; goals_to_admit = focused; - recovery_command = Some (Vernacexpr.VernacExpr([], Vernacexpr.VernacBullet (to_bullet_val b))) + recovery_command = Some (CAst.make @@ Vernacexpr.VernacExpr([], Vernacexpr.VernacBullet (to_bullet_val b))) } | `Not -> `Leaks @@ -128,7 +128,7 @@ let dynamic_curly_brace doc { dynamic_switch = id } = `ValidBlock { base_state = id; goals_to_admit = focused; - recovery_command = Some (Vernacexpr.VernacExpr ([], Vernacexpr.VernacEndSubproof)) + recovery_command = Some (CAst.make @@ Vernacexpr.VernacExpr ([], Vernacexpr.VernacEndSubproof)) } | `Not -> `Leaks diff --git a/stm/stm.ml b/stm/stm.ml index 06bc6e3340..3eb6d03529 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -121,7 +121,6 @@ let async_proofs_workers_extra_env = ref [||] type aast = { verbose : bool; - loc : Loc.t option; indentation : int; strlen : int; mutable expr : vernac_control; (* mutable: Proof using hinted by aux file *) @@ -1149,12 +1148,12 @@ end (* Wrapper for Vernacentries.interp to set the feedback id *) (* It is currently called 19 times, this number should be certainly reduced... *) -let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacstate.t = +let stm_vernac_interp ?proof ?route id st { verbose; expr } : Vernacstate.t = (* The Stm will gain the capability to interpret commmads affecting the whole document state, such as backtrack, etc... so we start to design the stm command interpreter now *) set_id_for_feedback ?route dummy_doc id; - Aux_file.record_in_aux_set_at ?loc (); + Aux_file.record_in_aux_set_at ?loc:expr.CAst.loc (); (* We need to check if a command should be filtered from * vernac_entries, as it cannot handle it. This should go away in * future refactorings. @@ -1175,7 +1174,7 @@ let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacstate.t | VernacShow ShowScript -> ShowScript.show_script (); st (* XX we are ignoring control here *) | _ -> stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); - try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st (CAst.make ?loc expr) + try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st expr with e -> let e = CErrors.push e in Exninfo.iraise Hooks.(call_process_error_once e) @@ -1630,8 +1629,8 @@ end = struct (* {{{ *) let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_vernac_interp stop ~proof:(pobject, terminator) st - { verbose = false; loc; indentation = 0; strlen = 0; - expr = VernacExpr ([], VernacEndProof (Proved (opaque,None))) }) in + { verbose = false; indentation = 0; strlen = 0; + expr = CAst.make ?loc @@ VernacExpr ([], VernacEndProof (Proved (opaque,None))) }) in ignore(Future.join checked_proof); end; (* STATE: Restore the state XXX: handle exn *) @@ -1780,8 +1779,8 @@ end = struct (* {{{ *) (* STATE We use the state resulting from reaching start. *) let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp stop ~proof st - { verbose = false; loc; indentation = 0; strlen = 0; - expr = VernacExpr ([], VernacEndProof (Proved (opaque,None))) }); + { verbose = false; indentation = 0; strlen = 0; + expr = CAst.make ?loc @@ VernacExpr ([], VernacEndProof (Proved (opaque,None))) }); `OK proof end with e -> @@ -1793,10 +1792,11 @@ end = struct (* {{{ *) spc () ++ iprint (e, info)) | Some (_, cur) -> match VCS.visit cur with - | { step = `Cmd { cast = { loc } } } - | { step = `Fork (( { loc }, _, _, _), _) } - | { step = `Qed ( { qast = { loc } }, _) } - | { step = `Sideff (ReplayCommand { loc }, _) } -> + | { step = `Cmd { cast } } + | { step = `Fork (( cast, _, _, _), _) } + | { step = `Qed ( { qast = cast }, _) } + | { step = `Sideff (ReplayCommand cast, _) } -> + let loc = cast.expr.CAst.loc in let start, stop = Option.cata Loc.unloc (0,0) loc in msg_warning Pp.( str"File " ++ str name ++ str ": proof of " ++ str r_name ++ @@ -2073,14 +2073,14 @@ end = struct (* {{{ *) f () let vernac_interp ~solve ~abstract ~cancel_switch nworkers safe_id id - { indentation; verbose; loc; expr = e; strlen } : unit + { indentation; verbose; expr = e; strlen } : unit = let e, time, batch, fail = - let rec find ~time ~batch ~fail = function - | VernacTime (batch,{CAst.v=e}) -> find ~time:true ~batch ~fail e - | VernacRedirect (_,{CAst.v=e}) -> find ~time ~batch ~fail e - | VernacFail {CAst.v=e} -> find ~time ~batch ~fail:true e - | e -> e, time, batch, fail in + let rec find ~time ~batch ~fail v = CAst.with_loc_val (fun ?loc -> function + | VernacTime (batch,e) -> find ~time:true ~batch ~fail e + | VernacRedirect (_,e) -> find ~time ~batch ~fail e + | VernacFail e -> find ~time ~batch ~fail:true e + | e -> CAst.make ?loc e, time, batch, fail) v in find ~time:false ~batch:false ~fail:false e in let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_fail ~st fail (fun () -> @@ -2094,7 +2094,7 @@ end = struct (* {{{ *) Future.create_delegate ~name:(Printf.sprintf "subgoal %d" i) (State.exn_on id ~valid:safe_id) in - let t_ast = (i, { indentation; verbose; loc; expr = e; strlen }) in + let t_ast = (i, { indentation; verbose; expr = e; strlen }) in let t_name = Goal.uid g in TaskQueue.enqueue_task queue { t_state = safe_id; t_state_fb = id; @@ -2243,7 +2243,7 @@ let collect_proof keep cur hd brkind id = let name = function | [] -> no_name | id :: _ -> Names.Id.to_string id in - let loc = (snd cur).loc in + let loc = (snd cur).expr.CAst.loc in let is_defined_expr = function | VernacEndProof (Proved (Proof_global.Transparent,_)) -> true | _ -> false in @@ -2309,7 +2309,7 @@ let collect_proof keep cur hd brkind id = (try let name, hint = name ids, get_hint_ctx loc in let t, v = proof_no_using last in - v.expr <- VernacExpr([], VernacProof(t, Some hint)); + v.expr <- CAst.map (fun _ -> VernacExpr([], VernacProof(t, Some hint))) v.expr; `ASync (parent last,accn,name,delegate name) with Not_found -> let name = name ids in @@ -2412,7 +2412,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = (* STATE: We use an updated state with proof *) let st = Vernacstate.freeze_interp_state ~marshallable:false in Option.iter (fun expr -> ignore(stm_vernac_interp id st { - verbose = true; loc = None; expr; indentation = 0; + verbose = true; expr; indentation = 0; strlen = 0 } )) recovery_command | _ -> assert false @@ -2532,7 +2532,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | `ASync (block_start, nodes, name, delegate) -> (fun () -> let keep' = get_vtkeep keep in let drop_pt = keep' == VtKeepAxiom in - let block_stop, exn_info, loc = eop, (id, eop), x.loc in + let block_stop, exn_info, loc = eop, (id, eop), x.expr.CAst.loc in log_processing_async id name; VCS.create_proof_task_box nodes ~qed:id ~block_start; begin match brinfo, qed.fproof with @@ -2592,7 +2592,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = log_processing_sync id name reason; reach eop; let wall_clock = Unix.gettimeofday () in - record_pb_time name ?loc:x.loc (wall_clock -. !wall_clock_last_fork); + record_pb_time name ?loc:x.expr.CAst.loc (wall_clock -. !wall_clock_last_fork); let proof = match keep with | VtDrop -> None @@ -2614,7 +2614,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id ?proof st x); let wall_clock3 = Unix.gettimeofday () in - Aux_file.record_in_aux_at ?loc:x.loc "proof_check_time" + Aux_file.record_in_aux_at ?loc:x.expr.CAst.loc "proof_check_time" (Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2)); PG_compat.discard_all () ), true, true @@ -2934,7 +2934,7 @@ let get_allow_nested_proofs = (** [process_transaction] adds a node in the document *) let process_transaction ~doc ?(newtip=Stateid.fresh ()) - ({ verbose; loc; expr } as x) c = + ({ verbose; expr } as x) c = stm_pperr_endline (fun () -> str "{{{ processing: " ++ pr_ast x); let vcs = VCS.backup () in try @@ -3120,11 +3120,11 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) let get_ast ~doc id = match VCS.visit id with - | { step = `Cmd { cast = { loc; expr } } } - | { step = `Fork (({ loc; expr }, _, _, _), _) } - | { step = `Sideff ((ReplayCommand {loc; expr}) , _) } - | { step = `Qed ({ qast = { loc; expr } }, _) } -> - Some (Loc.tag ?loc expr) + | { step = `Cmd { cast = { expr } } } + | { step = `Fork (({ expr }, _, _, _), _) } + | { step = `Sideff ((ReplayCommand { expr }) , _) } + | { step = `Qed ({ qast = { expr } }, _) } -> + Some expr | _ -> None let stop_worker n = Slaves.cancel_worker n @@ -3141,8 +3141,8 @@ let parse_sentence ~doc sid ~entry pa = let ind_len_loc_of_id sid = if Stateid.equal sid Stateid.initial then None else match (VCS.visit sid).step with - | `Cmd { ctac = true; cast = { indentation; strlen; loc } } -> - Some (indentation, strlen, loc) + | `Cmd { ctac = true; cast = { indentation; strlen; expr } } -> + Some (indentation, strlen, expr.CAst.loc) | _ -> None (* the indentation logic works like this: if the beginning of the @@ -3169,7 +3169,8 @@ let compute_indentation ?loc sid = Option.cata (fun loc -> eff_indent, len ) (0, 0) loc -let add ~doc ~ontop ?newtip verb { CAst.loc; v=ast } = +let add ~doc ~ontop ?newtip verb ast = + let loc = ast.CAst.loc in let cur_tip = VCS.cur_tip () in if not (Stateid.equal ontop cur_tip) then user_err ?loc ~hdr:"Stm.add" @@ -3179,7 +3180,7 @@ let add ~doc ~ontop ?newtip verb { CAst.loc; v=ast } = let indentation, strlen = compute_indentation ?loc ontop in (* XXX: Classifiy vernac should be moved inside process transaction *) let clas = Vernac_classifier.classify_vernac ast in - let aast = { verbose = verb; indentation; strlen; loc; expr = ast } in + let aast = { verbose = verb; indentation; strlen; expr = ast } in match process_transaction ~doc ?newtip aast clas with | `Ok -> doc, VCS.cur_tip (), `NewTip | `Unfocus qed_id -> doc, qed_id, `Unfocus (VCS.cur_tip ()) @@ -3199,14 +3200,15 @@ let query ~doc ~at ~route s = let rec loop () = match parse_sentence ~doc at ~entry:Pvernac.main_entry s with | None -> () - | Some {CAst.loc; v=ast} -> - let indentation, strlen = compute_indentation ?loc at in - let st = State.get_cached at in - let aast = { - verbose = true; indentation; strlen; - loc; expr = ast } in - ignore(stm_vernac_interp ~route at st aast); - loop () + | Some ast -> + let loc = ast.CAst.loc in + let indentation, strlen = compute_indentation ?loc at in + let st = State.get_cached at in + let aast = { + verbose = true; indentation; strlen; + expr = ast } in + ignore(stm_vernac_interp ~route at st aast); + loop () in loop () ) diff --git a/stm/stm.mli b/stm/stm.mli index 91651e3534..9d2bf56629 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -111,7 +111,7 @@ val parse_sentence : If [newtip] is provided, then the returned state id is guaranteed to be [newtip] *) val add : doc:doc -> ontop:Stateid.t -> ?newtip:Stateid.t -> - bool -> Vernacexpr.vernac_control CAst.t -> + bool -> Vernacexpr.vernac_control -> doc * Stateid.t * [ `NewTip | `Unfocus of Stateid.t ] (* Returns the proof state before the last tactic that was applied at or before @@ -175,7 +175,7 @@ val get_current_state : doc:doc -> Stateid.t val get_ldir : doc:doc -> Names.DirPath.t (* This returns the node at that position *) -val get_ast : doc:doc -> Stateid.t -> (Vernacexpr.vernac_control Loc.located) option +val get_ast : doc:doc -> Stateid.t -> Vernacexpr.vernac_control option (* Filename *) val set_compilation_hints : string -> unit diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 243b5c333d..4a4c5c94e9 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -137,7 +137,7 @@ let classify_vernac e = | Constructors l -> List.map (fun (_,({v=id},_)) -> id) l | RecordDecl (oid,l) -> (match oid with Some {v=x} -> [x] | _ -> []) @ CList.map_filter (function - | ((_,AssumExpr({v=Names.Name n},_)),_),_ -> Some n + | AssumExpr({v=Names.Name n},_), _ -> Some n | _ -> None) l) l in VtSideff (List.flatten ids), VtLater | VernacScheme l -> @@ -200,20 +200,20 @@ let classify_vernac e = try Vernacextend.get_vernac_classifier s l with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in - let rec static_control_classifier = function + let rec static_control_classifier v = v |> CAst.with_val (function | VernacExpr (f, e) -> let poly = Attributes.(parse_drop_extra polymorphic_nowarn f) in static_classifier ~poly e - | VernacTimeout (_,{v=e}) -> static_control_classifier e - | VernacTime (_,{v=e}) | VernacRedirect (_, {v=e}) -> + | VernacTimeout (_,e) -> static_control_classifier e + | VernacTime (_,e) | VernacRedirect (_, e) -> static_control_classifier e - | VernacFail {v=e} -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) + | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) (match static_control_classifier e with | ( VtQuery | VtProofStep _ | VtSideff _ | VtMeta), _ as x -> x | VtQed _, _ -> VtProofStep { parallel = `No; proof_block_detection = None }, VtLater - | (VtStartProof _ | VtUnknown | VtProofMode _), _ -> VtQuery, VtLater) + | (VtStartProof _ | VtUnknown | VtProofMode _), _ -> VtQuery, VtLater)) in static_control_classifier e diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index c1ac7d201a..160e4f164e 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -548,7 +548,7 @@ let make_resolve_hyp env sigma st flags only_classes pri decl = make_apply_entry ~name env sigma flags pri false]) else [] -let make_hints g st only_classes sign = +let make_hints g (modes,st) only_classes sign = let hintlist = List.fold_left (fun hints hyp -> @@ -565,7 +565,9 @@ let make_hints g st only_classes sign = in hint @ hints else hints) ([]) sign - in Hint_db.add_list (pf_env g) (project g) hintlist (Hint_db.empty st true) + in + let db = Hint_db.add_modes modes @@ Hint_db.empty st true in + Hint_db.add_list (pf_env g) (project g) hintlist db module Search = struct type autoinfo = @@ -578,29 +580,29 @@ module Search = struct (** Local hints *) let autogoal_cache = Summary.ref ~name:"autogoal_cache" - (DirPath.empty, true, Context.Named.empty, + (DirPath.empty, true, Context.Named.empty, GlobRef.Map.empty, Hint_db.empty TransparentState.full true) - let make_autogoal_hints only_classes ?(st=TransparentState.full) g = + let make_autogoal_hints only_classes (modes,st as mst) g = let open Proofview in let open Tacmach.New in let sign = Goal.hyps g in - let (dir, onlyc, sign', cached_hints) = !autogoal_cache in + let (dir, onlyc, sign', cached_modes, cached_hints) = !autogoal_cache in let cwd = Lib.cwd () in let eq c1 c2 = EConstr.eq_constr (project g) c1 c2 in if DirPath.equal cwd dir && (onlyc == only_classes) && Context.Named.equal eq sign sign' && - Hint_db.transparent_state cached_hints == st + cached_modes == modes then cached_hints else let hints = make_hints {it = Goal.goal g; sigma = project g} - st only_classes sign + mst only_classes sign in - autogoal_cache := (cwd, only_classes, sign, hints); hints + autogoal_cache := (cwd, only_classes, sign, modes, hints); hints - let make_autogoal ?(st=TransparentState.full) only_classes dep cut i g = - let hints = make_autogoal_hints only_classes ~st g in + let make_autogoal mst only_classes dep cut i g = + let hints = make_autogoal_hints only_classes mst g in { search_hints = hints; search_depth = [i]; last_tac = lazy (str"none"); search_dep = dep; @@ -695,7 +697,8 @@ module Search = struct if b && not (Context.Named.equal eq (Goal.hyps gl') (Goal.hyps gl)) then let st = Hint_db.transparent_state info.search_hints in - make_autogoal_hints info.search_only_classes ~st gl' + let modes = Hint_db.modes info.search_hints in + make_autogoal_hints info.search_only_classes (modes,st) gl' else info.search_hints in let dep' = info.search_dep || Proofview.unifiable sigma' (Goal.goal gl') gls in @@ -830,19 +833,19 @@ module Search = struct (fun e' -> let (e, info) = merge_exceptions e e' in Proofview.tclZERO ~info e)) - let search_tac_gl ?st only_classes dep hints depth i sigma gls gl : + let search_tac_gl mst only_classes dep hints depth i sigma gls gl : unit Proofview.tactic = let open Proofview in let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in - let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in + let info = make_autogoal mst only_classes dep (cut_of_hints hints) i gl in search_tac hints depth 1 info - let search_tac ?(st=TransparentState.full) only_classes dep hints depth = + let search_tac mst only_classes dep hints depth = let open Proofview in let tac sigma gls i = Goal.enter begin fun gl -> - search_tac_gl ~st only_classes dep hints depth (succ i) sigma gls gl end + search_tac_gl mst only_classes dep hints depth (succ i) sigma gls gl end in Proofview.Unsafe.tclGETGOALS >>= fun gls -> let gls = CList.map Proofview.drop_state gls in @@ -867,11 +870,11 @@ module Search = struct | (e,ie) -> Proofview.tclZERO ~info:ie e) in aux 1 - let eauto_tac ?(st=TransparentState.full) ?(unique=false) + let eauto_tac mst ?(unique=false) ~only_classes ?strategy ~depth ~dep hints = let open Proofview in let tac = - let search = search_tac ~st only_classes dep hints in + let search = search_tac mst only_classes dep hints in let dfs = match strategy with | None -> not (get_typeclasses_iterative_deepening ()) @@ -915,8 +918,8 @@ module Search = struct | Some i -> str ", with depth limit " ++ int i)); tac - let eauto_tac ?st ?unique ~only_classes ?strategy ~depth ~dep hints = - Hints.wrap_hint_warning @@ eauto_tac ?st ?unique ~only_classes ?strategy ~depth ~dep hints + let eauto_tac mst ?unique ~only_classes ?strategy ~depth ~dep hints = + Hints.wrap_hint_warning @@ eauto_tac mst ?unique ~only_classes ?strategy ~depth ~dep hints let run_on_evars env evm p tac = match evars_to_goals p evm with @@ -968,8 +971,8 @@ module Search = struct else raise Not_found with Logic_monad.TacticFailure _ -> raise Not_found - let evars_eauto env evd depth only_classes unique dep st hints p = - let eauto_tac = eauto_tac ~st ~unique ~only_classes ~depth ~dep:(unique || dep) hints in + let evars_eauto env evd depth only_classes unique dep mst hints p = + let eauto_tac = eauto_tac mst ~unique ~only_classes ~depth ~dep:(unique || dep) hints in let res = run_on_evars env evd p eauto_tac in match res with | None -> evd @@ -983,11 +986,11 @@ module Search = struct let typeclasses_resolve env evd debug depth unique p = let db = searchtable_map typeclasses_db in - typeclasses_eauto env evd ?depth unique (Hint_db.transparent_state db) [db] p + let st = Hint_db.transparent_state db in + let modes = Hint_db.modes db in + typeclasses_eauto env evd ?depth unique (modes,st) [db] p end -(** Binding to either V85 or Search implementations. *) - let typeclasses_eauto ?(only_classes=false) ?(st=TransparentState.full) ?strategy ~depth dbs = let dbs = List.map_filter @@ -996,8 +999,10 @@ let typeclasses_eauto ?(only_classes=false) ?(st=TransparentState.full) dbs in let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in + let modes = List.map Hint_db.modes dbs in + let modes = List.fold_left (GlobRef.Map.union (fun _ m1 m2 -> Some (m1@m2))) GlobRef.Map.empty modes in let depth = match depth with None -> get_typeclasses_depth () | Some l -> Some l in - Search.eauto_tac ~st ~only_classes ?strategy ~depth ~dep:true dbs + Search.eauto_tac (modes,st) ~only_classes ?strategy ~depth ~dep:true dbs (** We compute dependencies via a union-find algorithm. Beware of the imperative effects on the partition structure, @@ -1140,11 +1145,12 @@ let resolve_one_typeclass env ?(sigma=Evd.from_env env) gl unique = let gls = { it = gl ; sigma = sigma; } in let hints = searchtable_map typeclasses_db in let st = Hint_db.transparent_state hints in + let modes = Hint_db.modes hints in let depth = get_typeclasses_depth () in let gls' = try Proofview.V82.of_tactic - (Search.eauto_tac ~st ~only_classes:true ~depth [hints] ~dep:true) gls + (Search.eauto_tac (modes,st) ~only_classes:true ~depth [hints] ~dep:true) gls with Refiner.FailError _ -> raise Not_found in let evd = sig_sig gls' in diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index c950e3de3d..b9291f6124 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -27,9 +27,18 @@ type search_strategy = Dfs | Bfs val set_typeclasses_strategy : search_strategy -> unit -val typeclasses_eauto : ?only_classes:bool -> ?st:TransparentState.t -> ?strategy:search_strategy -> - depth:(Int.t option) -> - Hints.hint_db_name list -> unit Proofview.tactic +val typeclasses_eauto : + ?only_classes:bool + (** Should non-class goals be shelved and resolved at the end *) + -> ?st:TransparentState.t + (** The transparent_state used when working with local hypotheses *) + -> ?strategy:search_strategy + (** Is a traversing-strategy specified? *) + -> depth:(Int.t option) + (** Bounded or unbounded search *) + -> Hints.hint_db_name list + (** The list of hint databases to use *) + -> unit Proofview.tactic val head_of_constr : Id.t -> constr -> unit Proofview.tactic @@ -41,8 +50,8 @@ val autoapply : constr -> Hints.hint_db_name -> unit Proofview.tactic module Search : sig val eauto_tac : - ?st:TransparentState.t - (** The transparent_state used when working with local hypotheses *) + Hints.hint_mode array list GlobRef.Map.t * TransparentState.t + (** The transparent_state and modes used when working with local hypotheses *) -> ?unique:bool (** Should we force a unique solution *) -> only_classes:bool diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 70854e6e3c..0857c05968 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -514,7 +514,7 @@ let autounfold_one db cl = in if did then match cl with - | Some hyp -> change_in_hyp None (make_change_arg c') hyp + | Some hyp -> change_in_hyp ~check:true None (make_change_arg c') hyp | None -> convert_concl ~check:false c' DEFAULTcast else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") end diff --git a/tactics/equality.ml b/tactics/equality.ml index 3d760f1c3d..f049f8c568 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1613,10 +1613,10 @@ let cutSubstInHyp l2r eqn id = tclTHEN (Proofview.Unsafe.tclEVARS sigma) (tclTHENFIRST (tclTHENLIST [ - (change_in_hyp None (make_change_arg typ) (id,InHypTypeOnly)); + (change_in_hyp ~check:true None (make_change_arg typ) (id,InHypTypeOnly)); (replace_core (onHyp id) l2r eqn) ]) - (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly))) + (change_in_hyp ~check:true None (make_change_arg expected) (id,InHypTypeOnly))) end let try_rewrite tac = diff --git a/tactics/hints.ml b/tactics/hints.ml index 11a8816159..cc56c1c425 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -289,8 +289,6 @@ let lookup_tacs sigma concl st se = let sl' = List.stable_sort pri_order_int l' in List.merge pri_order_int se.sentry_nopat sl' -module Constr_map = Map.Make(GlobRef.Ordered) - let is_transparent_gr ts = function | VarRef id -> TransparentState.is_transparent_variable ts id | ConstRef cst -> TransparentState.is_transparent_constant ts cst @@ -520,6 +518,8 @@ val add_cut : hints_path -> t -> t val add_mode : GlobRef.t -> hint_mode array -> t -> t val cut : t -> hints_path val unfolds : t -> Id.Set.t * Cset.t +val add_modes : hint_mode array list GlobRef.Map.t -> t -> t +val modes : t -> hint_mode array list GlobRef.Map.t val fold : (GlobRef.t option -> hint_mode array list -> full_hint list -> 'a -> 'a) -> t -> 'a -> 'a @@ -532,7 +532,7 @@ struct hintdb_unfolds : Id.Set.t * Cset.t; hintdb_max_id : int; use_dn : bool; - hintdb_map : search_entry Constr_map.t; + hintdb_map : search_entry GlobRef.Map.t; (* A list of unindexed entries starting with an unfoldable constant or with no associated pattern. *) hintdb_nopat : (GlobRef.t option * stored_data) list; @@ -548,12 +548,12 @@ struct hintdb_unfolds = (Id.Set.empty, Cset.empty); hintdb_max_id = 0; use_dn = use_dn; - hintdb_map = Constr_map.empty; + hintdb_map = GlobRef.Map.empty; hintdb_nopat = []; hintdb_name = name; } let find key db = - try Constr_map.find key db.hintdb_map + try GlobRef.Map.find key db.hintdb_map with Not_found -> empty_se let realize_tac secvars (id,tac) = @@ -650,11 +650,11 @@ struct else db | Some gr -> let oval = find gr db in - { db with hintdb_map = Constr_map.add gr (add_tac pat idv dnst oval) db.hintdb_map } + { db with hintdb_map = GlobRef.Map.add gr (add_tac pat idv dnst oval) db.hintdb_map } let rebuild_db st' db = let db' = - { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map; + { db with hintdb_map = GlobRef.Map.map (rebuild_dn st') db.hintdb_map; hintdb_state = st'; hintdb_nopat = [] } in List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat @@ -693,7 +693,7 @@ struct let remove_list grs db = let filter (_, h) = match h.name with PathHints [gr] -> not (List.mem_f GlobRef.equal gr grs) | _ -> true in - let hintmap = Constr_map.map (remove_he db.hintdb_state filter) db.hintdb_map in + let hintmap = GlobRef.Map.map (remove_he db.hintdb_state filter) db.hintdb_map in let hintnopat = List.filter (fun (ge, sd) -> filter sd) db.hintdb_nopat in { db with hintdb_map = hintmap; hintdb_nopat = hintnopat } @@ -706,11 +706,11 @@ struct let iter f db = let iter_se k se = f (Some k) se.sentry_mode (get_entry se) in f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat); - Constr_map.iter iter_se db.hintdb_map + GlobRef.Map.iter iter_se db.hintdb_map let fold f db accu = let accu = f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat) accu in - Constr_map.fold (fun k se -> f (Some k) se.sentry_mode (get_entry se)) db.hintdb_map accu + GlobRef.Map.fold (fun k se -> f (Some k) se.sentry_mode (get_entry se)) db.hintdb_map accu let transparent_state db = db.hintdb_state @@ -724,12 +724,21 @@ struct let add_mode gr m db = let se = find gr db in let se = { se with sentry_mode = m :: se.sentry_mode } in - { db with hintdb_map = Constr_map.add gr se db.hintdb_map } + { db with hintdb_map = GlobRef.Map.add gr se db.hintdb_map } let cut db = db.hintdb_cut let unfolds db = db.hintdb_unfolds + let add_modes modes db = + let f gr e me = + Some { e with sentry_mode = me.sentry_mode @ e.sentry_mode } + in + let mode_entries = GlobRef.Map.map (fun m -> { empty_se with sentry_mode = m }) modes in + { db with hintdb_map = GlobRef.Map.union f db.hintdb_map mode_entries } + + let modes db = GlobRef.Map.map (fun se -> se.sentry_mode) db.hintdb_map + let use_dn db = db.use_dn end diff --git a/tactics/hints.mli b/tactics/hints.mli index 90a8b7fe52..7b8f96cdd8 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -162,6 +162,9 @@ module Hint_db : val cut : t -> hints_path val unfolds : t -> Id.Set.t * Cset.t + + val add_modes : hint_mode array list GlobRef.Map.t -> t -> t + val modes : t -> hint_mode array list GlobRef.Map.t end type hint_db = Hint_db.t diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b70dd63211..806c955591 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -145,7 +145,7 @@ let introduction id = let error msg = CErrors.user_err Pp.(str msg) -let convert_concl ?(check=true) ty k = +let convert_concl ~check ty k = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let conclty = Proofview.Goal.concl gl in @@ -163,12 +163,12 @@ let convert_concl ?(check=true) ty k = end end -let convert_hyp ?(check=true) d = +let convert_hyp ~check ~reorder d = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.concl gl in - let sign = convert_hyp check (named_context_val env) sigma d in + let sign = convert_hyp ~check ~reorder env sigma d in let env = reset_with_named_context sign env in Refine.refine ~typecheck:false begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ty @@ -176,7 +176,7 @@ let convert_hyp ?(check=true) d = end let convert_concl_no_check = convert_concl ~check:false -let convert_hyp_no_check = convert_hyp ~check:false +let convert_hyp_no_check = convert_hyp ~check:false ~reorder:false let convert_gen pb x y = Proofview.Goal.enter begin fun gl -> @@ -701,7 +701,7 @@ let bind_red_expr_occurrences occs nbcl redexp = (** Tactic reduction modulo evars (for universes essentially) *) -let e_change_in_concl ?(check = false) (redfun, sty) = +let e_change_in_concl ~check (redfun, sty) = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let (sigma, c') = redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in @@ -709,16 +709,16 @@ let e_change_in_concl ?(check = false) (redfun, sty) = (convert_concl ~check c' sty) end -let e_change_in_hyp ?(check = false) redfun (id,where) = +let e_change_in_hyp ~check ~reorder redfun (id,where) = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let hyp = Tacmach.New.pf_get_hyp id gl in let (sigma, c) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (convert_hyp ~check c) + (convert_hyp ~check ~reorder c) end -let e_change_in_hyps ?(check=true) f args = +let e_change_in_hyps ~check ~reorder f args = Proofview.Goal.enter begin fun gl -> let fold (env, sigma) arg = let (redfun, id, where) = f arg in @@ -728,7 +728,7 @@ let e_change_in_hyps ?(check=true) f args = raise (RefinerError (env, sigma, NoSuchHyp id)) in let (sigma, d) = e_pf_change_decl redfun where hyp env sigma in - let sign = Logic.convert_hyp check (named_context_val env) sigma d in + let sign = Logic.convert_hyp ~check ~reorder env sigma d in let env = reset_with_named_context sign env in (env, sigma) in @@ -745,26 +745,26 @@ let e_change_in_hyps ?(check=true) f args = let e_reduct_in_concl = e_change_in_concl -let reduct_in_concl ?(check = false) (redfun, sty) = +let reduct_in_concl ~check (redfun, sty) = let redfun env sigma c = (sigma, redfun env sigma c) in e_change_in_concl ~check (redfun, sty) -let e_reduct_in_hyp ?(check=false) redfun (id, where) = +let e_reduct_in_hyp ~check ~reorder redfun (id, where) = let redfun _ env sigma c = redfun env sigma c in - e_change_in_hyp ~check redfun (id, where) + e_change_in_hyp ~check ~reorder redfun (id, where) -let reduct_in_hyp ?(check = false) redfun (id, where) = +let reduct_in_hyp ~check ~reorder redfun (id, where) = let redfun _ env sigma c = (sigma, redfun env sigma c) in - e_change_in_hyp ~check redfun (id, where) + e_change_in_hyp ~check ~reorder redfun (id, where) let revert_cast (redfun,kind as r) = if kind == DEFAULTcast then (redfun,REVERTcast) else r -let e_reduct_option ?(check=false) redfun = function - | Some id -> e_reduct_in_hyp ~check (fst redfun) id +let e_reduct_option ~check redfun = function + | Some id -> e_reduct_in_hyp ~check ~reorder:check (fst redfun) id | None -> e_change_in_concl ~check (revert_cast redfun) -let reduct_option ?(check = false) (redfun, sty) where = +let reduct_option ~check (redfun, sty) where = let redfun env sigma c = (sigma, redfun env sigma c) in e_reduct_option ~check (redfun, sty) where @@ -802,15 +802,21 @@ let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = | Some sigma -> (sigma, t') (* Use cumulativity only if changing the conclusion not a subterm *) -let change_on_subterm cv_pb deep t where env sigma c = +let change_on_subterm ~check cv_pb deep t where env sigma c = let mayneedglobalcheck = ref false in let (sigma, c) = match where with - | None -> change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty) env sigma c + | None -> + if check then + change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty) env sigma c + else + t Id.Map.empty env sigma | Some occl -> e_contextually false occl (fun subst -> - change_and_check Reduction.CONV mayneedglobalcheck true (t subst)) - env sigma c in + if check then + change_and_check Reduction.CONV mayneedglobalcheck true (t subst) + else + fun env sigma _c -> t subst env sigma) env sigma c in if !mayneedglobalcheck then begin try ignore (Typing.unsafe_type_of env sigma c) @@ -819,14 +825,13 @@ let change_on_subterm cv_pb deep t where env sigma c = end; (sigma, c) -let change_in_concl occl t = - e_change_in_concl ~check:false ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast) +let change_in_concl ~check occl t = + (* No need to check in e_change_in_concl, the check is done in change_on_subterm *) + e_change_in_concl ~check:false ((change_on_subterm ~check Reduction.CUMUL false t occl),DEFAULTcast) -let change_in_hyp occl t id = - (* FIXME: we set the [check] flag only to reorder hypotheses in case of - introduction of dependencies in new variables. We should separate this - check from the conversion function. *) - e_change_in_hyp ~check:true (fun x -> change_on_subterm Reduction.CONV x t occl) id +let change_in_hyp ~check occl t id = + (* Same as above *) + e_change_in_hyp ~check:false ~reorder:check (fun x -> change_on_subterm ~check Reduction.CONV x t occl) id let concrete_clause_of enum_hyps cl = match cl.onhyps with | None -> @@ -835,43 +840,44 @@ let concrete_clause_of enum_hyps cl = match cl.onhyps with | Some l -> List.map (fun ((occs, id), w) -> (id, occs, w)) l -let change chg c cls = +let change ~check chg c cls = Proofview.Goal.enter begin fun gl -> let hyps = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in begin match cls.concl_occs with | NoOccurrences -> Proofview.tclUNIT () - | occs -> change_in_concl (bind_change_occurrences occs chg) c + | occs -> change_in_concl ~check (bind_change_occurrences occs chg) c end <*> let f (id, occs, where) = let occl = bind_change_occurrences occs chg in - let redfun deep env sigma t = change_on_subterm Reduction.CONV deep c occl env sigma t in + let redfun deep env sigma t = change_on_subterm ~check Reduction.CONV deep c occl env sigma t in (redfun, id, where) in - e_change_in_hyps ~check:true f hyps + (* Don't check, we do it already in [change_on_subterm] *) + e_change_in_hyps ~check:false ~reorder:check f hyps end let change_concl t = - change_in_concl None (make_change_arg t) + change_in_concl ~check:true None (make_change_arg t) (* Pour usage interne (le niveau User est pris en compte par reduce) *) -let red_in_concl = reduct_in_concl (red_product,REVERTcast) -let red_in_hyp = reduct_in_hyp red_product -let red_option = reduct_option (red_product,REVERTcast) -let hnf_in_concl = reduct_in_concl (hnf_constr,REVERTcast) -let hnf_in_hyp = reduct_in_hyp hnf_constr -let hnf_option = reduct_option (hnf_constr,REVERTcast) -let simpl_in_concl = reduct_in_concl (simpl,REVERTcast) -let simpl_in_hyp = reduct_in_hyp simpl -let simpl_option = reduct_option (simpl,REVERTcast) -let normalise_in_concl = reduct_in_concl (compute,REVERTcast) -let normalise_in_hyp = reduct_in_hyp compute -let normalise_option = reduct_option (compute,REVERTcast) -let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast) -let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,REVERTcast) -let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) -let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) -let pattern_option l = e_reduct_option (pattern_occs l,DEFAULTcast) +let red_in_concl = reduct_in_concl ~check:false (red_product,REVERTcast) +let red_in_hyp = reduct_in_hyp ~check:false ~reorder:false red_product +let red_option = reduct_option ~check:false (red_product,REVERTcast) +let hnf_in_concl = reduct_in_concl ~check:false (hnf_constr,REVERTcast) +let hnf_in_hyp = reduct_in_hyp ~check:false ~reorder:false hnf_constr +let hnf_option = reduct_option ~check:false (hnf_constr,REVERTcast) +let simpl_in_concl = reduct_in_concl ~check:false (simpl,REVERTcast) +let simpl_in_hyp = reduct_in_hyp ~check:false ~reorder:false simpl +let simpl_option = reduct_option ~check:false (simpl,REVERTcast) +let normalise_in_concl = reduct_in_concl ~check:false (compute,REVERTcast) +let normalise_in_hyp = reduct_in_hyp ~check:false ~reorder:false compute +let normalise_option = reduct_option ~check:false (compute,REVERTcast) +let normalise_vm_in_concl = reduct_in_concl ~check:false (Redexpr.cbv_vm,VMcast) +let unfold_in_concl loccname = reduct_in_concl ~check:false (unfoldn loccname,REVERTcast) +let unfold_in_hyp loccname = reduct_in_hyp ~check:false ~reorder:false (unfoldn loccname) +let unfold_option loccname = reduct_option ~check:false (unfoldn loccname,DEFAULTcast) +let pattern_option l = e_reduct_option ~check:false (pattern_occs l,DEFAULTcast) (* The main reduction function *) @@ -886,6 +892,7 @@ let reduce redexp cl = let hyps = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in let nbcl = (if cl.concl_occs = NoOccurrences then 0 else 1) + List.length hyps in let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in + let reorder = match redexp with Fold _ | Pattern _ -> true | _ -> false in begin match cl.concl_occs with | NoOccurrences -> Proofview.tclUNIT () | occs -> @@ -900,7 +907,7 @@ let reduce redexp cl = let redfun _ env sigma c = redfun env sigma c in (redfun, id, where) in - e_change_in_hyps ~check f hyps + e_change_in_hyps ~check ~reorder f hyps end end @@ -2647,7 +2654,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = [ Proofview.Unsafe.tclEVARS sigma; convert_concl ~check:false newcl DEFAULTcast; intro_gen (NamingMustBe (CAst.make id)) (decode_hyp lastlhyp) true false; - Tacticals.New.tclMAP (convert_hyp ~check:false) depdecls; + Tacticals.New.tclMAP (convert_hyp ~check:false ~reorder:false) depdecls; eq_tac ] end @@ -2856,17 +2863,21 @@ let generalize_dep ?(with_let=false) c = | _ -> tothin in let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in - let body = - if with_let then - match EConstr.kind sigma c with - | Var id -> id |> (fun id -> pf_get_hyp id gl) |> NamedDecl.get_value - | _ -> None - else None + let is_var, body = match EConstr.kind sigma c with + | Var id -> + let body = NamedDecl.get_value (pf_get_hyp id gl) in + let is_var = Option.is_empty body && not (List.mem id init_ids) in + if with_let then is_var, body else is_var, None + | _ -> false, None in let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in (* Check that the generalization is indeed well-typed *) - let (evd, _) = Typing.type_of env evd cl'' in + let evd = + (* No need to retype for variables, term is statically well-typed *) + if is_var then evd + else fst (Typing.type_of env evd cl'') + in let args = Context.Named.to_instance mkVar to_quantify_rev in tclTHENLIST [ Proofview.Unsafe.tclEVARS evd; @@ -3050,8 +3061,8 @@ let unfold_body x = Tacticals.New.afterHyp x begin fun aft -> let hl = List.fold_right (fun decl cl -> (NamedDecl.get_id decl, InHyp) :: cl) aft [] in let rfun _ _ c = replace_vars [x, xval] c in - let reducth h = reduct_in_hyp rfun h in - let reductc = reduct_in_concl (rfun, DEFAULTcast) in + let reducth h = reduct_in_hyp ~check:false ~reorder:false rfun h in + let reductc = reduct_in_concl ~check:false (rfun, DEFAULTcast) in Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc] end end @@ -3280,7 +3291,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = if Int.equal i nparams then let t = applist (hd, params@args) in Tacticals.New.tclTHEN - (change_in_hyp None (make_change_arg t) (hyp0,InHypTypeOnly)) + (change_in_hyp ~check:false None (make_change_arg t) (hyp0,InHypTypeOnly)) (tac avoid) else let c = List.nth argl (i-1) in diff --git a/tactics/tactics.mli b/tactics/tactics.mli index e7b95a820e..9eb8196280 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -33,8 +33,8 @@ val is_quantified_hypothesis : Id.t -> Proofview.Goal.t -> bool (** {6 Primitive tactics. } *) val introduction : Id.t -> unit Proofview.tactic -val convert_concl : ?check:bool -> types -> cast_kind -> unit Proofview.tactic -val convert_hyp : ?check:bool -> named_declaration -> unit Proofview.tactic +val convert_concl : check:bool -> types -> cast_kind -> unit Proofview.tactic +val convert_hyp : check:bool -> reorder:bool -> named_declaration -> unit Proofview.tactic val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic [@@ocaml.deprecated "use [Tactics.convert_concl]"] val convert_hyp_no_check : named_declaration -> unit Proofview.tactic @@ -152,13 +152,13 @@ type e_tactic_reduction = Reductionops.e_reduction_function type change_arg = patvar_map -> env -> evar_map -> evar_map * constr val make_change_arg : constr -> change_arg -val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic -val reduct_option : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic -val reduct_in_concl : ?check:bool -> tactic_reduction * cast_kind -> unit Proofview.tactic -val e_reduct_in_concl : ?check:bool -> e_tactic_reduction * cast_kind -> unit Proofview.tactic -val change_in_concl : (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic +val reduct_in_hyp : check:bool -> reorder:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic +val reduct_option : check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic +val reduct_in_concl : check:bool -> tactic_reduction * cast_kind -> unit Proofview.tactic +val e_reduct_in_concl : check:bool -> e_tactic_reduction * cast_kind -> unit Proofview.tactic +val change_in_concl : check:bool -> (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic val change_concl : constr -> unit Proofview.tactic -val change_in_hyp : (occurrences * constr_pattern) option -> change_arg -> +val change_in_hyp : check:bool -> (occurrences * constr_pattern) option -> change_arg -> hyp_location -> unit Proofview.tactic val red_in_concl : unit Proofview.tactic val red_in_hyp : hyp_location -> unit Proofview.tactic @@ -180,7 +180,7 @@ val unfold_in_hyp : val unfold_option : (occurrences * evaluable_global_reference) list -> goal_location -> unit Proofview.tactic val change : - constr_pattern option -> change_arg -> clause -> unit Proofview.tactic + check:bool -> constr_pattern option -> change_arg -> clause -> unit Proofview.tactic val pattern_option : (occurrences * constr) list -> goal_location -> unit Proofview.tactic val reduce : red_expr -> clause -> unit Proofview.tactic diff --git a/test-suite/Makefile b/test-suite/Makefile index ba591ede20..94011447d7 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -99,7 +99,7 @@ INTERACTIVE := interactive UNIT_TESTS := unit-tests VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ output-modulo-time $(INTERACTIVE) micromega $(COMPLEXITY) modules stm \ - coqdoc ssr arithmetic + coqdoc ssr arithmetic ltac2 # All subsystems SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile tools $(UNIT_TESTS) @@ -181,6 +181,7 @@ summary: $(call summary_dir, "tools/ tests", tools); \ $(call summary_dir, "Unit tests", unit-tests); \ $(call summary_dir, "Machine arithmetic tests", arithmetic); \ + $(call summary_dir, "Ltac2 tests", ltac2); \ nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \ nb_failure=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_failure) | wc -l`; \ nb_tests=`expr $$nb_success + $$nb_failure`; \ @@ -319,7 +320,7 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v } > "$@" ssr: $(wildcard ssr/*.v:%.v=%.v.log) -$(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v arithmetic/*.v)): %.v.log: %.v $(PREREQUISITELOG) +$(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v arithmetic/*.v ltac2/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ opts="$(if $(findstring modules/,$<),-R modules Mods)"; \ diff --git a/test-suite/arithmetic/diveucl_21.v b/test-suite/arithmetic/diveucl_21.v index 7e12a08906..b888c97be3 100644 --- a/test-suite/arithmetic/diveucl_21.v +++ b/test-suite/arithmetic/diveucl_21.v @@ -15,3 +15,11 @@ Check (eq_refl (4611686018427387904, 1) <: diveucl_21 3 1 2 = (46116860184273879 Check (eq_refl (4611686018427387904, 1) <<: diveucl_21 3 1 2 = (4611686018427387904, 1)). Definition compute2 := Eval compute in diveucl_21 3 1 2. Check (eq_refl compute2 : (4611686018427387904, 1) = (4611686018427387904, 1)). + +Check (eq_refl : diveucl_21 1 1 0 = (0,0)). +Check (eq_refl (0,0) <: diveucl_21 1 1 0 = (0,0)). +Check (eq_refl (0,0) <<: diveucl_21 1 1 0 = (0,0)). + +Check (eq_refl : diveucl_21 9223372036854775807 0 1 = (0,0)). +Check (eq_refl (0,0) <: diveucl_21 9223372036854775807 0 1 = (0,0)). +Check (eq_refl (0,0) <<: diveucl_21 9223372036854775807 0 1 = (0,0)). diff --git a/test-suite/bugs/closed/bug_10025.v b/test-suite/bugs/closed/bug_10025.v new file mode 100644 index 0000000000..1effc771b0 --- /dev/null +++ b/test-suite/bugs/closed/bug_10025.v @@ -0,0 +1,39 @@ +Require Import Program. + +Axiom I : Type. + +Inductive S : Type := NT : I -> S. + +Axiom F : S -> Type. + +Axiom G : forall (s : S), F s -> Type. + +Section S. + +Variable init : I. +Variable my_s : F (NT init). + +Inductive foo : forall (s: S) (hole_sem: F s), Type := +| Foo : foo (NT init) my_s. + +Goal forall + (n : I) (s : F (NT n)) (ptz : foo (NT n) s) (pt : G (NT n) s) (x : unit), +match + match x with tt => tt end +with +| tt => + match + match ptz in foo x s return (forall _ : G x s, unit) with + | Foo => fun _ : G (NT init) my_s => tt + end pt + with + | tt => False + end +end. +Proof. +dependent destruction ptz. +(* Check well-typedness of goal *) +match goal with [ |- ?P ] => let t := type of P in idtac end. +Abort. + +End S. diff --git a/test-suite/bugs/closed/bug_10031.v b/test-suite/bugs/closed/bug_10031.v new file mode 100644 index 0000000000..15b53de00d --- /dev/null +++ b/test-suite/bugs/closed/bug_10031.v @@ -0,0 +1,9 @@ +Require Import Int63 ZArith. + +Open Scope int63_scope. + +Goal False. +cut (let (q, r) := (0, 0) in ([|q|], [|r|]) = (9223372036854775808%Z, 0%Z)); + [discriminate| ]. +Fail (change (0, 0) with (diveucl_21 1 0 1); apply diveucl_21_spec). +Abort. diff --git a/test-suite/bugs/closed/bug_5752.v b/test-suite/bugs/closed/bug_5752.v new file mode 100644 index 0000000000..b4218d66df --- /dev/null +++ b/test-suite/bugs/closed/bug_5752.v @@ -0,0 +1,8 @@ +Class C (A : Type) := c : A. + +Hint Mode C ! : typeclass_instances. + +Goal forall f : (forall A, C A -> C (list A)), True. +intros. + Check c. (* Loops if modes are ignored. *) +Abort. diff --git a/test-suite/ltac2/compat.v b/test-suite/ltac2/compat.v new file mode 100644 index 0000000000..489fa638e4 --- /dev/null +++ b/test-suite/ltac2/compat.v @@ -0,0 +1,58 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Notations. + +(** Test calls to Ltac1 from Ltac2 *) + +Ltac2 foo () := ltac1:(discriminate). + +Goal true = false -> False. +Proof. +foo (). +Qed. + +Goal true = false -> false = true. +Proof. +intros H; ltac1:(match goal with [ H : ?P |- _ ] => rewrite H end); reflexivity. +Qed. + +Goal true = false -> false = true. +Proof. +intros H; ltac1:(rewrite H); reflexivity. +Abort. + +(** Variables do not cross the compatibility layer boundary. *) +Fail Ltac2 bar nay := ltac1:(discriminate nay). + +Fail Ltac2 pose1 (v : constr) := + ltac1:(pose $v). + +(** Test calls to Ltac2 from Ltac1 *) + +Set Default Proof Mode "Classic". + +Ltac foo := ltac2:(foo ()). + +Goal true = false -> False. +Proof. +ltac2:(foo ()). +Qed. + +Goal true = false -> False. +Proof. +foo. +Qed. + +(** Variables do not cross the compatibility layer boundary. *) +Fail Ltac bar x := ltac2:(foo x). + +Ltac mytac tac := idtac "wow". + +Goal True. +Proof. +(** Fails because quotation is evaluated eagerly *) +Fail mytac ltac2:(fail). +(** One has to thunk thanks to the idtac trick *) +let t := idtac; ltac2:(fail) in mytac t. +constructor. +Qed. diff --git a/test-suite/ltac2/errors.v b/test-suite/ltac2/errors.v new file mode 100644 index 0000000000..c677f6af5d --- /dev/null +++ b/test-suite/ltac2/errors.v @@ -0,0 +1,12 @@ +Require Import Ltac2.Ltac2. + +Goal True. +Proof. +let x := Control.plus + (fun () => let _ := constr:(nat -> 0) in 0) + (fun e => match e with Not_found => 1 | _ => 2 end) in +match Int.equal x 2 with +| true => () +| false => Control.throw (Tactic_failure None) +end. +Abort. diff --git a/test-suite/ltac2/example1.v b/test-suite/ltac2/example1.v new file mode 100644 index 0000000000..023791050f --- /dev/null +++ b/test-suite/ltac2/example1.v @@ -0,0 +1,27 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Control. + +(** Alternative implementation of the hyp primitive *) +Ltac2 get_hyp_by_name x := + let h := hyps () in + let rec find x l := match l with + | [] => zero Not_found + | p :: l => + match p with + | (id, _, t) => + match Ident.equal x id with + | true => t + | false => find x l + end + end + end in + find x h. + +Print Ltac2 get_hyp_by_name. + +Goal forall n m, n + m = 0 -> n = 0. +Proof. +refine (fun () => '(fun n m H => _)). +let t := get_hyp_by_name @H in Message.print (Message.of_constr t). +Abort. diff --git a/test-suite/ltac2/example2.v b/test-suite/ltac2/example2.v new file mode 100644 index 0000000000..c953d25061 --- /dev/null +++ b/test-suite/ltac2/example2.v @@ -0,0 +1,281 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Notations. + +Set Default Goal Selector "all". + +Goal exists n, n = 0. +Proof. +split with (x := 0). +reflexivity. +Qed. + +Goal exists n, n = 0. +Proof. +split with 0. +split. +Qed. + +Goal exists n, n = 0. +Proof. +let myvar := Std.NamedHyp @x in split with ($myvar := 0). +split. +Qed. + +Goal (forall n : nat, n = 0 -> False) -> True. +Proof. +intros H. +eelim &H. +split. +Qed. + +Goal (forall n : nat, n = 0 -> False) -> True. +Proof. +intros H. +elim &H with 0. +split. +Qed. + +Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> P 0. +Proof. +intros P H. +Fail apply &H. +apply &H with (m := 0). +split. +Qed. + +Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> (0 = 1) -> P 0. +Proof. +intros P H e. +apply &H with (m := 1) in e. +exact e. +Qed. + +Goal forall (P : nat -> Prop), (forall n m, n = m -> P n) -> P 0. +Proof. +intros P H. +eapply &H. +split. +Qed. + +Goal exists n, n = 0. +Proof. +Fail constructor 1. +constructor 1 with (x := 0). +split. +Qed. + +Goal exists n, n = 0. +Proof. +econstructor 1. +split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +induction &n as [|n] using nat_rect; split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +let n := @X in +let q := Std.NamedHyp @P in +induction &n as [|$n] using nat_rect with ($q := fun m => 0 + m = m); split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +destruct &n as [|n] using nat_rect; split. +Qed. + +Goal forall n, 0 + n = n. +Proof. +intros n. +let n := @X in +let q := Std.NamedHyp @P in +destruct &n as [|$n] using nat_rect with ($q := fun m => 0 + m = m); split. +Qed. + +Goal forall b1 b2, andb b1 b2 = andb b2 b1. +Proof. +intros b1 b2. +destruct &b1 as [|], &b2 as [|]; split. +Qed. + +Goal forall n m, n = 0 -> n + m = m. +Proof. +intros n m Hn. +rewrite &Hn; split. +Qed. + +Goal forall n m p, n = m -> p = m -> 0 = n -> p = 0. +Proof. +intros n m p He He' Hn. +rewrite &He, <- &He' in Hn. +rewrite &Hn. +split. +Qed. + +Goal forall n m, (m = n -> n = m) -> m = n -> n = 0 -> m = 0. +Proof. +intros n m He He' He''. +rewrite <- &He by assumption. +Control.refine (fun () => &He''). +Qed. + +Goal forall n (r := if true then n else 0), r = n. +Proof. +intros n r. +hnf in r. +split. +Qed. + +Goal 1 = 0 -> 0 = 0. +Proof. +intros H. +pattern 0 at 1. +let occ := 2 in pattern 1 at 1, 0 at $occ in H. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +vm_compute. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +native_compute. +reflexivity. +Qed. + +Goal 1 + 1 = 2 - 0 -> True. +Proof. +intros H. +vm_compute plus in H. +reflexivity. +Qed. + +Goal 1 = 0 -> True /\ True. +Proof. +intros H. +split; fold (1 + 0) (1 + 0) in H. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +cbv [ Nat.add ]. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +let x := reference:(Nat.add) in +cbn beta iota delta [ $x ]. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +simpl beta. +reflexivity. +Qed. + +Goal 1 + 1 = 2. +Proof. +lazy. +reflexivity. +Qed. + +Goal let x := 1 + 1 - 1 in x = x. +Proof. +intros x. +unfold &x at 1. +let x := reference:(Nat.sub) in unfold Nat.add, $x in x. +reflexivity. +Qed. + +Goal exists x y : nat, x = y. +Proof. +exists 0, 0; reflexivity. +Qed. + +Goal exists x y : nat, x = y. +Proof. +eexists _, 0; reflexivity. +Qed. + +Goal exists x y : nat, x = y. +Proof. +refine '(let x := 0 in _). +eexists; exists &x; reflexivity. +Qed. + +Goal True. +Proof. +pose (X := True). +constructor. +Qed. + +Goal True. +Proof. +pose True as X. +constructor. +Qed. + +Goal True. +Proof. +let x := @foo in +set ($x := True) in * |-. +constructor. +Qed. + +Goal 0 = 0. +Proof. +remember 0 as n eqn: foo at 1. +rewrite foo. +reflexivity. +Qed. + +Goal True. +Proof. +assert (H := 0 + 0). +constructor. +Qed. + +Goal True. +Proof. +assert (exists n, n = 0) as [n Hn]. ++ exists 0; reflexivity. ++ exact I. +Qed. + +Goal True -> True. +Proof. +assert (H : 0 + 0 = 0) by reflexivity. +intros x; exact x. +Qed. + +Goal 1 + 1 = 2. +Proof. +change (?a + 1 = 2) with (2 = $a + 1). +reflexivity. +Qed. + +Goal (forall n, n = 0 -> False) -> False. +Proof. +intros H. +specialize (H 0 eq_refl). +destruct H. +Qed. + +Goal (forall n, n = 0 -> False) -> False. +Proof. +intros H. +specialize (H 0 eq_refl) as []. +Qed. diff --git a/test-suite/ltac2/matching.v b/test-suite/ltac2/matching.v new file mode 100644 index 0000000000..4338cbd32f --- /dev/null +++ b/test-suite/ltac2/matching.v @@ -0,0 +1,71 @@ +Require Import Ltac2.Ltac2 Ltac2.Notations. + +Ltac2 Type exn ::= [ Nope ]. + +Ltac2 check_id id id' := match Ident.equal id id' with +| true => () +| false => Control.throw Nope +end. + +Goal True -> False. +Proof. +Fail +let b := { contents := true } in +let f c := + match b.(contents) with + | true => Message.print (Message.of_constr c); b.(contents) := false; fail + | false => () + end +in +(** This fails because the matching is not allowed to backtrack once + it commits to a branch*) +lazy_match! '(nat -> bool) with context [?a] => f a end. +lazy_match! Control.goal () with ?a -> ?b => Message.print (Message.of_constr b) end. + +(** This one works by taking the second match context, i.e. ?a := nat *) +let b := { contents := true } in +let f c := + match b.(contents) with + | true => b.(contents) := false; fail + | false => Message.print (Message.of_constr c) + end +in +match! '(nat -> bool) with context [?a] => f a end. +Abort. + +Goal forall (i j : unit) (x y : nat) (b : bool), True. +Proof. +Fail match! goal with +| [ h : ?t, h' : ?t |- _ ] => () +end. +intros i j x y b. +match! goal with +| [ h : ?t, h' : ?t |- _ ] => + check_id h @x; + check_id h' @y +end. +match! reverse goal with +| [ h : ?t, h' : ?t |- _ ] => + check_id h @j; + check_id h' @i +end. +Abort. + +(* Check #79 *) +Goal 2 = 3. + Control.plus + (fun () + => lazy_match! goal with + | [ |- 2 = 3 ] => Control.zero (Tactic_failure None) + | [ |- 2 = _ ] => Control.zero (Tactic_failure (Some (Message.of_string "should not be printed"))) + end) + (fun e + => match e with + | Tactic_failure c + => match c with + | None => () + | _ => Control.zero e + end + | e => Control.zero e + end). +Abort. diff --git a/test-suite/ltac2/quot.v b/test-suite/ltac2/quot.v new file mode 100644 index 0000000000..624c4ad0c1 --- /dev/null +++ b/test-suite/ltac2/quot.v @@ -0,0 +1,26 @@ +Require Import Ltac2.Ltac2. + +(** Test for quotations *) + +Ltac2 ref0 () := reference:(&x). +Ltac2 ref1 () := reference:(nat). +Ltac2 ref2 () := reference:(Datatypes.nat). +Fail Ltac2 ref () := reference:(i_certainly_dont_exist). +Fail Ltac2 ref () := reference:(And.Me.neither). + +Goal True. +Proof. +let x := constr:(I) in +let y := constr:((fun z => z) $x) in +Control.refine (fun _ => y). +Qed. + +Goal True. +Proof. +(** Here, Ltac2 should not put its variables in the same environment as + Ltac1 otherwise the second binding fails as x is bound but not an + ident. *) +let x := constr:(I) in +let y := constr:((fun x => x) $x) in +Control.refine (fun _ => y). +Qed. diff --git a/test-suite/ltac2/rebind.v b/test-suite/ltac2/rebind.v new file mode 100644 index 0000000000..e1c20a2059 --- /dev/null +++ b/test-suite/ltac2/rebind.v @@ -0,0 +1,34 @@ +Require Import Ltac2.Ltac2 Ltac2.Notations. + +Ltac2 mutable foo () := constructor. + +Goal True. +Proof. +foo (). +Qed. + +Ltac2 Set foo := fun _ => fail. + +Goal True. +Proof. +Fail foo (). +constructor. +Qed. + +(** Not the right type *) +Fail Ltac2 Set foo := 0. + +Ltac2 bar () := (). + +(** Cannot redefine non-mutable tactics *) +Fail Ltac2 Set bar := fun _ => (). + +(** Subtype check *) + +Ltac2 mutable rec f x := f x. + +Fail Ltac2 Set f := fun x => x. + +Ltac2 mutable g x := x. + +Ltac2 Set g := f. diff --git a/test-suite/ltac2/stuff/ltac2.v b/test-suite/ltac2/stuff/ltac2.v new file mode 100644 index 0000000000..370bc70d15 --- /dev/null +++ b/test-suite/ltac2/stuff/ltac2.v @@ -0,0 +1,143 @@ +Require Import Ltac2.Ltac2. + +Ltac2 foo (_ : int) := + let f (x : int) := x in + let _ := f 0 in + f 1. + +Print Ltac2 foo. + +Import Control. + +Ltac2 exact x := refine (fun () => x). + +Print Ltac2 refine. +Print Ltac2 exact. + +Ltac2 foo' () := ident:(bla). + +Print Ltac2 foo'. + +Ltac2 bar x h := match x with +| None => constr:(fun H => ltac2:(exact (hyp ident:(H))) -> nat) +| Some x => x +end. + +Print Ltac2 bar. + +Ltac2 qux := Some 0. + +Print Ltac2 qux. + +Ltac2 Type foo := [ Foo (int) ]. + +Fail Ltac2 qux0 := Foo None. + +Ltac2 Type 'a ref := { mutable contents : 'a }. + +Fail Ltac2 qux0 := { contents := None }. +Ltac2 foo0 () := { contents := None }. + +Print Ltac2 foo0. + +Ltac2 qux0 x := x.(contents). +Ltac2 qux1 x := x.(contents) := x.(contents). + +Ltac2 qux2 := ([1;2], true). + +Print Ltac2 qux0. +Print Ltac2 qux1. +Print Ltac2 qux2. + +Import Control. + +Ltac2 qux3 x := constr:(nat -> ltac2:(refine (fun () => hyp x))). + +Print Ltac2 qux3. + +Ltac2 Type rec nat := [ O | S (nat) ]. + +Ltac2 message_of_nat n := +let rec aux n := +match n with +| O => Message.of_string "O" +| S n => Message.concat (Message.of_string "S") (aux n) +end in aux n. + +Print Ltac2 message_of_nat. + +Ltac2 numgoals () := + let r := { contents := O } in + enter (fun () => r.(contents) := S (r.(contents))); + r.(contents). + +Print Ltac2 numgoals. + +Goal True /\ False. +Proof. +let n := numgoals () in Message.print (message_of_nat n). +refine (fun () => open_constr:((fun x => conj _ _) 0)); (). +let n := numgoals () in Message.print (message_of_nat n). + +Fail (hyp ident:(x)). +Fail (enter (fun () => hyp ident:(There_is_no_spoon); ())). + +enter (fun () => Message.print (Message.of_string "foo")). + +enter (fun () => Message.print (Message.of_constr (goal ()))). +Fail enter (fun () => Message.print (Message.of_constr (qux3 ident:(x)))). +enter (fun () => plus (fun () => constr:(_); ()) (fun _ => ())). +plus + (fun () => enter (fun () => let x := ident:(foo) in let _ := hyp x in ())) (fun _ => Message.print (Message.of_string "failed")). +let x := { contents := 0 } in +let x := x.(contents) := x.(contents) in x. +Abort. + +Ltac2 Type exn ::= [ Foo ]. + +Goal True. +Proof. +plus (fun () => zero Foo) (fun _ => ()). +Abort. + +Ltac2 Type exn ::= [ Bar (string) ]. + +Goal True. +Proof. +Fail zero (Bar "lol"). +Abort. + +Ltac2 Notation "refine!" c(thunk(constr)) := refine c. + +Goal True. +Proof. +refine! I. +Abort. + +Goal True. +Proof. +let x () := plus (fun () => 0) (fun _ => 1) in +match case x with +| Val x => + match x with + | (x, k) => Message.print (Message.of_int (k Not_found)) + end +| Err x => Message.print (Message.of_string "Err") +end. +Abort. + +Goal (forall n : nat, n = 0 -> False) -> True. +Proof. +refine (fun () => '(fun H => _)). +Std.case true (hyp @H, Std.ExplicitBindings [Std.NamedHyp @n, '0]). +refine (fun () => 'eq_refl). +Qed. + +Goal forall x, 1 + x = x + 1. +Proof. +refine (fun () => '(fun x => _)). +Std.cbv { + Std.rBeta := true; Std.rMatch := true; Std.rFix := true; Std.rCofix := true; + Std.rZeta := true; Std.rDelta := true; Std.rConst := []; +} { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences }. +Abort. diff --git a/test-suite/ltac2/tacticals.v b/test-suite/ltac2/tacticals.v new file mode 100644 index 0000000000..1a2fbcbb37 --- /dev/null +++ b/test-suite/ltac2/tacticals.v @@ -0,0 +1,34 @@ +Require Import Ltac2.Ltac2. + +Import Ltac2.Notations. + +Goal True. +Proof. +Fail fail. +Fail solve [ () ]. +try fail. +repeat fail. +repeat (). +solve [ constructor ]. +Qed. + +Goal True. +Proof. +first [ + Message.print (Message.of_string "Yay"); fail +| constructor +| Message.print (Message.of_string "I won't be printed") +]. +Qed. + +Goal True /\ True. +Proof. +Fail split > [ split | |]. +split > [split | split]. +Qed. + +Goal True /\ (True -> True) /\ True. +Proof. +split > [ | split] > [split | .. | split]. +intros H; refine &H. +Qed. diff --git a/test-suite/ltac2/typing.v b/test-suite/ltac2/typing.v new file mode 100644 index 0000000000..9f18292716 --- /dev/null +++ b/test-suite/ltac2/typing.v @@ -0,0 +1,72 @@ +Require Import Ltac2.Ltac2. + +(** Ltac2 is typed à la ML. *) + +Ltac2 test0 n := Int.add n 1. + +Print Ltac2 test0. + +Ltac2 test1 () := test0 0. + +Print Ltac2 test1. + +Fail Ltac2 test2 () := test0 true. + +Fail Ltac2 test2 () := test0 0 0. + +Ltac2 test3 f x := x, (f x, x). + +Print Ltac2 test3. + +(** Polymorphism *) + +Ltac2 rec list_length l := +match l with +| [] => 0 +| x :: l => Int.add 1 (list_length l) +end. + +Print Ltac2 list_length. + +(** Pattern-matching *) + +Ltac2 ifb b f g := match b with +| true => f () +| false => g () +end. + +Print Ltac2 ifb. + +Ltac2 if_not_found e f g := match e with +| Not_found => f () +| _ => g () +end. + +Fail Ltac2 ifb' b f g := match b with +| true => f () +end. + +Fail Ltac2 if_not_found' e f g := match e with +| Not_found => f () +end. + +(** Reimplementing 'do'. Return value of the function useless. *) + +Ltac2 rec do n tac := match Int.equal n 0 with +| true => () +| false => tac (); do (Int.sub n 1) tac +end. + +Print Ltac2 do. + +(** Non-function pure values are OK. *) + +Ltac2 tuple0 := ([1; 2], true, (fun () => "yay")). + +Print Ltac2 tuple0. + +(** Impure values are not. *) + +Fail Ltac2 not_a_value := { contents := 0 }. +Fail Ltac2 not_a_value := "nope". +Fail Ltac2 not_a_value := list_length []. diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index 7074ad2d41..3c1e27ba9d 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -27,7 +27,7 @@ Nat.sub : nat -> nat -> nat Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub when the 1st and - 2nd arguments evaluate to a constructor and when applied to 2 arguments + 2nd arguments evaluate to a constructor and when applied to 2 arguments Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat @@ -35,7 +35,7 @@ Nat.sub : nat -> nat -> nat Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub when the 1st and - 2nd arguments evaluate to a constructor + 2nd arguments evaluate to a constructor Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub pf : @@ -54,7 +54,7 @@ fcomp : forall A B C : Type, (B -> C) -> (A -> B) -> A -> C fcomp is not universe polymorphic Arguments A, B, C are implicit and maximally inserted Argument scopes are [type_scope type_scope type_scope _ _ _] -The reduction tactics unfold fcomp when applied to 6 arguments +The reduction tactics unfold fcomp when applied to 6 arguments fcomp is transparent Expands to: Constant Arguments.fcomp volatile : nat -> nat @@ -75,7 +75,7 @@ f : T1 -> T2 -> nat -> unit -> nat -> nat f is not universe polymorphic Argument scopes are [_ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 3rd, 4th and - 5th arguments evaluate to a constructor + 5th arguments evaluate to a constructor f is transparent Expands to: Constant Arguments.S1.S2.f f : forall T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat @@ -84,7 +84,7 @@ f is not universe polymorphic Argument T2 is implicit Argument scopes are [type_scope _ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 4th, 5th and - 6th arguments evaluate to a constructor + 6th arguments evaluate to a constructor f is transparent Expands to: Constant Arguments.S1.f f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat @@ -93,7 +93,7 @@ f is not universe polymorphic Arguments T1, T2 are implicit Argument scopes are [type_scope type_scope _ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 5th, 6th and - 7th arguments evaluate to a constructor + 7th arguments evaluate to a constructor f is transparent Expands to: Constant Arguments.f = forall v : unit, f 0 0 5 v 3 = 2 @@ -104,7 +104,7 @@ f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat f is not universe polymorphic The reduction tactics unfold f when the 5th, 6th and - 7th arguments evaluate to a constructor + 7th arguments evaluate to a constructor f is transparent Expands to: Constant Arguments.f forall w : r, w 3 true = tt @@ -115,3 +115,13 @@ w 3 true = tt : Prop The command has indeed failed with message: Extra arguments: _, _. +volatilematch : nat -> nat + +volatilematch is not universe polymorphic +Argument scope is [nat_scope] +The reduction tactics always unfold volatilematch + but avoid exposing match constructs +volatilematch is transparent +Expands to: Constant Arguments.volatilematch + = fun n : nat => volatilematch n + : nat -> nat diff --git a/test-suite/output/Arguments.v b/test-suite/output/Arguments.v index 844f96aaa1..b909f1b64c 100644 --- a/test-suite/output/Arguments.v +++ b/test-suite/output/Arguments.v @@ -55,3 +55,12 @@ Arguments w x%F y%B : extra scopes. Check (w $ $ = tt). Fail Arguments w _%F _%B. +Definition volatilematch (n : nat) := + match n with + | O => O + | S p => p + end. + +Arguments volatilematch / n : simpl nomatch. +About volatilematch. +Eval simpl in fun n => volatilematch n. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index 3f0717666c..65c902202d 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -62,7 +62,7 @@ Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] The reduction tactics unfold myplus when the 2nd and - 3rd arguments evaluate to a constructor + 3rd arguments evaluate to a constructor myplus is transparent Expands to: Constant Arguments_renaming.Test1.myplus @myplus @@ -101,7 +101,7 @@ Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] The reduction tactics unfold myplus when the 2nd and - 3rd arguments evaluate to a constructor + 3rd arguments evaluate to a constructor myplus is transparent Expands to: Constant Arguments_renaming.myplus @myplus diff --git a/test-suite/output/Error_msg_diffs.v b/test-suite/output/Error_msg_diffs.v index 11c766b210..a26e683398 100644 --- a/test-suite/output/Error_msg_diffs.v +++ b/test-suite/output/Error_msg_diffs.v @@ -1,4 +1,4 @@ -(* coq-prog-args: ("-color" "on" "-async-proofs" "off") *) +(* coq-prog-args: ("-color" "on" "-diffs" "on" "-async-proofs" "off") *) (* Re: -async-proofs off, see https://github.com/coq/coq/issues/9671 *) (* Shows diffs in an error message for an "Unable to unify" error *) Require Import Arith List Bool. diff --git a/test-suite/output/Quote.out b/test-suite/output/Quote.out deleted file mode 100644 index 998eb37cc8..0000000000 --- a/test-suite/output/Quote.out +++ /dev/null @@ -1,24 +0,0 @@ -(interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (f_atom End_idx)) -(interp_f (Node_vm B (Empty_vm Prop) (Empty_vm Prop)) - (f_and (f_const A) - (f_and (f_or (f_atom End_idx) (f_const A)) - (f_or (f_const A) (f_not (f_atom End_idx)))))) -1 subgoal - - H : interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (f_atom End_idx) \/ - B - ============================ - interp_f - (Node_vm B (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (Empty_vm Prop)) - (f_and (f_atom (Left_idx End_idx)) - (f_and (f_or (f_atom End_idx) (f_atom (Left_idx End_idx))) - (f_or (f_atom (Left_idx End_idx)) (f_not (f_atom End_idx))))) -1 subgoal - - H : interp_f (Node_vm A (Empty_vm Prop) (Empty_vm Prop)) (f_atom End_idx) \/ - B - ============================ - interp_f (Node_vm B (Empty_vm Prop) (Empty_vm Prop)) - (f_and (f_const A) - (f_and (f_or (f_atom End_idx) (f_const A)) - (f_or (f_const A) (f_not (f_atom End_idx))))) diff --git a/test-suite/output/bug_9370.out b/test-suite/output/bug_9370.out new file mode 100644 index 0000000000..0ff151c8b4 --- /dev/null +++ b/test-suite/output/bug_9370.out @@ -0,0 +1,12 @@ +1 subgoal + + ============================ + 1 = 1 +1 subgoal + + ============================ + 1 = 1 +1 subgoal + + ============================ + 1 = 1 diff --git a/test-suite/output/bug_9370.v b/test-suite/output/bug_9370.v new file mode 100644 index 0000000000..a7f4b7c23e --- /dev/null +++ b/test-suite/output/bug_9370.v @@ -0,0 +1,12 @@ +Require Import Reals. +Open Scope R_scope. +Goal 1/1=1. +Proof. + field_simplify (1/1). +Show. + field_simplify. +Show. + field_simplify. +Show. + reflexivity. +Qed. diff --git a/test-suite/prerequisite/ssr_mini_mathcomp.v b/test-suite/prerequisite/ssr_mini_mathcomp.v index ca360f65a7..6fc630056c 100644 --- a/test-suite/prerequisite/ssr_mini_mathcomp.v +++ b/test-suite/prerequisite/ssr_mini_mathcomp.v @@ -634,9 +634,9 @@ Fixpoint mem_seq (s : seq T) := Definition eqseq_class := seq T. Identity Coercion seq_of_eqseq : eqseq_class >-> seq. -Coercion pred_of_eq_seq (s : eqseq_class) : pred_class := [eta mem_seq s]. +Coercion pred_of_eq_seq (s : eqseq_class) : {pred T} := [eta mem_seq s]. -Canonical seq_predType := @mkPredType T (seq T) pred_of_eq_seq. +Canonical seq_predType := @PredType T (seq T) pred_of_eq_seq. Fixpoint uniq s := if s is x :: s' then (x \notin s') && uniq s' else true. diff --git a/test-suite/ssr/nonPropType.v b/test-suite/ssr/nonPropType.v new file mode 100644 index 0000000000..bcdc907b38 --- /dev/null +++ b/test-suite/ssr/nonPropType.v @@ -0,0 +1,23 @@ +Require Import ssreflect. + +(** Test the nonPropType interface and its application to prevent unwanted + instantiations in views. **) + +Lemma raw_flip {T} (x y : T) : x = y -> y = x. Proof. by []. Qed. +Lemma flip {T : nonPropType} (x y : T) : x = y -> y = x. Proof. by []. Qed. + +Lemma testSet : true = false -> True. +Proof. +Fail move/raw_flip. +have flip_true := @flip _ true. +(* flip_true : forall y : notProp bool, x = y -> y = x *) +simpl in flip_true. +(* flip_true : forall y : bool, x = y -> y = x *) +by move/flip. +Qed. + +Lemma override (t1 t2 : True) : t1 = t2 -> True. +Proof. +Fail move/flip. +by move/(@flip (notProp True)). +Qed. diff --git a/test-suite/ssr/predRewrite.v b/test-suite/ssr/predRewrite.v new file mode 100644 index 0000000000..2ad762ccf1 --- /dev/null +++ b/test-suite/ssr/predRewrite.v @@ -0,0 +1,28 @@ +Require Import ssreflect ssrfun ssrbool. + +(** Test the various idioms that control rewriting in boolean predicate. **) + +Definition simpl_P := [pred a | ~~ a]. +Definition nosimpl_P : pred bool := [pred a | ~~ a]. +Definition coll_P : collective_pred bool := [pred a | ~~ a]. +Definition appl_P : applicative_pred bool := [pred a | ~~ a]. +Definition can_appl_P : pred bool := [pred a | ~~ a]. +Canonical register_can_appl_P := ApplicativePred can_appl_P. +Ltac see_neg := (let x := fresh "x" in set x := {-}(~~ _); clear x). + +Lemma test_pred_rewrite (f := false) : True. +Proof. +have _: f \in simpl_P by rewrite inE; see_neg. +have _ a: simpl_P (a && f) by simpl; see_neg; rewrite andbF. +have _ a: simpl_P (a && f) by rewrite inE; see_neg; rewrite andbF. +have _: f \in nosimpl_P by rewrite inE; see_neg. +have _: nosimpl_P f. simpl. Fail see_neg. Fail rewrite inE. done. +have _: f \in coll_P. Fail rewrite inE. by rewrite in_collective; see_neg. +have _: f \in appl_P. + rewrite inE. Fail see_neg. Fail rewrite inE. simpl. Fail see_neg. + Fail rewrite app_predE. done. +have _: f \in can_appl_P. + rewrite inE. Fail see_neg. Fail rewrite inE. simpl. Fail see_neg. + by rewrite app_predE in_simpl; see_neg. +done. +Qed. diff --git a/test-suite/success/ROmega3.v b/test-suite/success/ROmega3.v deleted file mode 100644 index ef9cb17b4b..0000000000 --- a/test-suite/success/ROmega3.v +++ /dev/null @@ -1,35 +0,0 @@ - -Require Import ZArith Lia. -Local Open Scope Z_scope. - -(** Benchmark provided by Chantal Keller, that romega used to - solve far too slowly (compared to omega or lia). *) - -(* In Coq 8.9 (end of 2018), the `romega` tactics are deprecated. - The tests in this file remain but now call the `lia` tactic. *) - - -Parameter v4 : Z. -Parameter v3 : Z. -Parameter o4 : Z. -Parameter s5 : Z. -Parameter v2 : Z. -Parameter o5 : Z. -Parameter s6 : Z. -Parameter v1 : Z. -Parameter o6 : Z. -Parameter s7 : Z. -Parameter v0 : Z. -Parameter o7 : Z. - -Lemma lemma_5833 : - ~ 16 * v4 + (8 * v3 + (-8192 * o4 + (-4096 * s5 + (4 * v2 + - (-4096 * o5 + (-2048 * s6 + (2 * v1 + (-2048 * o6 + - (-1024 * s7 + (v0 + -1024 * o7)))))))))) >= 8192 -\/ - 16 * v4 + (8 * v3 + (-8192 * o4 + (-4096 * s5 + (4 * v2 + - (-4096 * o5 + (-2048 * s6 + (2 * v1 + (-2048 * o6 + - (-1024 * s7 + (v0 + -1024 * o7)))))))))) >= 1024. -Proof. -Timeout 1 lia. (* should take a few milliseconds, not seconds *) -Timeout 1 Qed. (* ditto *) diff --git a/test-suite/success/change.v b/test-suite/success/change.v index a9821b027f..2f676cf9ad 100644 --- a/test-suite/success/change.v +++ b/test-suite/success/change.v @@ -68,3 +68,16 @@ eassumption. match goal with |- ?x=1 => change (x=1) with (0+x=1) end. match goal with |- 0+1=1 => trivial end. Qed. + +(* Mini-check that no_check does not check *) + +Goal True -> False. +intro H. +change_no_check nat. +apply S. +change_no_check nat with bool. +change_no_check nat in H. +change_no_check nat with (bool->bool) in H. +exact (H true). +Fail Qed. +Abort. diff --git a/theories/Numbers/Cyclic/Int63/Cyclic63.v b/theories/Numbers/Cyclic/Int63/Cyclic63.v index 3b431d5b47..c03e6615cb 100644 --- a/theories/Numbers/Cyclic/Int63/Cyclic63.v +++ b/theories/Numbers/Cyclic/Int63/Cyclic63.v @@ -177,21 +177,6 @@ Proof. inversion W;rewrite Zmult_comm;trivial. Qed. -Lemma diveucl_21_spec_aux : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := diveucl_21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. -Proof. - intros a1 a2 b H1 H2;assert (W:= diveucl_21_spec a1 a2 b). - assert (W1:= to_Z_bounded a1). - assert ([|b|]>0) by (auto with zarith). - generalize (Z_div_mod ([|a1|]*wB+[|a2|]) [|b|] H). - destruct (diveucl_21 a1 a2 b);destruct (Z.div_eucl ([|a1|]*wB+[|a2|]) [|b|]). - inversion W;rewrite (Zmult_comm [|b|]);trivial. -Qed. - Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = a mod 2 ^ p. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index eac26add03..3c96130bf3 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -387,7 +387,8 @@ Axiom diveucl_def_spec : forall x y, diveucl x y = diveucl_def x y. Axiom diveucl_21_spec : forall a1 a2 b, let (q,r) := diveucl_21 a1 a2 b in - ([|q|],[|r|]) = Z.div_eucl ([|a1|] * wB + [|a2|]) [|b|]. + let (q',r') := Z.div_eucl ([|a1|] * wB + [|a2|]) [|b|] in + [|q|] = Z.modulo q' wB /\ [|r|] = r'. Axiom addmuldiv_def_spec : forall p x y, addmuldiv p x y = addmuldiv_def p x y. @@ -1413,12 +1414,51 @@ Proof. apply Z.le_trans with ([|ih|] * wB)%Z;try rewrite Z.pow_2_r; auto with zarith. Qed. -Lemma div2_phi ih il j: - [|fst (diveucl_21 ih il j)|] = [|| WW ih il||] /[|j|]. -Proof. - generalize (diveucl_21_spec ih il j). - case diveucl_21; intros q r Heq. - simpl zn2z_to_Z;unfold Z.div;rewrite <- Heq;trivial. +Lemma diveucl_21_spec_aux : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := diveucl_21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. +Proof. + intros a1 a2 b H1 H2;assert (W:= diveucl_21_spec a1 a2 b). + assert (W1:= to_Z_bounded a1). + assert (W2:= to_Z_bounded a2). + assert (Wb:= to_Z_bounded b). + assert ([|b|]>0) by (auto with zarith). + generalize (Z_div_mod ([|a1|]*wB+[|a2|]) [|b|] H). + revert W. + destruct (diveucl_21 a1 a2 b); destruct (Z.div_eucl ([|a1|]*wB+[|a2|]) [|b|]). + intros (H', H''); rewrite H', H''; clear H' H''. + intros (H', H''); split; [ |exact H'']. + rewrite H', Zmult_comm, Z.mod_small; [reflexivity| ]. + split. + { revert H'; case z; [now simpl..|intros p H']. + exfalso; apply (Z.lt_irrefl 0), (Z.le_lt_trans _ ([|a1|] * wB + [|a2|])). + { now apply Z.add_nonneg_nonneg; [apply Z.mul_nonneg_nonneg| ]. } + rewrite H'; apply (Zplus_lt_reg_r _ _ (- z0)); ring_simplify. + apply (Z.le_lt_trans _ (- [|b|])); [ |now auto with zarith]. + rewrite Z.opp_eq_mul_m1; apply Zmult_le_compat_l; [ |now apply Wb]. + rewrite <-!Pos2Z.opp_pos, <-Z.opp_le_mono. + now change 1 with (Z.succ 0); apply Zlt_le_succ. } + rewrite <-Z.nle_gt; intro Hz; revert H2; apply Zle_not_lt. + rewrite (Z.div_unique_pos (wB * [|a1|] + [|a2|]) wB [|a1|] [|a2|]); + [ |now simpl..]. + rewrite Z.mul_comm, H'. + rewrite (Z.div_unique_pos (wB * [|b|] + z0) wB [|b|] z0) at 1; + [ |split; [ |apply (Z.lt_trans _ [|b|])]; now simpl|reflexivity]. + apply Z_div_le; [now simpl| ]; rewrite Z.mul_comm; apply Zplus_le_compat_r. + now apply Zmult_le_compat_l. +Qed. + +Lemma div2_phi ih il j: (2^62 <= [|j|] -> [|ih|] < [|j|] -> + [|fst (diveucl_21 ih il j)|] = [|| WW ih il||] /[|j|])%Z. +Proof. + intros Hj Hj1. + generalize (diveucl_21_spec_aux ih il j Hj Hj1). + case diveucl_21; intros q r (Hq, Hr). + apply Zdiv_unique with [|r|]; auto with zarith. + simpl @fst; apply eq_trans with (1 := Hq); ring. Qed. Lemma sqrt2_step_correct rec ih il j: @@ -1436,9 +1476,9 @@ Proof. case (to_Z_bounded il); intros Hil1 _. case (to_Z_bounded j); intros _ Hj1. assert (Hp3: (0 < [||WW ih il||])). - simpl zn2z_to_Z;apply Z.lt_le_trans with ([|ih|] * wB)%Z; auto with zarith. + {simpl zn2z_to_Z;apply Z.lt_le_trans with ([|ih|] * wB)%Z; auto with zarith. apply Zmult_lt_0_compat; auto with zarith. - refine (Z.lt_le_trans _ _ _ _ Hih); auto with zarith. + refine (Z.lt_le_trans _ _ _ _ Hih); auto with zarith. } cbv zeta. case_eq (ih < j)%int63;intros Heq. rewrite -> ltb_spec in Heq. @@ -1450,28 +1490,28 @@ Proof. 2: rewrite Zmult_comm, Z_div_plus_full_l; unfold base; auto with zarith. case (Zle_or_lt (2^(Z_of_nat size -1)) [|j|]); intros Hjj. case_eq (fst (diveucl_21 ih il j) < j)%int63;intros Heq0. - 2: rewrite <-not_true_iff_false, ltb_spec, div2_phi in Heq0. + 2: rewrite <-not_true_iff_false, ltb_spec, (div2_phi _ _ _ Hjj Heq) in Heq0. 2: split; auto; apply sqrt_test_true; auto with zarith. - rewrite -> ltb_spec, div2_phi in Heq0. + rewrite -> ltb_spec, (div2_phi _ _ _ Hjj Heq) in Heq0. match goal with |- context[rec _ _ ?X] => set (u := X) end. assert (H: [|u|] = ([|j|] + ([||WW ih il||])/([|j|]))/2). - unfold u; generalize (addc_spec j (fst (diveucl_21 ih il j))); - case addc;unfold interp_carry;rewrite div2_phi;simpl zn2z_to_Z. - intros i H;rewrite lsr_spec, H;trivial. + { unfold u; generalize (addc_spec j (fst (diveucl_21 ih il j))); + case addc;unfold interp_carry;rewrite (div2_phi _ _ _ Hjj Heq);simpl zn2z_to_Z. + { intros i H;rewrite lsr_spec, H;trivial. } intros i H;rewrite <- H. case (to_Z_bounded i); intros H1i H2i. rewrite -> add_spec, Zmod_small, lsr_spec. - change (1 * wB) with ([|(1 << (digits -1))|] * 2)%Z. - rewrite Z_div_plus_full_l; auto with zarith. + { change (1 * wB) with ([|(1 << (digits -1))|] * 2)%Z. + rewrite Z_div_plus_full_l; auto with zarith. } change wB with (2 * (wB/2))%Z; auto. replace [|(1 << (digits - 1))|] with (wB/2); auto. rewrite lsr_spec; auto. replace (2^[|1|]) with 2%Z; auto. split; auto with zarith. assert ([|i|]/2 < wB/2); auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. } apply Hrec; rewrite H; clear u H. assert (Hf1: 0 <= [||WW ih il||]/ [|j|]) by (apply Z_div_pos; auto with zarith). case (Zle_lt_or_eq 1 ([|j|])); auto with zarith; intros Hf2. diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v index 03e6ff61ab..38bed570a3 100644 --- a/theories/Reals/Ratan.v +++ b/theories/Reals/Ratan.v @@ -324,8 +324,6 @@ unfold cos_approx; simpl; unfold cos_term. rewrite !INR_IZR_INZ. simpl. field_simplify. -unfold Rdiv. -rewrite Rmult_0_l. apply Rdiv_lt_0_compat ; now apply IZR_lt. Qed. @@ -1612,4 +1610,3 @@ Lemma PI_ineq : Proof. intros; rewrite <- Alt_PI_eq; apply Alt_PI_ineq. Qed. - diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v index c738b57f44..0f63855b55 100644 --- a/theories/Structures/EqualitiesFacts.v +++ b/theories/Structures/EqualitiesFacts.v @@ -212,3 +212,14 @@ Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. Defined. End PairUsualDecidableType. + +(** And also for pairs of UsualDecidableTypeFull *) + +Module PairUsualDecidableTypeFull (D1 D2:UsualDecidableTypeFull) + <: UsualDecidableTypeFull. + + Module M := PairUsualDecidableType D1 D2. + Include Backport_DT (M). + Include HasEqDec2Bool. + +End PairUsualDecidableTypeFull. diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index fa8b771a74..6ddc503542 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -214,7 +214,7 @@ let record_dune d ff = if Sys.file_exists sd && Sys.is_directory sd then let out = open_out (bpath [sd;"dune"]) in let fmt = formatter_of_out_channel out in - if List.nth d 0 = "plugins" then + if List.nth d 0 = "plugins" || List.nth d 0 = "user-contrib" then fprintf fmt "(include plugin_base.dune)@\n"; out_install fmt d ff; List.iter (pp_dep d fmt) ff; @@ -224,17 +224,20 @@ let record_dune d ff = eprintf "error in coq_dune, a directory disappeared: %s@\n%!" sd (* File Scanning *) -let scan_mlg m d = - let dir = ["plugins"; d] in +let scan_mlg ~root m d = + let dir = [root; d] in let m = DirMap.add dir [] m in let mlg = Sys.(List.filter (fun f -> Filename.(check_suffix f ".mlg")) Array.(to_list @@ readdir (bpath dir))) in - List.fold_left (fun m f -> add_map_list ["plugins"; d] (MLG f) m) m mlg + List.fold_left (fun m f -> add_map_list [root; d] (MLG f) m) m mlg -let scan_plugins m = +let scan_dir ~root m = let is_plugin_directory dir = Sys.(is_directory dir && file_exists (bpath [dir;"plugin_base.dune"])) in - let dirs = Sys.(List.filter (fun f -> is_plugin_directory @@ bpath ["plugins";f]) Array.(to_list @@ readdir "plugins")) in - List.fold_left scan_mlg m dirs + let dirs = Sys.(List.filter (fun f -> is_plugin_directory @@ bpath [root;f]) Array.(to_list @@ readdir root)) in + List.fold_left (scan_mlg ~root) m dirs + +let scan_plugins m = scan_dir ~root:"plugins" m +let scan_usercontrib m = scan_dir ~root:"user-contrib" m (* This will be removed when we drop support for Make *) let fix_cmo_cma file = @@ -291,5 +294,6 @@ let exec_ifile f = let _ = exec_ifile (fun ic -> let map = scan_plugins DirMap.empty in + let map = scan_usercontrib map in let map = read_vfiles ic map in out_map map) diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 7114965a11..8823206252 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -529,6 +529,11 @@ let coqdep () = add_rec_dir_import add_known "plugins" ["Coq"]; add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; + let user = "user-contrib" in + if Sys.file_exists user then begin + add_rec_dir_no_import add_known user []; + add_rec_dir_no_import (fun _ -> add_caml_known) user []; + end; end else begin (* option_boot is actually always false in this branch *) Envars.set_coqlib ~fail:(fun msg -> raise (CoqlibError msg)); diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml index aa023e6986..a638906c11 100644 --- a/tools/coqdep_boot.ml +++ b/tools/coqdep_boot.ml @@ -17,6 +17,9 @@ open Coqdep_common options (see for instance [option_natdynlk] below). *) +let split_period = Str.split (Str.regexp (Str.quote ".")) +let add_q_include path l = add_rec_dir_no_import add_known path (split_period l) + let rec parse = function | "-dyndep" :: "no" :: ll -> option_dynlink := No; parse ll | "-dyndep" :: "opt" :: ll -> option_dynlink := Opt; parse ll @@ -33,6 +36,7 @@ let rec parse = function add_caml_dir r; norec_dirs := StrSet.add r !norec_dirs; parse ll + | "-Q" :: r :: ln :: ll -> add_q_include r ln; parse ll | f :: ll -> treat_file None f; parse ll | [] -> () diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 319f5c8ad6..9a18baa0bc 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -34,7 +34,7 @@ let set_type_in_type () = (******************************************************************************) -type color = [`ON | `AUTO | `OFF] +type color = [`ON | `AUTO | `EMACS | `OFF] type native_compiler = NativeOff | NativeOn of { ondemand : bool } @@ -171,7 +171,7 @@ let add_load_vernacular opts verb s = (** Options for proof general *) let set_emacs opts = Printer.enable_goal_tags_printing := true; - { opts with color = `OFF; print_emacs = true } + { opts with color = `EMACS; print_emacs = true } let set_color opts = function | "yes" | "on" -> { opts with color = `ON } diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index 9bcfdca332..d7f9819bee 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -type color = [`ON | `AUTO | `OFF] +type color = [`ON | `AUTO | `EMACS | `OFF] val default_toplevel : Names.DirPath.t diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 087cd67f3a..de447db51f 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -279,7 +279,7 @@ let extract_default_loc loc doc_id sid : Loc.t option = | None -> try let doc = Stm.get_doc doc_id in - Option.cata fst None Stm.(get_ast ~doc sid) + Option.cata (fun {CAst.loc} -> loc) None Stm.(get_ast ~doc sid) with _ -> loc (** Coqloop Console feedback handler *) @@ -383,22 +383,22 @@ let rec vernac_loop ~state = try let input = top_buffer.tokens in match read_sentence ~state input with - | Some { v = VernacBacktrack(bid,_,_) } -> + | Some (VernacBacktrack(bid,_,_)) -> let bid = Stateid.of_int bid in let doc, res = Stm.edit_at ~doc:state.doc bid in assert (res = `NewTip); let state = { state with doc; sid = bid } in vernac_loop ~state - | Some { v = VernacQuit } -> + | Some VernacQuit -> exit 0 - | Some { v = VernacDrop } -> + | Some VernacDrop -> if Mltop.is_ocaml_top() then (drop_last_doc := Some state; state) else (Feedback.msg_warning (str "There is no ML toplevel."); vernac_loop ~state) - | Some { v = VernacControl c; loc } -> + | Some VernacControl { loc; v=c } -> let nstate = Vernac.process_expr ~state (make ?loc c) in top_goal_print ~doc:state.doc c state.proof nstate.proof; vernac_loop ~state:nstate diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 15172b30f8..9323a57417 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -113,6 +113,7 @@ let fatal_error_exn exn = let init_color opts = let has_color = match opts.color with | `OFF -> false + | `EMACS -> false | `ON -> true | `AUTO -> Terminal.has_style Unix.stdout && @@ -133,10 +134,13 @@ let init_color opts = Topfmt.default_styles (); false (* textual markers, no color *) end in - if not term_color then - Proof_diffs.write_color_enabled term_color; - if Proof_diffs.show_diffs () && not term_color then - (prerr_endline "Error: -diffs requires enabling -color"; exit 1); + if opts.color = `EMACS then + Topfmt.set_emacs_print_strings () + else if not term_color then begin + Proof_diffs.write_color_enabled term_color; + if Proof_diffs.show_diffs () then + (prerr_endline "Error: -diffs requires enabling -color"; exit 1) + end; Topfmt.init_terminal_output ~color:term_color let print_style_tags opts = diff --git a/toplevel/g_toplevel.mlg b/toplevel/g_toplevel.mlg index f2025858d7..0cac024300 100644 --- a/toplevel/g_toplevel.mlg +++ b/toplevel/g_toplevel.mlg @@ -21,7 +21,7 @@ type vernac_toplevel = | VernacControl of vernac_control module Toplevel_ : sig - val vernac_toplevel : vernac_toplevel CAst.t option Entry.t + val vernac_toplevel : vernac_toplevel option Entry.t end = struct let gec_vernac s = Entry.create ("toplevel:" ^ s) let vernac_toplevel = gec_vernac "vernac_toplevel" @@ -34,14 +34,14 @@ open Toplevel_ GRAMMAR EXTEND Gram GLOBAL: vernac_toplevel; vernac_toplevel: FIRST - [ [ IDENT "Drop"; "." -> { Some (CAst.make VernacDrop) } - | IDENT "Quit"; "." -> { Some (CAst.make VernacQuit) } + [ [ IDENT "Drop"; "." -> { Some VernacDrop } + | IDENT "Quit"; "." -> { Some VernacQuit } | IDENT "Backtrack"; n = natural ; m = natural ; p = natural; "." -> - { Some (CAst.make (VernacBacktrack (n,m,p))) } + { Some (VernacBacktrack (n,m,p)) } | cmd = Pvernac.Vernac_.main_entry -> { match cmd with | None -> None - | Some {CAst.loc; v} -> Some (CAst.make ?loc (VernacControl v)) } + | Some v -> Some (VernacControl v) } ] ] ; diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 6c6379ec5e..c41f16c95b 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -20,12 +20,12 @@ open Vernacprop Use the module Coqtoplevel, which catches these exceptions (the exceptions are explained only at the toplevel). *) -let checknav_simple {CAst.loc;v=cmd} = +let checknav_simple ({ CAst.loc; _ } as cmd) = if is_navigation_vernac cmd && not (is_reset cmd) then CErrors.user_err ?loc (str "Navigation commands forbidden in files.") -let checknav_deep {CAst.loc;v=ast} = - if is_deep_navigation_vernac ast then +let checknav_deep ({ CAst.loc; _ } as cmd) = + if is_deep_navigation_vernac cmd then CErrors.user_err ?loc (str "Navigation commands forbidden in nested commands.") (* Echo from a buffer based on position. @@ -163,10 +163,7 @@ let beautify_pass ~doc ~comments ~ids ~filename = set the comments, then we call print. This has to be done for each file. *) Pputils.beautify_comments := comments; - List.iter (fun id -> - Option.iter (fun (loc,ast) -> - pr_new_syntax ?loc ft_beautify (Some ast)) - (Stm.get_ast ~doc id)) ids; + List.iter (fun id -> pr_new_syntax ft_beautify (Stm.get_ast ~doc id)) ids; (* Is this called so comments at EOF are printed? *) pr_new_syntax ~loc:(Loc.make_loc (max_int,max_int)) ft_beautify None; diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index 1269540235..197891707c 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -24,7 +24,7 @@ end expected to handle and print errors in form of exceptions, however care is taken so the state machine is left in a consistent state. *) -val process_expr : state:State.t -> Vernacexpr.vernac_control CAst.t -> State.t +val process_expr : state:State.t -> Vernacexpr.vernac_control -> State.t (** [load_vernac echo sid file] Loads [file] on top of [sid], will echo the commands if [echo] is set. Callers are expected to handle diff --git a/user-contrib/Ltac2/Array.v b/user-contrib/Ltac2/Array.v new file mode 100644 index 0000000000..11b64e3515 --- /dev/null +++ b/user-contrib/Ltac2/Array.v @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ltac2.Init. + +Ltac2 @external make : int -> 'a -> 'a array := "ltac2" "array_make". +Ltac2 @external length : 'a array -> int := "ltac2" "array_length". +Ltac2 @external get : 'a array -> int -> 'a := "ltac2" "array_get". +Ltac2 @external set : 'a array -> int -> 'a -> unit := "ltac2" "array_set". diff --git a/user-contrib/Ltac2/Char.v b/user-contrib/Ltac2/Char.v new file mode 100644 index 0000000000..29fef60f2c --- /dev/null +++ b/user-contrib/Ltac2/Char.v @@ -0,0 +1,12 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ltac2.Init. + +Ltac2 @external of_int : int -> char := "ltac2" "char_of_int". +Ltac2 @external to_int : char -> int := "ltac2" "char_to_int". diff --git a/user-contrib/Ltac2/Constr.v b/user-contrib/Ltac2/Constr.v new file mode 100644 index 0000000000..d8d222730e --- /dev/null +++ b/user-contrib/Ltac2/Constr.v @@ -0,0 +1,72 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ltac2.Init. + +Ltac2 @ external type : constr -> constr := "ltac2" "constr_type". +(** Return the type of a term *) + +Ltac2 @ external equal : constr -> constr -> bool := "ltac2" "constr_equal". +(** Strict syntactic equality: only up to α-conversion and evar expansion *) + +Module Unsafe. + +(** Low-level access to kernel terms. Use with care! *) + +Ltac2 Type case. + +Ltac2 Type kind := [ +| Rel (int) +| Var (ident) +| Meta (meta) +| 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) +| 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) +| Proj (projection, constr) +]. + +Ltac2 @ external kind : constr -> kind := "ltac2" "constr_kind". + +Ltac2 @ external make : kind -> constr := "ltac2" "constr_make". + +Ltac2 @ external check : constr -> constr result := "ltac2" "constr_check". +(** Checks that a constr generated by unsafe means is indeed safe in the + current environment, and returns it, or the error otherwise. Panics if + not focussed. *) + +Ltac2 @ external substnl : constr list -> int -> constr -> constr := "ltac2" "constr_substnl". +(** [substnl [r₁;...;rₙ] k c] substitutes in parallel [Rel(k+1); ...; Rel(k+n)] with + [r₁;...;rₙ] in [c]. *) + +Ltac2 @ external closenl : ident list -> int -> constr -> constr := "ltac2" "constr_closenl". +(** [closenl [x₁;...;xₙ] k c] abstracts over variables [x₁;...;xₙ] and replaces them with + [Rel(k); ...; Rel(k+n-1)] in [c]. If two names are identical, the one of least index is kept. *) + +Ltac2 @ external case : inductive -> case := "ltac2" "constr_case". +(** Generate the case information for a given inductive type. *) + +Ltac2 @ external constructor : inductive -> int -> constructor := "ltac2" "constr_constructor". +(** Generate the i-th constructor for a given inductive type. Indexing starts + at 0. Panics if there is no such constructor. *) + +End Unsafe. + +Ltac2 @ external in_context : ident -> constr -> (unit -> unit) -> constr := "ltac2" "constr_in_context". +(** On a focussed goal [Γ ⊢ A], [in_context id c tac] evaluates [tac] in a + focussed goal [Γ, id : c ⊢ ?X] and returns [fun (id : c) => t] where [t] is + the proof built by the tactic. *) diff --git a/user-contrib/Ltac2/Control.v b/user-contrib/Ltac2/Control.v new file mode 100644 index 0000000000..071c2ea8ce --- /dev/null +++ b/user-contrib/Ltac2/Control.v @@ -0,0 +1,76 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ltac2.Init. + +(** Panic *) + +Ltac2 @ external throw : exn -> 'a := "ltac2" "throw". +(** Fatal exception throwing. This does not induce backtracking. *) + +(** Generic backtracking control *) + +Ltac2 @ external zero : exn -> 'a := "ltac2" "zero". +Ltac2 @ external plus : (unit -> 'a) -> (exn -> 'a) -> 'a := "ltac2" "plus". +Ltac2 @ external once : (unit -> 'a) -> 'a := "ltac2" "once". +Ltac2 @ external dispatch : (unit -> unit) list -> unit := "ltac2" "dispatch". +Ltac2 @ external extend : (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit := "ltac2" "extend". +Ltac2 @ external enter : (unit -> unit) -> unit := "ltac2" "enter". +Ltac2 @ external case : (unit -> 'a) -> ('a * (exn -> 'a)) result := "ltac2" "case". + +(** Proof state manipulation *) + +Ltac2 @ external focus : int -> int -> (unit -> 'a) -> 'a := "ltac2" "focus". +Ltac2 @ external shelve : unit -> unit := "ltac2" "shelve". +Ltac2 @ external shelve_unifiable : unit -> unit := "ltac2" "shelve_unifiable". + +Ltac2 @ external new_goal : evar -> unit := "ltac2" "new_goal". +(** Adds the given evar to the list of goals as the last one. If it is + already defined in the current state, don't do anything. Panics if the + evar is not in the current state. *) + +Ltac2 @ external progress : (unit -> 'a) -> 'a := "ltac2" "progress". + +(** Goal inspection *) + +Ltac2 @ external goal : unit -> constr := "ltac2" "goal". +(** Panics if there is not exactly one goal under focus. Otherwise returns + the conclusion of this goal. *) + +Ltac2 @ external hyp : ident -> constr := "ltac2" "hyp". +(** Panics if there is more than one goal under focus. If there is no + goal under focus, looks for the section variable with the given name. + If there is one, looks for the hypothesis with the given name. *) + +Ltac2 @ external hyps : unit -> (ident * constr option * constr) list := "ltac2" "hyps". +(** Panics if there is more than one goal under focus. If there is no + goal under focus, returns the list of section variables. + If there is one, returns the list of hypotheses. In both cases, the + list is ordered with rightmost values being last introduced. *) + +(** Refinement *) + +Ltac2 @ external refine : (unit -> constr) -> unit := "ltac2" "refine". + +(** Evars *) + +Ltac2 @ external with_holes : (unit -> 'a) -> ('a -> 'b) -> 'b := "ltac2" "with_holes". +(** [with_holes x f] evaluates [x], then apply [f] to the result, and fails if + all evars generated by the call to [x] have not been solved when [f] + returns. *) + +(** Misc *) + +Ltac2 @ external time : string option -> (unit -> 'a) -> 'a := "ltac2" "time". +(** Displays the time taken by a tactic to evaluate. *) + +Ltac2 @ external abstract : ident option -> (unit -> unit) -> unit := "ltac2" "abstract". +(** Abstract a subgoal. *) + +Ltac2 @ external check_interrupt : unit -> unit := "ltac2" "check_interrupt". +(** For internal use. *) diff --git a/user-contrib/Ltac2/Env.v b/user-contrib/Ltac2/Env.v new file mode 100644 index 0000000000..4aa1718c9a --- /dev/null +++ b/user-contrib/Ltac2/Env.v @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +From Ltac2 Require Import Init Std. + +Ltac2 @ external get : ident list -> Std.reference option := "ltac2" "env_get". +(** Returns the global reference corresponding to the absolute name given as + argument if it exists. *) + +Ltac2 @ external expand : ident list -> Std.reference list := "ltac2" "env_expand". +(** Returns the list of all global references whose absolute name contains + the argument list as a prefix. *) + +Ltac2 @ external path : Std.reference -> ident list := "ltac2" "env_path". +(** Returns the absolute name of the given reference. Panics if the reference + does not exist. *) + +Ltac2 @ external instantiate : Std.reference -> constr := "ltac2" "env_instantiate". +(** Returns a fresh instance of the corresponding reference, in particular + generating fresh universe variables and constraints when this reference is + universe-polymorphic. *) diff --git a/user-contrib/Ltac2/Fresh.v b/user-contrib/Ltac2/Fresh.v new file mode 100644 index 0000000000..5e876bb077 --- /dev/null +++ b/user-contrib/Ltac2/Fresh.v @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ltac2.Init. + +Module Free. + +Ltac2 Type t. +(** Type of sets of free variables *) + +Ltac2 @ external union : t -> t -> t := "ltac2" "fresh_free_union". + +Ltac2 @ external of_ids : ident list -> t := "ltac2" "fresh_free_of_ids". + +Ltac2 @ external of_constr : constr -> t := "ltac2" "fresh_free_of_constr". + +End Free. + +Ltac2 @ external fresh : Free.t -> ident -> ident := "ltac2" "fresh_fresh". +(** Generate a fresh identifier with the given base name which is not a + member of the provided set of free variables. *) diff --git a/user-contrib/Ltac2/Ident.v b/user-contrib/Ltac2/Ident.v new file mode 100644 index 0000000000..55456afbe2 --- /dev/null +++ b/user-contrib/Ltac2/Ident.v @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ltac2.Init. + +Ltac2 Type t := ident. + +Ltac2 @ external equal : t -> t -> bool := "ltac2" "ident_equal". + +Ltac2 @ external of_string : string -> t option := "ltac2" "ident_of_string". + +Ltac2 @ external to_string : t -> string := "ltac2" "ident_to_string". diff --git a/user-contrib/Ltac2/Init.v b/user-contrib/Ltac2/Init.v new file mode 100644 index 0000000000..16e7d7a6f9 --- /dev/null +++ b/user-contrib/Ltac2/Init.v @@ -0,0 +1,69 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Declare ML Module "ltac2_plugin". + +(** Primitive types *) + +Ltac2 Type int. +Ltac2 Type string. +Ltac2 Type char. +Ltac2 Type ident. + +(** Constr-specific built-in types *) +Ltac2 Type meta. +Ltac2 Type evar. +Ltac2 Type sort. +Ltac2 Type cast. +Ltac2 Type instance. +Ltac2 Type constant. +Ltac2 Type inductive. +Ltac2 Type constructor. +Ltac2 Type projection. +Ltac2 Type pattern. +Ltac2 Type constr. + +Ltac2 Type message. +Ltac2 Type exn := [ .. ]. +Ltac2 Type 'a array. + +(** Pervasive types *) + +Ltac2 Type 'a option := [ None | Some ('a) ]. + +Ltac2 Type 'a ref := { mutable contents : 'a }. + +Ltac2 Type bool := [ true | false ]. + +Ltac2 Type 'a result := [ Val ('a) | Err (exn) ]. + +(** Pervasive exceptions *) + +Ltac2 Type err. +(** Coq internal errors. Cannot be constructed, merely passed around. *) + +Ltac2 Type exn ::= [ Internal (err) ]. +(** Wrapper around the errors raised by Coq implementation. *) + +Ltac2 Type exn ::= [ Out_of_bounds ]. +(** Used for bound checking, e.g. with String and Array. *) + +Ltac2 Type exn ::= [ Not_focussed ]. +(** In Ltac2, the notion of "current environment" only makes sense when there is + at most one goal under focus. Contrarily to Ltac1, instead of dynamically + focussing when we need it, we raise this non-backtracking error when it does + not make sense. *) + +Ltac2 Type exn ::= [ Not_found ]. +(** Used when something is missing. *) + +Ltac2 Type exn ::= [ Match_failure ]. +(** Used to signal a pattern didn't match a term. *) + +Ltac2 Type exn ::= [ Tactic_failure (message option) ]. +(** Generic error for tactic failure. *) diff --git a/user-contrib/Ltac2/Int.v b/user-contrib/Ltac2/Int.v new file mode 100644 index 0000000000..0a90d757b6 --- /dev/null +++ b/user-contrib/Ltac2/Int.v @@ -0,0 +1,18 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ltac2.Init. + +Ltac2 Type exn ::= [ Division_by_zero ]. + +Ltac2 @ external equal : int -> int -> bool := "ltac2" "int_equal". +Ltac2 @ external compare : int -> int -> int := "ltac2" "int_compare". +Ltac2 @ external add : int -> int -> int := "ltac2" "int_add". +Ltac2 @ external sub : int -> int -> int := "ltac2" "int_sub". +Ltac2 @ external mul : int -> int -> int := "ltac2" "int_mul". +Ltac2 @ external neg : int -> int := "ltac2" "int_neg". diff --git a/user-contrib/Ltac2/Ltac1.v b/user-contrib/Ltac2/Ltac1.v new file mode 100644 index 0000000000..c4e0b606d0 --- /dev/null +++ b/user-contrib/Ltac2/Ltac1.v @@ -0,0 +1,36 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** This module defines the Ltac2 FFI to Ltac1 code. Due to intricate semantics + of the latter, the functions described here are voluntarily under-specified. + Not for the casual user, handle with care and expect undefined behaviours + otherwise. **) + +Require Import Ltac2.Init. + +Ltac2 Type t. +(** Dynamically-typed Ltac1 values. *) + +Ltac2 @ external ref : ident list -> t := "ltac2" "ltac1_ref". +(** Returns the Ltac1 definition with the given absolute name. *) + +Ltac2 @ external run : t -> unit := "ltac2" "ltac1_run". +(** Runs an Ltac1 value, assuming it is a 'tactic', i.e. not returning + anything. *) + +Ltac2 @ external apply : t -> t list -> (t -> unit) -> unit := "ltac2" "ltac1_apply". +(** Applies an Ltac1 value to a list of arguments, and provides the result in + CPS style. It does **not** run the returned value. *) + +(** Conversion functions *) + +Ltac2 @ external of_constr : constr -> t := "ltac2" "ltac1_of_constr". +Ltac2 @ external to_constr : t -> constr option := "ltac2" "ltac1_to_constr". + +Ltac2 @ external of_list : t list -> t := "ltac2" "ltac1_of_list". +Ltac2 @ external to_list : t -> t list option := "ltac2" "ltac1_to_list". diff --git a/user-contrib/Ltac2/Ltac2.v b/user-contrib/Ltac2/Ltac2.v new file mode 100644 index 0000000000..ac90f63560 --- /dev/null +++ b/user-contrib/Ltac2/Ltac2.v @@ -0,0 +1,24 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Export Ltac2.Init. + +Require Ltac2.Int. +Require Ltac2.Char. +Require Ltac2.String. +Require Ltac2.Ident. +Require Ltac2.Array. +Require Ltac2.Message. +Require Ltac2.Constr. +Require Ltac2.Control. +Require Ltac2.Fresh. +Require Ltac2.Pattern. +Require Ltac2.Std. +Require Ltac2.Env. +Require Ltac2.Ltac1. +Require Export Ltac2.Notations. diff --git a/user-contrib/Ltac2/Message.v b/user-contrib/Ltac2/Message.v new file mode 100644 index 0000000000..7bffe0746b --- /dev/null +++ b/user-contrib/Ltac2/Message.v @@ -0,0 +1,25 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ltac2.Init. + +Ltac2 @ external print : message -> unit := "ltac2" "print". + +Ltac2 @ external of_string : string -> message := "ltac2" "message_of_string". + +Ltac2 @ external of_int : int -> message := "ltac2" "message_of_int". + +Ltac2 @ external of_ident : ident -> message := "ltac2" "message_of_ident". + +Ltac2 @ external of_constr : constr -> message := "ltac2" "message_of_constr". +(** Panics if there is more than one goal under focus. *) + +Ltac2 @ external of_exn : exn -> message := "ltac2" "message_of_exn". +(** Panics if there is more than one goal under focus. *) + +Ltac2 @ external concat : message -> message -> message := "ltac2" "message_concat". diff --git a/user-contrib/Ltac2/Notations.v b/user-contrib/Ltac2/Notations.v new file mode 100644 index 0000000000..0eab36df82 --- /dev/null +++ b/user-contrib/Ltac2/Notations.v @@ -0,0 +1,556 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ltac2.Init. +Require Ltac2.Control Ltac2.Pattern Ltac2.Array Ltac2.Int Ltac2.Std. + +(** Constr matching *) + +Ltac2 Notation "lazy_match!" t(tactic(6)) "with" m(constr_matching) "end" := + Pattern.lazy_match0 t m. + +Ltac2 Notation "multi_match!" t(tactic(6)) "with" m(constr_matching) "end" := + Pattern.multi_match0 t m. + +Ltac2 Notation "match!" t(tactic(6)) "with" m(constr_matching) "end" := + Pattern.one_match0 t m. + +(** Goal matching *) + +Ltac2 Notation "lazy_match!" "goal" "with" m(goal_matching) "end" := + Pattern.lazy_goal_match0 false m. + +Ltac2 Notation "multi_match!" "goal" "with" m(goal_matching) "end" := + Pattern.multi_goal_match0 false m. + +Ltac2 Notation "match!" "goal" "with" m(goal_matching) "end" := + Pattern.one_goal_match0 false m. + +Ltac2 Notation "lazy_match!" "reverse" "goal" "with" m(goal_matching) "end" := + Pattern.lazy_goal_match0 true m. + +Ltac2 Notation "multi_match!" "reverse" "goal" "with" m(goal_matching) "end" := + Pattern.multi_goal_match0 true m. + +Ltac2 Notation "match!" "reverse" "goal" "with" m(goal_matching) "end" := + Pattern.one_goal_match0 true m. + +(** Tacticals *) + +Ltac2 orelse t f := +match Control.case t with +| Err e => f e +| Val ans => + let (x, k) := ans in + Control.plus (fun _ => x) k +end. + +Ltac2 ifcatch t s f := +match Control.case t with +| Err e => f e +| Val ans => + let (x, k) := ans in + Control.plus (fun _ => s x) (fun e => s (k e)) +end. + +Ltac2 fail0 (_ : unit) := Control.enter (fun _ => Control.zero (Tactic_failure None)). + +Ltac2 Notation fail := fail0 (). + +Ltac2 try0 t := Control.enter (fun _ => orelse t (fun _ => ())). + +Ltac2 Notation try := try0. + +Ltac2 rec repeat0 (t : unit -> unit) := + Control.enter (fun () => + ifcatch (fun _ => Control.progress t) + (fun _ => Control.check_interrupt (); repeat0 t) (fun _ => ())). + +Ltac2 Notation repeat := repeat0. + +Ltac2 dispatch0 t (head, tail) := + match tail with + | None => Control.enter (fun _ => t (); Control.dispatch head) + | Some tacs => + let (def, rem) := tacs in + Control.enter (fun _ => t (); Control.extend head def rem) + end. + +Ltac2 Notation t(thunk(self)) ">" "[" l(dispatch) "]" : 4 := dispatch0 t l. + +Ltac2 do0 n t := + let rec aux n t := match Int.equal n 0 with + | true => () + | false => t (); aux (Int.sub n 1) t + end in + aux (n ()) t. + +Ltac2 Notation do := do0. + +Ltac2 Notation once := Control.once. + +Ltac2 progress0 tac := Control.enter (fun _ => Control.progress tac). + +Ltac2 Notation progress := progress0. + +Ltac2 rec first0 tacs := +match tacs with +| [] => Control.zero (Tactic_failure None) +| tac :: tacs => Control.enter (fun _ => orelse tac (fun _ => first0 tacs)) +end. + +Ltac2 Notation "first" "[" tacs(list0(thunk(tactic(6)), "|")) "]" := first0 tacs. + +Ltac2 complete tac := + let ans := tac () in + Control.enter (fun () => Control.zero (Tactic_failure None)); + ans. + +Ltac2 rec solve0 tacs := +match tacs with +| [] => Control.zero (Tactic_failure None) +| tac :: tacs => + Control.enter (fun _ => orelse (fun _ => complete tac) (fun _ => solve0 tacs)) +end. + +Ltac2 Notation "solve" "[" tacs(list0(thunk(tactic(6)), "|")) "]" := solve0 tacs. + +Ltac2 time0 tac := Control.time None tac. + +Ltac2 Notation time := time0. + +Ltac2 abstract0 tac := Control.abstract None tac. + +Ltac2 Notation abstract := abstract0. + +(** Base tactics *) + +(** Note that we redeclare notations that can be parsed as mere identifiers + as abbreviations, so that it allows to parse them as function arguments + without having to write them within parentheses. *) + +(** Enter and check evar resolution *) +Ltac2 enter_h ev f arg := +match ev with +| true => Control.enter (fun () => f ev (arg ())) +| false => + Control.enter (fun () => + Control.with_holes arg (fun x => f ev x)) +end. + +Ltac2 intros0 ev p := + Control.enter (fun () => Std.intros false p). + +Ltac2 Notation "intros" p(intropatterns) := intros0 false p. +Ltac2 Notation intros := intros. + +Ltac2 Notation "eintros" p(intropatterns) := intros0 true p. +Ltac2 Notation eintros := eintros. + +Ltac2 split0 ev bnd := + enter_h ev Std.split bnd. + +Ltac2 Notation "split" bnd(thunk(with_bindings)) := split0 false bnd. +Ltac2 Notation split := split. + +Ltac2 Notation "esplit" bnd(thunk(with_bindings)) := split0 true bnd. +Ltac2 Notation esplit := esplit. + +Ltac2 exists0 ev bnds := match bnds with +| [] => split0 ev (fun () => Std.NoBindings) +| _ => + let rec aux bnds := match bnds with + | [] => () + | bnd :: bnds => split0 ev bnd; aux bnds + end in + aux bnds +end. + +Ltac2 Notation "exists" bnd(list0(thunk(bindings), ",")) := exists0 false bnd. +(* Ltac2 Notation exists := exists. *) + +Ltac2 Notation "eexists" bnd(list0(thunk(bindings), ",")) := exists0 true bnd. +Ltac2 Notation eexists := eexists. + +Ltac2 left0 ev bnd := enter_h ev Std.left bnd. + +Ltac2 Notation "left" bnd(thunk(with_bindings)) := left0 false bnd. +Ltac2 Notation left := left. + +Ltac2 Notation "eleft" bnd(thunk(with_bindings)) := left0 true bnd. +Ltac2 Notation eleft := eleft. + +Ltac2 right0 ev bnd := enter_h ev Std.right bnd. + +Ltac2 Notation "right" bnd(thunk(with_bindings)) := right0 false bnd. +Ltac2 Notation right := right. + +Ltac2 Notation "eright" bnd(thunk(with_bindings)) := right0 true bnd. +Ltac2 Notation eright := eright. + +Ltac2 constructor0 ev n bnd := + enter_h ev (fun ev bnd => Std.constructor_n ev n bnd) bnd. + +Ltac2 Notation "constructor" := Control.enter (fun () => Std.constructor false). +Ltac2 Notation constructor := constructor. +Ltac2 Notation "constructor" n(tactic) bnd(thunk(with_bindings)) := constructor0 false n bnd. + +Ltac2 Notation "econstructor" := Control.enter (fun () => Std.constructor true). +Ltac2 Notation econstructor := econstructor. +Ltac2 Notation "econstructor" n(tactic) bnd(thunk(with_bindings)) := constructor0 true n bnd. + +Ltac2 specialize0 c pat := + enter_h false (fun _ c => Std.specialize c pat) c. + +Ltac2 Notation "specialize" c(thunk(seq(constr, with_bindings))) ipat(opt(seq("as", intropattern))) := + specialize0 c ipat. + +Ltac2 elim0 ev c bnd use := + let f ev (c, bnd, use) := Std.elim ev (c, bnd) use in + enter_h ev f (fun () => c (), bnd (), use ()). + +Ltac2 Notation "elim" c(thunk(constr)) bnd(thunk(with_bindings)) + use(thunk(opt(seq("using", constr, with_bindings)))) := + elim0 false c bnd use. + +Ltac2 Notation "eelim" c(thunk(constr)) bnd(thunk(with_bindings)) + use(thunk(opt(seq("using", constr, with_bindings)))) := + elim0 true c bnd use. + +Ltac2 apply0 adv ev cb cl := + Std.apply adv ev cb cl. + +Ltac2 Notation "eapply" + cb(list1(thunk(seq(constr, with_bindings)), ",")) + cl(opt(seq("in", ident, opt(seq("as", intropattern))))) := + apply0 true true cb cl. + +Ltac2 Notation "apply" + cb(list1(thunk(seq(constr, with_bindings)), ",")) + cl(opt(seq("in", ident, opt(seq("as", intropattern))))) := + apply0 true false cb cl. + +Ltac2 default_on_concl cl := +match cl with +| None => { Std.on_hyps := Some []; Std.on_concl := Std.AllOccurrences } +| Some cl => cl +end. + +Ltac2 pose0 ev p := + enter_h ev (fun ev (na, p) => Std.pose na p) p. + +Ltac2 Notation "pose" p(thunk(pose)) := + pose0 false p. + +Ltac2 Notation "epose" p(thunk(pose)) := + pose0 true p. + +Ltac2 Notation "set" p(thunk(pose)) cl(opt(clause)) := + Std.set false p (default_on_concl cl). + +Ltac2 Notation "eset" p(thunk(pose)) cl(opt(clause)) := + Std.set true p (default_on_concl cl). + +Ltac2 assert0 ev ast := + enter_h ev (fun _ ast => Std.assert ast) ast. + +Ltac2 Notation "assert" ast(thunk(assert)) := assert0 false ast. + +Ltac2 Notation "eassert" ast(thunk(assert)) := assert0 true ast. + +Ltac2 default_everywhere cl := +match cl with +| None => { Std.on_hyps := None; Std.on_concl := Std.AllOccurrences } +| Some cl => cl +end. + +Ltac2 Notation "remember" + c(thunk(open_constr)) + na(opt(seq("as", ident))) + pat(opt(seq("eqn", ":", intropattern))) + cl(opt(clause)) := + Std.remember false na c pat (default_everywhere cl). + +Ltac2 Notation "eremember" + c(thunk(open_constr)) + na(opt(seq("as", ident))) + pat(opt(seq("eqn", ":", intropattern))) + cl(opt(clause)) := + Std.remember true na c pat (default_everywhere cl). + +Ltac2 induction0 ev ic use := + let f ev use := Std.induction ev ic use in + enter_h ev f use. + +Ltac2 Notation "induction" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, with_bindings)))) := + induction0 false ic use. + +Ltac2 Notation "einduction" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, with_bindings)))) := + induction0 true ic use. + +Ltac2 generalize0 gen := + enter_h false (fun _ gen => Std.generalize gen) gen. + +Ltac2 Notation "generalize" + gen(thunk(list1(seq (open_constr, occurrences, opt(seq("as", ident))), ","))) := + generalize0 gen. + +Ltac2 destruct0 ev ic use := + let f ev use := Std.destruct ev ic use in + enter_h ev f use. + +Ltac2 Notation "destruct" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, with_bindings)))) := + destruct0 false ic use. + +Ltac2 Notation "edestruct" + ic(list1(induction_clause, ",")) + use(thunk(opt(seq("using", constr, with_bindings)))) := + destruct0 true ic use. + +Ltac2 Notation "simple" "inversion" + arg(destruction_arg) + pat(opt(seq("as", intropattern))) + ids(opt(seq("in", list1(ident)))) := + Std.inversion Std.SimpleInversion arg pat ids. + +Ltac2 Notation "inversion" + arg(destruction_arg) + pat(opt(seq("as", intropattern))) + ids(opt(seq("in", list1(ident)))) := + Std.inversion Std.FullInversion arg pat ids. + +Ltac2 Notation "inversion_clear" + arg(destruction_arg) + pat(opt(seq("as", intropattern))) + ids(opt(seq("in", list1(ident)))) := + Std.inversion Std.FullInversionClear arg pat ids. + +Ltac2 Notation "red" cl(opt(clause)) := + Std.red (default_on_concl cl). +Ltac2 Notation red := red. + +Ltac2 Notation "hnf" cl(opt(clause)) := + Std.hnf (default_on_concl cl). +Ltac2 Notation hnf := hnf. + +Ltac2 Notation "simpl" s(strategy) pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := + Std.simpl s pl (default_on_concl cl). +Ltac2 Notation simpl := simpl. + +Ltac2 Notation "cbv" s(strategy) cl(opt(clause)) := + Std.cbv s (default_on_concl cl). +Ltac2 Notation cbv := cbv. + +Ltac2 Notation "cbn" s(strategy) cl(opt(clause)) := + Std.cbn s (default_on_concl cl). +Ltac2 Notation cbn := cbn. + +Ltac2 Notation "lazy" s(strategy) cl(opt(clause)) := + Std.lazy s (default_on_concl cl). +Ltac2 Notation lazy := lazy. + +Ltac2 Notation "unfold" pl(list1(seq(reference, occurrences), ",")) cl(opt(clause)) := + Std.unfold pl (default_on_concl cl). + +Ltac2 fold0 pl cl := + let cl := default_on_concl cl in + Control.enter (fun () => Control.with_holes pl (fun pl => Std.fold pl cl)). + +Ltac2 Notation "fold" pl(thunk(list1(open_constr))) cl(opt(clause)) := + fold0 pl cl. + +Ltac2 Notation "pattern" pl(list1(seq(constr, occurrences), ",")) cl(opt(clause)) := + Std.pattern pl (default_on_concl cl). + +Ltac2 Notation "vm_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := + Std.vm pl (default_on_concl cl). +Ltac2 Notation vm_compute := vm_compute. + +Ltac2 Notation "native_compute" pl(opt(seq(pattern, occurrences))) cl(opt(clause)) := + Std.native pl (default_on_concl cl). +Ltac2 Notation native_compute := native_compute. + +Ltac2 change0 p cl := + let (pat, c) := p in + Std.change pat c (default_on_concl cl). + +Ltac2 Notation "change" c(conversion) cl(opt(clause)) := change0 c cl. + +Ltac2 rewrite0 ev rw cl tac := + let cl := default_on_concl cl in + Std.rewrite ev rw cl tac. + +Ltac2 Notation "rewrite" + rw(list1(rewriting, ",")) + cl(opt(clause)) + tac(opt(seq("by", thunk(tactic)))) := + rewrite0 false rw cl tac. + +Ltac2 Notation "erewrite" + rw(list1(rewriting, ",")) + cl(opt(clause)) + tac(opt(seq("by", thunk(tactic)))) := + rewrite0 true rw cl tac. + +(** coretactics *) + +Ltac2 exact0 ev c := + Control.enter (fun _ => + match ev with + | true => + let c := c () in + Control.refine (fun _ => c) + | false => + Control.with_holes c (fun c => Control.refine (fun _ => c)) + end + ). + +Ltac2 Notation "exact" c(thunk(open_constr)) := exact0 false c. +Ltac2 Notation "eexact" c(thunk(open_constr)) := exact0 true c. + +Ltac2 Notation "intro" id(opt(ident)) mv(opt(move_location)) := Std.intro id mv. +Ltac2 Notation intro := intro. + +Ltac2 Notation "move" id(ident) mv(move_location) := Std.move id mv. + +Ltac2 Notation reflexivity := Std.reflexivity (). + +Ltac2 symmetry0 cl := + Std.symmetry (default_on_concl cl). + +Ltac2 Notation "symmetry" cl(opt(clause)) := symmetry0 cl. +Ltac2 Notation symmetry := symmetry. + +Ltac2 Notation "revert" ids(list1(ident)) := Std.revert ids. + +Ltac2 Notation assumption := Std.assumption (). + +Ltac2 Notation etransitivity := Std.etransitivity (). + +Ltac2 Notation admit := Std.admit (). + +Ltac2 clear0 ids := match ids with +| [] => Std.keep [] +| _ => Std.clear ids +end. + +Ltac2 Notation "clear" ids(list0(ident)) := clear0 ids. +Ltac2 Notation "clear" "-" ids(list1(ident)) := Std.keep ids. +Ltac2 Notation clear := clear. + +Ltac2 Notation refine := Control.refine. + +(** extratactics *) + +Ltac2 absurd0 c := Control.enter (fun _ => Std.absurd (c ())). + +Ltac2 Notation "absurd" c(thunk(open_constr)) := absurd0 c. + +Ltac2 subst0 ids := match ids with +| [] => Std.subst_all () +| _ => Std.subst ids +end. + +Ltac2 Notation "subst" ids(list0(ident)) := subst0 ids. +Ltac2 Notation subst := subst. + +Ltac2 Notation "discriminate" arg(opt(destruction_arg)) := + Std.discriminate false arg. +Ltac2 Notation discriminate := discriminate. + +Ltac2 Notation "ediscriminate" arg(opt(destruction_arg)) := + Std.discriminate true arg. +Ltac2 Notation ediscriminate := ediscriminate. + +Ltac2 Notation "injection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropatterns))):= + Std.injection false ipat arg. + +Ltac2 Notation "einjection" arg(opt(destruction_arg)) ipat(opt(seq("as", intropatterns))):= + Std.injection true ipat arg. + +(** Auto *) + +Ltac2 default_db dbs := match dbs with +| None => Some [] +| Some dbs => + match dbs with + | None => None + | Some l => Some l + end +end. + +Ltac2 default_list use := match use with +| None => [] +| Some use => use +end. + +Ltac2 trivial0 use dbs := + let dbs := default_db dbs in + let use := default_list use in + Std.trivial Std.Off use dbs. + +Ltac2 Notation "trivial" + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := trivial0 use dbs. + +Ltac2 Notation trivial := trivial. + +Ltac2 auto0 n use dbs := + let dbs := default_db dbs in + let use := default_list use in + Std.auto Std.Off n use dbs. + +Ltac2 Notation "auto" n(opt(tactic(0))) + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := auto0 n use dbs. + +Ltac2 Notation auto := auto. + +Ltac2 new_eauto0 n use dbs := + let dbs := default_db dbs in + let use := default_list use in + Std.new_auto Std.Off n use dbs. + +Ltac2 Notation "new" "auto" n(opt(tactic(0))) + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := new_eauto0 n use dbs. + +Ltac2 eauto0 n p use dbs := + let dbs := default_db dbs in + let use := default_list use in + Std.eauto Std.Off n p use dbs. + +Ltac2 Notation "eauto" n(opt(tactic(0))) p(opt(tactic(0))) + use(opt(seq("using", list1(thunk(constr), ",")))) + dbs(opt(seq("with", hintdb))) := eauto0 n p use dbs. + +Ltac2 Notation eauto := eauto. + +Ltac2 Notation "typeclasses_eauto" n(opt(tactic(0))) + dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto None n dbs. + +Ltac2 Notation "typeclasses_eauto" "bfs" n(opt(tactic(0))) + dbs(opt(seq("with", list1(ident)))) := Std.typeclasses_eauto (Some Std.BFS) n dbs. + +Ltac2 Notation typeclasses_eauto := typeclasses_eauto. + +(** Congruence *) + +Ltac2 f_equal0 () := ltac1:(f_equal). +Ltac2 Notation f_equal := f_equal0 (). + +(** now *) + +Ltac2 now0 t := t (); ltac1:(easy). +Ltac2 Notation "now" t(thunk(self)) := now0 t. diff --git a/user-contrib/Ltac2/Pattern.v b/user-contrib/Ltac2/Pattern.v new file mode 100644 index 0000000000..8d1fb0cd8a --- /dev/null +++ b/user-contrib/Ltac2/Pattern.v @@ -0,0 +1,145 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ltac2.Init. +Require Ltac2.Control. + +Ltac2 Type t := pattern. + +Ltac2 Type context. + +Ltac2 Type match_kind := [ +| MatchPattern +| MatchContext +]. + +Ltac2 @ external empty_context : unit -> context := + "ltac2" "pattern_empty_context". +(** A trivial context only made of the hole. *) + +Ltac2 @ external matches : t -> constr -> (ident * constr) list := + "ltac2" "pattern_matches". +(** If the term matches the pattern, returns the bound variables. If it doesn't, + fail with [Match_failure]. Panics if not focussed. *) + +Ltac2 @ external matches_subterm : t -> constr -> context * ((ident * constr) list) := + "ltac2" "pattern_matches_subterm". +(** Returns a stream of results corresponding to all of the subterms of the term + that matches the pattern as in [matches]. The stream is encoded as a + backtracking value whose last exception is [Match_failure]. The additional + value compared to [matches] is the context of the match, to be filled with + the instantiate function. *) + +Ltac2 @ external matches_vect : t -> constr -> constr array := + "ltac2" "pattern_matches_vect". +(** Internal version of [matches] that does not return the identifiers. *) + +Ltac2 @ external matches_subterm_vect : t -> constr -> context * constr array := + "ltac2" "pattern_matches_subterm_vect". +(** Internal version of [matches_subterms] that does not return the identifiers. *) + +Ltac2 @ external matches_goal : bool -> (match_kind * t) list -> (match_kind * t) -> + ident array * context array * constr array * context := + "ltac2" "pattern_matches_goal". +(** Given a list of patterns [hpats] for hypotheses and one pattern [cpat] for the + conclusion, [matches_goal rev hpats cpat] produces (a stream of) tuples of: + - An array of idents, whose size is the length of [hpats], corresponding to the + name of matched hypotheses. + - An array of contexts, whose size is the length of [hpats], corresponding to + the contexts matched for every hypothesis pattern. In case the match kind of + a hypothesis was [MatchPattern], the corresponding context is ensured to be empty. + - An array of terms, whose size is the total number of pattern variables without + duplicates. Terms are ordered by identifier order, e.g. ?a comes before ?b. + - A context corresponding to the conclusion, which is ensured to be empty if + the kind of [cpat] was [MatchPattern]. + This produces a backtracking stream of results containing all the possible + result combinations. The order of considered hypotheses is reversed if [rev] + is true. +*) + +Ltac2 @ external instantiate : context -> constr -> constr := + "ltac2" "pattern_instantiate". +(** Fill the hole of a context with the given term. *) + +(** Implementation of Ltac matching over terms and goals *) + +Ltac2 lazy_match0 t pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let (knd, pat, f) := p in + let p := match knd with + | MatchPattern => + (fun _ => + let context := empty_context () in + let bind := matches_vect pat t in + fun _ => f context bind) + | MatchContext => + (fun _ => + let (context, bind) := matches_subterm_vect pat t in + fun _ => f context bind) + end in + Control.plus p next + end in + Control.once (fun () => interp pats) (). + +Ltac2 multi_match0 t pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let (knd, pat, f) := p in + let p := match knd with + | MatchPattern => + (fun _ => + let context := empty_context () in + let bind := matches_vect pat t in + f context bind) + | MatchContext => + (fun _ => + let (context, bind) := matches_subterm_vect pat t in + f context bind) + end in + Control.plus p next + end in + interp pats. + +Ltac2 one_match0 t m := Control.once (fun _ => multi_match0 t m). + +Ltac2 lazy_goal_match0 rev pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let (pat, f) := p in + let (phyps, pconcl) := pat in + let cur _ := + let (hids, hctx, subst, cctx) := matches_goal rev phyps pconcl in + fun _ => f hids hctx subst cctx + in + Control.plus cur next + end in + Control.once (fun () => interp pats) (). + +Ltac2 multi_goal_match0 rev pats := + let rec interp m := match m with + | [] => Control.zero Match_failure + | p :: m => + let next _ := interp m in + let (pat, f) := p in + let (phyps, pconcl) := pat in + let cur _ := + let (hids, hctx, subst, cctx) := matches_goal rev phyps pconcl in + f hids hctx subst cctx + in + Control.plus cur next + end in + interp pats. + +Ltac2 one_goal_match0 rev pats := Control.once (fun _ => multi_goal_match0 rev pats). diff --git a/user-contrib/Ltac2/Std.v b/user-contrib/Ltac2/Std.v new file mode 100644 index 0000000000..6c3f465f33 --- /dev/null +++ b/user-contrib/Ltac2/Std.v @@ -0,0 +1,259 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ltac2.Init. + +(** ML-facing types *) + +Ltac2 Type hypothesis := [ AnonHyp (int) | NamedHyp (ident) ]. + +Ltac2 Type bindings := [ +| NoBindings +| ImplicitBindings (constr list) +| ExplicitBindings ((hypothesis * constr) list) +]. + +Ltac2 Type constr_with_bindings := constr * bindings. + +Ltac2 Type occurrences := [ +| AllOccurrences +| AllOccurrencesBut (int list) +| NoOccurrences +| OnlyOccurrences (int list) +]. + +Ltac2 Type hyp_location_flag := [ InHyp | InHypTypeOnly | InHypValueOnly ]. + +Ltac2 Type clause := { + on_hyps : (ident * occurrences * hyp_location_flag) list option; + on_concl : occurrences; +}. + +Ltac2 Type reference := [ +| VarRef (ident) +| ConstRef (constant) +| IndRef (inductive) +| ConstructRef (constructor) +]. + +Ltac2 Type red_flags := { + rBeta : bool; + rMatch : bool; + rFix : bool; + rCofix : bool; + rZeta : bool; + rDelta : bool; (** true = delta all but rConst; false = delta only on rConst*) + rConst : reference list +}. + +Ltac2 Type 'a not_implemented. + +Ltac2 Type rec intro_pattern := [ +| IntroForthcoming (bool) +| IntroNaming (intro_pattern_naming) +| IntroAction (intro_pattern_action) +] +with intro_pattern_naming := [ +| IntroIdentifier (ident) +| IntroFresh (ident) +| IntroAnonymous +] +with intro_pattern_action := [ +| IntroWildcard +| IntroOrAndPattern (or_and_intro_pattern) +| IntroInjection (intro_pattern list) +| IntroApplyOn ((unit -> constr), intro_pattern) +| IntroRewrite (bool) +] +with or_and_intro_pattern := [ +| IntroOrPattern (intro_pattern list list) +| IntroAndPattern (intro_pattern list) +]. + +Ltac2 Type destruction_arg := [ +| ElimOnConstr (unit -> constr_with_bindings) +| ElimOnIdent (ident) +| ElimOnAnonHyp (int) +]. + +Ltac2 Type induction_clause := { + indcl_arg : destruction_arg; + indcl_eqn : intro_pattern_naming option; + indcl_as : or_and_intro_pattern option; + indcl_in : clause option; +}. + +Ltac2 Type assertion := [ +| AssertType (intro_pattern option, constr, (unit -> unit) option) +| AssertValue (ident, constr) +]. + +Ltac2 Type repeat := [ +| Precisely (int) +| UpTo (int) +| RepeatStar +| RepeatPlus +]. + +Ltac2 Type orientation := [ LTR | RTL ]. + +Ltac2 Type rewriting := { + rew_orient : orientation option; + rew_repeat : repeat; + rew_equatn : (unit -> constr_with_bindings); +}. + +Ltac2 Type evar_flag := bool. +Ltac2 Type advanced_flag := bool. + +Ltac2 Type move_location := [ +| MoveAfter (ident) +| MoveBefore (ident) +| MoveFirst +| MoveLast +]. + +Ltac2 Type inversion_kind := [ +| SimpleInversion +| FullInversion +| FullInversionClear +]. + +(** Standard, built-in tactics. See Ltac1 for documentation. *) + +Ltac2 @ external intros : evar_flag -> intro_pattern list -> unit := "ltac2" "tac_intros". + +Ltac2 @ external apply : advanced_flag -> evar_flag -> + (unit -> constr_with_bindings) list -> (ident * (intro_pattern option)) option -> unit := "ltac2" "tac_apply". + +Ltac2 @ external elim : evar_flag -> constr_with_bindings -> constr_with_bindings option -> unit := "ltac2" "tac_elim". +Ltac2 @ external case : evar_flag -> constr_with_bindings -> unit := "ltac2" "tac_case". + +Ltac2 @ external generalize : (constr * occurrences * ident option) list -> unit := "ltac2" "tac_generalize". + +Ltac2 @ external assert : assertion -> unit := "ltac2" "tac_assert". +Ltac2 @ external enough : constr -> (unit -> unit) option option -> intro_pattern option -> unit := "ltac2" "tac_enough". + +Ltac2 @ external pose : ident option -> constr -> unit := "ltac2" "tac_pose". +Ltac2 @ external set : evar_flag -> (unit -> ident option * constr) -> clause -> unit := "ltac2" "tac_set". + +Ltac2 @ external remember : evar_flag -> ident option -> (unit -> constr) -> intro_pattern option -> clause -> unit := "ltac2" "tac_remember". + +Ltac2 @ external destruct : evar_flag -> induction_clause list -> + constr_with_bindings option -> unit := "ltac2" "tac_induction". + +Ltac2 @ external induction : evar_flag -> induction_clause list -> + constr_with_bindings option -> unit := "ltac2" "tac_induction". + +Ltac2 @ external red : clause -> unit := "ltac2" "tac_red". +Ltac2 @ external hnf : clause -> unit := "ltac2" "tac_hnf". +Ltac2 @ external simpl : red_flags -> (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_simpl". +Ltac2 @ external cbv : red_flags -> clause -> unit := "ltac2" "tac_cbv". +Ltac2 @ external cbn : red_flags -> clause -> unit := "ltac2" "tac_cbn". +Ltac2 @ external lazy : red_flags -> clause -> unit := "ltac2" "tac_lazy". +Ltac2 @ external unfold : (reference * occurrences) list -> clause -> unit := "ltac2" "tac_unfold". +Ltac2 @ external fold : constr list -> clause -> unit := "ltac2" "tac_fold". +Ltac2 @ external pattern : (constr * occurrences) list -> clause -> unit := "ltac2" "tac_pattern". +Ltac2 @ external vm : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_vm". +Ltac2 @ external native : (pattern * occurrences) option -> clause -> unit := "ltac2" "tac_native". + +Ltac2 @ external eval_red : constr -> constr := "ltac2" "eval_red". +Ltac2 @ external eval_hnf : constr -> constr := "ltac2" "eval_hnf". +Ltac2 @ external eval_red : constr -> constr := "ltac2" "eval_red". +Ltac2 @ external eval_simpl : red_flags -> (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_simpl". +Ltac2 @ external eval_cbv : red_flags -> constr -> constr := "ltac2" "eval_cbv". +Ltac2 @ external eval_cbn : red_flags -> constr -> constr := "ltac2" "eval_cbn". +Ltac2 @ external eval_lazy : red_flags -> constr -> constr := "ltac2" "eval_lazy". +Ltac2 @ external eval_unfold : (reference * occurrences) list -> constr -> constr := "ltac2" "eval_unfold". +Ltac2 @ external eval_fold : constr list -> constr -> constr := "ltac2" "eval_fold". +Ltac2 @ external eval_pattern : (constr * occurrences) list -> constr -> constr := "ltac2" "eval_pattern". +Ltac2 @ external eval_vm : (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_vm". +Ltac2 @ external eval_native : (pattern * occurrences) option -> constr -> constr := "ltac2" "eval_native". + +Ltac2 @ external change : pattern option -> (constr array -> constr) -> clause -> unit := "ltac2" "tac_change". + +Ltac2 @ external rewrite : evar_flag -> rewriting list -> clause -> (unit -> unit) option -> unit := "ltac2" "tac_rewrite". + +Ltac2 @ external reflexivity : unit -> unit := "ltac2" "tac_reflexivity". + +Ltac2 @ external assumption : unit -> unit := "ltac2" "tac_assumption". + +Ltac2 @ external transitivity : constr -> unit := "ltac2" "tac_transitivity". + +Ltac2 @ external etransitivity : unit -> unit := "ltac2" "tac_etransitivity". + +Ltac2 @ external cut : constr -> unit := "ltac2" "tac_cut". + +Ltac2 @ external left : evar_flag -> bindings -> unit := "ltac2" "tac_left". +Ltac2 @ external right : evar_flag -> bindings -> unit := "ltac2" "tac_right". + +Ltac2 @ external constructor : evar_flag -> unit := "ltac2" "tac_constructor". +Ltac2 @ external split : evar_flag -> bindings -> unit := "ltac2" "tac_split". + +Ltac2 @ external constructor_n : evar_flag -> int -> bindings -> unit := "ltac2" "tac_constructorn". + +Ltac2 @ external intros_until : hypothesis -> unit := "ltac2" "tac_introsuntil". + +Ltac2 @ external symmetry : clause -> unit := "ltac2" "tac_symmetry". + +Ltac2 @ external rename : (ident * ident) list -> unit := "ltac2" "tac_rename". + +Ltac2 @ external revert : ident list -> unit := "ltac2" "tac_revert". + +Ltac2 @ external admit : unit -> unit := "ltac2" "tac_admit". + +Ltac2 @ external fix_ : ident option -> int -> unit := "ltac2" "tac_fix". +Ltac2 @ external cofix_ : ident option -> unit := "ltac2" "tac_cofix". + +Ltac2 @ external clear : ident list -> unit := "ltac2" "tac_clear". +Ltac2 @ external keep : ident list -> unit := "ltac2" "tac_keep". + +Ltac2 @ external clearbody : ident list -> unit := "ltac2" "tac_clearbody". + +Ltac2 @ external exact_no_check : constr -> unit := "ltac2" "tac_exactnocheck". +Ltac2 @ external vm_cast_no_check : constr -> unit := "ltac2" "tac_vmcastnocheck". +Ltac2 @ external native_cast_no_check : constr -> unit := "ltac2" "tac_nativecastnocheck". + +Ltac2 @ external inversion : inversion_kind -> destruction_arg -> intro_pattern option -> ident list option -> unit := "ltac2" "tac_inversion". + +(** coretactics *) + +Ltac2 @ external move : ident -> move_location -> unit := "ltac2" "tac_move". + +Ltac2 @ external intro : ident option -> move_location option -> unit := "ltac2" "tac_intro". + +Ltac2 @ external specialize : constr_with_bindings -> intro_pattern option -> unit := "ltac2" "tac_specialize". + +(** extratactics *) + +Ltac2 @ external discriminate : evar_flag -> destruction_arg option -> unit := "ltac2" "tac_discriminate". +Ltac2 @ external injection : evar_flag -> intro_pattern list option -> destruction_arg option -> unit := "ltac2" "tac_injection". + +Ltac2 @ external absurd : constr -> unit := "ltac2" "tac_absurd". +Ltac2 @ external contradiction : constr_with_bindings option -> unit := "ltac2" "tac_contradiction". + +Ltac2 @ external autorewrite : bool -> (unit -> unit) option -> ident list -> clause -> unit := "ltac2" "tac_autorewrite". + +Ltac2 @ external subst : ident list -> unit := "ltac2" "tac_subst". +Ltac2 @ external subst_all : unit -> unit := "ltac2" "tac_substall". + +(** auto *) + +Ltac2 Type debug := [ Off | Info | Debug ]. + +Ltac2 Type strategy := [ BFS | DFS ]. + +Ltac2 @ external trivial : debug -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_trivial". + +Ltac2 @ external auto : debug -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_auto". + +Ltac2 @ external new_auto : debug -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_newauto". + +Ltac2 @ external eauto : debug -> int option -> int option -> (unit -> constr) list -> ident list option -> unit := "ltac2" "tac_eauto". + +Ltac2 @ external typeclasses_eauto : strategy option -> int option -> ident list option -> unit := "ltac2" "tac_typeclasses_eauto". diff --git a/user-contrib/Ltac2/String.v b/user-contrib/Ltac2/String.v new file mode 100644 index 0000000000..99e1dab76b --- /dev/null +++ b/user-contrib/Ltac2/String.v @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ltac2.Init. + +Ltac2 @external make : int -> char -> string := "ltac2" "string_make". +Ltac2 @external length : string -> int := "ltac2" "string_length". +Ltac2 @external get : string -> int -> char := "ltac2" "string_get". +Ltac2 @external set : string -> int -> char -> unit := "ltac2" "string_set". diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg new file mode 100644 index 0000000000..890ed76d52 --- /dev/null +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -0,0 +1,933 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +{ + +open Pp +open Util +open Names +open Tok +open Pcoq +open Attributes +open Constrexpr +open Tac2expr +open Tac2qexpr +open Ltac_plugin + +let err () = raise Stream.Failure + +type lookahead = int -> Tok.t Stream.t -> int option + +let entry_of_lookahead s (lk : lookahead) = + let run strm = match lk 0 strm with None -> err () | Some _ -> () in + Pcoq.Entry.of_parser s run + +let (>>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with +| None -> None +| Some n -> lk2 n strm + +let (<+>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with +| None -> lk2 n strm +| Some n -> Some n + +let lk_kw kw n strm = match stream_nth n strm with +| KEYWORD kw' | IDENT kw' -> if String.equal kw kw' then Some (n + 1) else None +| _ -> None + +let lk_ident n strm = match stream_nth n strm with +| IDENT _ -> Some (n + 1) +| _ -> None + +let lk_int n strm = match stream_nth n strm with +| NUMERAL { NumTok.int = _; frac = ""; exp = "" } -> Some (n + 1) +| _ -> None + +let lk_ident_or_anti = lk_ident <+> (lk_kw "$" >> lk_ident) + +(* lookahead for (x:=t), (?x:=t) and (1:=t) *) +let test_lpar_idnum_coloneq = + entry_of_lookahead "test_lpar_idnum_coloneq" begin + lk_kw "(" >> (lk_ident_or_anti <+> lk_int) >> lk_kw ":=" + end + +(* lookahead for (x:t), (?x:t) *) +let test_lpar_id_colon = + entry_of_lookahead "test_lpar_id_colon" begin + lk_kw "(" >> lk_ident_or_anti >> lk_kw ":" + end + +(* Hack to recognize "(x := t)" and "($x := t)" *) +let test_lpar_id_coloneq = + entry_of_lookahead "test_lpar_id_coloneq" begin + lk_kw "(" >> lk_ident_or_anti >> lk_kw ":=" + end + +(* Hack to recognize "(x)" *) +let test_lpar_id_rpar = + entry_of_lookahead "test_lpar_id_rpar" begin + lk_kw "(" >> lk_ident >> lk_kw ")" + end + +let test_ampersand_ident = + entry_of_lookahead "test_ampersand_ident" begin + lk_kw "&" >> lk_ident + end + +let test_dollar_ident = + entry_of_lookahead "test_dollar_ident" begin + lk_kw "$" >> lk_ident + end + +let tac2expr = Tac2entries.Pltac.tac2expr +let tac2type = Entry.create "tactic:tac2type" +let tac2def_val = Entry.create "tactic:tac2def_val" +let tac2def_typ = Entry.create "tactic:tac2def_typ" +let tac2def_ext = Entry.create "tactic:tac2def_ext" +let tac2def_syn = Entry.create "tactic:tac2def_syn" +let tac2def_mut = Entry.create "tactic:tac2def_mut" +let tac2def_run = Entry.create "tactic:tac2def_run" +let tac2mode = Entry.create "vernac:ltac2_command" + +let ltac1_expr = Pltac.tactic_expr + +let inj_wit wit loc x = CAst.make ~loc @@ CTacExt (wit, x) +let inj_open_constr loc c = inj_wit Tac2quote.wit_open_constr loc c +let inj_pattern loc c = inj_wit Tac2quote.wit_pattern loc c +let inj_reference loc c = inj_wit Tac2quote.wit_reference loc c +let inj_ltac1 loc e = inj_wit Tac2quote.wit_ltac1 loc e +let inj_ltac1val loc e = inj_wit Tac2quote.wit_ltac1val loc e + +let pattern_of_qualid qid = + if Tac2env.is_constructor qid then CAst.make ?loc:qid.CAst.loc @@ CPatRef (RelId qid, []) + else + let open Libnames in + if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ CPatVar (Name (qualid_basename qid)) + else + CErrors.user_err ?loc:qid.CAst.loc (Pp.str "Syntax error") + +} + +GRAMMAR EXTEND Gram + GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn + tac2def_mut tac2def_run; + tac2pat: + [ "1" LEFTA + [ qid = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> { + if Tac2env.is_constructor qid then + CAst.make ~loc @@ CPatRef (RelId qid, pl) + else + CErrors.user_err ~loc (Pp.str "Syntax error") } + | qid = Prim.qualid -> { pattern_of_qualid qid } + | "["; "]" -> { CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_nil), []) } + | p1 = tac2pat; "::"; p2 = tac2pat -> + { CAst.make ~loc @@ CPatRef (AbsKn (Other Tac2core.Core.c_cons), [p1; p2])} + ] + | "0" + [ "_" -> { CAst.make ~loc @@ CPatVar Anonymous } + | "()" -> { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) } + | qid = Prim.qualid -> { pattern_of_qualid qid } + | "("; p = atomic_tac2pat; ")" -> { p } + ] ] + ; + atomic_tac2pat: + [ [ -> + { CAst.make ~loc @@ CPatRef (AbsKn (Tuple 0), []) } + | p = tac2pat; ":"; t = tac2type -> + { CAst.make ~loc @@ CPatCnv (p, t) } + | p = tac2pat; ","; pl = LIST0 tac2pat SEP "," -> + { let pl = p :: pl in + CAst.make ~loc @@ CPatRef (AbsKn (Tuple (List.length pl)), pl) } + | p = tac2pat -> { p } + ] ] + ; + tac2expr: + [ "6" RIGHTA + [ e1 = SELF; ";"; e2 = SELF -> { CAst.make ~loc @@ CTacSeq (e1, e2) } ] + | "5" + [ "fun"; it = LIST1 input_fun ; "=>"; body = tac2expr LEVEL "6" -> + { CAst.make ~loc @@ CTacFun (it, body) } + | "let"; isrec = rec_flag; + lc = LIST1 let_clause SEP "with"; "in"; + e = tac2expr LEVEL "6" -> + { CAst.make ~loc @@ CTacLet (isrec, lc, e) } + | "match"; e = tac2expr LEVEL "5"; "with"; bl = branches; "end" -> + { CAst.make ~loc @@ CTacCse (e, bl) } + ] + | "4" LEFTA [ ] + | "::" RIGHTA + [ e1 = tac2expr; "::"; e2 = tac2expr -> + { CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) } + ] + | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> + { let el = e0 :: el in + CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) } ] + | "1" LEFTA + [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> + { CAst.make ~loc @@ CTacApp (e, el) } + | e = SELF; ".("; qid = Prim.qualid; ")" -> + { CAst.make ~loc @@ CTacPrj (e, RelId qid) } + | e = SELF; ".("; qid = Prim.qualid; ")"; ":="; r = tac2expr LEVEL "5" -> + { CAst.make ~loc @@ CTacSet (e, RelId qid, r) } ] + | "0" + [ "("; a = SELF; ")" -> { a } + | "("; a = SELF; ":"; t = tac2type; ")" -> + { CAst.make ~loc @@ CTacCnv (a, t) } + | "()" -> + { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } + | "("; ")" -> + { CAst.make ~loc @@ CTacCst (AbsKn (Tuple 0)) } + | "["; a = LIST0 tac2expr LEVEL "5" SEP ";"; "]" -> + { Tac2quote.of_list ~loc (fun x -> x) a } + | "{"; a = tac2rec_fieldexprs; "}" -> + { CAst.make ~loc @@ CTacRec a } + | a = tactic_atom -> { a } ] + ] + ; + branches: + [ [ -> { [] } + | "|"; bl = LIST1 branch SEP "|" -> { bl } + | bl = LIST1 branch SEP "|" -> { bl } ] + ] + ; + branch: + [ [ pat = tac2pat LEVEL "1"; "=>"; e = tac2expr LEVEL "6" -> { (pat, e) } ] ] + ; + rec_flag: + [ [ IDENT "rec" -> { true } + | -> { false } ] ] + ; + mut_flag: + [ [ IDENT "mutable" -> { true } + | -> { false } ] ] + ; + typ_param: + [ [ "'"; id = Prim.ident -> { id } ] ] + ; + tactic_atom: + [ [ n = Prim.integer -> { CAst.make ~loc @@ CTacAtm (AtmInt n) } + | s = Prim.string -> { CAst.make ~loc @@ CTacAtm (AtmStr s) } + | qid = Prim.qualid -> + { if Tac2env.is_constructor qid then + CAst.make ~loc @@ CTacCst (RelId qid) + else + CAst.make ~loc @@ CTacRef (RelId qid) } + | "@"; id = Prim.ident -> { Tac2quote.of_ident (CAst.make ~loc id) } + | "&"; id = lident -> { Tac2quote.of_hyp ~loc id } + | "'"; c = Constr.constr -> { inj_open_constr loc c } + | IDENT "constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_constr c } + | IDENT "open_constr"; ":"; "("; c = Constr.lconstr; ")" -> { Tac2quote.of_open_constr c } + | IDENT "ident"; ":"; "("; c = lident; ")" -> { Tac2quote.of_ident c } + | IDENT "pattern"; ":"; "("; c = Constr.lconstr_pattern; ")" -> { inj_pattern loc c } + | IDENT "reference"; ":"; "("; c = globref; ")" -> { inj_reference loc c } + | IDENT "ltac1"; ":"; "("; qid = ltac1_expr; ")" -> { inj_ltac1 loc qid } + | IDENT "ltac1val"; ":"; "("; qid = ltac1_expr; ")" -> { inj_ltac1val loc qid } + ] ] + ; + let_clause: + [ [ binder = let_binder; ":="; te = tac2expr -> + { let (pat, fn) = binder in + let te = match fn with + | None -> te + | Some args -> CAst.make ~loc @@ CTacFun (args, te) + in + (pat, te) } + ] ] + ; + let_binder: + [ [ pats = LIST1 input_fun -> + { match pats with + | [{CAst.v=CPatVar _} as pat] -> (pat, None) + | ({CAst.v=CPatVar (Name id)} as pat) :: args -> (pat, Some args) + | [pat] -> (pat, None) + | _ -> CErrors.user_err ~loc (str "Invalid pattern") } + ] ] + ; + tac2type: + [ "5" RIGHTA + [ t1 = tac2type; "->"; t2 = tac2type -> { CAst.make ~loc @@ CTypArrow (t1, t2) } ] + | "2" + [ t = tac2type; "*"; tl = LIST1 tac2type LEVEL "1" SEP "*" -> + { let tl = t :: tl in + CAst.make ~loc @@ CTypRef (AbsKn (Tuple (List.length tl)), tl) } ] + | "1" LEFTA + [ t = SELF; qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, [t]) } ] + | "0" + [ "("; t = tac2type LEVEL "5"; ")" -> { t } + | id = typ_param -> { CAst.make ~loc @@ CTypVar (Name id) } + | "_" -> { CAst.make ~loc @@ CTypVar Anonymous } + | qid = Prim.qualid -> { CAst.make ~loc @@ CTypRef (RelId qid, []) } + | "("; p = LIST1 tac2type LEVEL "5" SEP ","; ")"; qid = Prim.qualid -> + { CAst.make ~loc @@ CTypRef (RelId qid, p) } ] + ]; + locident: + [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] + ; + binder: + [ [ "_" -> { CAst.make ~loc Anonymous } + | l = Prim.ident -> { CAst.make ~loc (Name l) } ] ] + ; + input_fun: + [ [ b = tac2pat LEVEL "0" -> { b } ] ] + ; + tac2def_body: + [ [ name = binder; it = LIST0 input_fun; ":="; e = tac2expr -> + { let e = if List.is_empty it then e else CAst.make ~loc @@ CTacFun (it, e) in + (name, e) } + ] ] + ; + tac2def_val: + [ [ mut = mut_flag; isrec = rec_flag; l = LIST1 tac2def_body SEP "with" -> + { StrVal (mut, isrec, l) } + ] ] + ; + tac2def_mut: + [ [ "Set"; qid = Prim.qualid; ":="; e = tac2expr -> { StrMut (qid, e) } ] ] + ; + tac2def_run: + [ [ "Eval"; e = tac2expr -> { StrRun e } ] ] + ; + tac2typ_knd: + [ [ t = tac2type -> { CTydDef (Some t) } + | "["; ".."; "]" -> { CTydOpn } + | "["; t = tac2alg_constructors; "]" -> { CTydAlg t } + | "{"; t = tac2rec_fields; "}"-> { CTydRec t } ] ] + ; + tac2alg_constructors: + [ [ "|"; cs = LIST1 tac2alg_constructor SEP "|" -> { cs } + | cs = LIST0 tac2alg_constructor SEP "|" -> { cs } ] ] + ; + tac2alg_constructor: + [ [ c = Prim.ident -> { (c, []) } + | c = Prim.ident; "("; args = LIST0 tac2type SEP ","; ")"-> { (c, args) } ] ] + ; + tac2rec_fields: + [ [ f = tac2rec_field; ";"; l = tac2rec_fields -> { f :: l } + | f = tac2rec_field; ";" -> { [f] } + | f = tac2rec_field -> { [f] } + | -> { [] } ] ] + ; + tac2rec_field: + [ [ mut = mut_flag; id = Prim.ident; ":"; t = tac2type -> { (id, mut, t) } ] ] + ; + tac2rec_fieldexprs: + [ [ f = tac2rec_fieldexpr; ";"; l = tac2rec_fieldexprs -> { f :: l } + | f = tac2rec_fieldexpr; ";" -> { [f] } + | f = tac2rec_fieldexpr-> { [f] } + | -> { [] } ] ] + ; + tac2rec_fieldexpr: + [ [ qid = Prim.qualid; ":="; e = tac2expr LEVEL "1" -> { RelId qid, e } ] ] + ; + tac2typ_prm: + [ [ -> { [] } + | id = typ_param -> { [CAst.make ~loc id] } + | "("; ids = LIST1 [ id = typ_param -> { CAst.make ~loc id } ] SEP "," ;")" -> { ids } + ] ] + ; + tac2typ_def: + [ [ prm = tac2typ_prm; id = Prim.qualid; b = tac2type_body -> { let (r, e) = b in (id, r, (prm, e)) } ] ] + ; + tac2type_body: + [ [ -> { false, CTydDef None } + | ":="; e = tac2typ_knd -> { false, e } + | "::="; e = tac2typ_knd -> { true, e } + ] ] + ; + tac2def_typ: + [ [ "Type"; isrec = rec_flag; l = LIST1 tac2typ_def SEP "with" -> + { StrTyp (isrec, l) } + ] ] + ; + tac2def_ext: + [ [ "@"; IDENT "external"; id = locident; ":"; t = tac2type LEVEL "5"; ":="; + plugin = Prim.string; name = Prim.string -> + { let ml = { mltac_plugin = plugin; mltac_tactic = name } in + StrPrm (id, t, ml) } + ] ] + ; + syn_node: + [ [ "_" -> { CAst.make ~loc None } + | id = Prim.ident -> { CAst.make ~loc (Some id) } + ] ] + ; + sexpr: + [ [ s = Prim.string -> { SexprStr (CAst.make ~loc s) } + | n = Prim.integer -> { SexprInt (CAst.make ~loc n) } + | id = syn_node -> { SexprRec (loc, id, []) } + | id = syn_node; "("; tok = LIST1 sexpr SEP "," ; ")" -> + { SexprRec (loc, id, tok) } + ] ] + ; + syn_level: + [ [ -> { None } + | ":"; n = Prim.integer -> { Some n } + ] ] + ; + tac2def_syn: + [ [ "Notation"; toks = LIST1 sexpr; n = syn_level; ":="; + e = tac2expr -> + { StrSyn (toks, n, e) } + ] ] + ; + lident: + [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] + ; + globref: + [ [ "&"; id = Prim.ident -> { CAst.make ~loc (QHypothesis id) } + | qid = Prim.qualid -> { CAst.make ~loc @@ QReference qid } + ] ] + ; +END + +(* Quotation scopes used by notations *) + +{ + +open Tac2entries.Pltac + +let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) + +} + +GRAMMAR EXTEND Gram + GLOBAL: q_ident q_bindings q_intropattern q_intropatterns q_induction_clause + q_conversion q_rewriting q_clause q_dispatch q_occurrences q_strategy_flag + q_destruction_arg q_reference q_with_bindings q_constr_matching + q_goal_matching q_hintdb q_move_location q_pose q_assert; + anti: + [ [ "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } ] ] + ; + ident_or_anti: + [ [ id = lident -> { QExpr id } + | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } + ] ] + ; + lident: + [ [ id = Prim.ident -> { CAst.make ~loc id } ] ] + ; + lnatural: + [ [ n = Prim.natural -> { CAst.make ~loc n } ] ] + ; + q_ident: + [ [ id = ident_or_anti -> { id } ] ] + ; + qhyp: + [ [ x = anti -> { x } + | n = lnatural -> { QExpr (CAst.make ~loc @@ QAnonHyp n) } + | id = lident -> { QExpr (CAst.make ~loc @@ QNamedHyp id) } + ] ] + ; + simple_binding: + [ [ "("; h = qhyp; ":="; c = Constr.lconstr; ")" -> + { CAst.make ~loc (h, c) } + ] ] + ; + bindings: + [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> + { CAst.make ~loc @@ QExplicitBindings bl } + | bl = LIST1 Constr.constr -> + { CAst.make ~loc @@ QImplicitBindings bl } + ] ] + ; + q_bindings: + [ [ bl = bindings -> { bl } ] ] + ; + q_with_bindings: + [ [ bl = with_bindings -> { bl } ] ] + ; + intropatterns: + [ [ l = LIST0 nonsimple_intropattern -> { CAst.make ~loc l } ] ] + ; +(* ne_intropatterns: *) +(* [ [ l = LIST1 nonsimple_intropattern -> l ]] *) +(* ; *) + or_and_intropattern: + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> { CAst.make ~loc @@ QIntroOrPattern tc } + | "()" -> { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc []) } + | "("; si = simple_intropattern; ")" -> { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc [si]) } + | "("; si = simple_intropattern; ","; + tc = LIST1 simple_intropattern SEP "," ; ")" -> + { CAst.make ~loc @@ QIntroAndPattern (CAst.make ~loc (si::tc)) } + | "("; si = simple_intropattern; "&"; + tc = LIST1 simple_intropattern SEP "&" ; ")" -> + (* (A & B & C) is translated into (A,(B,C)) *) + { let rec pairify = function + | ([]|[_]|[_;_]) as l -> CAst.make ~loc l + | t::q -> + let q = + CAst.make ~loc @@ + QIntroAction (CAst.make ~loc @@ + QIntroOrAndPattern (CAst.make ~loc @@ + QIntroAndPattern (pairify q))) + in + CAst.make ~loc [t; q] + in CAst.make ~loc @@ QIntroAndPattern (pairify (si::tc)) } ] ] + ; + equality_intropattern: + [ [ "->" -> { CAst.make ~loc @@ QIntroRewrite true } + | "<-" -> { CAst.make ~loc @@ QIntroRewrite false } + | "[="; tc = intropatterns; "]" -> { CAst.make ~loc @@ QIntroInjection tc } ] ] + ; + naming_intropattern: + [ [ LEFTQMARK; id = lident -> + { CAst.make ~loc @@ QIntroFresh (QExpr id) } + | "?$"; id = lident -> + { CAst.make ~loc @@ QIntroFresh (QAnti id) } + | "?" -> + { CAst.make ~loc @@ QIntroAnonymous } + | id = ident_or_anti -> + { CAst.make ~loc @@ QIntroIdentifier id } + ] ] + ; + nonsimple_intropattern: + [ [ l = simple_intropattern -> { l } + | "*" -> { CAst.make ~loc @@ QIntroForthcoming true } + | "**" -> { CAst.make ~loc @@ QIntroForthcoming false } ] ] + ; + simple_intropattern: + [ [ pat = simple_intropattern_closed -> +(* l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> *) + (** TODO: handle %pat *) + { pat } + ] ] + ; + simple_intropattern_closed: + [ [ pat = or_and_intropattern -> + { CAst.make ~loc @@ QIntroAction (CAst.make ~loc @@ QIntroOrAndPattern pat) } + | pat = equality_intropattern -> + { CAst.make ~loc @@ QIntroAction pat } + | "_" -> + { CAst.make ~loc @@ QIntroAction (CAst.make ~loc @@ QIntroWildcard) } + | pat = naming_intropattern -> + { CAst.make ~loc @@ QIntroNaming pat } + ] ] + ; + q_intropatterns: + [ [ ipat = intropatterns -> { ipat } ] ] + ; + q_intropattern: + [ [ ipat = simple_intropattern -> { ipat } ] ] + ; + nat_or_anti: + [ [ n = lnatural -> { QExpr n } + | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } + ] ] + ; + eqn_ipat: + [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> { Some pat } + | -> { None } + ] ] + ; + with_bindings: + [ [ "with"; bl = bindings -> { bl } | -> { CAst.make ~loc @@ QNoBindings } ] ] + ; + constr_with_bindings: + [ [ c = Constr.constr; l = with_bindings -> { CAst.make ~loc @@ (c, l) } ] ] + ; + destruction_arg: + [ [ n = lnatural -> { CAst.make ~loc @@ QElimOnAnonHyp n } + | id = lident -> { CAst.make ~loc @@ QElimOnIdent id } + | c = constr_with_bindings -> { CAst.make ~loc @@ QElimOnConstr c } + ] ] + ; + q_destruction_arg: + [ [ arg = destruction_arg -> { arg } ] ] + ; + as_or_and_ipat: + [ [ "as"; ipat = or_and_intropattern -> { Some ipat } + | -> { None } + ] ] + ; + occs_nums: + [ [ nl = LIST1 nat_or_anti -> { CAst.make ~loc @@ QOnlyOccurrences nl } + | "-"; n = nat_or_anti; nl = LIST0 nat_or_anti -> + { CAst.make ~loc @@ QAllOccurrencesBut (n::nl) } + ] ] + ; + occs: + [ [ "at"; occs = occs_nums -> { occs } | -> { CAst.make ~loc QAllOccurrences } ] ] + ; + hypident: + [ [ id = ident_or_anti -> + { id,Locus.InHyp } + | "("; IDENT "type"; IDENT "of"; id = ident_or_anti; ")" -> + { id,Locus.InHypTypeOnly } + | "("; IDENT "value"; IDENT "of"; id = ident_or_anti; ")" -> + { id,Locus.InHypValueOnly } + ] ] + ; + hypident_occ: + [ [ h=hypident; occs=occs -> { let (id,l) = h in ((occs,id),l) } ] ] + ; + in_clause: + [ [ "*"; occs=occs -> + { { q_onhyps = None; q_concl_occs = occs } } + | "*"; "|-"; occs = concl_occ -> + { { q_onhyps = None; q_concl_occs = occs } } + | hl = LIST0 hypident_occ SEP ","; "|-"; occs = concl_occ -> + { { q_onhyps = Some hl; q_concl_occs = occs } } + | hl = LIST0 hypident_occ SEP "," -> + { { q_onhyps = Some hl; q_concl_occs = CAst.make ~loc QNoOccurrences } } + ] ] + ; + clause: + [ [ "in"; cl = in_clause -> { CAst.make ~loc @@ cl } + | "at"; occs = occs_nums -> + { CAst.make ~loc @@ { q_onhyps = Some []; q_concl_occs = occs } } + ] ] + ; + q_clause: + [ [ cl = clause -> { cl } ] ] + ; + concl_occ: + [ [ "*"; occs = occs -> { occs } + | -> { CAst.make ~loc QNoOccurrences } + ] ] + ; + induction_clause: + [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; + cl = OPT clause -> + { CAst.make ~loc @@ { + indcl_arg = c; + indcl_eqn = eq; + indcl_as = pat; + indcl_in = cl; + } } + ] ] + ; + q_induction_clause: + [ [ cl = induction_clause -> { cl } ] ] + ; + conversion: + [ [ c = Constr.constr -> + { CAst.make ~loc @@ QConvert c } + | c1 = Constr.constr; "with"; c2 = Constr.constr -> + { CAst.make ~loc @@ QConvertWith (c1, c2) } + ] ] + ; + q_conversion: + [ [ c = conversion -> { c } ] ] + ; + orient: + [ [ "->" -> { CAst.make ~loc (Some true) } + | "<-" -> { CAst.make ~loc (Some false) } + | -> { CAst.make ~loc None } + ]] + ; + rewriter: + [ [ "!"; c = constr_with_bindings -> + { (CAst.make ~loc @@ QRepeatPlus,c) } + | [ "?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings -> + { (CAst.make ~loc @@ QRepeatStar,c) } + | n = lnatural; "!"; c = constr_with_bindings -> + { (CAst.make ~loc @@ QPrecisely n,c) } + | n = lnatural; ["?" -> { () } | LEFTQMARK -> { () } ]; c = constr_with_bindings -> + { (CAst.make ~loc @@ QUpTo n,c) } + | n = lnatural; c = constr_with_bindings -> + { (CAst.make ~loc @@ QPrecisely n,c) } + | c = constr_with_bindings -> + { (CAst.make ~loc @@ QPrecisely (CAst.make 1), c) } + ] ] + ; + oriented_rewriter: + [ [ b = orient; r = rewriter -> + { let (m, c) = r in + CAst.make ~loc @@ { + rew_orient = b; + rew_repeat = m; + rew_equatn = c; + } } + ] ] + ; + q_rewriting: + [ [ r = oriented_rewriter -> { r } ] ] + ; + tactic_then_last: + [ [ "|"; lta = LIST0 (OPT tac2expr LEVEL "6") SEP "|" -> { lta } + | -> { [] } + ] ] + ; + tactic_then_gen: + [ [ ta = tac2expr; "|"; tg = tactic_then_gen -> { let (first,last) = tg in (Some ta :: first, last) } + | ta = tac2expr; ".."; l = tactic_then_last -> { ([], Some (Some ta, l)) } + | ".."; l = tactic_then_last -> { ([], Some (None, l)) } + | ta = tac2expr -> { ([Some ta], None) } + | "|"; tg = tactic_then_gen -> { let (first,last) = tg in (None :: first, last) } + | -> { ([None], None) } + ] ] + ; + q_dispatch: + [ [ d = tactic_then_gen -> { CAst.make ~loc d } ] ] + ; + q_occurrences: + [ [ occs = occs -> { occs } ] ] + ; + red_flag: + [ [ IDENT "beta" -> { CAst.make ~loc @@ QBeta } + | IDENT "iota" -> { CAst.make ~loc @@ QIota } + | IDENT "match" -> { CAst.make ~loc @@ QMatch } + | IDENT "fix" -> { CAst.make ~loc @@ QFix } + | IDENT "cofix" -> { CAst.make ~loc @@ QCofix } + | IDENT "zeta" -> { CAst.make ~loc @@ QZeta } + | IDENT "delta"; d = delta_flag -> { d } + ] ] + ; + refglobal: + [ [ "&"; id = Prim.ident -> { QExpr (CAst.make ~loc @@ QHypothesis id) } + | qid = Prim.qualid -> { QExpr (CAst.make ~loc @@ QReference qid) } + | "$"; id = Prim.ident -> { QAnti (CAst.make ~loc id) } + ] ] + ; + q_reference: + [ [ r = refglobal -> { r } ] ] + ; + refglobals: + [ [ gl = LIST1 refglobal -> { CAst.make ~loc gl } ] ] + ; + delta_flag: + [ [ "-"; "["; idl = refglobals; "]" -> { CAst.make ~loc @@ QDeltaBut idl } + | "["; idl = refglobals; "]" -> { CAst.make ~loc @@ QConst idl } + | -> { CAst.make ~loc @@ QDeltaBut (CAst.make ~loc []) } + ] ] + ; + strategy_flag: + [ [ s = LIST1 red_flag -> { CAst.make ~loc s } + | d = delta_flag -> + { CAst.make ~loc + [CAst.make ~loc QBeta; CAst.make ~loc QIota; CAst.make ~loc QZeta; d] } + ] ] + ; + q_strategy_flag: + [ [ flag = strategy_flag -> { flag } ] ] + ; + hintdb: + [ [ "*" -> { CAst.make ~loc @@ QHintAll } + | l = LIST1 ident_or_anti -> { CAst.make ~loc @@ QHintDbs l } + ] ] + ; + q_hintdb: + [ [ db = hintdb -> { db } ] ] + ; + match_pattern: + [ [ IDENT "context"; id = OPT Prim.ident; + "["; pat = Constr.lconstr_pattern; "]" -> { CAst.make ~loc @@ QConstrMatchContext (id, pat) } + | pat = Constr.lconstr_pattern -> { CAst.make ~loc @@ QConstrMatchPattern pat } ] ] + ; + match_rule: + [ [ mp = match_pattern; "=>"; tac = tac2expr -> + { CAst.make ~loc @@ (mp, tac) } + ] ] + ; + match_list: + [ [ mrl = LIST1 match_rule SEP "|" -> { CAst.make ~loc @@ mrl } + | "|"; mrl = LIST1 match_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ] + ; + q_constr_matching: + [ [ m = match_list -> { m } ] ] + ; + gmatch_hyp_pattern: + [ [ na = Prim.name; ":"; pat = match_pattern -> { (na, pat) } ] ] + ; + gmatch_pattern: + [ [ "["; hl = LIST0 gmatch_hyp_pattern SEP ","; "|-"; p = match_pattern; "]" -> + { CAst.make ~loc @@ { + q_goal_match_concl = p; + q_goal_match_hyps = hl; + } } + ] ] + ; + gmatch_rule: + [ [ mp = gmatch_pattern; "=>"; tac = tac2expr -> + { CAst.make ~loc @@ (mp, tac) } + ] ] + ; + gmatch_list: + [ [ mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } + | "|"; mrl = LIST1 gmatch_rule SEP "|" -> { CAst.make ~loc @@ mrl } ] ] + ; + q_goal_matching: + [ [ m = gmatch_list -> { m } ] ] + ; + move_location: + [ [ "at"; IDENT "top" -> { CAst.make ~loc @@ QMoveFirst } + | "at"; IDENT "bottom" -> { CAst.make ~loc @@ QMoveLast } + | IDENT "after"; id = ident_or_anti -> { CAst.make ~loc @@ QMoveAfter id } + | IDENT "before"; id = ident_or_anti -> { CAst.make ~loc @@ QMoveBefore id } + ] ] + ; + q_move_location: + [ [ mv = move_location -> { mv } ] ] + ; + as_name: + [ [ -> { None } + | "as"; id = ident_or_anti -> { Some id } + ] ] + ; + pose: + [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> + { CAst.make ~loc (Some id, c) } + | c = Constr.constr; na = as_name -> { CAst.make ~loc (na, c) } + ] ] + ; + q_pose: + [ [ p = pose -> { p } ] ] + ; + as_ipat: + [ [ "as"; ipat = simple_intropattern -> { Some ipat } + | -> { None } + ] ] + ; + by_tactic: + [ [ "by"; tac = tac2expr -> { Some tac } + | -> { None } + ] ] + ; + assertion: + [ [ test_lpar_id_coloneq; "("; id = ident_or_anti; ":="; c = Constr.lconstr; ")" -> + { CAst.make ~loc (QAssertValue (id, c)) } + | test_lpar_id_colon; "("; id = ident_or_anti; ":"; c = Constr.lconstr; ")"; tac = by_tactic -> + { let ipat = CAst.make ~loc @@ QIntroNaming (CAst.make ~loc @@ QIntroIdentifier id) in + CAst.make ~loc (QAssertType (Some ipat, c, tac)) } + | c = Constr.constr; ipat = as_ipat; tac = by_tactic -> + { CAst.make ~loc (QAssertType (ipat, c, tac)) } + ] ] + ; + q_assert: + [ [ a = assertion -> { a } ] ] + ; +END + +(** Extension of constr syntax *) + +(* +GRAMMAR EXTEND Gram + Pcoq.Constr.operconstr: LEVEL "0" + [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> + { let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } + | test_ampersand_ident; "&"; id = Prim.ident -> + { let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } + | test_dollar_ident; "$"; id = Prim.ident -> + { let id = Loc.tag ~loc id in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } + ] ] + ; +END +*) +{ + +let () = + +let open Extend in +let open Tok in +let (++) r s = Next (r, s) in +let rules = [ + Rule ( + Stop ++ Aentry test_dollar_ident ++ Atoken (PKEYWORD "$") ++ Aentry Prim.ident, + begin fun id _ _ loc -> + let id = Loc.tag ~loc id in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) + end + ); + + Rule ( + Stop ++ Aentry test_ampersand_ident ++ Atoken (PKEYWORD "&") ++ Aentry Prim.ident, + begin fun id _ _ loc -> + let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) + end + ); + + Rule ( + Stop ++ Atoken (PIDENT (Some "ltac2")) ++ Atoken (PKEYWORD ":") ++ + Atoken (PKEYWORD "(") ++ Aentry tac2expr ++ Atoken (PKEYWORD ")"), + begin fun _ tac _ _ _ loc -> + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) + end + ) +] in + +Hook.set Tac2entries.register_constr_quotations begin fun () -> + Pcoq.grammar_extend Pcoq.Constr.operconstr None (Some (Gramlib.Gramext.Level "0"), [(None, None, rules)]) +end + +} + +{ + +let pr_ltac2entry _ = mt () (* FIXME *) +let pr_ltac2expr _ = mt () (* FIXME *) + +} + +VERNAC ARGUMENT EXTEND ltac2_entry +PRINTED BY { pr_ltac2entry } +| [ tac2def_val(v) ] -> { v } +| [ tac2def_typ(t) ] -> { t } +| [ tac2def_ext(e) ] -> { e } +| [ tac2def_syn(e) ] -> { e } +| [ tac2def_mut(e) ] -> { e } +| [ tac2def_run(e) ] -> { e } +END + +{ + +let classify_ltac2 = function +| StrSyn _ -> Vernacextend.(VtSideff [], VtNow) +| StrMut _ | StrVal _ | StrPrm _ | StrTyp _ | StrRun _ -> Vernacextend.classify_as_sideeff + +} + +VERNAC COMMAND EXTEND VernacDeclareTactic2Definition +| #[ local = locality ] ![proof] [ "Ltac2" ltac2_entry(e) ] => { classify_ltac2 e } -> { + fun ~pstate -> Tac2entries.register_struct ?local ~pstate e; pstate + } +END + +{ + +let _ = Pvernac.register_proof_mode "Ltac2" tac2mode + +} + +VERNAC ARGUMENT EXTEND ltac2_expr +PRINTED BY { pr_ltac2expr } +| [ tac2expr(e) ] -> { e } +END + +{ + +open G_ltac +open Vernacextend + +} + +VERNAC { tac2mode } EXTEND VernacLtac2 +| ![proof] [ ltac2_expr(t) ltac_use_default(default) ] => + { classify_as_proofstep } -> { +(* let g = Option.default (Proof_global.get_default_goal_selector ()) g in *) + fun ~pstate -> + Option.map (fun pstate -> Tac2entries.call ~pstate ~default t) pstate + } +END + +{ + +open Stdarg + +} + +VERNAC COMMAND EXTEND Ltac2Print CLASSIFIED AS SIDEFF +| [ "Print" "Ltac2" reference(tac) ] -> { Tac2entries.print_ltac tac } +END diff --git a/user-contrib/Ltac2/ltac2_plugin.mlpack b/user-contrib/Ltac2/ltac2_plugin.mlpack new file mode 100644 index 0000000000..2a25e825cb --- /dev/null +++ b/user-contrib/Ltac2/ltac2_plugin.mlpack @@ -0,0 +1,14 @@ +Tac2dyn +Tac2ffi +Tac2env +Tac2print +Tac2intern +Tac2interp +Tac2entries +Tac2quote +Tac2match +Tac2core +Tac2extffi +Tac2tactics +Tac2stdlib +G_ltac2 diff --git a/user-contrib/Ltac2/plugin_base.dune b/user-contrib/Ltac2/plugin_base.dune new file mode 100644 index 0000000000..711e9b95d3 --- /dev/null +++ b/user-contrib/Ltac2/plugin_base.dune @@ -0,0 +1,6 @@ +(library + (name ltac2_plugin) + (public_name coq.plugins.ltac2) + (synopsis "Coq's Ltac2 plugin") + (modules_without_implementation tac2expr tac2qexpr tac2types) + (libraries coq.plugins.ltac)) diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml new file mode 100644 index 0000000000..d7e7b91ee6 --- /dev/null +++ b/user-contrib/Ltac2/tac2core.ml @@ -0,0 +1,1446 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Pp +open Names +open Genarg +open Tac2env +open Tac2expr +open Tac2entries.Pltac +open Proofview.Notations + +(** Standard values *) + +module Value = Tac2ffi +open Value + +let core_prefix path n = KerName.make path (Label.of_id (Id.of_string_soft n)) + +let std_core n = core_prefix Tac2env.std_prefix n +let coq_core n = core_prefix Tac2env.coq_prefix n +let ltac1_core n = core_prefix Tac2env.ltac1_prefix n + +module Core = +struct + +let t_int = coq_core "int" +let t_string = coq_core "string" +let t_array = coq_core "array" +let t_unit = coq_core "unit" +let t_list = coq_core "list" +let t_constr = coq_core "constr" +let t_pattern = coq_core "pattern" +let t_ident = coq_core "ident" +let t_option = coq_core "option" +let t_exn = coq_core "exn" +let t_reference = std_core "reference" +let t_ltac1 = ltac1_core "t" + +let c_nil = coq_core "[]" +let c_cons = coq_core "::" + +let c_none = coq_core "None" +let c_some = coq_core "Some" + +let c_true = coq_core "true" +let c_false = coq_core "false" + +end + +open Core + +let v_unit = Value.of_unit () +let v_blk = Valexpr.make_block + +let of_name c = match c with +| Anonymous -> Value.of_option Value.of_ident None +| Name id -> Value.of_option Value.of_ident (Some id) + +let to_name c = match Value.to_option Value.to_ident c with +| None -> Anonymous +| Some id -> Name id + +let of_relevance = function + | Sorts.Relevant -> ValInt 0 + | Sorts.Irrelevant -> ValInt 1 + +let to_relevance = function + | ValInt 0 -> Sorts.Relevant + | ValInt 1 -> Sorts.Irrelevant + | _ -> assert false + +let of_annot f Context.{binder_name;binder_relevance} = + of_tuple [|(f binder_name); of_relevance binder_relevance|] + +let to_annot f x = + match to_tuple x with + | [|x;y|] -> + let x = f x in + let y = to_relevance y in + Context.make_annot x y + | _ -> assert false + +let of_instance u = + let u = Univ.Instance.to_array (EConstr.Unsafe.to_instance u) in + Value.of_array (fun v -> Value.of_ext Value.val_univ v) u + +let to_instance u = + let u = Value.to_array (fun v -> Value.to_ext Value.val_univ v) u in + EConstr.EInstance.make (Univ.Instance.of_array u) + +let of_rec_declaration (nas, ts, cs) = + (Value.of_array (of_annot of_name) nas, + Value.of_array Value.of_constr ts, + Value.of_array Value.of_constr cs) + +let to_rec_declaration (nas, ts, cs) = + (Value.to_array (to_annot to_name) nas, + Value.to_array Value.to_constr ts, + Value.to_array Value.to_constr cs) + +let of_result f = function +| Inl c -> v_blk 0 [|f c|] +| Inr e -> v_blk 1 [|Value.of_exn e|] + +(** Stdlib exceptions *) + +let err_notfocussed = + Tac2interp.LtacError (coq_core "Not_focussed", [||]) + +let err_outofbounds = + Tac2interp.LtacError (coq_core "Out_of_bounds", [||]) + +let err_notfound = + Tac2interp.LtacError (coq_core "Not_found", [||]) + +let err_matchfailure = + Tac2interp.LtacError (coq_core "Match_failure", [||]) + +(** Helper functions *) + +let thaw f = Tac2ffi.apply f [v_unit] + +let fatal_flag : unit Exninfo.t = Exninfo.make () + +let set_bt info = + if !Tac2interp.print_ltac2_backtrace then + Tac2interp.get_backtrace >>= fun bt -> + Proofview.tclUNIT (Exninfo.add info Tac2entries.backtrace bt) + else Proofview.tclUNIT info + +let throw ?(info = Exninfo.null) e = + set_bt info >>= fun info -> + let info = Exninfo.add info fatal_flag () in + Proofview.tclLIFT (Proofview.NonLogical.raise ~info e) + +let fail ?(info = Exninfo.null) e = + set_bt info >>= fun info -> + Proofview.tclZERO ~info e + +let return x = Proofview.tclUNIT x +let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } + +let wrap f = + return () >>= fun () -> return (f ()) + +let wrap_unit f = + return () >>= fun () -> f (); return v_unit + +let assert_focussed = + Proofview.Goal.goals >>= fun gls -> + match gls with + | [_] -> Proofview.tclUNIT () + | [] | _ :: _ :: _ -> throw err_notfocussed + +let pf_apply f = + Proofview.Goal.goals >>= function + | [] -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + f env sigma + | [gl] -> + gl >>= fun gl -> + f (Proofview.Goal.env gl) (Tacmach.New.project gl) + | _ :: _ :: _ -> + throw err_notfocussed + +(** Primitives *) + +let define_primitive name arity f = + Tac2env.define_primitive (pname name) (mk_closure arity f) + +let define0 name f = define_primitive name arity_one (fun _ -> f) + +let define1 name r0 f = define_primitive name arity_one begin fun x -> + f (Value.repr_to r0 x) +end + +let define2 name r0 r1 f = define_primitive name (arity_suc arity_one) begin fun x y -> + f (Value.repr_to r0 x) (Value.repr_to r1 y) +end + +let define3 name r0 r1 r2 f = define_primitive name (arity_suc (arity_suc arity_one)) begin fun x y z -> + f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) +end + +(** Printing *) + +let () = define1 "print" pp begin fun pp -> + wrap_unit (fun () -> Feedback.msg_notice pp) +end + +let () = define1 "message_of_int" int begin fun n -> + return (Value.of_pp (Pp.int n)) +end + +let () = define1 "message_of_string" string begin fun s -> + return (Value.of_pp (str (Bytes.to_string s))) +end + +let () = define1 "message_of_constr" constr begin fun c -> + pf_apply begin fun env sigma -> + let pp = Printer.pr_econstr_env env sigma c in + return (Value.of_pp pp) + end +end + +let () = define1 "message_of_ident" ident begin fun c -> + let pp = Id.print c in + return (Value.of_pp pp) +end + +let () = define1 "message_of_exn" valexpr begin fun v -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + let pp = Tac2print.pr_valexpr env sigma v (GTypRef (Other Core.t_exn, [])) in + return (Value.of_pp pp) +end + + +let () = define2 "message_concat" pp pp begin fun m1 m2 -> + return (Value.of_pp (Pp.app m1 m2)) +end + +(** Array *) + +let () = define2 "array_make" int valexpr begin fun n x -> + if n < 0 || n > Sys.max_array_length then throw err_outofbounds + else wrap (fun () -> v_blk 0 (Array.make n x)) +end + +let () = define1 "array_length" block begin fun (_, v) -> + return (Value.of_int (Array.length v)) +end + +let () = define3 "array_set" block int valexpr begin fun (_, v) n x -> + if n < 0 || n >= Array.length v then throw err_outofbounds + else wrap_unit (fun () -> v.(n) <- x) +end + +let () = define2 "array_get" block int begin fun (_, v) n -> + if n < 0 || n >= Array.length v then throw err_outofbounds + else wrap (fun () -> v.(n)) +end + +(** Ident *) + +let () = define2 "ident_equal" ident ident begin fun id1 id2 -> + return (Value.of_bool (Id.equal id1 id2)) +end + +let () = define1 "ident_to_string" ident begin fun id -> + return (Value.of_string (Bytes.of_string (Id.to_string id))) +end + +let () = define1 "ident_of_string" string begin fun s -> + let id = try Some (Id.of_string (Bytes.to_string s)) with _ -> None in + return (Value.of_option Value.of_ident id) +end + +(** Int *) + +let () = define2 "int_equal" int int begin fun m n -> + return (Value.of_bool (m == n)) +end + +let binop n f = define2 n int int begin fun m n -> + return (Value.of_int (f m n)) +end + +let () = binop "int_compare" Int.compare +let () = binop "int_add" (+) +let () = binop "int_sub" (-) +let () = binop "int_mul" ( * ) + +let () = define1 "int_neg" int begin fun m -> + return (Value.of_int (~- m)) +end + +(** Char *) + +let () = define1 "char_of_int" int begin fun n -> + wrap (fun () -> Value.of_char (Char.chr n)) +end + +let () = define1 "char_to_int" char begin fun n -> + wrap (fun () -> Value.of_int (Char.code n)) +end + +(** String *) + +let () = define2 "string_make" int char begin fun n c -> + if n < 0 || n > Sys.max_string_length then throw err_outofbounds + else wrap (fun () -> Value.of_string (Bytes.make n c)) +end + +let () = define1 "string_length" string begin fun s -> + return (Value.of_int (Bytes.length s)) +end + +let () = define3 "string_set" string int char begin fun s n c -> + if n < 0 || n >= Bytes.length s then throw err_outofbounds + else wrap_unit (fun () -> Bytes.set s n c) +end + +let () = define2 "string_get" string int begin fun s n -> + if n < 0 || n >= Bytes.length s then throw err_outofbounds + else wrap (fun () -> Value.of_char (Bytes.get s n)) +end + +(** Terms *) + +(** constr -> constr *) +let () = define1 "constr_type" constr begin fun c -> + let get_type env sigma = + Proofview.V82.wrap_exceptions begin fun () -> + let (sigma, t) = Typing.type_of env sigma c in + let t = Value.of_constr t in + Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT t + end in + pf_apply get_type +end + +(** constr -> constr *) +let () = define2 "constr_equal" constr constr begin fun c1 c2 -> + Proofview.tclEVARMAP >>= fun sigma -> + let b = EConstr.eq_constr sigma c1 c2 in + Proofview.tclUNIT (Value.of_bool b) +end + +let () = define1 "constr_kind" constr begin fun c -> + let open Constr in + Proofview.tclEVARMAP >>= fun sigma -> + return begin match EConstr.kind sigma c with + | Rel n -> + v_blk 0 [|Value.of_int n|] + | Var id -> + v_blk 1 [|Value.of_ident id|] + | Meta n -> + v_blk 2 [|Value.of_int n|] + | Evar (evk, args) -> + v_blk 3 [| + Value.of_int (Evar.repr evk); + Value.of_array Value.of_constr args; + |] + | Sort s -> + v_blk 4 [|Value.of_ext Value.val_sort s|] + | Cast (c, k, t) -> + v_blk 5 [| + Value.of_constr c; + Value.of_ext Value.val_cast k; + Value.of_constr t; + |] + | Prod (na, t, u) -> + v_blk 6 [| + of_annot of_name na; + Value.of_constr t; + Value.of_constr u; + |] + | Lambda (na, t, c) -> + v_blk 7 [| + of_annot of_name na; + Value.of_constr t; + Value.of_constr c; + |] + | LetIn (na, b, t, c) -> + v_blk 8 [| + of_annot of_name na; + Value.of_constr b; + Value.of_constr t; + Value.of_constr c; + |] + | App (c, cl) -> + v_blk 9 [| + Value.of_constr c; + Value.of_array Value.of_constr cl; + |] + | Const (cst, u) -> + v_blk 10 [| + Value.of_constant cst; + of_instance u; + |] + | Ind (ind, u) -> + v_blk 11 [| + Value.of_ext Value.val_inductive ind; + of_instance u; + |] + | Construct (cstr, u) -> + v_blk 12 [| + Value.of_ext Value.val_constructor cstr; + of_instance u; + |] + | Case (ci, c, t, bl) -> + v_blk 13 [| + Value.of_ext Value.val_case ci; + Value.of_constr c; + Value.of_constr t; + Value.of_array Value.of_constr bl; + |] + | Fix ((recs, i), def) -> + let (nas, ts, cs) = of_rec_declaration def in + v_blk 14 [| + Value.of_array Value.of_int recs; + Value.of_int i; + nas; + ts; + cs; + |] + | CoFix (i, def) -> + let (nas, ts, cs) = of_rec_declaration def in + v_blk 15 [| + Value.of_int i; + nas; + ts; + cs; + |] + | Proj (p, c) -> + v_blk 16 [| + Value.of_ext Value.val_projection p; + Value.of_constr c; + |] + | Int _ -> + assert false + end +end + +let () = define1 "constr_make" valexpr begin fun knd -> + let c = match Tac2ffi.to_block knd with + | (0, [|n|]) -> + let n = Value.to_int n in + EConstr.mkRel n + | (1, [|id|]) -> + let id = Value.to_ident id in + EConstr.mkVar id + | (2, [|n|]) -> + let n = Value.to_int n in + EConstr.mkMeta n + | (3, [|evk; args|]) -> + let evk = Evar.unsafe_of_int (Value.to_int evk) in + let args = Value.to_array Value.to_constr args in + EConstr.mkEvar (evk, args) + | (4, [|s|]) -> + let s = Value.to_ext Value.val_sort s in + EConstr.mkSort (EConstr.Unsafe.to_sorts s) + | (5, [|c; k; t|]) -> + let c = Value.to_constr c in + let k = Value.to_ext Value.val_cast k in + let t = Value.to_constr t in + EConstr.mkCast (c, k, t) + | (6, [|na; t; u|]) -> + let na = to_annot to_name na in + let t = Value.to_constr t in + let u = Value.to_constr u in + EConstr.mkProd (na, t, u) + | (7, [|na; t; c|]) -> + let na = to_annot to_name na in + let t = Value.to_constr t in + let u = Value.to_constr c in + EConstr.mkLambda (na, t, u) + | (8, [|na; b; t; c|]) -> + let na = to_annot to_name na in + let b = Value.to_constr b in + let t = Value.to_constr t in + let c = Value.to_constr c in + EConstr.mkLetIn (na, b, t, c) + | (9, [|c; cl|]) -> + let c = Value.to_constr c in + let cl = Value.to_array Value.to_constr cl in + EConstr.mkApp (c, cl) + | (10, [|cst; u|]) -> + let cst = Value.to_constant cst in + let u = to_instance u in + EConstr.mkConstU (cst, u) + | (11, [|ind; u|]) -> + let ind = Value.to_ext Value.val_inductive ind in + let u = to_instance u in + EConstr.mkIndU (ind, u) + | (12, [|cstr; u|]) -> + let cstr = Value.to_ext Value.val_constructor cstr in + let u = to_instance u in + EConstr.mkConstructU (cstr, u) + | (13, [|ci; c; t; bl|]) -> + let ci = Value.to_ext Value.val_case ci in + let c = Value.to_constr c in + let t = Value.to_constr t in + let bl = Value.to_array Value.to_constr bl in + EConstr.mkCase (ci, c, t, bl) + | (14, [|recs; i; nas; ts; cs|]) -> + let recs = Value.to_array Value.to_int recs in + let i = Value.to_int i in + let def = to_rec_declaration (nas, ts, cs) in + EConstr.mkFix ((recs, i), def) + | (15, [|i; nas; ts; cs|]) -> + let i = Value.to_int i in + let def = to_rec_declaration (nas, ts, cs) in + EConstr.mkCoFix (i, def) + | (16, [|p; c|]) -> + let p = Value.to_ext Value.val_projection p in + let c = Value.to_constr c in + EConstr.mkProj (p, c) + | _ -> assert false + in + return (Value.of_constr c) +end + +let () = define1 "constr_check" constr begin fun c -> + pf_apply begin fun env sigma -> + try + let (sigma, _) = Typing.type_of env sigma c in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + return (of_result Value.of_constr (Inl c)) + with e when CErrors.noncritical e -> + let e = CErrors.push e in + return (of_result Value.of_constr (Inr e)) + end +end + +let () = define3 "constr_substnl" (list constr) int constr begin fun subst k c -> + let ans = EConstr.Vars.substnl subst k c in + return (Value.of_constr ans) +end + +let () = define3 "constr_closenl" (list ident) int constr begin fun ids k c -> + let ans = EConstr.Vars.substn_vars k ids c in + return (Value.of_constr ans) +end + +let () = define1 "constr_case" (repr_ext val_inductive) begin fun ind -> + Proofview.tclENV >>= fun env -> + try + let ans = Inductiveops.make_case_info env ind Sorts.Relevant Constr.RegularStyle in + return (Value.of_ext Value.val_case ans) + with e when CErrors.noncritical e -> + throw err_notfound +end + +let () = define2 "constr_constructor" (repr_ext val_inductive) int begin fun (ind, i) k -> + Proofview.tclENV >>= fun env -> + try + let open Declarations in + let ans = Environ.lookup_mind ind env in + let _ = ans.mind_packets.(i).mind_consnames.(k) in + return (Value.of_ext val_constructor ((ind, i), (k + 1))) + with e when CErrors.noncritical e -> + throw err_notfound +end + +let () = define3 "constr_in_context" ident constr closure begin fun id t c -> + Proofview.Goal.goals >>= function + | [gl] -> + gl >>= fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let has_var = + try + let _ = Environ.lookup_named_val id env in + true + with Not_found -> false + in + if has_var then + Tacticals.New.tclZEROMSG (str "Variable already exists") + else + let open Context.Named.Declaration in + let nenv = EConstr.push_named (LocalAssum (Context.make_annot id Sorts.Relevant, t)) env in + let (sigma, (evt, _)) = Evarutil.new_type_evar nenv sigma Evd.univ_flexible in + let (sigma, evk) = Evarutil.new_pure_evar (Environ.named_context_val nenv) sigma evt in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state evk] >>= fun () -> + thaw c >>= fun _ -> + Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state (Proofview.Goal.goal gl)] >>= fun () -> + let args = List.map (fun d -> EConstr.mkVar (get_id d)) (EConstr.named_context env) in + let args = Array.of_list (EConstr.mkRel 1 :: args) in + let ans = EConstr.mkEvar (evk, args) in + let ans = EConstr.mkLambda (Context.make_annot (Name id) Sorts.Relevant, t, ans) in + return (Value.of_constr ans) + | _ -> + throw err_notfocussed +end + +(** Patterns *) + +let empty_context = EConstr.mkMeta Constr_matching.special_meta + +let () = define0 "pattern_empty_context" begin + return (Value.of_constr empty_context) +end + +let () = define2 "pattern_matches" pattern constr begin fun pat c -> + pf_apply begin fun env sigma -> + let ans = + try Some (Constr_matching.matches env sigma pat c) + with Constr_matching.PatternMatchingFailure -> None + in + begin match ans with + | None -> fail err_matchfailure + | Some ans -> + let ans = Id.Map.bindings ans in + let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in + return (Value.of_list of_pair ans) + end + end +end + +let () = define2 "pattern_matches_subterm" pattern constr begin fun pat c -> + let open Constr_matching in + let rec of_ans s = match IStream.peek s with + | IStream.Nil -> fail err_matchfailure + | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> + let ans = Id.Map.bindings sub in + let of_pair (id, c) = Value.of_tuple [| Value.of_ident id; Value.of_constr c |] in + let ans = Value.of_tuple [| Value.of_constr (Lazy.force m_ctx); Value.of_list of_pair ans |] in + Proofview.tclOR (return ans) (fun _ -> of_ans s) + in + pf_apply begin fun env sigma -> + let ans = Constr_matching.match_subterm env sigma (Id.Set.empty,pat) c in + of_ans ans + end +end + +let () = define2 "pattern_matches_vect" pattern constr begin fun pat c -> + pf_apply begin fun env sigma -> + let ans = + try Some (Constr_matching.matches env sigma pat c) + with Constr_matching.PatternMatchingFailure -> None + in + begin match ans with + | None -> fail err_matchfailure + | Some ans -> + let ans = Id.Map.bindings ans in + let ans = Array.map_of_list snd ans in + return (Value.of_array Value.of_constr ans) + end + end +end + +let () = define2 "pattern_matches_subterm_vect" pattern constr begin fun pat c -> + let open Constr_matching in + let rec of_ans s = match IStream.peek s with + | IStream.Nil -> fail err_matchfailure + | IStream.Cons ({ m_sub = (_, sub); m_ctx }, s) -> + let ans = Id.Map.bindings sub in + let ans = Array.map_of_list snd ans in + let ans = Value.of_tuple [| Value.of_constr (Lazy.force m_ctx); Value.of_array Value.of_constr ans |] in + Proofview.tclOR (return ans) (fun _ -> of_ans s) + in + pf_apply begin fun env sigma -> + let ans = Constr_matching.match_subterm env sigma (Id.Set.empty,pat) c in + of_ans ans + end +end + +let () = define3 "pattern_matches_goal" bool (list (pair bool pattern)) (pair bool pattern) begin fun rev hp cp -> + assert_focussed >>= fun () -> + Proofview.Goal.enter_one begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let concl = Proofview.Goal.concl gl in + let mk_pattern (b, pat) = if b then Tac2match.MatchPattern pat else Tac2match.MatchContext pat in + let r = (List.map mk_pattern hp, mk_pattern cp) in + Tac2match.match_goal env sigma concl ~rev r >>= fun (hyps, ctx, subst) -> + let of_ctxopt ctx = Value.of_constr (Option.default empty_context ctx) in + let hids = Value.of_array Value.of_ident (Array.map_of_list fst hyps) in + let hctx = Value.of_array of_ctxopt (Array.map_of_list snd hyps) in + let subs = Value.of_array Value.of_constr (Array.map_of_list snd (Id.Map.bindings subst)) in + let cctx = of_ctxopt ctx in + let ans = Value.of_tuple [| hids; hctx; subs; cctx |] in + Proofview.tclUNIT ans + end +end + +let () = define2 "pattern_instantiate" constr constr begin fun ctx c -> + let ctx = EConstr.Unsafe.to_constr ctx in + let c = EConstr.Unsafe.to_constr c in + let ans = Termops.subst_meta [Constr_matching.special_meta, c] ctx in + return (Value.of_constr (EConstr.of_constr ans)) +end + +(** Error *) + +let () = define1 "throw" exn begin fun (e, info) -> + throw ~info e +end + +(** Control *) + +(** exn -> 'a *) +let () = define1 "zero" exn begin fun (e, info) -> + fail ~info e +end + +(** (unit -> 'a) -> (exn -> 'a) -> 'a *) +let () = define2 "plus" closure closure begin fun x k -> + Proofview.tclOR (thaw x) (fun e -> Tac2ffi.apply k [Value.of_exn e]) +end + +(** (unit -> 'a) -> 'a *) +let () = define1 "once" closure begin fun f -> + Proofview.tclONCE (thaw f) +end + +(** (unit -> unit) list -> unit *) +let () = define1 "dispatch" (list closure) begin fun l -> + let l = List.map (fun f -> Proofview.tclIGNORE (thaw f)) l in + Proofview.tclDISPATCH l >>= fun () -> return v_unit +end + +(** (unit -> unit) list -> (unit -> unit) -> (unit -> unit) list -> unit *) +let () = define3 "extend" (list closure) closure (list closure) begin fun lft tac rgt -> + let lft = List.map (fun f -> Proofview.tclIGNORE (thaw f)) lft in + let tac = Proofview.tclIGNORE (thaw tac) in + let rgt = List.map (fun f -> Proofview.tclIGNORE (thaw f)) rgt in + Proofview.tclEXTEND lft tac rgt >>= fun () -> return v_unit +end + +(** (unit -> unit) -> unit *) +let () = define1 "enter" closure begin fun f -> + let f = Proofview.tclIGNORE (thaw f) in + Proofview.tclINDEPENDENT f >>= fun () -> return v_unit +end + +(** (unit -> 'a) -> ('a * ('exn -> 'a)) result *) +let () = define1 "case" closure begin fun f -> + Proofview.tclCASE (thaw f) >>= begin function + | Proofview.Next (x, k) -> + let k = Tac2ffi.mk_closure arity_one begin fun e -> + let (e, info) = Value.to_exn e in + set_bt info >>= fun info -> + k (e, info) + end in + return (v_blk 0 [| Value.of_tuple [| x; Value.of_closure k |] |]) + | Proofview.Fail e -> return (v_blk 1 [| Value.of_exn e |]) + end +end + +(** int -> int -> (unit -> 'a) -> 'a *) +let () = define3 "focus" int int closure begin fun i j tac -> + Proofview.tclFOCUS i j (thaw tac) +end + +(** unit -> unit *) +let () = define0 "shelve" begin + Proofview.shelve >>= fun () -> return v_unit +end + +(** unit -> unit *) +let () = define0 "shelve_unifiable" begin + Proofview.shelve_unifiable >>= fun () -> return v_unit +end + +let () = define1 "new_goal" int begin fun ev -> + let ev = Evar.unsafe_of_int ev in + Proofview.tclEVARMAP >>= fun sigma -> + if Evd.mem sigma ev then + Proofview.Unsafe.tclNEWGOALS [Proofview.with_empty_state ev] <*> Proofview.tclUNIT v_unit + else throw err_notfound +end + +(** unit -> constr *) +let () = define0 "goal" begin + assert_focussed >>= fun () -> + Proofview.Goal.enter_one begin fun gl -> + let concl = Tacmach.New.pf_nf_concl gl in + return (Value.of_constr concl) + end +end + +(** ident -> constr *) +let () = define1 "hyp" ident begin fun id -> + pf_apply begin fun env _ -> + let mem = try ignore (Environ.lookup_named id env); true with Not_found -> false in + if mem then return (Value.of_constr (EConstr.mkVar id)) + else Tacticals.New.tclZEROMSG + (str "Hypothesis " ++ quote (Id.print id) ++ str " not found") (* FIXME: Do something more sensible *) + end +end + +let () = define0 "hyps" begin + pf_apply begin fun env _ -> + let open Context in + let open Named.Declaration in + let hyps = List.rev (Environ.named_context env) in + let map = function + | LocalAssum (id, t) -> + let t = EConstr.of_constr t in + Value.of_tuple [|Value.of_ident id.binder_name; Value.of_option Value.of_constr None; Value.of_constr t|] + | LocalDef (id, c, t) -> + let c = EConstr.of_constr c in + let t = EConstr.of_constr t in + Value.of_tuple [|Value.of_ident id.binder_name; Value.of_option Value.of_constr (Some c); Value.of_constr t|] + in + return (Value.of_list map hyps) + end +end + +(** (unit -> constr) -> unit *) +let () = define1 "refine" closure begin fun c -> + let c = thaw c >>= fun c -> Proofview.tclUNIT ((), Value.to_constr c) in + Proofview.Goal.enter begin fun gl -> + Refine.generic_refine ~typecheck:true c gl + end >>= fun () -> return v_unit +end + +let () = define2 "with_holes" closure closure begin fun x f -> + Proofview.tclEVARMAP >>= fun sigma0 -> + thaw x >>= fun ans -> + Proofview.tclEVARMAP >>= fun sigma -> + Proofview.Unsafe.tclEVARS sigma0 >>= fun () -> + Tacticals.New.tclWITHHOLES false (Tac2ffi.apply f [ans]) sigma +end + +let () = define1 "progress" closure begin fun f -> + Proofview.tclPROGRESS (thaw f) +end + +let () = define2 "abstract" (option ident) closure begin fun id f -> + Abstract.tclABSTRACT id (Proofview.tclIGNORE (thaw f)) >>= fun () -> + return v_unit +end + +let () = define2 "time" (option string) closure begin fun s f -> + let s = Option.map Bytes.to_string s in + Proofview.tclTIME s (thaw f) +end + +let () = define0 "check_interrupt" begin + Proofview.tclCHECKINTERRUPT >>= fun () -> return v_unit +end + +(** Fresh *) + +let () = define2 "fresh_free_union" (repr_ext val_free) (repr_ext val_free) begin fun set1 set2 -> + let ans = Id.Set.union set1 set2 in + return (Value.of_ext Value.val_free ans) +end + +let () = define1 "fresh_free_of_ids" (list ident) begin fun ids -> + let free = List.fold_right Id.Set.add ids Id.Set.empty in + return (Value.of_ext Value.val_free free) +end + +let () = define1 "fresh_free_of_constr" constr begin fun c -> + Proofview.tclEVARMAP >>= fun sigma -> + let rec fold accu c = match EConstr.kind sigma c with + | Constr.Var id -> Id.Set.add id accu + | _ -> EConstr.fold sigma fold accu c + in + let ans = fold Id.Set.empty c in + return (Value.of_ext Value.val_free ans) +end + +let () = define2 "fresh_fresh" (repr_ext val_free) ident begin fun avoid id -> + let nid = Namegen.next_ident_away_from id (fun id -> Id.Set.mem id avoid) in + return (Value.of_ident nid) +end + +(** Env *) + +let () = define1 "env_get" (list ident) begin fun ids -> + let r = match ids with + | [] -> None + | _ :: _ as ids -> + let (id, path) = List.sep_last ids in + let path = DirPath.make (List.rev path) in + let fp = Libnames.make_path path id in + try Some (Nametab.global_of_path fp) with Not_found -> None + in + return (Value.of_option Value.of_reference r) +end + +let () = define1 "env_expand" (list ident) begin fun ids -> + let r = match ids with + | [] -> [] + | _ :: _ as ids -> + let (id, path) = List.sep_last ids in + let path = DirPath.make (List.rev path) in + let qid = Libnames.make_qualid path id in + Nametab.locate_all qid + in + return (Value.of_list Value.of_reference r) +end + +let () = define1 "env_path" reference begin fun r -> + match Nametab.path_of_global r with + | fp -> + let (path, id) = Libnames.repr_path fp in + let path = DirPath.repr path in + return (Value.of_list Value.of_ident (List.rev_append path [id])) + | exception Not_found -> + throw err_notfound +end + +let () = define1 "env_instantiate" reference begin fun r -> + Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + let (sigma, c) = Evd.fresh_global env sigma r in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + return (Value.of_constr c) +end + +(** Ltac1 in Ltac2 *) + +let ltac1 = Tac2ffi.repr_ext Value.val_ltac1 +let of_ltac1 v = Value.of_ext Value.val_ltac1 v + +let () = define1 "ltac1_ref" (list ident) begin fun ids -> + let open Ltac_plugin in + let r = match ids with + | [] -> raise Not_found + | _ :: _ as ids -> + let (id, path) = List.sep_last ids in + let path = DirPath.make (List.rev path) in + let fp = Libnames.make_path path id in + if Tacenv.exists_tactic fp then + List.hd (Tacenv.locate_extended_all_tactic (Libnames.qualid_of_path fp)) + else raise Not_found + in + let tac = Tacinterp.Value.of_closure (Tacinterp.default_ist ()) (Tacenv.interp_ltac r) in + return (Value.of_ext val_ltac1 tac) +end + +let () = define1 "ltac1_run" ltac1 begin fun v -> + let open Ltac_plugin in + Tacinterp.tactic_of_value (Tacinterp.default_ist ()) v >>= fun () -> + return v_unit +end + +let () = define3 "ltac1_apply" ltac1 (list ltac1) closure begin fun f args k -> + let open Ltac_plugin in + let open Tacexpr in + let open Locus in + let k ret = + Proofview.tclIGNORE (Tac2ffi.apply k [Value.of_ext val_ltac1 ret]) + in + let fold arg (i, vars, lfun) = + let id = Id.of_string ("x" ^ string_of_int i) in + let x = Reference (ArgVar CAst.(make id)) in + (succ i, x :: vars, Id.Map.add id arg lfun) + in + let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in + let lfun = Id.Map.add (Id.of_string "F") f lfun in + let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in + let tac = TacArg(CAst.make @@ TacCall (CAst.make (ArgVar CAst.(make @@ Id.of_string "F"),args))) in + Tacinterp.val_interp ist tac k >>= fun () -> + return v_unit +end + +let () = define1 "ltac1_of_constr" constr begin fun c -> + let open Ltac_plugin in + return (Value.of_ext val_ltac1 (Tacinterp.Value.of_constr c)) +end + +let () = define1 "ltac1_to_constr" ltac1 begin fun v -> + let open Ltac_plugin in + return (Value.of_option Value.of_constr (Tacinterp.Value.to_constr v)) +end + +let () = define1 "ltac1_of_list" (list ltac1) begin fun l -> + let open Geninterp.Val in + return (Value.of_ext val_ltac1 (inject (Base typ_list) l)) +end + +let () = define1 "ltac1_to_list" ltac1 begin fun v -> + let open Ltac_plugin in + return (Value.of_option (Value.of_list of_ltac1) (Tacinterp.Value.to_list v)) +end + +(** ML types *) + +let constr_flags () = + let open Pretyping in + { + use_typeclasses = true; + solve_unification_constraints = true; + fail_evar = true; + expand_evars = true; + program_mode = false; + polymorphic = false; + } + +let open_constr_no_classes_flags () = + let open Pretyping in + { + use_typeclasses = false; + solve_unification_constraints = true; + fail_evar = false; + expand_evars = true; + program_mode = false; + polymorphic = false; + } + +(** Embed all Ltac2 data into Values *) +let to_lvar ist = + let open Glob_ops in + let lfun = Tac2interp.set_env ist Id.Map.empty in + { empty_lvar with Ltac_pretype.ltac_genargs = lfun } + +let gtypref kn = GTypRef (Other kn, []) + +let intern_constr self ist c = + let (_, (c, _)) = Genintern.intern Stdarg.wit_constr ist c in + (GlbVal c, gtypref t_constr) + +let catchable_exception = function + | Logic_monad.Exception _ -> false + | e -> CErrors.noncritical e + +let interp_constr flags ist c = + let open Pretyping in + let ist = to_lvar ist in + pf_apply begin fun env sigma -> + try + let (sigma, c) = understand_ltac flags env sigma ist WithoutTypeConstraint c in + let c = Value.of_constr c in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT c + with e when catchable_exception e -> + let (e, info) = CErrors.push e in + set_bt info >>= fun info -> + match Exninfo.get info fatal_flag with + | None -> Proofview.tclZERO ~info e + | Some () -> throw ~info e + end + +let () = + let intern = intern_constr in + let interp ist c = interp_constr (constr_flags ()) ist c in + let print env c = str "constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in + let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_constr obj + +let () = + let intern = intern_constr in + let interp ist c = interp_constr (open_constr_no_classes_flags ()) ist c in + let print env c = str "open_constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in + let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_open_constr obj + +let () = + let interp _ id = return (Value.of_ident id) in + let print _ id = str "ident:(" ++ Id.print id ++ str ")" in + let obj = { + ml_intern = (fun _ _ id -> GlbVal id, gtypref t_ident); + ml_interp = interp; + ml_subst = (fun _ id -> id); + ml_print = print; + } in + define_ml_object Tac2quote.wit_ident obj + +let () = + let intern self ist c = + let env = ist.Genintern.genv in + let sigma = Evd.from_env env in + let warn = if !Ltac_plugin.Tacintern.strict_check then fun x -> x else Constrintern.for_grammar in + let _, pat = warn (fun () ->Constrintern.intern_constr_pattern env sigma ~as_type:false c) () in + GlbVal pat, gtypref t_pattern + in + let subst subst c = + let env = Global.env () in + let sigma = Evd.from_env env in + Patternops.subst_pattern env sigma subst c + in + let print env pat = str "pattern:(" ++ Printer.pr_lconstr_pattern_env env Evd.empty pat ++ str ")" in + let interp _ c = return (Value.of_pattern c) in + let obj = { + ml_intern = intern; + ml_interp = interp; + ml_subst = subst; + ml_print = print; + } in + define_ml_object Tac2quote.wit_pattern obj + +let () = + let intern self ist ref = match ref.CAst.v with + | Tac2qexpr.QHypothesis id -> + GlbVal (Globnames.VarRef id), gtypref t_reference + | Tac2qexpr.QReference qid -> + let gr = + try Nametab.locate qid + with Not_found -> + Nametab.error_global_not_found qid + in + GlbVal gr, gtypref t_reference + in + let subst s c = Globnames.subst_global_reference s c in + let interp _ gr = return (Value.of_reference gr) in + let print _ = function + | Globnames.VarRef id -> str "reference:(" ++ str "&" ++ Id.print id ++ str ")" + | r -> str "reference:(" ++ Printer.pr_global r ++ str ")" + in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_reference obj + +let () = + let intern self ist tac = + (* Prevent inner calls to Ltac2 values *) + let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in + let ist = { ist with Genintern.extra } in + let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in + GlbVal tac, gtypref t_unit + in + let interp ist tac = + let ist = { env_ist = Id.Map.empty } in + let lfun = Tac2interp.set_env ist Id.Map.empty in + let ist = Ltac_plugin.Tacinterp.default_ist () in + let ist = { ist with Geninterp.lfun = lfun } in + let tac = (Ltac_plugin.Tacinterp.eval_tactic_ist ist tac : unit Proofview.tactic) in + let wrap (e, info) = set_bt info >>= fun info -> Proofview.tclZERO ~info e in + Proofview.tclOR tac wrap >>= fun () -> + return v_unit + in + let subst s tac = Genintern.substitute Ltac_plugin.Tacarg.wit_tactic s tac in + let print env tac = + str "ltac1:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic env tac ++ str ")" + in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_ltac1 obj + +let () = + let open Ltac_plugin in + let intern self ist tac = + (* Prevent inner calls to Ltac2 values *) + let extra = Tac2intern.drop_ltac2_env ist.Genintern.extra in + let ist = { ist with Genintern.extra } in + let _, tac = Genintern.intern Ltac_plugin.Tacarg.wit_tactic ist tac in + GlbVal tac, gtypref t_ltac1 + in + let interp ist tac = + let ist = { env_ist = Id.Map.empty } in + let lfun = Tac2interp.set_env ist Id.Map.empty in + let ist = Ltac_plugin.Tacinterp.default_ist () in + let ist = { ist with Geninterp.lfun = lfun } in + return (Value.of_ext val_ltac1 (Tacinterp.Value.of_closure ist tac)) + in + let subst s tac = Genintern.substitute Tacarg.wit_tactic s tac in + let print env tac = + str "ltac1val:(" ++ Ltac_plugin.Pptactic.pr_glob_tactic env tac ++ str ")" + in + let obj = { + ml_intern = intern; + ml_subst = subst; + ml_interp = interp; + ml_print = print; + } in + define_ml_object Tac2quote.wit_ltac1val obj + +(** Ltac2 in terms *) + +let () = + let interp ist poly env sigma concl tac = + let ist = Tac2interp.get_env ist in + let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in + let name, poly = Id.of_string "ltac2", poly in + let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma concl tac in + (EConstr.of_constr c, sigma) + in + GlobEnv.register_constr_interp0 wit_ltac2 interp + +let () = + let interp ist poly env sigma concl id = + let ist = Tac2interp.get_env ist in + let c = Id.Map.find id ist.env_ist in + let c = Value.to_constr c in + let sigma = Typing.check env sigma c concl in + (c, sigma) + in + GlobEnv.register_constr_interp0 wit_ltac2_quotation interp + +let () = + let pr_raw id = Genprint.PrinterBasic (fun _env _sigma -> mt ()) in + let pr_glb id = Genprint.PrinterBasic (fun _env _sigma -> str "$" ++ Id.print id) in + let pr_top _ = Genprint.TopPrinterBasic mt in + Genprint.register_print0 wit_ltac2_quotation pr_raw pr_glb pr_top + +(** Ltac2 in Ltac1 *) + +let () = + let e = Tac2entries.Pltac.tac2expr in + let inject (loc, v) = Ltac_plugin.Tacexpr.TacGeneric (in_gen (rawwit wit_ltac2) v) in + Ltac_plugin.Tacentries.create_ltac_quotation "ltac2" inject (e, None) + +let () = + let open Ltac_plugin in + let open Tacinterp in + let idtac = Value.of_closure (default_ist ()) (Tacexpr.TacId []) in + let interp ist tac = +(* let ist = Tac2interp.get_env ist.Geninterp.lfun in *) + let ist = { env_ist = Id.Map.empty } in + Tac2interp.interp ist tac >>= fun _ -> + Ftactic.return idtac + in + Geninterp.register_interp0 wit_ltac2 interp + +let () = + let pr_raw _ = Genprint.PrinterBasic (fun _env _sigma -> mt ()) in + let pr_glb e = Genprint.PrinterBasic (fun _env _sigma -> Tac2print.pr_glbexpr e) in + let pr_top _ = Genprint.TopPrinterBasic mt in + Genprint.register_print0 wit_ltac2 pr_raw pr_glb pr_top + +(** Built-in notation scopes *) + +let add_scope s f = + Tac2entries.register_scope (Id.of_string s) f + +let rec pr_scope = let open CAst in function +| SexprStr {v=s} -> qstring s +| SexprInt {v=n} -> Pp.int n +| SexprRec (_, {v=na}, args) -> + let na = match na with + | None -> str "_" + | Some id -> Id.print id + in + na ++ str "(" ++ prlist_with_sep (fun () -> str ", ") pr_scope args ++ str ")" + +let scope_fail s args = + let args = str "(" ++ prlist_with_sep (fun () -> str ", ") pr_scope args ++ str ")" in + CErrors.user_err (str "Invalid arguments " ++ args ++ str " in scope " ++ str s) + +let q_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) + +let add_generic_scope s entry arg = + let parse = function + | [] -> + let scope = Extend.Aentry entry in + let act x = CAst.make @@ CTacExt (arg, x) in + Tac2entries.ScopeRule (scope, act) + | arg -> scope_fail s arg + in + add_scope s parse + +open CAst + +let () = add_scope "keyword" begin function +| [SexprStr {loc;v=s}] -> + let scope = Extend.Atoken (Tok.PKEYWORD s) in + Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) +| arg -> scope_fail "keyword" arg +end + +let () = add_scope "terminal" begin function +| [SexprStr {loc;v=s}] -> + let scope = Extend.Atoken (CLexer.terminal s) in + Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) +| arg -> scope_fail "terminal" arg +end + +let () = add_scope "list0" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Alist0 scope in + let act l = Tac2quote.of_list act l in + Tac2entries.ScopeRule (scope, act) +| [tok; SexprStr {v=str}] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let sep = Extend.Atoken (CLexer.terminal str) in + let scope = Extend.Alist0sep (scope, sep) in + let act l = Tac2quote.of_list act l in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "list0" arg +end + +let () = add_scope "list1" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Alist1 scope in + let act l = Tac2quote.of_list act l in + Tac2entries.ScopeRule (scope, act) +| [tok; SexprStr {v=str}] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let sep = Extend.Atoken (CLexer.terminal str) in + let scope = Extend.Alist1sep (scope, sep) in + let act l = Tac2quote.of_list act l in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "list1" arg +end + +let () = add_scope "opt" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let scope = Extend.Aopt scope in + let act opt = match opt with + | None -> + CAst.make @@ CTacCst (AbsKn (Other Core.c_none)) + | Some x -> + CAst.make @@ CTacApp (CAst.make @@ CTacCst (AbsKn (Other Core.c_some)), [act x]) + in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "opt" arg +end + +let () = add_scope "self" begin function +| [] -> + let scope = Extend.Aself in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "self" arg +end + +let () = add_scope "next" begin function +| [] -> + let scope = Extend.Anext in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "next" arg +end + +let () = add_scope "tactic" begin function +| [] -> + (* Default to level 5 parsing *) + let scope = Extend.Aentryl (tac2expr, "5") in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| [SexprInt {loc;v=n}] as arg -> + let () = if n < 0 || n > 6 then scope_fail "tactic" arg in + let scope = Extend.Aentryl (tac2expr, string_of_int n) in + let act tac = tac in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "tactic" arg +end + +let () = add_scope "thunk" begin function +| [tok] -> + let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in + let act e = Tac2quote.thunk (act e) in + Tac2entries.ScopeRule (scope, act) +| arg -> scope_fail "thunk" arg +end + +let add_expr_scope name entry f = + add_scope name begin function + | [] -> Tac2entries.ScopeRule (Extend.Aentry entry, f) + | arg -> scope_fail name arg + end + +let () = add_expr_scope "ident" q_ident (fun id -> Tac2quote.of_anti Tac2quote.of_ident id) +let () = add_expr_scope "bindings" q_bindings Tac2quote.of_bindings +let () = add_expr_scope "with_bindings" q_with_bindings Tac2quote.of_bindings +let () = add_expr_scope "intropattern" q_intropattern Tac2quote.of_intro_pattern +let () = add_expr_scope "intropatterns" q_intropatterns Tac2quote.of_intro_patterns +let () = add_expr_scope "destruction_arg" q_destruction_arg Tac2quote.of_destruction_arg +let () = add_expr_scope "induction_clause" q_induction_clause Tac2quote.of_induction_clause +let () = add_expr_scope "conversion" q_conversion Tac2quote.of_conversion +let () = add_expr_scope "rewriting" q_rewriting Tac2quote.of_rewriting +let () = add_expr_scope "clause" q_clause Tac2quote.of_clause +let () = add_expr_scope "hintdb" q_hintdb Tac2quote.of_hintdb +let () = add_expr_scope "occurrences" q_occurrences Tac2quote.of_occurrences +let () = add_expr_scope "dispatch" q_dispatch Tac2quote.of_dispatch +let () = add_expr_scope "strategy" q_strategy_flag Tac2quote.of_strategy_flag +let () = add_expr_scope "reference" q_reference Tac2quote.of_reference +let () = add_expr_scope "move_location" q_move_location Tac2quote.of_move_location +let () = add_expr_scope "pose" q_pose Tac2quote.of_pose +let () = add_expr_scope "assert" q_assert Tac2quote.of_assertion +let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching +let () = add_expr_scope "goal_matching" q_goal_matching Tac2quote.of_goal_matching + +let () = add_generic_scope "constr" Pcoq.Constr.constr Tac2quote.wit_constr +let () = add_generic_scope "open_constr" Pcoq.Constr.constr Tac2quote.wit_open_constr +let () = add_generic_scope "pattern" Pcoq.Constr.constr Tac2quote.wit_pattern + +(** seq scope, a bit hairy *) + +open Extend +exception SelfSymbol + +let rec generalize_symbol : + type a tr s. (s, tr, a) Extend.symbol -> (s, Extend.norec, a) Extend.symbol = function +| Atoken tok -> Atoken tok +| Alist1 e -> Alist1 (generalize_symbol e) +| Alist1sep (e, sep) -> + let e = generalize_symbol e in + let sep = generalize_symbol sep in + Alist1sep (e, sep) +| Alist0 e -> Alist0 (generalize_symbol e) +| Alist0sep (e, sep) -> + let e = generalize_symbol e in + let sep = generalize_symbol sep in + Alist0sep (e, sep) +| Aopt e -> Aopt (generalize_symbol e) +| Aself -> raise SelfSymbol +| Anext -> raise SelfSymbol +| Aentry e -> Aentry e +| Aentryl (e, l) -> Aentryl (e, l) +| Arules r -> Arules r + +type _ converter = +| CvNil : (Loc.t -> raw_tacexpr) converter +| CvCns : 'act converter * ('a -> raw_tacexpr) option -> ('a -> 'act) converter + +let rec apply : type a. a converter -> raw_tacexpr list -> a = function +| CvNil -> fun accu loc -> Tac2quote.of_tuple ~loc accu +| CvCns (c, None) -> fun accu x -> apply c accu +| CvCns (c, Some f) -> fun accu x -> apply c (f x :: accu) + +type seqrule = +| Seqrule : (Tac2expr.raw_tacexpr, Extend.norec, 'act, Loc.t -> raw_tacexpr) rule * 'act converter -> seqrule + +let rec make_seq_rule = function +| [] -> + Seqrule (Stop, CvNil) +| tok :: rem -> + let Tac2entries.ScopeRule (scope, f) = Tac2entries.parse_scope tok in + let scope = generalize_symbol scope in + let Seqrule (r, c) = make_seq_rule rem in + let r = NextNoRec (r, scope) in + let f = match tok with + | SexprStr _ -> None (* Leave out mere strings *) + | _ -> Some f + in + Seqrule (r, CvCns (c, f)) + +let () = add_scope "seq" begin fun toks -> + let scope = + try + let Seqrule (r, c) = make_seq_rule (List.rev toks) in + Arules [Rules (r, apply c [])] + with SelfSymbol -> + CErrors.user_err (str "Recursive symbols (self / next) are not allowed in local rules") + in + Tac2entries.ScopeRule (scope, (fun e -> e)) +end diff --git a/user-contrib/Ltac2/tac2core.mli b/user-contrib/Ltac2/tac2core.mli new file mode 100644 index 0000000000..9fae65bb3e --- /dev/null +++ b/user-contrib/Ltac2/tac2core.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Tac2expr + +(** {5 Hardwired data} *) + +module Core : +sig + +val t_list : type_constant +val c_nil : ltac_constructor +val c_cons : ltac_constructor + +val t_int : type_constant +val t_option : type_constant +val t_string : type_constant +val t_array : type_constant + +val c_true : ltac_constructor +val c_false : ltac_constructor + +end + +val pf_apply : (Environ.env -> Evd.evar_map -> 'a Proofview.tactic) -> 'a Proofview.tactic diff --git a/user-contrib/Ltac2/tac2dyn.ml b/user-contrib/Ltac2/tac2dyn.ml new file mode 100644 index 0000000000..896676f08b --- /dev/null +++ b/user-contrib/Ltac2/tac2dyn.ml @@ -0,0 +1,27 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +module Arg = +struct + module DYN = Dyn.Make(struct end) + module Map = DYN.Map + type ('a, 'b) tag = ('a * 'b) DYN.tag + let eq = DYN.eq + let repr = DYN.repr + let create = DYN.create +end + +module type Param = sig type ('raw, 'glb) t end + +module ArgMap (M : Param) = +struct + type _ pack = Pack : ('raw, 'glb) M.t -> ('raw * 'glb) pack + include Arg.Map(struct type 'a t = 'a pack end) +end + +module Val = Dyn.Make(struct end) diff --git a/user-contrib/Ltac2/tac2dyn.mli b/user-contrib/Ltac2/tac2dyn.mli new file mode 100644 index 0000000000..e995296840 --- /dev/null +++ b/user-contrib/Ltac2/tac2dyn.mli @@ -0,0 +1,34 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Dynamic arguments for Ltac2. *) + +module Arg : +sig + type ('a, 'b) tag + val create : string -> ('a, 'b) tag + val eq : ('a1, 'b1) tag -> ('a2, 'b2) tag -> ('a1 * 'b1, 'a2 * 'b2) CSig.eq option + val repr : ('a, 'b) tag -> string +end +(** Arguments that are part of an AST. *) + +module type Param = sig type ('raw, 'glb) t end + +module ArgMap (M : Param) : +sig + type _ pack = Pack : ('raw, 'glb) M.t -> ('raw * 'glb) pack + type t + val empty : t + val add : ('a, 'b) Arg.tag -> ('a * 'b) pack -> t -> t + val remove : ('a, 'b) Arg.tag -> t -> t + val find : ('a, 'b) Arg.tag -> t -> ('a * 'b) pack + val mem : ('a, 'b) Arg.tag -> t -> bool +end + +module Val : Dyn.S +(** Toplevel values *) diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml new file mode 100644 index 0000000000..9fd01426de --- /dev/null +++ b/user-contrib/Ltac2/tac2entries.ml @@ -0,0 +1,938 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open Util +open CAst +open CErrors +open Names +open Libnames +open Libobject +open Nametab +open Tac2expr +open Tac2print +open Tac2intern + +(** Grammar entries *) + +module Pltac = +struct +let tac2expr = Pcoq.Entry.create "tactic:tac2expr" + +let q_ident = Pcoq.Entry.create "tactic:q_ident" +let q_bindings = Pcoq.Entry.create "tactic:q_bindings" +let q_with_bindings = Pcoq.Entry.create "tactic:q_with_bindings" +let q_intropattern = Pcoq.Entry.create "tactic:q_intropattern" +let q_intropatterns = Pcoq.Entry.create "tactic:q_intropatterns" +let q_destruction_arg = Pcoq.Entry.create "tactic:q_destruction_arg" +let q_induction_clause = Pcoq.Entry.create "tactic:q_induction_clause" +let q_conversion = Pcoq.Entry.create "tactic:q_conversion" +let q_rewriting = Pcoq.Entry.create "tactic:q_rewriting" +let q_clause = Pcoq.Entry.create "tactic:q_clause" +let q_dispatch = Pcoq.Entry.create "tactic:q_dispatch" +let q_occurrences = Pcoq.Entry.create "tactic:q_occurrences" +let q_reference = Pcoq.Entry.create "tactic:q_reference" +let q_strategy_flag = Pcoq.Entry.create "tactic:q_strategy_flag" +let q_constr_matching = Pcoq.Entry.create "tactic:q_constr_matching" +let q_goal_matching = Pcoq.Entry.create "tactic:q_goal_matching" +let q_hintdb = Pcoq.Entry.create "tactic:q_hintdb" +let q_move_location = Pcoq.Entry.create "tactic:q_move_location" +let q_pose = Pcoq.Entry.create "tactic:q_pose" +let q_assert = Pcoq.Entry.create "tactic:q_assert" +end + +(** Tactic definition *) + +type tacdef = { + tacdef_local : bool; + tacdef_mutable : bool; + tacdef_expr : glb_tacexpr; + tacdef_type : type_scheme; +} + +let perform_tacdef visibility ((sp, kn), def) = + let () = if not def.tacdef_local then Tac2env.push_ltac visibility sp (TacConstant kn) in + let data = { + Tac2env.gdata_expr = def.tacdef_expr; + gdata_type = def.tacdef_type; + gdata_mutable = def.tacdef_mutable; + } in + Tac2env.define_global kn data + +let load_tacdef i obj = perform_tacdef (Until i) obj +let open_tacdef i obj = perform_tacdef (Exactly i) obj + +let cache_tacdef ((sp, kn), def) = + let () = Tac2env.push_ltac (Until 1) sp (TacConstant kn) in + let data = { + Tac2env.gdata_expr = def.tacdef_expr; + gdata_type = def.tacdef_type; + gdata_mutable = def.tacdef_mutable; + } in + Tac2env.define_global kn data + +let subst_tacdef (subst, def) = + let expr' = subst_expr subst def.tacdef_expr in + let type' = subst_type_scheme subst def.tacdef_type in + if expr' == def.tacdef_expr && type' == def.tacdef_type then def + else { def with tacdef_expr = expr'; tacdef_type = type' } + +let classify_tacdef o = Substitute o + +let inTacDef : tacdef -> obj = + declare_object {(default_object "TAC2-DEFINITION") with + cache_function = cache_tacdef; + load_function = load_tacdef; + open_function = open_tacdef; + subst_function = subst_tacdef; + classify_function = classify_tacdef} + +(** Type definition *) + +type typdef = { + typdef_local : bool; + typdef_expr : glb_quant_typedef; +} + +let change_kn_label kn id = + let mp = KerName.modpath kn in + KerName.make mp (Label.of_id id) + +let change_sp_label sp id = + let (dp, _) = Libnames.repr_path sp in + Libnames.make_path dp id + +let push_typedef visibility sp kn (_, def) = match def with +| GTydDef _ -> + Tac2env.push_type visibility sp kn +| GTydAlg { galg_constructors = cstrs } -> + (* Register constructors *) + let iter (c, _) = + let spc = change_sp_label sp c in + let knc = change_kn_label kn c in + Tac2env.push_constructor visibility spc knc + in + Tac2env.push_type visibility sp kn; + List.iter iter cstrs +| GTydRec fields -> + (* Register fields *) + let iter (c, _, _) = + let spc = change_sp_label sp c in + let knc = change_kn_label kn c in + Tac2env.push_projection visibility spc knc + in + Tac2env.push_type visibility sp kn; + List.iter iter fields +| GTydOpn -> + Tac2env.push_type visibility sp kn + +let next i = + let ans = !i in + let () = incr i in + ans + +let define_typedef kn (params, def as qdef) = match def with +| GTydDef _ -> + Tac2env.define_type kn qdef +| GTydAlg { galg_constructors = cstrs } -> + (* Define constructors *) + let constant = ref 0 in + let nonconstant = ref 0 in + let iter (c, args) = + let knc = change_kn_label kn c in + let tag = if List.is_empty args then next constant else next nonconstant in + let data = { + Tac2env.cdata_prms = params; + cdata_type = kn; + cdata_args = args; + cdata_indx = Some tag; + } in + Tac2env.define_constructor knc data + in + Tac2env.define_type kn qdef; + List.iter iter cstrs +| GTydRec fs -> + (* Define projections *) + let iter i (id, mut, t) = + let knp = change_kn_label kn id in + let proj = { + Tac2env.pdata_prms = params; + pdata_type = kn; + pdata_ptyp = t; + pdata_mutb = mut; + pdata_indx = i; + } in + Tac2env.define_projection knp proj + in + Tac2env.define_type kn qdef; + List.iteri iter fs +| GTydOpn -> + Tac2env.define_type kn qdef + +let perform_typdef vs ((sp, kn), def) = + let () = if not def.typdef_local then push_typedef vs sp kn def.typdef_expr in + define_typedef kn def.typdef_expr + +let load_typdef i obj = perform_typdef (Until i) obj +let open_typdef i obj = perform_typdef (Exactly i) obj + +let cache_typdef ((sp, kn), def) = + let () = push_typedef (Until 1) sp kn def.typdef_expr in + define_typedef kn def.typdef_expr + +let subst_typdef (subst, def) = + let expr' = subst_quant_typedef subst def.typdef_expr in + if expr' == def.typdef_expr then def else { def with typdef_expr = expr' } + +let classify_typdef o = Substitute o + +let inTypDef : typdef -> obj = + declare_object {(default_object "TAC2-TYPE-DEFINITION") with + cache_function = cache_typdef; + load_function = load_typdef; + open_function = open_typdef; + subst_function = subst_typdef; + classify_function = classify_typdef} + +(** Type extension *) + +type extension_data = { + edata_name : Id.t; + edata_args : int glb_typexpr list; +} + +type typext = { + typext_local : bool; + typext_prms : int; + typext_type : type_constant; + typext_expr : extension_data list; +} + +let push_typext vis sp kn def = + let iter data = + let spc = change_sp_label sp data.edata_name in + let knc = change_kn_label kn data.edata_name in + Tac2env.push_constructor vis spc knc + in + List.iter iter def.typext_expr + +let define_typext kn def = + let iter data = + let knc = change_kn_label kn data.edata_name in + let cdata = { + Tac2env.cdata_prms = def.typext_prms; + cdata_type = def.typext_type; + cdata_args = data.edata_args; + cdata_indx = None; + } in + Tac2env.define_constructor knc cdata + in + List.iter iter def.typext_expr + +let cache_typext ((sp, kn), def) = + let () = define_typext kn def in + push_typext (Until 1) sp kn def + +let perform_typext vs ((sp, kn), def) = + let () = if not def.typext_local then push_typext vs sp kn def in + define_typext kn def + +let load_typext i obj = perform_typext (Until i) obj +let open_typext i obj = perform_typext (Exactly i) obj + +let subst_typext (subst, e) = + let open Mod_subst in + let subst_data data = + let edata_args = List.Smart.map (fun e -> subst_type subst e) data.edata_args in + if edata_args == data.edata_args then data + else { data with edata_args } + in + let typext_type = subst_kn subst e.typext_type in + let typext_expr = List.Smart.map subst_data e.typext_expr in + if typext_type == e.typext_type && typext_expr == e.typext_expr then + e + else + { e with typext_type; typext_expr } + +let classify_typext o = Substitute o + +let inTypExt : typext -> obj = + declare_object {(default_object "TAC2-TYPE-EXTENSION") with + cache_function = cache_typext; + load_function = load_typext; + open_function = open_typext; + subst_function = subst_typext; + classify_function = classify_typext} + +(** Toplevel entries *) + +let fresh_var avoid x = + let bad id = + Id.Set.mem id avoid || + (try ignore (Tac2env.locate_ltac (qualid_of_ident id)); true with Not_found -> false) + in + Namegen.next_ident_away_from (Id.of_string x) bad + +let extract_pattern_type ({loc;v=p} as pat) = match p with +| CPatCnv (pat, ty) -> pat, Some ty +| CPatVar _ | CPatRef _ -> pat, None + +(** Mangle recursive tactics *) +let inline_rec_tactic tactics = + let avoid = List.fold_left (fun accu ({v=id}, _) -> Id.Set.add id accu) Id.Set.empty tactics in + let map (id, e) = match e.v with + | CTacFun (pat, _) -> (id, List.map extract_pattern_type pat, e) + | _ -> + user_err ?loc:id.loc (str "Recursive tactic definitions must be functions") + in + let tactics = List.map map tactics in + let map (id, pat, e) = + let fold_var (avoid, ans) (pat, _) = + let id = fresh_var avoid "x" in + let loc = pat.loc in + (Id.Set.add id avoid, CAst.make ?loc id :: ans) + in + (* Fresh variables to abstract over the function patterns *) + let _, vars = List.fold_left fold_var (avoid, []) pat in + let map_body ({loc;v=id}, _, e) = CAst.(make ?loc @@ CPatVar (Name id)), e in + let bnd = List.map map_body tactics in + let pat_of_id {loc;v=id} = CAst.make ?loc @@ CPatVar (Name id) in + let var_of_id {loc;v=id} = + let qid = qualid_of_ident ?loc id in + CAst.make ?loc @@ CTacRef (RelId qid) + in + let loc0 = e.loc in + let vpat = List.map pat_of_id vars in + let varg = List.map var_of_id vars in + let e = CAst.make ?loc:loc0 @@ CTacLet (true, bnd, CAst.make ?loc:loc0 @@ CTacApp (var_of_id id, varg)) in + (id, CAst.make ?loc:loc0 @@ CTacFun (vpat, e)) + in + List.map map tactics + +let check_lowercase {loc;v=id} = + if Tac2env.is_constructor (Libnames.qualid_of_ident id) then + user_err ?loc (str "The identifier " ++ Id.print id ++ str " must be lowercase") + +let register_ltac ?(local = false) ?(mut = false) isrec tactics = + let map ({loc;v=na}, e) = + let id = match na with + | Anonymous -> + user_err ?loc (str "Tactic definition must have a name") + | Name id -> id + in + let () = check_lowercase CAst.(make ?loc id) in + (CAst.(make ?loc id), e) + in + let tactics = List.map map tactics in + let tactics = + if isrec then inline_rec_tactic tactics else tactics + in + let map ({loc;v=id}, e) = + let (e, t) = intern ~strict:true e in + let () = + if not (is_value e) then + user_err ?loc (str "Tactic definition must be a syntactical value") + in + let kn = Lib.make_kn id in + let exists = + try let _ = Tac2env.interp_global kn in true with Not_found -> false + in + let () = + if exists then + user_err ?loc (str "Tactic " ++ Names.Id.print id ++ str " already exists") + in + (id, e, t) + in + let defs = List.map map tactics in + let iter (id, e, t) = + let def = { + tacdef_local = local; + tacdef_mutable = mut; + tacdef_expr = e; + tacdef_type = t; + } in + ignore (Lib.add_leaf id (inTacDef def)) + in + List.iter iter defs + +let qualid_to_ident qid = + if qualid_is_ident qid then CAst.make ?loc:qid.CAst.loc @@ qualid_basename qid + else user_err ?loc:qid.CAst.loc (str "Identifier expected") + +let register_typedef ?(local = false) isrec types = + let same_name ({v=id1}, _) ({v=id2}, _) = Id.equal id1 id2 in + let () = match List.duplicates same_name types with + | [] -> () + | ({loc;v=id}, _) :: _ -> + user_err ?loc (str "Multiple definition of the type name " ++ Id.print id) + in + let check ({loc;v=id}, (params, def)) = + let same_name {v=id1} {v=id2} = Id.equal id1 id2 in + let () = match List.duplicates same_name params with + | [] -> () + | {loc;v=id} :: _ -> + user_err ?loc (str "The type parameter " ++ Id.print id ++ + str " occurs several times") + in + match def with + | CTydDef _ -> + if isrec then + user_err ?loc (str "The type abbreviation " ++ Id.print id ++ + str " cannot be recursive") + | CTydAlg cs -> + let same_name (id1, _) (id2, _) = Id.equal id1 id2 in + let () = match List.duplicates same_name cs with + | [] -> () + | (id, _) :: _ -> + user_err (str "Multiple definitions of the constructor " ++ Id.print id) + in + () + | CTydRec ps -> + let same_name (id1, _, _) (id2, _, _) = Id.equal id1 id2 in + let () = match List.duplicates same_name ps with + | [] -> () + | (id, _, _) :: _ -> + user_err (str "Multiple definitions of the projection " ++ Id.print id) + in + () + | CTydOpn -> + if isrec then + user_err ?loc (str "The open type declaration " ++ Id.print id ++ + str " cannot be recursive") + in + let () = List.iter check types in + let self = + if isrec then + let fold accu ({v=id}, (params, _)) = + Id.Map.add id (Lib.make_kn id, List.length params) accu + in + List.fold_left fold Id.Map.empty types + else Id.Map.empty + in + let map ({v=id}, def) = + let typdef = { + typdef_local = local; + typdef_expr = intern_typedef self def; + } in + (id, typdef) + in + let types = List.map map types in + let iter (id, def) = ignore (Lib.add_leaf id (inTypDef def)) in + List.iter iter types + +let register_primitive ?(local = false) {loc;v=id} t ml = + let t = intern_open_type t in + let rec count_arrow = function + | GTypArrow (_, t) -> 1 + count_arrow t + | _ -> 0 + in + let arrows = count_arrow (snd t) in + let () = if Int.equal arrows 0 then + user_err ?loc (str "External tactic must have at least one argument") in + let () = + try let _ = Tac2env.interp_primitive ml in () with Not_found -> + user_err ?loc (str "Unregistered primitive " ++ + quote (str ml.mltac_plugin) ++ spc () ++ quote (str ml.mltac_tactic)) + in + let init i = Id.of_string (Printf.sprintf "x%i" i) in + let names = List.init arrows init in + let bnd = List.map (fun id -> Name id) names in + let arg = List.map (fun id -> GTacVar id) names in + let e = GTacFun (bnd, GTacPrm (ml, arg)) in + let def = { + tacdef_local = local; + tacdef_mutable = false; + tacdef_expr = e; + tacdef_type = t; + } in + ignore (Lib.add_leaf id (inTacDef def)) + +let register_open ?(local = false) qid (params, def) = + let kn = + try Tac2env.locate_type qid + with Not_found -> + user_err ?loc:qid.CAst.loc (str "Unbound type " ++ pr_qualid qid) + in + let (tparams, t) = Tac2env.interp_type kn in + let () = match t with + | GTydOpn -> () + | GTydAlg _ | GTydRec _ | GTydDef _ -> + user_err ?loc:qid.CAst.loc (str "Type " ++ pr_qualid qid ++ str " is not an open type") + in + let () = + if not (Int.equal (List.length params) tparams) then + Tac2intern.error_nparams_mismatch ?loc:qid.CAst.loc (List.length params) tparams + in + match def with + | CTydOpn -> () + | CTydAlg def -> + let intern_type t = + let tpe = CTydDef (Some t) in + let (_, ans) = intern_typedef Id.Map.empty (params, tpe) in + match ans with + | GTydDef (Some t) -> t + | _ -> assert false + in + let map (id, tpe) = + let tpe = List.map intern_type tpe in + { edata_name = id; edata_args = tpe } + in + let def = List.map map def in + let def = { + typext_local = local; + typext_type = kn; + typext_prms = tparams; + typext_expr = def; + } in + Lib.add_anonymous_leaf (inTypExt def) + | CTydRec _ | CTydDef _ -> + user_err ?loc:qid.CAst.loc (str "Extensions only accept inductive constructors") + +let register_type ?local isrec types = match types with +| [qid, true, def] -> + let () = if isrec then user_err ?loc:qid.CAst.loc (str "Extensions cannot be recursive") in + register_open ?local qid def +| _ -> + let map (qid, redef, def) = + let () = if redef then + user_err ?loc:qid.loc (str "Types can only be extended one by one") + in + (qualid_to_ident qid, def) + in + let types = List.map map types in + register_typedef ?local isrec types + +(** Parsing *) + +type 'a token = +| TacTerm of string +| TacNonTerm of Name.t * 'a + +type scope_rule = +| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule + +type scope_interpretation = sexpr list -> scope_rule + +let scope_table : scope_interpretation Id.Map.t ref = ref Id.Map.empty + +let register_scope id s = + scope_table := Id.Map.add id s !scope_table + +module ParseToken = +struct + +let loc_of_token = function +| SexprStr {loc} -> loc +| SexprInt {loc} -> loc +| SexprRec (loc, _, _) -> Some loc + +let parse_scope = function +| SexprRec (_, {loc;v=Some id}, toks) -> + if Id.Map.mem id !scope_table then + Id.Map.find id !scope_table toks + else + CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Names.Id.print id) +| SexprStr {v=str} -> + let v_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) in + ScopeRule (Extend.Atoken (Tok.PIDENT (Some str)), (fun _ -> v_unit)) +| tok -> + let loc = loc_of_token tok in + CErrors.user_err ?loc (str "Invalid parsing token") + +let parse_token = function +| SexprStr {v=s} -> TacTerm s +| SexprRec (_, {v=na}, [tok]) -> + let na = match na with None -> Anonymous | Some id -> Name id in + let scope = parse_scope tok in + TacNonTerm (na, scope) +| tok -> + let loc = loc_of_token tok in + CErrors.user_err ?loc (str "Invalid parsing token") + +end + +let parse_scope = ParseToken.parse_scope + +type synext = { + synext_tok : sexpr list; + synext_exp : raw_tacexpr; + synext_lev : int option; + synext_loc : bool; +} + +type krule = +| KRule : + (raw_tacexpr, _, 'act, Loc.t -> raw_tacexpr) Extend.rule * + ((Loc.t -> (Name.t * raw_tacexpr) list -> raw_tacexpr) -> 'act) -> krule + +let rec get_rule (tok : scope_rule token list) : krule = match tok with +| [] -> KRule (Extend.Stop, fun k loc -> k loc []) +| TacNonTerm (na, ScopeRule (scope, inj)) :: tok -> + let KRule (rule, act) = get_rule tok in + let rule = Extend.Next (rule, scope) in + let act k e = act (fun loc acc -> k loc ((na, inj e) :: acc)) in + KRule (rule, act) +| TacTerm t :: tok -> + let KRule (rule, act) = get_rule tok in + let rule = Extend.Next (rule, Extend.Atoken (CLexer.terminal t)) in + let act k _ = act k in + KRule (rule, act) + +let perform_notation syn st = + let tok = List.rev_map ParseToken.parse_token syn.synext_tok in + let KRule (rule, act) = get_rule tok in + let mk loc args = + let map (na, e) = + ((CAst.make ?loc:e.loc @@ CPatVar na), e) + in + let bnd = List.map map args in + CAst.make ~loc @@ CTacLet (false, bnd, syn.synext_exp) + in + let rule = Extend.Rule (rule, act mk) in + let lev = match syn.synext_lev with + | None -> None + | Some lev -> Some (string_of_int lev) + in + let rule = (lev, None, [rule]) in + ([Pcoq.ExtendRule (Pltac.tac2expr, None, (None, [rule]))], st) + +let ltac2_notation = + Pcoq.create_grammar_command "ltac2-notation" perform_notation + +let cache_synext (_, syn) = + Pcoq.extend_grammar_command ltac2_notation syn + +let open_synext i (_, syn) = + if Int.equal i 1 then Pcoq.extend_grammar_command ltac2_notation syn + +let subst_synext (subst, syn) = + let e = Tac2intern.subst_rawexpr subst syn.synext_exp in + if e == syn.synext_exp then syn else { syn with synext_exp = e } + +let classify_synext o = + if o.synext_loc then Dispose else Substitute o + +let inTac2Notation : synext -> obj = + declare_object {(default_object "TAC2-NOTATION") with + cache_function = cache_synext; + open_function = open_synext; + subst_function = subst_synext; + classify_function = classify_synext} + +type abbreviation = { + abbr_body : raw_tacexpr; +} + +let perform_abbreviation visibility ((sp, kn), abbr) = + let () = Tac2env.push_ltac visibility sp (TacAlias kn) in + Tac2env.define_alias kn abbr.abbr_body + +let load_abbreviation i obj = perform_abbreviation (Until i) obj +let open_abbreviation i obj = perform_abbreviation (Exactly i) obj + +let cache_abbreviation ((sp, kn), abbr) = + let () = Tac2env.push_ltac (Until 1) sp (TacAlias kn) in + Tac2env.define_alias kn abbr.abbr_body + +let subst_abbreviation (subst, abbr) = + let body' = subst_rawexpr subst abbr.abbr_body in + if body' == abbr.abbr_body then abbr + else { abbr_body = body' } + +let classify_abbreviation o = Substitute o + +let inTac2Abbreviation : abbreviation -> obj = + declare_object {(default_object "TAC2-ABBREVIATION") with + cache_function = cache_abbreviation; + load_function = load_abbreviation; + open_function = open_abbreviation; + subst_function = subst_abbreviation; + classify_function = classify_abbreviation} + +let register_notation ?(local = false) tkn lev body = match tkn, lev with +| [SexprRec (_, {loc;v=Some id}, [])], None -> + (* Tactic abbreviation *) + let () = check_lowercase CAst.(make ?loc id) in + let body = Tac2intern.globalize Id.Set.empty body in + let abbr = { abbr_body = body } in + ignore (Lib.add_leaf id (inTac2Abbreviation abbr)) +| _ -> + (* Check that the tokens make sense *) + let entries = List.map ParseToken.parse_token tkn in + let fold accu tok = match tok with + | TacTerm _ -> accu + | TacNonTerm (Name id, _) -> Id.Set.add id accu + | TacNonTerm (Anonymous, _) -> accu + in + let ids = List.fold_left fold Id.Set.empty entries in + (* Globalize so that names are absolute *) + let body = Tac2intern.globalize ids body in + let lev = match lev with Some _ -> lev | None -> Some 5 in + let ext = { + synext_tok = tkn; + synext_exp = body; + synext_lev = lev; + synext_loc = local; + } in + Lib.add_anonymous_leaf (inTac2Notation ext) + +type redefinition = { + redef_kn : ltac_constant; + redef_body : glb_tacexpr; +} + +let perform_redefinition (_, redef) = + let kn = redef.redef_kn in + let data = Tac2env.interp_global kn in + let data = { data with Tac2env.gdata_expr = redef.redef_body } in + Tac2env.define_global kn data + +let subst_redefinition (subst, redef) = + let kn = Mod_subst.subst_kn subst redef.redef_kn in + let body = Tac2intern.subst_expr subst redef.redef_body in + if kn == redef.redef_kn && body == redef.redef_body then redef + else { redef_kn = kn; redef_body = body } + +let classify_redefinition o = Substitute o + +let inTac2Redefinition : redefinition -> obj = + declare_object {(default_object "TAC2-REDEFINITION") with + cache_function = perform_redefinition; + open_function = (fun _ -> perform_redefinition); + subst_function = subst_redefinition; + classify_function = classify_redefinition } + +let register_redefinition ?(local = false) qid e = + let kn = + try Tac2env.locate_ltac qid + with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown tactic " ++ pr_qualid qid) + in + let kn = match kn with + | TacConstant kn -> kn + | TacAlias _ -> + user_err ?loc:qid.CAst.loc (str "Cannot redefine syntactic abbreviations") + in + let data = Tac2env.interp_global kn in + let () = + if not (data.Tac2env.gdata_mutable) then + user_err ?loc:qid.CAst.loc (str "The tactic " ++ pr_qualid qid ++ str " is not declared as mutable") + in + let (e, t) = intern ~strict:true e in + let () = + if not (is_value e) then + user_err ?loc:qid.CAst.loc (str "Tactic definition must be a syntactical value") + in + let () = + if not (Tac2intern.check_subtype t data.Tac2env.gdata_type) then + let name = int_name () in + user_err ?loc:qid.CAst.loc (str "Type " ++ pr_glbtype name (snd t) ++ + str " is not a subtype of " ++ pr_glbtype name (snd data.Tac2env.gdata_type)) + in + let def = { + redef_kn = kn; + redef_body = e; + } in + Lib.add_anonymous_leaf (inTac2Redefinition def) + +let perform_eval ~pstate e = + let open Proofview.Notations in + let env = Global.env () in + let (e, ty) = Tac2intern.intern ~strict:false e in + let v = Tac2interp.interp Tac2interp.empty_environment e in + let selector, proof = + match pstate with + | None -> + let sigma = Evd.from_env env in + let name, poly = Id.of_string "ltac2", false in + Goal_select.SelectAll, Proof.start ~name ~poly sigma [] + | Some pstate -> + Goal_select.get_default_goal_selector (), + Proof_global.give_me_the_proof pstate + in + let v = match selector with + | Goal_select.SelectNth i -> Proofview.tclFOCUS i i v + | Goal_select.SelectList l -> Proofview.tclFOCUSLIST l v + | Goal_select.SelectId id -> Proofview.tclFOCUSID id v + | Goal_select.SelectAll -> v + | Goal_select.SelectAlreadyFocused -> assert false (* TODO **) + in + (* HACK: the API doesn't allow to return a value *) + let ans = ref None in + let tac = (v >>= fun r -> ans := Some r; Proofview.tclUNIT ()) in + let (proof, _) = Proof.run_tactic (Global.env ()) tac proof in + let sigma = Proof.in_proof proof (fun sigma -> sigma) in + let ans = match !ans with None -> assert false | Some r -> r in + let name = int_name () in + Feedback.msg_notice (str "- : " ++ pr_glbtype name (snd ty) + ++ spc () ++ str "=" ++ spc () ++ + Tac2print.pr_valexpr env sigma ans (snd ty)) + +(** Toplevel entries *) + +let register_struct ?local ~pstate str = match str with +| StrVal (mut, isrec, e) -> register_ltac ?local ~mut isrec e +| StrTyp (isrec, t) -> register_type ?local isrec t +| StrPrm (id, t, ml) -> register_primitive ?local id t ml +| StrSyn (tok, lev, e) -> register_notation ?local tok lev e +| StrMut (qid, e) -> register_redefinition ?local qid e +| StrRun e -> perform_eval ~pstate e + +(** Toplevel exception *) + +let _ = Goptions.declare_bool_option { + Goptions.optdepr = false; + Goptions.optname = "print Ltac2 backtrace"; + Goptions.optkey = ["Ltac2"; "Backtrace"]; + Goptions.optread = (fun () -> !Tac2interp.print_ltac2_backtrace); + Goptions.optwrite = (fun b -> Tac2interp.print_ltac2_backtrace := b); +} + +let backtrace : backtrace Exninfo.t = Exninfo.make () + +let pr_frame = function +| FrAnon e -> str "Call {" ++ pr_glbexpr e ++ str "}" +| FrLtac kn -> + str "Call " ++ Libnames.pr_qualid (Tac2env.shortest_qualid_of_ltac (TacConstant kn)) +| FrPrim ml -> + str "Prim <" ++ str ml.mltac_plugin ++ str ":" ++ str ml.mltac_tactic ++ str ">" +| FrExtn (tag, arg) -> + let obj = Tac2env.interp_ml_object tag in + str "Extn " ++ str (Tac2dyn.Arg.repr tag) ++ str ":" ++ spc () ++ + obj.Tac2env.ml_print (Global.env ()) arg + +let () = register_handler begin function +| Tac2interp.LtacError (kn, args) -> + let t_exn = KerName.make Tac2env.coq_prefix (Label.make "exn") in + let v = Tac2ffi.of_open (kn, args) in + let t = GTypRef (Other t_exn, []) in + let c = Tac2print.pr_valexpr (Global.env ()) Evd.empty v t in + hov 0 (str "Uncaught Ltac2 exception:" ++ spc () ++ hov 0 c) +| _ -> raise Unhandled +end + +let () = ExplainErr.register_additional_error_info begin fun (e, info) -> + if !Tac2interp.print_ltac2_backtrace then + let bt = Exninfo.get info backtrace in + let bt = match bt with + | Some bt -> bt + | None -> raise Exit + in + let bt = + str "Backtrace:" ++ fnl () ++ prlist_with_sep fnl pr_frame bt ++ fnl () + in + Some (Loc.tag @@ Some bt) + else raise Exit +end + +(** Printing *) + +let print_ltac qid = + if Tac2env.is_constructor qid then + let kn = + try Tac2env.locate_constructor qid + with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown constructor " ++ pr_qualid qid) + in + let _ = Tac2env.interp_constructor kn in + Feedback.msg_notice (hov 2 (str "Constructor" ++ spc () ++ str ":" ++ spc () ++ pr_qualid qid)) + else + let kn = + try Tac2env.locate_ltac qid + with Not_found -> user_err ?loc:qid.CAst.loc (str "Unknown tactic " ++ pr_qualid qid) + in + match kn with + | TacConstant kn -> + let data = Tac2env.interp_global kn in + let e = data.Tac2env.gdata_expr in + let (_, t) = data.Tac2env.gdata_type in + let name = int_name () in + Feedback.msg_notice ( + hov 0 ( + hov 2 (pr_qualid qid ++ spc () ++ str ":" ++ spc () ++ pr_glbtype name t) ++ fnl () ++ + hov 2 (pr_qualid qid ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr e) + ) + ) + | TacAlias kn -> + Feedback.msg_notice (str "Alias to ...") + +(** Calling tactics *) + +let solve ~pstate default tac = + let pstate, status = Proof_global.with_current_proof begin fun etac p -> + let with_end_tac = if default then Some etac else None in + let g = Goal_select.get_default_goal_selector () in + let (p, status) = Pfedit.solve g None tac ?with_end_tac p in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p, status + end pstate in + if not status then Feedback.feedback Feedback.AddedAxiom; + pstate + +let call ~pstate ~default e = + let loc = e.loc in + let (e, t) = intern ~strict:false e in + let () = check_unit ?loc t in + let tac = Tac2interp.interp Tac2interp.empty_environment e in + solve ~pstate default (Proofview.tclIGNORE tac) + +(** Primitive algebraic types than can't be defined Coq-side *) + +let register_prim_alg name params def = + let id = Id.of_string name in + let def = List.map (fun (cstr, tpe) -> (Id.of_string_soft cstr, tpe)) def in + let getn (const, nonconst) (c, args) = match args with + | [] -> (succ const, nonconst) + | _ :: _ -> (const, succ nonconst) + in + let nconst, nnonconst = List.fold_left getn (0, 0) def in + let alg = { + galg_constructors = def; + galg_nconst = nconst; + galg_nnonconst = nnonconst; + } in + let def = (params, GTydAlg alg) in + let def = { typdef_local = false; typdef_expr = def } in + ignore (Lib.add_leaf id (inTypDef def)) + +let coq_def n = KerName.make Tac2env.coq_prefix (Label.make n) + +let def_unit = { + typdef_local = false; + typdef_expr = 0, GTydDef (Some (GTypRef (Tuple 0, []))); +} + +let t_list = coq_def "list" + +let (f_register_constr_quotations, register_constr_quotations) = Hook.make () + +let cache_ltac2_init (_, ()) = + Hook.get f_register_constr_quotations () + +let load_ltac2_init _ (_, ()) = + Hook.get f_register_constr_quotations () + +let open_ltac2_init _ (_, ()) = + Goptions.set_string_option_value_gen ["Default"; "Proof"; "Mode"] "Ltac2" + +(** Dummy object that register global rules when Require is called *) +let inTac2Init : unit -> obj = + declare_object {(default_object "TAC2-INIT") with + cache_function = cache_ltac2_init; + load_function = load_ltac2_init; + open_function = open_ltac2_init; + } + +let _ = Mltop.declare_cache_obj begin fun () -> + ignore (Lib.add_leaf (Id.of_string "unit") (inTypDef def_unit)); + register_prim_alg "list" 1 [ + ("[]", []); + ("::", [GTypVar 0; GTypRef (Other t_list, [GTypVar 0])]); + ]; + Lib.add_anonymous_leaf (inTac2Init ()); +end "ltac2_plugin" diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli new file mode 100644 index 0000000000..d493192bb3 --- /dev/null +++ b/user-contrib/Ltac2/tac2entries.mli @@ -0,0 +1,93 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Libnames +open Tac2expr + +(** {5 Toplevel definitions} *) + +val register_ltac : ?local:bool -> ?mut:bool -> rec_flag -> + (Names.lname * raw_tacexpr) list -> unit + +val register_type : ?local:bool -> rec_flag -> + (qualid * redef_flag * raw_quant_typedef) list -> unit + +val register_primitive : ?local:bool -> + Names.lident -> raw_typexpr -> ml_tactic_name -> unit + +val register_struct + : ?local:bool + -> pstate:Proof_global.t option + -> strexpr + -> unit + +val register_notation : ?local:bool -> sexpr list -> int option -> + raw_tacexpr -> unit + +(** {5 Notations} *) + +type scope_rule = +| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule + +type scope_interpretation = sexpr list -> scope_rule + +val register_scope : Id.t -> scope_interpretation -> unit +(** Create a new scope with the provided name *) + +val parse_scope : sexpr -> scope_rule +(** Use this to interpret the subscopes for interpretation functions *) + +(** {5 Inspecting} *) + +val print_ltac : Libnames.qualid -> unit + +(** {5 Eval loop} *) + +(** Evaluate a tactic expression in the current environment *) +val call : pstate:Proof_global.t -> default:bool -> raw_tacexpr -> Proof_global.t + +(** {5 Toplevel exceptions} *) + +val backtrace : backtrace Exninfo.t + +(** {5 Parsing entries} *) + +module Pltac : +sig +val tac2expr : raw_tacexpr Pcoq.Entry.t + +(** Quoted entries. To be used for complex notations. *) + +open Tac2qexpr + +val q_ident : Id.t CAst.t or_anti Pcoq.Entry.t +val q_bindings : bindings Pcoq.Entry.t +val q_with_bindings : bindings Pcoq.Entry.t +val q_intropattern : intro_pattern Pcoq.Entry.t +val q_intropatterns : intro_pattern list CAst.t Pcoq.Entry.t +val q_destruction_arg : destruction_arg Pcoq.Entry.t +val q_induction_clause : induction_clause Pcoq.Entry.t +val q_conversion : conversion Pcoq.Entry.t +val q_rewriting : rewriting Pcoq.Entry.t +val q_clause : clause Pcoq.Entry.t +val q_dispatch : dispatch Pcoq.Entry.t +val q_occurrences : occurrences Pcoq.Entry.t +val q_reference : reference or_anti Pcoq.Entry.t +val q_strategy_flag : strategy_flag Pcoq.Entry.t +val q_constr_matching : constr_matching Pcoq.Entry.t +val q_goal_matching : goal_matching Pcoq.Entry.t +val q_hintdb : hintdb Pcoq.Entry.t +val q_move_location : move_location Pcoq.Entry.t +val q_pose : pose Pcoq.Entry.t +val q_assert : assertion Pcoq.Entry.t +end + +(** {5 Hooks} *) + +val register_constr_quotations : (unit -> unit) Hook.t diff --git a/user-contrib/Ltac2/tac2env.ml b/user-contrib/Ltac2/tac2env.ml new file mode 100644 index 0000000000..93ad57e97e --- /dev/null +++ b/user-contrib/Ltac2/tac2env.ml @@ -0,0 +1,298 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Libnames +open Tac2expr +open Tac2ffi + +type global_data = { + gdata_expr : glb_tacexpr; + gdata_type : type_scheme; + gdata_mutable : bool; +} + +type constructor_data = { + cdata_prms : int; + cdata_type : type_constant; + cdata_args : int glb_typexpr list; + cdata_indx : int option; +} + +type projection_data = { + pdata_prms : int; + pdata_type : type_constant; + pdata_ptyp : int glb_typexpr; + pdata_mutb : bool; + pdata_indx : int; +} + +type ltac_state = { + ltac_tactics : global_data KNmap.t; + ltac_constructors : constructor_data KNmap.t; + ltac_projections : projection_data KNmap.t; + ltac_types : glb_quant_typedef KNmap.t; + ltac_aliases : raw_tacexpr KNmap.t; +} + +let empty_state = { + ltac_tactics = KNmap.empty; + ltac_constructors = KNmap.empty; + ltac_projections = KNmap.empty; + ltac_types = KNmap.empty; + ltac_aliases = KNmap.empty; +} + +let ltac_state = Summary.ref empty_state ~name:"ltac2-state" + +let define_global kn e = + let state = !ltac_state in + ltac_state := { state with ltac_tactics = KNmap.add kn e state.ltac_tactics } + +let interp_global kn = + let data = KNmap.find kn ltac_state.contents.ltac_tactics in + data + +let define_constructor kn t = + let state = !ltac_state in + ltac_state := { state with ltac_constructors = KNmap.add kn t state.ltac_constructors } + +let interp_constructor kn = KNmap.find kn ltac_state.contents.ltac_constructors + +let define_projection kn t = + let state = !ltac_state in + ltac_state := { state with ltac_projections = KNmap.add kn t state.ltac_projections } + +let interp_projection kn = KNmap.find kn ltac_state.contents.ltac_projections + +let define_type kn e = + let state = !ltac_state in + ltac_state := { state with ltac_types = KNmap.add kn e state.ltac_types } + +let interp_type kn = KNmap.find kn ltac_state.contents.ltac_types + +let define_alias kn tac = + let state = !ltac_state in + ltac_state := { state with ltac_aliases = KNmap.add kn tac state.ltac_aliases } + +let interp_alias kn = KNmap.find kn ltac_state.contents.ltac_aliases + +module ML = +struct + type t = ml_tactic_name + let compare n1 n2 = + let c = String.compare n1.mltac_plugin n2.mltac_plugin in + if Int.equal c 0 then String.compare n1.mltac_tactic n2.mltac_tactic + else c +end + +module MLMap = Map.Make(ML) + +let primitive_map = ref MLMap.empty + +let define_primitive name f = primitive_map := MLMap.add name f !primitive_map +let interp_primitive name = MLMap.find name !primitive_map + +(** Name management *) + +module FullPath = +struct + type t = full_path + let equal = eq_full_path + let to_string = string_of_path + let repr sp = + let dir,id = repr_path sp in + id, (DirPath.repr dir) +end + +type tacref = Tac2expr.tacref = +| TacConstant of ltac_constant +| TacAlias of ltac_alias + +module TacRef = +struct +type t = tacref +let compare r1 r2 = match r1, r2 with +| TacConstant c1, TacConstant c2 -> KerName.compare c1 c2 +| TacAlias c1, TacAlias c2 -> KerName.compare c1 c2 +| TacConstant _, TacAlias _ -> -1 +| TacAlias _, TacConstant _ -> 1 + +let equal r1 r2 = compare r1 r2 == 0 + +end + +module KnTab = Nametab.Make(FullPath)(KerName) +module RfTab = Nametab.Make(FullPath)(TacRef) +module RfMap = Map.Make(TacRef) + +type nametab = { + tab_ltac : RfTab.t; + tab_ltac_rev : full_path RfMap.t; + tab_cstr : KnTab.t; + tab_cstr_rev : full_path KNmap.t; + tab_type : KnTab.t; + tab_type_rev : full_path KNmap.t; + tab_proj : KnTab.t; + tab_proj_rev : full_path KNmap.t; +} + +let empty_nametab = { + tab_ltac = RfTab.empty; + tab_ltac_rev = RfMap.empty; + tab_cstr = KnTab.empty; + tab_cstr_rev = KNmap.empty; + tab_type = KnTab.empty; + tab_type_rev = KNmap.empty; + tab_proj = KnTab.empty; + tab_proj_rev = KNmap.empty; +} + +let nametab = Summary.ref empty_nametab ~name:"ltac2-nametab" + +let push_ltac vis sp kn = + let tab = !nametab in + let tab_ltac = RfTab.push vis sp kn tab.tab_ltac in + let tab_ltac_rev = RfMap.add kn sp tab.tab_ltac_rev in + nametab := { tab with tab_ltac; tab_ltac_rev } + +let locate_ltac qid = + let tab = !nametab in + RfTab.locate qid tab.tab_ltac + +let locate_extended_all_ltac qid = + let tab = !nametab in + RfTab.find_prefixes qid tab.tab_ltac + +let shortest_qualid_of_ltac kn = + let tab = !nametab in + let sp = RfMap.find kn tab.tab_ltac_rev in + RfTab.shortest_qualid Id.Set.empty sp tab.tab_ltac + +let push_constructor vis sp kn = + let tab = !nametab in + let tab_cstr = KnTab.push vis sp kn tab.tab_cstr in + let tab_cstr_rev = KNmap.add kn sp tab.tab_cstr_rev in + nametab := { tab with tab_cstr; tab_cstr_rev } + +let locate_constructor qid = + let tab = !nametab in + KnTab.locate qid tab.tab_cstr + +let locate_extended_all_constructor qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_cstr + +let shortest_qualid_of_constructor kn = + let tab = !nametab in + let sp = KNmap.find kn tab.tab_cstr_rev in + KnTab.shortest_qualid Id.Set.empty sp tab.tab_cstr + +let push_type vis sp kn = + let tab = !nametab in + let tab_type = KnTab.push vis sp kn tab.tab_type in + let tab_type_rev = KNmap.add kn sp tab.tab_type_rev in + nametab := { tab with tab_type; tab_type_rev } + +let locate_type qid = + let tab = !nametab in + KnTab.locate qid tab.tab_type + +let locate_extended_all_type qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_type + +let shortest_qualid_of_type ?loc kn = + let tab = !nametab in + let sp = KNmap.find kn tab.tab_type_rev in + KnTab.shortest_qualid ?loc Id.Set.empty sp tab.tab_type + +let push_projection vis sp kn = + let tab = !nametab in + let tab_proj = KnTab.push vis sp kn tab.tab_proj in + let tab_proj_rev = KNmap.add kn sp tab.tab_proj_rev in + nametab := { tab with tab_proj; tab_proj_rev } + +let locate_projection qid = + let tab = !nametab in + KnTab.locate qid tab.tab_proj + +let locate_extended_all_projection qid = + let tab = !nametab in + KnTab.find_prefixes qid tab.tab_proj + +let shortest_qualid_of_projection kn = + let tab = !nametab in + let sp = KNmap.find kn tab.tab_proj_rev in + KnTab.shortest_qualid Id.Set.empty sp tab.tab_proj + +type 'a or_glb_tacexpr = +| GlbVal of 'a +| GlbTacexpr of glb_tacexpr + +type environment = { + env_ist : valexpr Id.Map.t; +} + +type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr + +type ('a, 'b) ml_object = { + ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; + ml_subst : Mod_subst.substitution -> 'b -> 'b; + ml_interp : environment -> 'b -> valexpr Proofview.tactic; + ml_print : Environ.env -> 'b -> Pp.t; +} + +module MLTypeObj = +struct + type ('a, 'b) t = ('a, 'b) ml_object +end + +module MLType = Tac2dyn.ArgMap(MLTypeObj) + +let ml_object_table = ref MLType.empty + +let define_ml_object t tpe = + ml_object_table := MLType.add t (MLType.Pack tpe) !ml_object_table + +let interp_ml_object t = + try + let MLType.Pack ans = MLType.find t !ml_object_table in + ans + with Not_found -> + CErrors.anomaly Pp.(str "Unknown object type " ++ str (Tac2dyn.Arg.repr t)) + +(** Absolute paths *) + +let coq_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Init"; "Ltac2"])) + +let std_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Std"; "Ltac2"])) + +let ltac1_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Ltac1"; "Ltac2"])) + +(** Generic arguments *) + +let wit_ltac2 = Genarg.make0 "ltac2:value" +let wit_ltac2_quotation = Genarg.make0 "ltac2:quotation" +let () = Geninterp.register_val0 wit_ltac2 None +let () = Geninterp.register_val0 wit_ltac2_quotation None + +let is_constructor qid = + let (_, id) = repr_qualid qid in + let id = Id.to_string id in + assert (String.length id > 0); + match id with + | "true" | "false" -> true (* built-in constructors *) + | _ -> + match id.[0] with + | 'A'..'Z' -> true + | _ -> false diff --git a/user-contrib/Ltac2/tac2env.mli b/user-contrib/Ltac2/tac2env.mli new file mode 100644 index 0000000000..c7e87c5432 --- /dev/null +++ b/user-contrib/Ltac2/tac2env.mli @@ -0,0 +1,146 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Genarg +open Names +open Libnames +open Nametab +open Tac2expr +open Tac2ffi + +(** Ltac2 global environment *) + +(** {5 Toplevel definition of values} *) + +type global_data = { + gdata_expr : glb_tacexpr; + gdata_type : type_scheme; + gdata_mutable : bool; +} + +val define_global : ltac_constant -> global_data -> unit +val interp_global : ltac_constant -> global_data + +(** {5 Toplevel definition of types} *) + +val define_type : type_constant -> glb_quant_typedef -> unit +val interp_type : type_constant -> glb_quant_typedef + +(** {5 Toplevel definition of algebraic constructors} *) + +type constructor_data = { + cdata_prms : int; + (** Type parameters *) + cdata_type : type_constant; + (** Inductive definition to which the constructor pertains *) + cdata_args : int glb_typexpr list; + (** Types of the constructor arguments *) + cdata_indx : int option; + (** Index of the constructor in the ADT. Numbering is duplicated between + argumentless and argument-using constructors, e.g. in type ['a option] + [None] and [Some] have both index 0. This field is empty whenever the + constructor is a member of an open type. *) +} + +val define_constructor : ltac_constructor -> constructor_data -> unit +val interp_constructor : ltac_constructor -> constructor_data + +(** {5 Toplevel definition of projections} *) + +type projection_data = { + pdata_prms : int; + (** Type parameters *) + pdata_type : type_constant; + (** Record definition to which the projection pertains *) + pdata_ptyp : int glb_typexpr; + (** Type of the projection *) + pdata_mutb : bool; + (** Whether the field is mutable *) + pdata_indx : int; + (** Index of the projection *) +} + +val define_projection : ltac_projection -> projection_data -> unit +val interp_projection : ltac_projection -> projection_data + +(** {5 Toplevel definition of aliases} *) + +val define_alias : ltac_constant -> raw_tacexpr -> unit +val interp_alias : ltac_constant -> raw_tacexpr + +(** {5 Name management} *) + +val push_ltac : visibility -> full_path -> tacref -> unit +val locate_ltac : qualid -> tacref +val locate_extended_all_ltac : qualid -> tacref list +val shortest_qualid_of_ltac : tacref -> qualid + +val push_constructor : visibility -> full_path -> ltac_constructor -> unit +val locate_constructor : qualid -> ltac_constructor +val locate_extended_all_constructor : qualid -> ltac_constructor list +val shortest_qualid_of_constructor : ltac_constructor -> qualid + +val push_type : visibility -> full_path -> type_constant -> unit +val locate_type : qualid -> type_constant +val locate_extended_all_type : qualid -> type_constant list +val shortest_qualid_of_type : ?loc:Loc.t -> type_constant -> qualid + +val push_projection : visibility -> full_path -> ltac_projection -> unit +val locate_projection : qualid -> ltac_projection +val locate_extended_all_projection : qualid -> ltac_projection list +val shortest_qualid_of_projection : ltac_projection -> qualid + +(** {5 Toplevel definitions of ML tactics} *) + +(** This state is not part of the summary, contrarily to the ones above. It is + intended to be used from ML plugins to register ML-side functions. *) + +val define_primitive : ml_tactic_name -> closure -> unit +val interp_primitive : ml_tactic_name -> closure + +(** {5 ML primitive types} *) + +type 'a or_glb_tacexpr = +| GlbVal of 'a +| GlbTacexpr of glb_tacexpr + +type ('a, 'b, 'r) intern_fun = Genintern.glob_sign -> 'a -> 'b * 'r glb_typexpr + +type environment = { + env_ist : valexpr Id.Map.t; +} + +type ('a, 'b) ml_object = { + ml_intern : 'r. (raw_tacexpr, glb_tacexpr, 'r) intern_fun -> ('a, 'b or_glb_tacexpr, 'r) intern_fun; + ml_subst : Mod_subst.substitution -> 'b -> 'b; + ml_interp : environment -> 'b -> valexpr Proofview.tactic; + ml_print : Environ.env -> 'b -> Pp.t; +} + +val define_ml_object : ('a, 'b) Tac2dyn.Arg.tag -> ('a, 'b) ml_object -> unit +val interp_ml_object : ('a, 'b) Tac2dyn.Arg.tag -> ('a, 'b) ml_object + +(** {5 Absolute paths} *) + +val coq_prefix : ModPath.t +(** Path where primitive datatypes are defined in Ltac2 plugin. *) + +val std_prefix : ModPath.t +(** Path where Ltac-specific datatypes are defined in Ltac2 plugin. *) + +val ltac1_prefix : ModPath.t +(** Path where the Ltac1 legacy FFI is defined. *) + +(** {5 Generic arguments} *) + +val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type +val wit_ltac2_quotation : (Id.t Loc.located, Id.t, Util.Empty.t) genarg_type + +(** {5 Helper functions} *) + +val is_constructor : qualid -> bool diff --git a/user-contrib/Ltac2/tac2expr.mli b/user-contrib/Ltac2/tac2expr.mli new file mode 100644 index 0000000000..1069d0bfa3 --- /dev/null +++ b/user-contrib/Ltac2/tac2expr.mli @@ -0,0 +1,190 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Libnames + +type mutable_flag = bool +type rec_flag = bool +type redef_flag = bool +type lid = Id.t +type uid = Id.t + +type ltac_constant = KerName.t +type ltac_alias = KerName.t +type ltac_constructor = KerName.t +type ltac_projection = KerName.t +type type_constant = KerName.t + +type tacref = +| TacConstant of ltac_constant +| TacAlias of ltac_alias + +type 'a or_relid = +| RelId of qualid +| AbsKn of 'a + +(** {5 Misc} *) + +type ml_tactic_name = { + mltac_plugin : string; + mltac_tactic : string; +} + +type 'a or_tuple = +| Tuple of int +| Other of 'a + +(** {5 Type syntax} *) + +type raw_typexpr_r = +| CTypVar of Name.t +| CTypArrow of raw_typexpr * raw_typexpr +| CTypRef of type_constant or_tuple or_relid * raw_typexpr list + +and raw_typexpr = raw_typexpr_r CAst.t + +type raw_typedef = +| CTydDef of raw_typexpr option +| CTydAlg of (uid * raw_typexpr list) list +| CTydRec of (lid * mutable_flag * raw_typexpr) list +| CTydOpn + +type 'a glb_typexpr = +| GTypVar of 'a +| GTypArrow of 'a glb_typexpr * 'a glb_typexpr +| GTypRef of type_constant or_tuple * 'a glb_typexpr list + +type glb_alg_type = { + galg_constructors : (uid * int glb_typexpr list) list; + (** Constructors of the algebraic type *) + galg_nconst : int; + (** Number of constant constructors *) + galg_nnonconst : int; + (** Number of non-constant constructors *) +} + +type glb_typedef = +| GTydDef of int glb_typexpr option +| GTydAlg of glb_alg_type +| GTydRec of (lid * mutable_flag * int glb_typexpr) list +| GTydOpn + +type type_scheme = int * int glb_typexpr + +type raw_quant_typedef = Names.lident list * raw_typedef +type glb_quant_typedef = int * glb_typedef + +(** {5 Term syntax} *) + +type atom = +| AtmInt of int +| AtmStr of string + +(** Tactic expressions *) +type raw_patexpr_r = +| CPatVar of Name.t +| CPatRef of ltac_constructor or_tuple or_relid * raw_patexpr list +| CPatCnv of raw_patexpr * raw_typexpr + +and raw_patexpr = raw_patexpr_r CAst.t + +type raw_tacexpr_r = +| CTacAtm of atom +| CTacRef of tacref or_relid +| CTacCst of ltac_constructor or_tuple or_relid +| CTacFun of raw_patexpr list * raw_tacexpr +| CTacApp of raw_tacexpr * raw_tacexpr list +| CTacLet of rec_flag * (raw_patexpr * raw_tacexpr) list * raw_tacexpr +| CTacCnv of raw_tacexpr * raw_typexpr +| CTacSeq of raw_tacexpr * raw_tacexpr +| CTacCse of raw_tacexpr * raw_taccase list +| CTacRec of raw_recexpr +| CTacPrj of raw_tacexpr * ltac_projection or_relid +| CTacSet of raw_tacexpr * ltac_projection or_relid * raw_tacexpr +| CTacExt : ('a, _) Tac2dyn.Arg.tag * 'a -> raw_tacexpr_r + +and raw_tacexpr = raw_tacexpr_r CAst.t + +and raw_taccase = raw_patexpr * raw_tacexpr + +and raw_recexpr = (ltac_projection or_relid * raw_tacexpr) list + +type case_info = type_constant or_tuple + +type 'a open_match = { + opn_match : 'a; + opn_branch : (Name.t * Name.t array * 'a) KNmap.t; + (** Invariant: should not be empty *) + opn_default : Name.t * 'a; +} + +type glb_tacexpr = +| GTacAtm of atom +| GTacVar of Id.t +| GTacRef of ltac_constant +| GTacFun of Name.t list * glb_tacexpr +| GTacApp of glb_tacexpr * glb_tacexpr list +| GTacLet of rec_flag * (Name.t * glb_tacexpr) list * glb_tacexpr +| GTacCst of case_info * int * glb_tacexpr list +| GTacCse of glb_tacexpr * case_info * glb_tacexpr array * (Name.t array * glb_tacexpr) array +| GTacPrj of type_constant * glb_tacexpr * int +| GTacSet of type_constant * glb_tacexpr * int * glb_tacexpr +| GTacOpn of ltac_constructor * glb_tacexpr list +| GTacWth of glb_tacexpr open_match +| GTacExt : (_, 'a) Tac2dyn.Arg.tag * 'a -> glb_tacexpr +| GTacPrm of ml_tactic_name * glb_tacexpr list + +(** {5 Parsing & Printing} *) + +type exp_level = +| E5 +| E4 +| E3 +| E2 +| E1 +| E0 + +type sexpr = +| SexprStr of string CAst.t +| SexprInt of int CAst.t +| SexprRec of Loc.t * Id.t option CAst.t * sexpr list + +(** {5 Toplevel statements} *) + +type strexpr = +| StrVal of mutable_flag * rec_flag * (Names.lname * raw_tacexpr) list + (** Term definition *) +| StrTyp of rec_flag * (qualid * redef_flag * raw_quant_typedef) list + (** Type definition *) +| StrPrm of Names.lident * raw_typexpr * ml_tactic_name + (** External definition *) +| StrSyn of sexpr list * int option * raw_tacexpr + (** Syntactic extensions *) +| StrMut of qualid * raw_tacexpr + (** Redefinition of mutable globals *) +| StrRun of raw_tacexpr + (** Toplevel evaluation of an expression *) + +(** {5 Dynamic semantics} *) + +(** Values are represented in a way similar to OCaml, i.e. they constrast + immediate integers (integers, constructors without arguments) and structured + blocks (tuples, arrays, constructors with arguments), as well as a few other + base cases, namely closures, strings, named constructors, and dynamic type + coming from the Coq implementation. *) + +type tag = int + +type frame = +| FrLtac of ltac_constant +| FrAnon of glb_tacexpr +| FrPrim of ml_tactic_name +| FrExtn : ('a, 'b) Tac2dyn.Arg.tag * 'b -> frame + +type backtrace = frame list diff --git a/user-contrib/Ltac2/tac2extffi.ml b/user-contrib/Ltac2/tac2extffi.ml new file mode 100644 index 0000000000..315c970f9e --- /dev/null +++ b/user-contrib/Ltac2/tac2extffi.ml @@ -0,0 +1,40 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Tac2ffi +open Tac2types + +module Value = Tac2ffi + +(** Make a representation with a dummy from function *) +let make_to_repr f = Tac2ffi.make_repr (fun _ -> assert false) f + +(** More ML representations *) + +let to_qhyp v = match Value.to_block v with +| (0, [| i |]) -> AnonHyp (Value.to_int i) +| (1, [| id |]) -> NamedHyp (Value.to_ident id) +| _ -> assert false + +let qhyp = make_to_repr to_qhyp + +let to_bindings = function +| ValInt 0 -> NoBindings +| ValBlk (0, [| vl |]) -> + ImplicitBindings (Value.to_list Value.to_constr vl) +| ValBlk (1, [| vl |]) -> + ExplicitBindings ((Value.to_list (fun p -> to_pair to_qhyp Value.to_constr p) vl)) +| _ -> assert false + +let bindings = make_to_repr to_bindings + +let to_constr_with_bindings v = match Value.to_tuple v with +| [| c; bnd |] -> (Value.to_constr c, to_bindings bnd) +| _ -> assert false + +let constr_with_bindings = make_to_repr to_constr_with_bindings diff --git a/user-contrib/Ltac2/tac2extffi.mli b/user-contrib/Ltac2/tac2extffi.mli new file mode 100644 index 0000000000..f5251c3d0d --- /dev/null +++ b/user-contrib/Ltac2/tac2extffi.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Tac2ffi +open Tac2types + +val qhyp : quantified_hypothesis repr + +val bindings : bindings repr + +val constr_with_bindings : constr_with_bindings repr diff --git a/user-contrib/Ltac2/tac2ffi.ml b/user-contrib/Ltac2/tac2ffi.ml new file mode 100644 index 0000000000..e3127ab9df --- /dev/null +++ b/user-contrib/Ltac2/tac2ffi.ml @@ -0,0 +1,382 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Globnames +open Tac2dyn +open Tac2expr +open Proofview.Notations + +type ('a, _) arity0 = +| OneAty : ('a, 'a -> 'a Proofview.tactic) arity0 +| AddAty : ('a, 'b) arity0 -> ('a, 'a -> 'b) arity0 + +type valexpr = +| ValInt of int + (** Immediate integers *) +| ValBlk of tag * valexpr array + (** Structured blocks *) +| ValStr of Bytes.t + (** Strings *) +| ValCls of closure + (** Closures *) +| ValOpn of KerName.t * valexpr array + (** Open constructors *) +| ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr + (** Arbitrary data *) + +and closure = MLTactic : (valexpr, 'v) arity0 * 'v -> closure + +let arity_one = OneAty +let arity_suc a = AddAty a + +type 'a arity = (valexpr, 'a) arity0 + +let mk_closure arity f = MLTactic (arity, f) + +module Valexpr = +struct + +type t = valexpr + +let is_int = function +| ValInt _ -> true +| ValBlk _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> false + +let tag v = match v with +| ValBlk (n, _) -> n +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> + CErrors.anomaly (Pp.str "Unexpected value shape") + +let field v n = match v with +| ValBlk (_, v) -> v.(n) +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> + CErrors.anomaly (Pp.str "Unexpected value shape") + +let set_field v n w = match v with +| ValBlk (_, v) -> v.(n) <- w +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> + CErrors.anomaly (Pp.str "Unexpected value shape") + +let make_block tag v = ValBlk (tag, v) +let make_int n = ValInt n + +end + +type 'a repr = { + r_of : 'a -> valexpr; + r_to : valexpr -> 'a; + r_id : bool; +} + +let repr_of r x = r.r_of x +let repr_to r x = r.r_to x + +let make_repr r_of r_to = { r_of; r_to; r_id = false; } + +(** Dynamic tags *) + +let val_exn = Val.create "exn" +let val_constr = Val.create "constr" +let val_ident = Val.create "ident" +let val_pattern = Val.create "pattern" +let val_pp = Val.create "pp" +let val_sort = Val.create "sort" +let val_cast = Val.create "cast" +let val_inductive = Val.create "inductive" +let val_constant = Val.create "constant" +let val_constructor = Val.create "constructor" +let val_projection = Val.create "projection" +let val_case = Val.create "case" +let val_univ = Val.create "universe" +let val_free : Names.Id.Set.t Val.tag = Val.create "free" +let val_ltac1 : Geninterp.Val.t Val.tag = Val.create "ltac1" + +let extract_val (type a) (type b) (tag : a Val.tag) (tag' : b Val.tag) (v : b) : a = +match Val.eq tag tag' with +| None -> assert false +| Some Refl -> v + +(** Exception *) + +exception LtacError of KerName.t * valexpr array + +(** Conversion functions *) + +let valexpr = { + r_of = (fun obj -> obj); + r_to = (fun obj -> obj); + r_id = true; +} + +let of_unit () = ValInt 0 + +let to_unit = function +| ValInt 0 -> () +| _ -> assert false + +let unit = { + r_of = of_unit; + r_to = to_unit; + r_id = false; +} + +let of_int n = ValInt n +let to_int = function +| ValInt n -> n +| _ -> assert false + +let int = { + r_of = of_int; + r_to = to_int; + r_id = false; +} + +let of_bool b = if b then ValInt 0 else ValInt 1 + +let to_bool = function +| ValInt 0 -> true +| ValInt 1 -> false +| _ -> assert false + +let bool = { + r_of = of_bool; + r_to = to_bool; + r_id = false; +} + +let of_char n = ValInt (Char.code n) +let to_char = function +| ValInt n -> Char.chr n +| _ -> assert false + +let char = { + r_of = of_char; + r_to = to_char; + r_id = false; +} + +let of_string s = ValStr s +let to_string = function +| ValStr s -> s +| _ -> assert false + +let string = { + r_of = of_string; + r_to = to_string; + r_id = false; +} + +let rec of_list f = function +| [] -> ValInt 0 +| x :: l -> ValBlk (0, [| f x; of_list f l |]) + +let rec to_list f = function +| ValInt 0 -> [] +| ValBlk (0, [|v; vl|]) -> f v :: to_list f vl +| _ -> assert false + +let list r = { + r_of = (fun l -> of_list r.r_of l); + r_to = (fun l -> to_list r.r_to l); + r_id = false; +} + +let of_closure cls = ValCls cls + +let to_closure = function +| ValCls cls -> cls +| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ -> assert false + +let closure = { + r_of = of_closure; + r_to = to_closure; + r_id = false; +} + +let of_ext tag c = + ValExt (tag, c) + +let to_ext tag = function +| ValExt (tag', e) -> extract_val tag tag' e +| _ -> assert false + +let repr_ext tag = { + r_of = (fun e -> of_ext tag e); + r_to = (fun e -> to_ext tag e); + r_id = false; +} + +let of_constr c = of_ext val_constr c +let to_constr c = to_ext val_constr c +let constr = repr_ext val_constr + +let of_ident c = of_ext val_ident c +let to_ident c = to_ext val_ident c +let ident = repr_ext val_ident + +let of_pattern c = of_ext val_pattern c +let to_pattern c = to_ext val_pattern c +let pattern = repr_ext val_pattern + +let internal_err = + let open Names in + let coq_prefix = + MPfile (DirPath.make (List.map Id.of_string ["Init"; "Ltac2"])) + in + KerName.make coq_prefix (Label.of_id (Id.of_string "Internal")) + +(** FIXME: handle backtrace in Ltac2 exceptions *) +let of_exn c = match fst c with +| LtacError (kn, c) -> ValOpn (kn, c) +| _ -> ValOpn (internal_err, [|of_ext val_exn c|]) + +let to_exn c = match c with +| ValOpn (kn, c) -> + if Names.KerName.equal kn internal_err then + to_ext val_exn c.(0) + else + (LtacError (kn, c), Exninfo.null) +| _ -> assert false + +let exn = { + r_of = of_exn; + r_to = to_exn; + r_id = false; +} + +let of_option f = function +| None -> ValInt 0 +| Some c -> ValBlk (0, [|f c|]) + +let to_option f = function +| ValInt 0 -> None +| ValBlk (0, [|c|]) -> Some (f c) +| _ -> assert false + +let option r = { + r_of = (fun l -> of_option r.r_of l); + r_to = (fun l -> to_option r.r_to l); + r_id = false; +} + +let of_pp c = of_ext val_pp c +let to_pp c = to_ext val_pp c +let pp = repr_ext val_pp + +let of_tuple cl = ValBlk (0, cl) +let to_tuple = function +| ValBlk (0, cl) -> cl +| _ -> assert false + +let of_pair f g (x, y) = ValBlk (0, [|f x; g y|]) +let to_pair f g = function +| ValBlk (0, [|x; y|]) -> (f x, g y) +| _ -> assert false +let pair r0 r1 = { + r_of = (fun p -> of_pair r0.r_of r1.r_of p); + r_to = (fun p -> to_pair r0.r_to r1.r_to p); + r_id = false; +} + +let of_array f vl = ValBlk (0, Array.map f vl) +let to_array f = function +| ValBlk (0, vl) -> Array.map f vl +| _ -> assert false +let array r = { + r_of = (fun l -> of_array r.r_of l); + r_to = (fun l -> to_array r.r_to l); + r_id = false; +} + +let of_block (n, args) = ValBlk (n, args) +let to_block = function +| ValBlk (n, args) -> (n, args) +| _ -> assert false + +let block = { + r_of = of_block; + r_to = to_block; + r_id = false; +} + +let of_open (kn, args) = ValOpn (kn, args) + +let to_open = function +| ValOpn (kn, args) -> (kn, args) +| _ -> assert false + +let open_ = { + r_of = of_open; + r_to = to_open; + r_id = false; +} + +let of_constant c = of_ext val_constant c +let to_constant c = to_ext val_constant c +let constant = repr_ext val_constant + +let of_reference = function +| VarRef id -> ValBlk (0, [| of_ident id |]) +| ConstRef cst -> ValBlk (1, [| of_constant cst |]) +| IndRef ind -> ValBlk (2, [| of_ext val_inductive ind |]) +| ConstructRef cstr -> ValBlk (3, [| of_ext val_constructor cstr |]) + +let to_reference = function +| ValBlk (0, [| id |]) -> VarRef (to_ident id) +| ValBlk (1, [| cst |]) -> ConstRef (to_constant cst) +| ValBlk (2, [| ind |]) -> IndRef (to_ext val_inductive ind) +| ValBlk (3, [| cstr |]) -> ConstructRef (to_ext val_constructor cstr) +| _ -> assert false + +let reference = { + r_of = of_reference; + r_to = to_reference; + r_id = false; +} + +type ('a, 'b) fun1 = closure + +let fun1 (r0 : 'a repr) (r1 : 'b repr) : ('a, 'b) fun1 repr = closure +let to_fun1 r0 r1 f = to_closure f + +let rec apply : type a. a arity -> a -> valexpr list -> valexpr Proofview.tactic = + fun arity f args -> match args, arity with + | [], arity -> Proofview.tclUNIT (ValCls (MLTactic (arity, f))) + (* A few hardcoded cases for efficiency *) + | [a0], OneAty -> f a0 + | [a0; a1], AddAty OneAty -> f a0 a1 + | [a0; a1; a2], AddAty (AddAty OneAty) -> f a0 a1 a2 + | [a0; a1; a2; a3], AddAty (AddAty (AddAty OneAty)) -> f a0 a1 a2 a3 + (* Generic cases *) + | a :: args, OneAty -> + f a >>= fun f -> + let MLTactic (arity, f) = to_closure f in + apply arity f args + | a :: args, AddAty arity -> + apply arity (f a) args + +let apply (MLTactic (arity, f)) args = apply arity f args + +type n_closure = +| NClosure : 'a arity * (valexpr list -> 'a) -> n_closure + +let rec abstract n f = + if Int.equal n 1 then NClosure (OneAty, fun accu v -> f (List.rev (v :: accu))) + else + let NClosure (arity, fe) = abstract (n - 1) f in + NClosure (AddAty arity, fun accu v -> fe (v :: accu)) + +let abstract n f = + let () = assert (n > 0) in + let NClosure (arity, f) = abstract n f in + MLTactic (arity, f []) + +let app_fun1 cls r0 r1 x = + apply cls [r0.r_of x] >>= fun v -> Proofview.tclUNIT (r1.r_to v) diff --git a/user-contrib/Ltac2/tac2ffi.mli b/user-contrib/Ltac2/tac2ffi.mli new file mode 100644 index 0000000000..bfc93d99e6 --- /dev/null +++ b/user-contrib/Ltac2/tac2ffi.mli @@ -0,0 +1,189 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open EConstr +open Tac2dyn +open Tac2expr + +(** {5 Toplevel values} *) + +type closure + +type valexpr = +| ValInt of int + (** Immediate integers *) +| ValBlk of tag * valexpr array + (** Structured blocks *) +| ValStr of Bytes.t + (** Strings *) +| ValCls of closure + (** Closures *) +| ValOpn of KerName.t * valexpr array + (** Open constructors *) +| ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr + (** Arbitrary data *) + +type 'a arity + +val arity_one : (valexpr -> valexpr Proofview.tactic) arity +val arity_suc : 'a arity -> (valexpr -> 'a) arity + +val mk_closure : 'v arity -> 'v -> closure + +module Valexpr : +sig + type t = valexpr + val is_int : t -> bool + val tag : t -> int + val field : t -> int -> t + val set_field : t -> int -> t -> unit + val make_block : int -> t array -> t + val make_int : int -> t +end + +(** {5 Ltac2 FFI} *) + +type 'a repr + +val repr_of : 'a repr -> 'a -> valexpr +val repr_to : 'a repr -> valexpr -> 'a + +val make_repr : ('a -> valexpr) -> (valexpr -> 'a) -> 'a repr + +(** These functions allow to convert back and forth between OCaml and Ltac2 + data representation. The [to_*] functions raise an anomaly whenever the data + has not expected shape. *) + +val of_unit : unit -> valexpr +val to_unit : valexpr -> unit +val unit : unit repr + +val of_int : int -> valexpr +val to_int : valexpr -> int +val int : int repr + +val of_bool : bool -> valexpr +val to_bool : valexpr -> bool +val bool : bool repr + +val of_char : char -> valexpr +val to_char : valexpr -> char +val char : char repr + +val of_string : Bytes.t -> valexpr +val to_string : valexpr -> Bytes.t +val string : Bytes.t repr + +val of_list : ('a -> valexpr) -> 'a list -> valexpr +val to_list : (valexpr -> 'a) -> valexpr -> 'a list +val list : 'a repr -> 'a list repr + +val of_constr : EConstr.t -> valexpr +val to_constr : valexpr -> EConstr.t +val constr : EConstr.t repr + +val of_exn : Exninfo.iexn -> valexpr +val to_exn : valexpr -> Exninfo.iexn +val exn : Exninfo.iexn repr + +val of_ident : Id.t -> valexpr +val to_ident : valexpr -> Id.t +val ident : Id.t repr + +val of_closure : closure -> valexpr +val to_closure : valexpr -> closure +val closure : closure repr + +val of_block : (int * valexpr array) -> valexpr +val to_block : valexpr -> (int * valexpr array) +val block : (int * valexpr array) repr + +val of_array : ('a -> valexpr) -> 'a array -> valexpr +val to_array : (valexpr -> 'a) -> valexpr -> 'a array +val array : 'a repr -> 'a array repr + +val of_tuple : valexpr array -> valexpr +val to_tuple : valexpr -> valexpr array + +val of_pair : ('a -> valexpr) -> ('b -> valexpr) -> 'a * 'b -> valexpr +val to_pair : (valexpr -> 'a) -> (valexpr -> 'b) -> valexpr -> 'a * 'b +val pair : 'a repr -> 'b repr -> ('a * 'b) repr + +val of_option : ('a -> valexpr) -> 'a option -> valexpr +val to_option : (valexpr -> 'a) -> valexpr -> 'a option +val option : 'a repr -> 'a option repr + +val of_pattern : Pattern.constr_pattern -> valexpr +val to_pattern : valexpr -> Pattern.constr_pattern +val pattern : Pattern.constr_pattern repr + +val of_pp : Pp.t -> valexpr +val to_pp : valexpr -> Pp.t +val pp : Pp.t repr + +val of_constant : Constant.t -> valexpr +val to_constant : valexpr -> Constant.t +val constant : Constant.t repr + +val of_reference : GlobRef.t -> valexpr +val to_reference : valexpr -> GlobRef.t +val reference : GlobRef.t repr + +val of_ext : 'a Val.tag -> 'a -> valexpr +val to_ext : 'a Val.tag -> valexpr -> 'a +val repr_ext : 'a Val.tag -> 'a repr + +val of_open : KerName.t * valexpr array -> valexpr +val to_open : valexpr -> KerName.t * valexpr array +val open_ : (KerName.t * valexpr array) repr + +type ('a, 'b) fun1 + +val app_fun1 : ('a, 'b) fun1 -> 'a repr -> 'b repr -> 'a -> 'b Proofview.tactic + +val to_fun1 : 'a repr -> 'b repr -> valexpr -> ('a, 'b) fun1 +val fun1 : 'a repr -> 'b repr -> ('a, 'b) fun1 repr + +val valexpr : valexpr repr + +(** {5 Dynamic tags} *) + +val val_constr : EConstr.t Val.tag +val val_ident : Id.t Val.tag +val val_pattern : Pattern.constr_pattern Val.tag +val val_pp : Pp.t Val.tag +val val_sort : ESorts.t Val.tag +val val_cast : Constr.cast_kind Val.tag +val val_inductive : inductive Val.tag +val val_constant : Constant.t Val.tag +val val_constructor : constructor Val.tag +val val_projection : Projection.t Val.tag +val val_case : Constr.case_info Val.tag +val val_univ : Univ.Level.t Val.tag +val val_free : Id.Set.t Val.tag +val val_ltac1 : Geninterp.Val.t Val.tag + +val val_exn : Exninfo.iexn Tac2dyn.Val.tag +(** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] + should be put into a value with tag [val_exn]. *) + +(** Closures *) + +val apply : closure -> valexpr list -> valexpr Proofview.tactic +(** Given a closure, apply it to some arguments. Handling of argument mismatches + is done automatically, i.e. in case of over or under-application. *) + +val abstract : int -> (valexpr list -> valexpr Proofview.tactic) -> closure +(** Turn a fixed-arity function into a closure. The inner function is guaranteed + to be applied to a list whose size is the integer argument. *) + +(** Exception *) + +exception LtacError of KerName.t * valexpr array +(** Ltac2-defined exceptions seen from OCaml side *) diff --git a/user-contrib/Ltac2/tac2intern.ml b/user-contrib/Ltac2/tac2intern.ml new file mode 100644 index 0000000000..de99fb167f --- /dev/null +++ b/user-contrib/Ltac2/tac2intern.ml @@ -0,0 +1,1545 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open Util +open CAst +open CErrors +open Names +open Libnames +open Locus +open Tac2env +open Tac2print +open Tac2expr + +(** Hardwired types and constants *) + +let coq_type n = KerName.make Tac2env.coq_prefix (Label.make n) + +let t_int = coq_type "int" +let t_string = coq_type "string" +let t_constr = coq_type "constr" + +(** Union find *) + +module UF : +sig +type elt +type 'a t +val equal : elt -> elt -> bool +val create : unit -> 'a t +val fresh : 'a t -> elt +val find : elt -> 'a t -> (elt * 'a option) +val union : elt -> elt -> 'a t -> unit +val set : elt -> 'a -> 'a t -> unit +module Map : +sig + type key = elt + type +'a t + val empty : 'a t + val add : key -> 'a -> 'a t -> 'a t + val mem : key -> 'a t -> bool + val find : key -> 'a t -> 'a + val exists : (key -> 'a -> bool) -> 'a t -> bool +end +end += +struct +type elt = int +let equal = Int.equal +module Map = Int.Map + +type 'a node = +| Canon of int * 'a option +| Equiv of elt + +type 'a t = { + mutable uf_data : 'a node array; + mutable uf_size : int; +} + +let resize p = + if Int.equal (Array.length p.uf_data) p.uf_size then begin + let nsize = 2 * p.uf_size + 1 in + let v = Array.make nsize (Equiv 0) in + Array.blit p.uf_data 0 v 0 (Array.length p.uf_data); + p.uf_data <- v; + end + +let create () = { uf_data = [||]; uf_size = 0 } + +let fresh p = + resize p; + let n = p.uf_size in + p.uf_data.(n) <- (Canon (1, None)); + p.uf_size <- n + 1; + n + +let rec lookup n p = + let node = Array.get p.uf_data n in + match node with + | Canon (size, v) -> n, size, v + | Equiv y -> + let ((z, _, _) as res) = lookup y p in + if not (Int.equal z y) then Array.set p.uf_data n (Equiv z); + res + +let find n p = + let (x, _, v) = lookup n p in (x, v) + +let union x y p = + let ((x, size1, _) as xcan) = lookup x p in + let ((y, size2, _) as ycan) = lookup y p in + let xcan, ycan = if size1 < size2 then xcan, ycan else ycan, xcan in + let x, _, xnode = xcan in + let y, _, ynode = ycan in + assert (Option.is_empty xnode); + assert (Option.is_empty ynode); + p.uf_data.(x) <- Equiv y; + p.uf_data.(y) <- Canon (size1 + size2, None) + +let set x v p = + let (x, s, v') = lookup x p in + assert (Option.is_empty v'); + p.uf_data.(x) <- Canon (s, Some v) + +end + +type mix_var = +| GVar of UF.elt +| LVar of int + +type mix_type_scheme = int * mix_var glb_typexpr + +type environment = { + env_var : mix_type_scheme Id.Map.t; + (** Type schemes of bound variables *) + env_cst : UF.elt glb_typexpr UF.t; + (** Unification state *) + env_als : UF.elt Id.Map.t ref; + (** Map user-facing type variables to unification variables *) + env_opn : bool; + (** Accept unbound type variables *) + env_rec : (KerName.t * int) Id.Map.t; + (** Recursive type definitions *) + env_str : bool; + (** True iff in strict mode *) +} + +let empty_env () = { + env_var = Id.Map.empty; + env_cst = UF.create (); + env_als = ref Id.Map.empty; + env_opn = true; + env_rec = Id.Map.empty; + env_str = true; +} + +let env_name env = + (* Generate names according to a provided environment *) + let mk num = + let base = num mod 26 in + let rem = num / 26 in + let name = String.make 1 (Char.chr (97 + base)) in + let suff = if Int.equal rem 0 then "" else string_of_int rem in + let name = name ^ suff in + name + in + let fold id elt acc = UF.Map.add elt (Id.to_string id) acc in + let vars = Id.Map.fold fold env.env_als.contents UF.Map.empty in + let vars = ref vars in + let rec fresh n = + let name = mk n in + if UF.Map.exists (fun _ name' -> String.equal name name') !vars then fresh (succ n) + else name + in + fun n -> + if UF.Map.mem n !vars then UF.Map.find n !vars + else + let ans = fresh 0 in + let () = vars := UF.Map.add n ans !vars in + ans + +let ltac2_env : environment Genintern.Store.field = + Genintern.Store.field () + +let drop_ltac2_env store = + Genintern.Store.remove store ltac2_env + +let fresh_id env = UF.fresh env.env_cst + +let get_alias {loc;v=id} env = + try Id.Map.find id env.env_als.contents + with Not_found -> + if env.env_opn then + let n = fresh_id env in + let () = env.env_als := Id.Map.add id n env.env_als.contents in + n + else user_err ?loc (str "Unbound type parameter " ++ Id.print id) + +let push_name id t env = match id with +| Anonymous -> env +| Name id -> { env with env_var = Id.Map.add id t env.env_var } + +let error_nargs_mismatch ?loc kn nargs nfound = + let cstr = Tac2env.shortest_qualid_of_constructor kn in + user_err ?loc (str "Constructor " ++ pr_qualid cstr ++ str " expects " ++ + int nargs ++ str " arguments, but is applied to " ++ int nfound ++ + str " arguments") + +let error_nparams_mismatch ?loc nargs nfound = + user_err ?loc (str "Type expects " ++ int nargs ++ + str " arguments, but is applied to " ++ int nfound ++ + str " arguments") + +let rec subst_type subst (t : 'a glb_typexpr) = match t with +| GTypVar id -> subst id +| GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) +| GTypRef (qid, args) -> + GTypRef (qid, List.map (fun t -> subst_type subst t) args) + +let rec intern_type env ({loc;v=t} : raw_typexpr) : UF.elt glb_typexpr = match t with +| CTypVar (Name id) -> GTypVar (get_alias (CAst.make ?loc id) env) +| CTypVar Anonymous -> GTypVar (fresh_id env) +| CTypRef (rel, args) -> + let (kn, nparams) = match rel with + | RelId qid -> + let id = qualid_basename qid in + if qualid_is_ident qid && Id.Map.mem id env.env_rec then + let (kn, n) = Id.Map.find id env.env_rec in + (Other kn, n) + else + let kn = + try Tac2env.locate_type qid + with Not_found -> + user_err ?loc (str "Unbound type constructor " ++ pr_qualid qid) + in + let (nparams, _) = Tac2env.interp_type kn in + (Other kn, nparams) + | AbsKn (Other kn) -> + let (nparams, _) = Tac2env.interp_type kn in + (Other kn, nparams) + | AbsKn (Tuple n) -> + (Tuple n, n) + in + let nargs = List.length args in + let () = + if not (Int.equal nparams nargs) then + let qid = match rel with + | RelId lid -> lid + | AbsKn (Other kn) -> shortest_qualid_of_type ?loc kn + | AbsKn (Tuple _) -> assert false + in + user_err ?loc (strbrk "The type constructor " ++ pr_qualid qid ++ + strbrk " expects " ++ int nparams ++ strbrk " argument(s), but is here \ + applied to " ++ int nargs ++ strbrk "argument(s)") + in + GTypRef (kn, List.map (fun t -> intern_type env t) args) +| CTypArrow (t1, t2) -> GTypArrow (intern_type env t1, intern_type env t2) + +let fresh_type_scheme env (t : type_scheme) : UF.elt glb_typexpr = + let (n, t) = t in + let subst = Array.init n (fun _ -> fresh_id env) in + let substf i = GTypVar subst.(i) in + subst_type substf t + +let fresh_mix_type_scheme env (t : mix_type_scheme) : UF.elt glb_typexpr = + let (n, t) = t in + let subst = Array.init n (fun _ -> fresh_id env) in + let substf = function + | LVar i -> GTypVar subst.(i) + | GVar n -> GTypVar n + in + subst_type substf t + +let fresh_reftype env (kn : KerName.t or_tuple) = + let n = match kn with + | Other kn -> fst (Tac2env.interp_type kn) + | Tuple n -> n + in + let subst = Array.init n (fun _ -> fresh_id env) in + let t = GTypRef (kn, Array.map_to_list (fun i -> GTypVar i) subst) in + (subst, t) + +(** First-order unification algorithm *) +let is_unfoldable kn = match snd (Tac2env.interp_type kn) with +| GTydDef (Some _) -> true +| GTydDef None | GTydAlg _ | GTydRec _ | GTydOpn -> false + +let unfold env kn args = + let (nparams, def) = Tac2env.interp_type kn in + let def = match def with + | GTydDef (Some t) -> t + | _ -> assert false + in + let args = Array.of_list args in + let subst n = args.(n) in + subst_type subst def + +(** View function, allows to ensure head normal forms *) +let rec kind env t = match t with +| GTypVar id -> + let (id, v) = UF.find id env.env_cst in + begin match v with + | None -> GTypVar id + | Some t -> kind env t + end +| GTypRef (Other kn, tl) -> + if is_unfoldable kn then kind env (unfold env kn tl) else t +| GTypArrow _ | GTypRef (Tuple _, _) -> t + +(** Normalize unification variables without unfolding type aliases *) +let rec nf env t = match t with +| GTypVar id -> + let (id, v) = UF.find id env.env_cst in + begin match v with + | None -> GTypVar id + | Some t -> nf env t + end +| GTypRef (kn, tl) -> + let tl = List.map (fun t -> nf env t) tl in + GTypRef (kn, tl) +| GTypArrow (t, u) -> + let t = nf env t in + let u = nf env u in + GTypArrow (t, u) + +let pr_glbtype env t = + let t = nf env t in + let name = env_name env in + pr_glbtype name t + +exception Occur + +let rec occur_check env id t = match kind env t with +| GTypVar id' -> if UF.equal id id' then raise Occur +| GTypArrow (t1, t2) -> + let () = occur_check env id t1 in + occur_check env id t2 +| GTypRef (kn, tl) -> + List.iter (fun t -> occur_check env id t) tl + +exception CannotUnify of UF.elt glb_typexpr * UF.elt glb_typexpr + +let unify_var env id t = match kind env t with +| GTypVar id' -> + if not (UF.equal id id') then UF.union id id' env.env_cst +| GTypArrow _ | GTypRef _ -> + try + let () = occur_check env id t in + UF.set id t env.env_cst + with Occur -> raise (CannotUnify (GTypVar id, t)) + +let eq_or_tuple eq t1 t2 = match t1, t2 with +| Tuple n1, Tuple n2 -> Int.equal n1 n2 +| Other o1, Other o2 -> eq o1 o2 +| _ -> false + +let rec unify0 env t1 t2 = match kind env t1, kind env t2 with +| GTypVar id, t | t, GTypVar id -> + unify_var env id t +| GTypArrow (t1, u1), GTypArrow (t2, u2) -> + let () = unify0 env t1 t2 in + unify0 env u1 u2 +| GTypRef (kn1, tl1), GTypRef (kn2, tl2) -> + if eq_or_tuple KerName.equal kn1 kn2 then + List.iter2 (fun t1 t2 -> unify0 env t1 t2) tl1 tl2 + else raise (CannotUnify (t1, t2)) +| _ -> raise (CannotUnify (t1, t2)) + +let unify ?loc env t1 t2 = + try unify0 env t1 t2 + with CannotUnify (u1, u2) -> + user_err ?loc (str "This expression has type" ++ spc () ++ pr_glbtype env t1 ++ + spc () ++ str "but an expression was expected of type" ++ spc () ++ pr_glbtype env t2) + +let unify_arrow ?loc env ft args = + let ft0 = ft in + let rec iter ft args is_fun = match kind env ft, args with + | t, [] -> t + | GTypArrow (t1, ft), (loc, t2) :: args -> + let () = unify ?loc env t2 t1 in + iter ft args true + | GTypVar id, (_, t) :: args -> + let ft = GTypVar (fresh_id env) in + let () = unify_var env id (GTypArrow (t, ft)) in + iter ft args true + | GTypRef _, _ :: _ -> + if is_fun then + user_err ?loc (str "This function has type" ++ spc () ++ pr_glbtype env ft0 ++ + spc () ++ str "and is applied to too many arguments") + else + user_err ?loc (str "This expression has type" ++ spc () ++ pr_glbtype env ft0 ++ + spc () ++ str "and is not a function") + in + iter ft args false + +(** Term typing *) + +let is_pure_constructor kn = + match snd (Tac2env.interp_type kn) with + | GTydAlg _ | GTydOpn -> true + | GTydRec fields -> + let is_pure (_, mut, _) = not mut in + List.for_all is_pure fields + | GTydDef _ -> assert false (** Type definitions have no constructors *) + +let rec is_value = function +| GTacAtm (AtmInt _) | GTacVar _ | GTacRef _ | GTacFun _ -> true +| GTacAtm (AtmStr _) | GTacApp _ | GTacLet _ -> false +| GTacCst (Tuple _, _, el) -> List.for_all is_value el +| GTacCst (_, _, []) -> true +| GTacOpn (_, el) -> List.for_all is_value el +| GTacCst (Other kn, _, el) -> is_pure_constructor kn && List.for_all is_value el +| GTacCse _ | GTacPrj _ | GTacSet _ | GTacExt _ | GTacPrm _ +| GTacWth _ -> false + +let is_rec_rhs = function +| GTacFun _ -> true +| GTacAtm _ | GTacVar _ | GTacRef _ | GTacApp _ | GTacLet _ | GTacPrj _ +| GTacSet _ | GTacExt _ | GTacPrm _ | GTacCst _ +| GTacCse _ | GTacOpn _ | GTacWth _ -> false + +let rec fv_type f t accu = match t with +| GTypVar id -> f id accu +| GTypArrow (t1, t2) -> fv_type f t1 (fv_type f t2 accu) +| GTypRef (kn, tl) -> List.fold_left (fun accu t -> fv_type f t accu) accu tl + +let fv_env env = + let rec f id accu = match UF.find id env.env_cst with + | id, None -> UF.Map.add id () accu + | _, Some t -> fv_type f t accu + in + let fold_var id (_, t) accu = + let fmix id accu = match id with + | LVar _ -> accu + | GVar id -> f id accu + in + fv_type fmix t accu + in + let fv_var = Id.Map.fold fold_var env.env_var UF.Map.empty in + let fold_als _ id accu = f id accu in + Id.Map.fold fold_als !(env.env_als) fv_var + +let abstract_var env (t : UF.elt glb_typexpr) : mix_type_scheme = + let fv = fv_env env in + let count = ref 0 in + let vars = ref UF.Map.empty in + let rec subst id = + let (id, t) = UF.find id env.env_cst in + match t with + | None -> + if UF.Map.mem id fv then GTypVar (GVar id) + else + begin try UF.Map.find id !vars + with Not_found -> + let n = !count in + let var = GTypVar (LVar n) in + let () = incr count in + let () = vars := UF.Map.add id var !vars in + var + end + | Some t -> subst_type subst t + in + let t = subst_type subst t in + (!count, t) + +let monomorphic (t : UF.elt glb_typexpr) : mix_type_scheme = + let subst id = GTypVar (GVar id) in + (0, subst_type subst t) + +let warn_not_unit = + CWarnings.create ~name:"not-unit" ~category:"ltac" + (fun () -> strbrk "The following expression should have type unit.") + +let warn_redundant_clause = + CWarnings.create ~name:"redundant-clause" ~category:"ltac" + (fun () -> strbrk "The following clause is redundant.") + +let check_elt_unit loc env t = + let maybe_unit = match kind env t with + | GTypVar _ -> true + | GTypArrow _ -> false + | GTypRef (Tuple 0, []) -> true + | GTypRef _ -> false + in + if not maybe_unit then warn_not_unit ?loc () + +let check_elt_empty loc env t = match kind env t with +| GTypVar _ -> + user_err ?loc (str "Cannot infer an empty type for this expression") +| GTypArrow _ | GTypRef (Tuple _, _) -> + user_err ?loc (str "Type" ++ spc () ++ pr_glbtype env t ++ spc () ++ str "is not an empty type") +| GTypRef (Other kn, _) -> + let def = Tac2env.interp_type kn in + match def with + | _, GTydAlg { galg_constructors = [] } -> kn + | _ -> + user_err ?loc (str "Type" ++ spc () ++ pr_glbtype env t ++ spc () ++ str "is not an empty type") + +let check_unit ?loc t = + let env = empty_env () in + (* Should not matter, t should be closed. *) + let t = fresh_type_scheme env t in + let maybe_unit = match kind env t with + | GTypVar _ -> true + | GTypArrow _ -> false + | GTypRef (Tuple 0, []) -> true + | GTypRef _ -> false + in + if not maybe_unit then warn_not_unit ?loc () + +let check_redundant_clause = function +| [] -> () +| (p, _) :: _ -> warn_redundant_clause ?loc:p.loc () + +let get_variable0 mem var = match var with +| RelId qid -> + let id = qualid_basename qid in + if qualid_is_ident qid && mem id then ArgVar CAst.(make ?loc:qid.CAst.loc id) + else + let kn = + try Tac2env.locate_ltac qid + with Not_found -> + CErrors.user_err ?loc:qid.CAst.loc (str "Unbound value " ++ pr_qualid qid) + in + ArgArg kn +| AbsKn kn -> ArgArg kn + +let get_variable env var = + let mem id = Id.Map.mem id env.env_var in + get_variable0 mem var + +let get_constructor env var = match var with +| RelId qid -> + let c = try Some (Tac2env.locate_constructor qid) with Not_found -> None in + begin match c with + | Some knc -> Other knc + | None -> + CErrors.user_err ?loc:qid.CAst.loc (str "Unbound constructor " ++ pr_qualid qid) + end +| AbsKn knc -> knc + +let get_projection var = match var with +| RelId qid -> + let kn = try Tac2env.locate_projection qid with Not_found -> + user_err ?loc:qid.CAst.loc (pr_qualid qid ++ str " is not a projection") + in + Tac2env.interp_projection kn +| AbsKn kn -> + Tac2env.interp_projection kn + +let intern_atm env = function +| AtmInt n -> (GTacAtm (AtmInt n), GTypRef (Other t_int, [])) +| AtmStr s -> (GTacAtm (AtmStr s), GTypRef (Other t_string, [])) + +let invalid_pattern ?loc kn kn' = + let pr t = match t with + | Other kn' -> str "type " ++ pr_typref kn' + | Tuple n -> str "tuple of size " ++ int n + in + user_err ?loc (str "Invalid pattern, expected a pattern for " ++ + pr kn ++ str ", found a pattern for " ++ pr kn') (** FIXME *) + +(** Pattern view *) + +type glb_patexpr = +| GPatVar of Name.t +| GPatRef of ltac_constructor or_tuple * glb_patexpr list + +let rec intern_patexpr env {loc;v=pat} = match pat with +| CPatVar na -> GPatVar na +| CPatRef (qid, pl) -> + let kn = get_constructor env qid in + GPatRef (kn, List.map (fun p -> intern_patexpr env p) pl) +| CPatCnv (pat, ty) -> + user_err ?loc (str "Pattern not handled yet") + +type pattern_kind = +| PKind_empty +| PKind_variant of type_constant or_tuple +| PKind_open of type_constant +| PKind_any + +let get_pattern_kind env pl = match pl with +| [] -> PKind_empty +| p :: pl -> + let rec get_kind (p, _) pl = match intern_patexpr env p with + | GPatVar _ -> + begin match pl with + | [] -> PKind_any + | p :: pl -> get_kind p pl + end + | GPatRef (Other kn, pl) -> + let data = Tac2env.interp_constructor kn in + if Option.is_empty data.cdata_indx then PKind_open data.cdata_type + else PKind_variant (Other data.cdata_type) + | GPatRef (Tuple _, tp) -> PKind_variant (Tuple (List.length tp)) + in + get_kind p pl + +(** Internalization *) + +(** Used to generate a fresh tactic variable for pattern-expansion *) +let fresh_var avoid = + let bad id = + Id.Set.mem id avoid || + (try ignore (locate_ltac (qualid_of_ident id)); true with Not_found -> false) + in + Namegen.next_ident_away_from (Id.of_string "p") bad + +let add_name accu = function +| Name id -> Id.Set.add id accu +| Anonymous -> accu + +let rec ids_of_pattern accu {v=pat} = match pat with +| CPatVar Anonymous -> accu +| CPatVar (Name id) -> Id.Set.add id accu +| CPatRef (_, pl) -> + List.fold_left ids_of_pattern accu pl +| CPatCnv (pat, _) -> ids_of_pattern accu pat + +let loc_of_relid = function +| RelId {loc} -> loc +| AbsKn _ -> None + +let extract_pattern_type ({loc;v=p} as pat) = match p with +| CPatCnv (pat, ty) -> pat, Some ty +| CPatVar _ | CPatRef _ -> pat, None + +(** Expand pattern: [p => t] becomes [x => match x with p => t end] *) +let expand_pattern avoid bnd = + let fold (avoid, bnd) (pat, t) = + let na, expand = match pat.v with + | CPatVar na -> + (* Don't expand variable patterns *) + na, None + | _ -> + let id = fresh_var avoid in + let qid = RelId (qualid_of_ident ?loc:pat.loc id) in + Name id, Some qid + in + let avoid = ids_of_pattern avoid pat in + let avoid = add_name avoid na in + (avoid, (na, pat, expand) :: bnd) + in + let (_, bnd) = List.fold_left fold (avoid, []) bnd in + let fold e (na, pat, expand) = match expand with + | None -> e + | Some qid -> + let loc = loc_of_relid qid in + CAst.make ?loc @@ CTacCse (CAst.make ?loc @@ CTacRef qid, [pat, e]) + in + let expand e = List.fold_left fold e bnd in + let nas = List.rev_map (fun (na, _, _) -> na) bnd in + (nas, expand) + +let is_alias env qid = match get_variable env qid with +| ArgArg (TacAlias _) -> true +| ArgVar _ | (ArgArg (TacConstant _)) -> false + +let rec intern_rec env {loc;v=e} = match e with +| CTacAtm atm -> intern_atm env atm +| CTacRef qid -> + begin match get_variable env qid with + | ArgVar {CAst.v=id} -> + let sch = Id.Map.find id env.env_var in + (GTacVar id, fresh_mix_type_scheme env sch) + | ArgArg (TacConstant kn) -> + let { Tac2env.gdata_type = sch } = + try Tac2env.interp_global kn + with Not_found -> + CErrors.anomaly (str "Missing hardwired primitive " ++ KerName.print kn) + in + (GTacRef kn, fresh_type_scheme env sch) + | ArgArg (TacAlias kn) -> + let e = + try Tac2env.interp_alias kn + with Not_found -> + CErrors.anomaly (str "Missing hardwired alias " ++ KerName.print kn) + in + intern_rec env e + end +| CTacCst qid -> + let kn = get_constructor env qid in + intern_constructor env loc kn [] +| CTacFun (bnd, e) -> + let bnd = List.map extract_pattern_type bnd in + let map (_, t) = match t with + | None -> GTypVar (fresh_id env) + | Some t -> intern_type env t + in + let tl = List.map map bnd in + let (nas, exp) = expand_pattern (Id.Map.domain env.env_var) bnd in + let env = List.fold_left2 (fun env na t -> push_name na (monomorphic t) env) env nas tl in + let (e, t) = intern_rec env (exp e) in + let t = List.fold_right (fun t accu -> GTypArrow (t, accu)) tl t in + (GTacFun (nas, e), t) +| CTacApp ({loc;v=CTacCst qid}, args) -> + let kn = get_constructor env qid in + intern_constructor env loc kn args +| CTacApp ({v=CTacRef qid}, args) when is_alias env qid -> + let kn = match get_variable env qid with + | ArgArg (TacAlias kn) -> kn + | ArgVar _ | (ArgArg (TacConstant _)) -> assert false + in + let e = Tac2env.interp_alias kn in + let map arg = + (* Thunk alias arguments *) + let loc = arg.loc in + let t_unit = CAst.make ?loc @@ CTypRef (AbsKn (Tuple 0), []) in + let var = CAst.make ?loc @@ CPatCnv (CAst.make ?loc @@ CPatVar Anonymous, t_unit) in + CAst.make ?loc @@ CTacFun ([var], arg) + in + let args = List.map map args in + intern_rec env (CAst.make ?loc @@ CTacApp (e, args)) +| CTacApp (f, args) -> + let loc = f.loc in + let (f, ft) = intern_rec env f in + let fold arg (args, t) = + let loc = arg.loc in + let (arg, argt) = intern_rec env arg in + (arg :: args, (loc, argt) :: t) + in + let (args, t) = List.fold_right fold args ([], []) in + let ret = unify_arrow ?loc env ft t in + (GTacApp (f, args), ret) +| CTacLet (is_rec, el, e) -> + let map (pat, e) = + let (pat, ty) = extract_pattern_type pat in + (pat, ty, e) + in + let el = List.map map el in + let fold accu (pat, _, e) = + let ids = ids_of_pattern Id.Set.empty pat in + let common = Id.Set.inter ids accu in + if Id.Set.is_empty common then Id.Set.union ids accu + else + let id = Id.Set.choose common in + user_err ?loc:pat.loc (str "Variable " ++ Id.print id ++ str " is bound several \ + times in this matching") + in + let ids = List.fold_left fold Id.Set.empty el in + if is_rec then intern_let_rec env loc ids el e + else intern_let env loc ids el e +| CTacCnv (e, tc) -> + let (e, t) = intern_rec env e in + let tc = intern_type env tc in + let () = unify ?loc env t tc in + (e, tc) +| CTacSeq (e1, e2) -> + let loc1 = e1.loc in + let (e1, t1) = intern_rec env e1 in + let (e2, t2) = intern_rec env e2 in + let () = check_elt_unit loc1 env t1 in + (GTacLet (false, [Anonymous, e1], e2), t2) +| CTacCse (e, pl) -> + intern_case env loc e pl +| CTacRec fs -> + intern_record env loc fs +| CTacPrj (e, proj) -> + let pinfo = get_projection proj in + let loc = e.loc in + let (e, t) = intern_rec env e in + let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in + let params = Array.map_to_list (fun i -> GTypVar i) subst in + let exp = GTypRef (Other pinfo.pdata_type, params) in + let () = unify ?loc env t exp in + let substf i = GTypVar subst.(i) in + let ret = subst_type substf pinfo.pdata_ptyp in + (GTacPrj (pinfo.pdata_type, e, pinfo.pdata_indx), ret) +| CTacSet (e, proj, r) -> + let pinfo = get_projection proj in + let () = + if not pinfo.pdata_mutb then + let loc = match proj with + | RelId {CAst.loc} -> loc + | AbsKn _ -> None + in + user_err ?loc (str "Field is not mutable") + in + let subst = Array.init pinfo.pdata_prms (fun _ -> fresh_id env) in + let params = Array.map_to_list (fun i -> GTypVar i) subst in + let exp = GTypRef (Other pinfo.pdata_type, params) in + let e = intern_rec_with_constraint env e exp in + let substf i = GTypVar subst.(i) in + let ret = subst_type substf pinfo.pdata_ptyp in + let r = intern_rec_with_constraint env r ret in + (GTacSet (pinfo.pdata_type, e, pinfo.pdata_indx, r), GTypRef (Tuple 0, [])) +| CTacExt (tag, arg) -> + let open Genintern in + let self ist e = + let env = match Store.get ist.extra ltac2_env with + | None -> empty_env () + | Some env -> env + in + intern_rec env e + in + let obj = interp_ml_object tag in + (* External objects do not have access to the named context because this is + not stable by dynamic semantics. *) + let genv = Global.env_of_context Environ.empty_named_context_val in + let ist = empty_glob_sign genv in + let ist = { ist with extra = Store.set ist.extra ltac2_env env } in + let arg, tpe = + if env.env_str then + let arg () = obj.ml_intern self ist arg in + Flags.with_option Ltac_plugin.Tacintern.strict_check arg () + else + obj.ml_intern self ist arg + in + let e = match arg with + | GlbVal arg -> GTacExt (tag, arg) + | GlbTacexpr e -> e + in + (e, tpe) + +and intern_rec_with_constraint env e exp = + let (er, t) = intern_rec env e in + let () = unify ?loc:e.loc env t exp in + er + +and intern_let env loc ids el e = + let avoid = Id.Set.union ids (Id.Map.domain env.env_var) in + let fold (pat, t, e) (avoid, accu) = + let nas, exp = expand_pattern avoid [pat, t] in + let na = match nas with [x] -> x | _ -> assert false in + let avoid = List.fold_left add_name avoid nas in + (avoid, (na, exp, t, e) :: accu) + in + let (_, el) = List.fold_right fold el (avoid, []) in + let fold (na, exp, tc, e) (body, el, p) = + let (e, t) = match tc with + | None -> intern_rec env e + | Some tc -> + let tc = intern_type env tc in + (intern_rec_with_constraint env e tc, tc) + in + let t = if is_value e then abstract_var env t else monomorphic t in + (exp body, (na, e) :: el, (na, t) :: p) + in + let (e, el, p) = List.fold_right fold el (e, [], []) in + let env = List.fold_left (fun accu (na, t) -> push_name na t accu) env p in + let (e, t) = intern_rec env e in + (GTacLet (false, el, e), t) + +and intern_let_rec env loc ids el e = + let map env (pat, t, e) = + let na = match pat.v with + | CPatVar na -> na + | CPatRef _ | CPatCnv _ -> + user_err ?loc:pat.loc (str "This kind of pattern is forbidden in let-rec bindings") + in + let id = fresh_id env in + let env = push_name na (monomorphic (GTypVar id)) env in + (env, (loc, na, t, e, id)) + in + let (env, el) = List.fold_left_map map env el in + let fold (loc, na, tc, e, id) (el, tl) = + let loc_e = e.loc in + let (e, t) = intern_rec env e in + let () = + if not (is_rec_rhs e) then + user_err ?loc:loc_e (str "This kind of expression is not allowed as \ + right-hand side of a recursive binding") + in + let () = unify ?loc env t (GTypVar id) in + let () = match tc with + | None -> () + | Some tc -> + let tc = intern_type env tc in + unify ?loc env t tc + in + ((na, e) :: el, t :: tl) + in + let (el, tl) = List.fold_right fold el ([], []) in + let (e, t) = intern_rec env e in + (GTacLet (true, el, e), t) + +(** For now, patterns recognized by the pattern-matching compiling are limited + to depth-one where leaves are either variables or catch-all *) +and intern_case env loc e pl = + let (e', t) = intern_rec env e in + let todo ?loc () = user_err ?loc (str "Pattern not handled yet") in + match get_pattern_kind env pl with + | PKind_any -> + let (pat, b) = List.hd pl in + let na = match intern_patexpr env pat with + | GPatVar na -> na + | _ -> assert false + in + let () = check_redundant_clause (List.tl pl) in + let env = push_name na (monomorphic t) env in + let (b, tb) = intern_rec env b in + (GTacLet (false, [na, e'], b), tb) + | PKind_empty -> + let kn = check_elt_empty loc env t in + let r = fresh_id env in + (GTacCse (e', Other kn, [||], [||]), GTypVar r) + | PKind_variant kn -> + let subst, tc = fresh_reftype env kn in + let () = unify ?loc:e.loc env t tc in + let (nconst, nnonconst, arities) = match kn with + | Tuple 0 -> 1, 0, [0] + | Tuple n -> 0, 1, [n] + | Other kn -> + let (_, def) = Tac2env.interp_type kn in + let galg = match def with | GTydAlg c -> c | _ -> assert false in + let arities = List.map (fun (_, args) -> List.length args) galg.galg_constructors in + galg.galg_nconst, galg.galg_nnonconst, arities + in + let const = Array.make nconst None in + let nonconst = Array.make nnonconst None in + let ret = GTypVar (fresh_id env) in + let rec intern_branch = function + | [] -> () + | (pat, br) :: rem -> + let tbr = match pat.v with + | CPatVar (Name _) -> + let loc = pat.loc in + todo ?loc () + | CPatVar Anonymous -> + let () = check_redundant_clause rem in + let (br', brT) = intern_rec env br in + (* Fill all remaining branches *) + let fill (ncst, narg) arity = + if Int.equal arity 0 then + let () = + if Option.is_empty const.(ncst) then const.(ncst) <- Some br' + in + (succ ncst, narg) + else + let () = + if Option.is_empty nonconst.(narg) then + let ids = Array.make arity Anonymous in + nonconst.(narg) <- Some (ids, br') + in + (ncst, succ narg) + in + let _ = List.fold_left fill (0, 0) arities in + brT + | CPatRef (qid, args) -> + let loc = pat.loc in + let knc = get_constructor env qid in + let kn', index, arity = match knc with + | Tuple n -> Tuple n, 0, List.init n (fun i -> GTypVar i) + | Other knc -> + let data = Tac2env.interp_constructor knc in + let index = Option.get data.cdata_indx in + Other data.cdata_type, index, data.cdata_args + in + let () = + if not (eq_or_tuple KerName.equal kn kn') then + invalid_pattern ?loc kn kn' + in + let get_id pat = match pat with + | {v=CPatVar na} -> na + | {loc} -> todo ?loc () + in + let ids = List.map get_id args in + let nids = List.length ids in + let nargs = List.length arity in + let () = match knc with + | Tuple n -> assert (n == nids) + | Other knc -> + if not (Int.equal nids nargs) then error_nargs_mismatch ?loc knc nargs nids + in + let fold env id tpe = + (* Instantiate all arguments *) + let subst n = GTypVar subst.(n) in + let tpe = subst_type subst tpe in + push_name id (monomorphic tpe) env + in + let nenv = List.fold_left2 fold env ids arity in + let (br', brT) = intern_rec nenv br in + let () = + if List.is_empty args then + if Option.is_empty const.(index) then const.(index) <- Some br' + else warn_redundant_clause ?loc () + else + let ids = Array.of_list ids in + if Option.is_empty nonconst.(index) then nonconst.(index) <- Some (ids, br') + else warn_redundant_clause ?loc () + in + brT + | CPatCnv _ -> + user_err ?loc (str "Pattern not handled yet") + in + let () = unify ?loc:br.loc env tbr ret in + intern_branch rem + in + let () = intern_branch pl in + let map n is_const = function + | None -> + let kn = match kn with Other kn -> kn | _ -> assert false in + let cstr = pr_internal_constructor kn n is_const in + user_err ?loc (str "Unhandled match case for constructor " ++ cstr) + | Some x -> x + in + let const = Array.mapi (fun i o -> map i true o) const in + let nonconst = Array.mapi (fun i o -> map i false o) nonconst in + let ce = GTacCse (e', kn, const, nonconst) in + (ce, ret) + | PKind_open kn -> + let subst, tc = fresh_reftype env (Other kn) in + let () = unify ?loc:e.loc env t tc in + let ret = GTypVar (fresh_id env) in + let rec intern_branch map = function + | [] -> + user_err ?loc (str "Missing default case") + | (pat, br) :: rem -> + match intern_patexpr env pat with + | GPatVar na -> + let () = check_redundant_clause rem in + let nenv = push_name na (monomorphic tc) env in + let br' = intern_rec_with_constraint nenv br ret in + let def = (na, br') in + (map, def) + | GPatRef (knc, args) -> + let get = function + | GPatVar na -> na + | GPatRef _ -> + user_err ?loc (str "TODO: Unhandled match case") (* FIXME *) + in + let loc = pat.loc in + let knc = match knc with + | Other knc -> knc + | Tuple n -> invalid_pattern ?loc (Other kn) (Tuple n) + in + let ids = List.map get args in + let data = Tac2env.interp_constructor knc in + let () = + if not (KerName.equal kn data.cdata_type) then + invalid_pattern ?loc (Other kn) (Other data.cdata_type) + in + let nids = List.length ids in + let nargs = List.length data.cdata_args in + let () = + if not (Int.equal nids nargs) then error_nargs_mismatch ?loc knc nargs nids + in + let fold env id tpe = + (* Instantiate all arguments *) + let subst n = GTypVar subst.(n) in + let tpe = subst_type subst tpe in + push_name id (monomorphic tpe) env + in + let nenv = List.fold_left2 fold env ids data.cdata_args in + let br' = intern_rec_with_constraint nenv br ret in + let map = + if KNmap.mem knc map then + let () = warn_redundant_clause ?loc () in + map + else + KNmap.add knc (Anonymous, Array.of_list ids, br') map + in + intern_branch map rem + in + let (map, def) = intern_branch KNmap.empty pl in + (GTacWth { opn_match = e'; opn_branch = map; opn_default = def }, ret) + +and intern_constructor env loc kn args = match kn with +| Other kn -> + let cstr = interp_constructor kn in + let nargs = List.length cstr.cdata_args in + if Int.equal nargs (List.length args) then + let subst = Array.init cstr.cdata_prms (fun _ -> fresh_id env) in + let substf i = GTypVar subst.(i) in + let types = List.map (fun t -> subst_type substf t) cstr.cdata_args in + let targs = List.init cstr.cdata_prms (fun i -> GTypVar subst.(i)) in + let ans = GTypRef (Other cstr.cdata_type, targs) in + let map arg tpe = intern_rec_with_constraint env arg tpe in + let args = List.map2 map args types in + match cstr.cdata_indx with + | Some idx -> + (GTacCst (Other cstr.cdata_type, idx, args), ans) + | None -> + (GTacOpn (kn, args), ans) + else + error_nargs_mismatch ?loc kn nargs (List.length args) +| Tuple n -> + assert (Int.equal n (List.length args)); + let types = List.init n (fun i -> GTypVar (fresh_id env)) in + let map arg tpe = intern_rec_with_constraint env arg tpe in + let args = List.map2 map args types in + let ans = GTypRef (Tuple n, types) in + GTacCst (Tuple n, 0, args), ans + +and intern_record env loc fs = + let map (proj, e) = + let loc = match proj with + | RelId {CAst.loc} -> loc + | AbsKn _ -> None + in + let proj = get_projection proj in + (loc, proj, e) + in + let fs = List.map map fs in + let kn = match fs with + | [] -> user_err ?loc (str "Cannot infer the corresponding record type") + | (_, proj, _) :: _ -> proj.pdata_type + in + let params, typdef = match Tac2env.interp_type kn with + | n, GTydRec def -> n, def + | _ -> assert false + in + let subst = Array.init params (fun _ -> fresh_id env) in + (* Set the answer [args] imperatively *) + let args = Array.make (List.length typdef) None in + let iter (loc, pinfo, e) = + if KerName.equal kn pinfo.pdata_type then + let index = pinfo.pdata_indx in + match args.(index) with + | None -> + let exp = subst_type (fun i -> GTypVar subst.(i)) pinfo.pdata_ptyp in + let e = intern_rec_with_constraint env e exp in + args.(index) <- Some e + | Some _ -> + let (name, _, _) = List.nth typdef pinfo.pdata_indx in + user_err ?loc (str "Field " ++ Id.print name ++ str " is defined \ + several times") + else + user_err ?loc (str "Field " ++ (*KerName.print knp ++*) str " does not \ + pertain to record definition " ++ pr_typref pinfo.pdata_type) + in + let () = List.iter iter fs in + let () = match Array.findi (fun _ o -> Option.is_empty o) args with + | None -> () + | Some i -> + let (field, _, _) = List.nth typdef i in + user_err ?loc (str "Field " ++ Id.print field ++ str " is undefined") + in + let args = Array.map_to_list Option.get args in + let tparam = List.init params (fun i -> GTypVar subst.(i)) in + (GTacCst (Other kn, 0, args), GTypRef (Other kn, tparam)) + +let normalize env (count, vars) (t : UF.elt glb_typexpr) = + let get_var id = + try UF.Map.find id !vars + with Not_found -> + let () = assert env.env_opn in + let n = GTypVar !count in + let () = incr count in + let () = vars := UF.Map.add id n !vars in + n + in + let rec subst id = match UF.find id env.env_cst with + | id, None -> get_var id + | _, Some t -> subst_type subst t + in + subst_type subst t + +let intern ~strict e = + let env = empty_env () in + let env = if strict then env else { env with env_str = false } in + let (e, t) = intern_rec env e in + let count = ref 0 in + let vars = ref UF.Map.empty in + let t = normalize env (count, vars) t in + (e, (!count, t)) + +let intern_typedef self (ids, t) : glb_quant_typedef = + let env = { (empty_env ()) with env_rec = self } in + (* Initialize type parameters *) + let map id = get_alias id env in + let ids = List.map map ids in + let count = ref (List.length ids) in + let vars = ref UF.Map.empty in + let iter n id = vars := UF.Map.add id (GTypVar n) !vars in + let () = List.iteri iter ids in + (* Do not accept unbound type variables *) + let env = { env with env_opn = false } in + let intern t = + let t = intern_type env t in + normalize env (count, vars) t + in + let count = !count in + match t with + | CTydDef None -> (count, GTydDef None) + | CTydDef (Some t) -> (count, GTydDef (Some (intern t))) + | CTydAlg constrs -> + let map (c, t) = (c, List.map intern t) in + let constrs = List.map map constrs in + let getn (const, nonconst) (c, args) = match args with + | [] -> (succ const, nonconst) + | _ :: _ -> (const, succ nonconst) + in + let nconst, nnonconst = List.fold_left getn (0, 0) constrs in + let galg = { + galg_constructors = constrs; + galg_nconst = nconst; + galg_nnonconst = nnonconst; + } in + (count, GTydAlg galg) + | CTydRec fields -> + let map (c, mut, t) = (c, mut, intern t) in + let fields = List.map map fields in + (count, GTydRec fields) + | CTydOpn -> (count, GTydOpn) + +let intern_open_type t = + let env = empty_env () in + let t = intern_type env t in + let count = ref 0 in + let vars = ref UF.Map.empty in + let t = normalize env (count, vars) t in + (!count, t) + +(** Subtyping *) + +let check_subtype t1 t2 = + let env = empty_env () in + let t1 = fresh_type_scheme env t1 in + (* We build a substitution mimicking rigid variable by using dummy tuples *) + let rigid i = GTypRef (Tuple (i + 1), []) in + let (n, t2) = t2 in + let subst = Array.init n rigid in + let substf i = subst.(i) in + let t2 = subst_type substf t2 in + try unify0 env t1 t2; true with CannotUnify _ -> false + +(** Globalization *) + +let get_projection0 var = match var with +| RelId qid -> + let kn = try Tac2env.locate_projection qid with Not_found -> + user_err ?loc:qid.CAst.loc (pr_qualid qid ++ str " is not a projection") + in + kn +| AbsKn kn -> kn + +let rec globalize ids ({loc;v=er} as e) = match er with +| CTacAtm _ -> e +| CTacRef ref -> + let mem id = Id.Set.mem id ids in + begin match get_variable0 mem ref with + | ArgVar _ -> e + | ArgArg kn -> CAst.make ?loc @@ CTacRef (AbsKn kn) + end +| CTacCst qid -> + let knc = get_constructor () qid in + CAst.make ?loc @@ CTacCst (AbsKn knc) +| CTacFun (bnd, e) -> + let fold (pats, accu) pat = + let accu = ids_of_pattern accu pat in + let pat = globalize_pattern ids pat in + (pat :: pats, accu) + in + let bnd, ids = List.fold_left fold ([], ids) bnd in + let bnd = List.rev bnd in + let e = globalize ids e in + CAst.make ?loc @@ CTacFun (bnd, e) +| CTacApp (e, el) -> + let e = globalize ids e in + let el = List.map (fun e -> globalize ids e) el in + CAst.make ?loc @@ CTacApp (e, el) +| CTacLet (isrec, bnd, e) -> + let fold accu (pat, _) = ids_of_pattern accu pat in + let ext = List.fold_left fold Id.Set.empty bnd in + let eids = Id.Set.union ext ids in + let e = globalize eids e in + let map (qid, e) = + let ids = if isrec then eids else ids in + let qid = globalize_pattern ids qid in + (qid, globalize ids e) + in + let bnd = List.map map bnd in + CAst.make ?loc @@ CTacLet (isrec, bnd, e) +| CTacCnv (e, t) -> + let e = globalize ids e in + CAst.make ?loc @@ CTacCnv (e, t) +| CTacSeq (e1, e2) -> + let e1 = globalize ids e1 in + let e2 = globalize ids e2 in + CAst.make ?loc @@ CTacSeq (e1, e2) +| CTacCse (e, bl) -> + let e = globalize ids e in + let bl = List.map (fun b -> globalize_case ids b) bl in + CAst.make ?loc @@ CTacCse (e, bl) +| CTacRec r -> + let map (p, e) = + let p = get_projection0 p in + let e = globalize ids e in + (AbsKn p, e) + in + CAst.make ?loc @@ CTacRec (List.map map r) +| CTacPrj (e, p) -> + let e = globalize ids e in + let p = get_projection0 p in + CAst.make ?loc @@ CTacPrj (e, AbsKn p) +| CTacSet (e, p, e') -> + let e = globalize ids e in + let p = get_projection0 p in + let e' = globalize ids e' in + CAst.make ?loc @@ CTacSet (e, AbsKn p, e') +| CTacExt (tag, arg) -> + let arg = str (Tac2dyn.Arg.repr tag) in + CErrors.user_err ?loc (str "Cannot globalize generic arguments of type" ++ spc () ++ arg) + +and globalize_case ids (p, e) = + (globalize_pattern ids p, globalize ids e) + +and globalize_pattern ids ({loc;v=pr} as p) = match pr with +| CPatVar _ -> p +| CPatRef (cst, pl) -> + let knc = get_constructor () cst in + let cst = AbsKn knc in + let pl = List.map (fun p -> globalize_pattern ids p) pl in + CAst.make ?loc @@ CPatRef (cst, pl) +| CPatCnv (pat, ty) -> + let pat = globalize_pattern ids pat in + CAst.make ?loc @@ CPatCnv (pat, ty) + +(** Kernel substitution *) + +open Mod_subst + +let subst_or_tuple f subst o = match o with +| Tuple _ -> o +| Other v -> + let v' = f subst v in + if v' == v then o else Other v' + +let rec subst_type subst t = match t with +| GTypVar _ -> t +| GTypArrow (t1, t2) -> + let t1' = subst_type subst t1 in + let t2' = subst_type subst t2 in + if t1' == t1 && t2' == t2 then t + else GTypArrow (t1', t2') +| GTypRef (kn, tl) -> + let kn' = subst_or_tuple subst_kn subst kn in + let tl' = List.Smart.map (fun t -> subst_type subst t) tl in + if kn' == kn && tl' == tl then t else GTypRef (kn', tl') + +let rec subst_expr subst e = match e with +| GTacAtm _ | GTacVar _ | GTacPrm _ -> e +| GTacRef kn -> GTacRef (subst_kn subst kn) +| GTacFun (ids, e) -> GTacFun (ids, subst_expr subst e) +| GTacApp (f, args) -> + GTacApp (subst_expr subst f, List.map (fun e -> subst_expr subst e) args) +| GTacLet (r, bs, e) -> + let bs = List.map (fun (na, e) -> (na, subst_expr subst e)) bs in + GTacLet (r, bs, subst_expr subst e) +| GTacCst (t, n, el) as e0 -> + let t' = subst_or_tuple subst_kn subst t in + let el' = List.Smart.map (fun e -> subst_expr subst e) el in + if t' == t && el' == el then e0 else GTacCst (t', n, el') +| GTacCse (e, ci, cse0, cse1) -> + let cse0' = Array.map (fun e -> subst_expr subst e) cse0 in + let cse1' = Array.map (fun (ids, e) -> (ids, subst_expr subst e)) cse1 in + let ci' = subst_or_tuple subst_kn subst ci in + GTacCse (subst_expr subst e, ci', cse0', cse1') +| GTacWth { opn_match = e; opn_branch = br; opn_default = (na, def) } as e0 -> + let e' = subst_expr subst e in + let def' = subst_expr subst def in + let fold kn (self, vars, p) accu = + let kn' = subst_kn subst kn in + let p' = subst_expr subst p in + if kn' == kn && p' == p then accu + else KNmap.add kn' (self, vars, p') (KNmap.remove kn accu) + in + let br' = KNmap.fold fold br br in + if e' == e && br' == br && def' == def then e0 + else GTacWth { opn_match = e'; opn_default = (na, def'); opn_branch = br' } +| GTacPrj (kn, e, p) as e0 -> + let kn' = subst_kn subst kn in + let e' = subst_expr subst e in + if kn' == kn && e' == e then e0 else GTacPrj (kn', e', p) +| GTacSet (kn, e, p, r) as e0 -> + let kn' = subst_kn subst kn in + let e' = subst_expr subst e in + let r' = subst_expr subst r in + if kn' == kn && e' == e && r' == r then e0 else GTacSet (kn', e', p, r') +| GTacExt (tag, arg) -> + let tpe = interp_ml_object tag in + let arg' = tpe.ml_subst subst arg in + if arg' == arg then e else GTacExt (tag, arg') +| GTacOpn (kn, el) as e0 -> + let kn' = subst_kn subst kn in + let el' = List.Smart.map (fun e -> subst_expr subst e) el in + if kn' == kn && el' == el then e0 else GTacOpn (kn', el') + +let subst_typedef subst e = match e with +| GTydDef t -> + let t' = Option.Smart.map (fun t -> subst_type subst t) t in + if t' == t then e else GTydDef t' +| GTydAlg galg -> + let map (c, tl as p) = + let tl' = List.Smart.map (fun t -> subst_type subst t) tl in + if tl' == tl then p else (c, tl') + in + let constrs' = List.Smart.map map galg.galg_constructors in + if constrs' == galg.galg_constructors then e + else GTydAlg { galg with galg_constructors = constrs' } +| GTydRec fields -> + let map (c, mut, t as p) = + let t' = subst_type subst t in + if t' == t then p else (c, mut, t') + in + let fields' = List.Smart.map map fields in + if fields' == fields then e else GTydRec fields' +| GTydOpn -> GTydOpn + +let subst_quant_typedef subst (prm, def as qdef) = + let def' = subst_typedef subst def in + if def' == def then qdef else (prm, def') + +let subst_type_scheme subst (prm, t as sch) = + let t' = subst_type subst t in + if t' == t then sch else (prm, t') + +let subst_or_relid subst ref = match ref with +| RelId _ -> ref +| AbsKn kn -> + let kn' = subst_or_tuple subst_kn subst kn in + if kn' == kn then ref else AbsKn kn' + +let rec subst_rawtype subst ({loc;v=tr} as t) = match tr with +| CTypVar _ -> t +| CTypArrow (t1, t2) -> + let t1' = subst_rawtype subst t1 in + let t2' = subst_rawtype subst t2 in + if t1' == t1 && t2' == t2 then t else CAst.make ?loc @@ CTypArrow (t1', t2') +| CTypRef (ref, tl) -> + let ref' = subst_or_relid subst ref in + let tl' = List.Smart.map (fun t -> subst_rawtype subst t) tl in + if ref' == ref && tl' == tl then t else CAst.make ?loc @@ CTypRef (ref', tl') + +let subst_tacref subst ref = match ref with +| RelId _ -> ref +| AbsKn (TacConstant kn) -> + let kn' = subst_kn subst kn in + if kn' == kn then ref else AbsKn (TacConstant kn') +| AbsKn (TacAlias kn) -> + let kn' = subst_kn subst kn in + if kn' == kn then ref else AbsKn (TacAlias kn') + +let subst_projection subst prj = match prj with +| RelId _ -> prj +| AbsKn kn -> + let kn' = subst_kn subst kn in + if kn' == kn then prj else AbsKn kn' + +let rec subst_rawpattern subst ({loc;v=pr} as p) = match pr with +| CPatVar _ -> p +| CPatRef (c, pl) -> + let pl' = List.Smart.map (fun p -> subst_rawpattern subst p) pl in + let c' = subst_or_relid subst c in + if pl' == pl && c' == c then p else CAst.make ?loc @@ CPatRef (c', pl') +| CPatCnv (pat, ty) -> + let pat' = subst_rawpattern subst pat in + let ty' = subst_rawtype subst ty in + if pat' == pat && ty' == ty then p else CAst.make ?loc @@ CPatCnv (pat', ty') + +(** Used for notations *) +let rec subst_rawexpr subst ({loc;v=tr} as t) = match tr with +| CTacAtm _ -> t +| CTacRef ref -> + let ref' = subst_tacref subst ref in + if ref' == ref then t else CAst.make ?loc @@ CTacRef ref' +| CTacCst ref -> + let ref' = subst_or_relid subst ref in + if ref' == ref then t else CAst.make ?loc @@ CTacCst ref' +| CTacFun (bnd, e) -> + let map pat = subst_rawpattern subst pat in + let bnd' = List.Smart.map map bnd in + let e' = subst_rawexpr subst e in + if bnd' == bnd && e' == e then t else CAst.make ?loc @@ CTacFun (bnd', e') +| CTacApp (e, el) -> + let e' = subst_rawexpr subst e in + let el' = List.Smart.map (fun e -> subst_rawexpr subst e) el in + if e' == e && el' == el then t else CAst.make ?loc @@ CTacApp (e', el') +| CTacLet (isrec, bnd, e) -> + let map (na, e as p) = + let na' = subst_rawpattern subst na in + let e' = subst_rawexpr subst e in + if na' == na && e' == e then p else (na', e') + in + let bnd' = List.Smart.map map bnd in + let e' = subst_rawexpr subst e in + if bnd' == bnd && e' == e then t else CAst.make ?loc @@ CTacLet (isrec, bnd', e') +| CTacCnv (e, c) -> + let e' = subst_rawexpr subst e in + let c' = subst_rawtype subst c in + if c' == c && e' == e then t else CAst.make ?loc @@ CTacCnv (e', c') +| CTacSeq (e1, e2) -> + let e1' = subst_rawexpr subst e1 in + let e2' = subst_rawexpr subst e2 in + if e1' == e1 && e2' == e2 then t else CAst.make ?loc @@ CTacSeq (e1', e2') +| CTacCse (e, bl) -> + let map (p, e as x) = + let p' = subst_rawpattern subst p in + let e' = subst_rawexpr subst e in + if p' == p && e' == e then x else (p', e') + in + let e' = subst_rawexpr subst e in + let bl' = List.Smart.map map bl in + if e' == e && bl' == bl then t else CAst.make ?loc @@ CTacCse (e', bl') +| CTacRec el -> + let map (prj, e as p) = + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + if prj' == prj && e' == e then p else (prj', e') + in + let el' = List.Smart.map map el in + if el' == el then t else CAst.make ?loc @@ CTacRec el' +| CTacPrj (e, prj) -> + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + if prj' == prj && e' == e then t else CAst.make ?loc @@ CTacPrj (e', prj') +| CTacSet (e, prj, r) -> + let prj' = subst_projection subst prj in + let e' = subst_rawexpr subst e in + let r' = subst_rawexpr subst r in + if prj' == prj && e' == e && r' == r then t else CAst.make ?loc @@ CTacSet (e', prj', r') +| CTacExt _ -> assert false (** Should not be generated by globalization *) + +(** Registering *) + +let () = + let open Genintern in + let intern ist tac = + let env = match Genintern.Store.get ist.extra ltac2_env with + | None -> + (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) + let env = empty_env () in + if !Ltac_plugin.Tacintern.strict_check then env + else { env with env_str = false } + | Some env -> env + in + let loc = tac.loc in + let (tac, t) = intern_rec env tac in + let () = check_elt_unit loc env t in + (ist, tac) + in + Genintern.register_intern0 wit_ltac2 intern +let () = Genintern.register_subst0 wit_ltac2 subst_expr + +let () = + let open Genintern in + let intern ist (loc, id) = + let env = match Genintern.Store.get ist.extra ltac2_env with + | None -> + (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) + let env = empty_env () in + if !Ltac_plugin.Tacintern.strict_check then env + else { env with env_str = false } + | Some env -> env + in + let t = + try Id.Map.find id env.env_var + with Not_found -> + CErrors.user_err ?loc (str "Unbound value " ++ Id.print id) + in + let t = fresh_mix_type_scheme env t in + let () = unify ?loc env t (GTypRef (Other t_constr, [])) in + (ist, id) + in + Genintern.register_intern0 wit_ltac2_quotation intern + +let () = Genintern.register_subst0 wit_ltac2_quotation (fun _ id -> id) diff --git a/user-contrib/Ltac2/tac2intern.mli b/user-contrib/Ltac2/tac2intern.mli new file mode 100644 index 0000000000..d646b5cda5 --- /dev/null +++ b/user-contrib/Ltac2/tac2intern.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Mod_subst +open Tac2expr + +val intern : strict:bool -> raw_tacexpr -> glb_tacexpr * type_scheme +val intern_typedef : (KerName.t * int) Id.Map.t -> raw_quant_typedef -> glb_quant_typedef +val intern_open_type : raw_typexpr -> type_scheme + +(** Check that a term is a value. Only values are safe to marshall between + processes. *) +val is_value : glb_tacexpr -> bool +val check_unit : ?loc:Loc.t -> type_scheme -> unit + +val check_subtype : type_scheme -> type_scheme -> bool +(** [check_subtype t1 t2] returns [true] iff all values of intances of type [t1] + also have type [t2]. *) + +val subst_type : substitution -> 'a glb_typexpr -> 'a glb_typexpr +val subst_expr : substitution -> glb_tacexpr -> glb_tacexpr +val subst_quant_typedef : substitution -> glb_quant_typedef -> glb_quant_typedef +val subst_type_scheme : substitution -> type_scheme -> type_scheme + +val subst_rawexpr : substitution -> raw_tacexpr -> raw_tacexpr + +(** {5 Notations} *) + +val globalize : Id.Set.t -> raw_tacexpr -> raw_tacexpr +(** Replaces all qualified identifiers by their corresponding kernel name. The + set represents bound variables in the context. *) + +(** Errors *) + +val error_nargs_mismatch : ?loc:Loc.t -> ltac_constructor -> int -> int -> 'a +val error_nparams_mismatch : ?loc:Loc.t -> int -> int -> 'a + +(** Misc *) + +val drop_ltac2_env : Genintern.Store.t -> Genintern.Store.t diff --git a/user-contrib/Ltac2/tac2interp.ml b/user-contrib/Ltac2/tac2interp.ml new file mode 100644 index 0000000000..db779db471 --- /dev/null +++ b/user-contrib/Ltac2/tac2interp.ml @@ -0,0 +1,227 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Pp +open CErrors +open Names +open Proofview.Notations +open Tac2expr +open Tac2ffi + +exception LtacError = Tac2ffi.LtacError + +let backtrace : backtrace Evd.Store.field = Evd.Store.field () + +let print_ltac2_backtrace = ref false + +let get_backtrace = + Proofview.tclEVARMAP >>= fun sigma -> + match Evd.Store.get (Evd.get_extra_data sigma) backtrace with + | None -> Proofview.tclUNIT [] + | Some bt -> Proofview.tclUNIT bt + +let set_backtrace bt = + Proofview.tclEVARMAP >>= fun sigma -> + let store = Evd.get_extra_data sigma in + let store = Evd.Store.set store backtrace bt in + let sigma = Evd.set_extra_data store sigma in + Proofview.Unsafe.tclEVARS sigma + +let with_frame frame tac = + if !print_ltac2_backtrace then + get_backtrace >>= fun bt -> + set_backtrace (frame :: bt) >>= fun () -> + tac >>= fun ans -> + set_backtrace bt >>= fun () -> + Proofview.tclUNIT ans + else tac + +type environment = Tac2env.environment = { + env_ist : valexpr Id.Map.t; +} + +let empty_environment = { + env_ist = Id.Map.empty; +} + +type closure = { + mutable clos_env : valexpr Id.Map.t; + (** Mutable so that we can implement recursive functions imperatively *) + clos_var : Name.t list; + (** Bound variables *) + clos_exp : glb_tacexpr; + (** Body *) + clos_ref : ltac_constant option; + (** Global constant from which the closure originates *) +} + +let push_name ist id v = match id with +| Anonymous -> ist +| Name id -> { env_ist = Id.Map.add id v ist.env_ist } + +let get_var ist id = + try Id.Map.find id ist.env_ist with Not_found -> + anomaly (str "Unbound variable " ++ Id.print id) + +let get_ref ist kn = + try + let data = Tac2env.interp_global kn in + data.Tac2env.gdata_expr + with Not_found -> + anomaly (str "Unbound reference" ++ KerName.print kn) + +let return = Proofview.tclUNIT + +let rec interp (ist : environment) = function +| GTacAtm (AtmInt n) -> return (Tac2ffi.of_int n) +| GTacAtm (AtmStr s) -> return (Tac2ffi.of_string (Bytes.of_string s)) +| GTacVar id -> return (get_var ist id) +| GTacRef kn -> + let data = get_ref ist kn in + return (eval_pure (Some kn) data) +| GTacFun (ids, e) -> + let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in + let f = interp_app cls in + return (Tac2ffi.of_closure f) +| GTacApp (f, args) -> + interp ist f >>= fun f -> + Proofview.Monad.List.map (fun e -> interp ist e) args >>= fun args -> + Tac2ffi.apply (Tac2ffi.to_closure f) args +| GTacLet (false, el, e) -> + let fold accu (na, e) = + interp ist e >>= fun e -> + return (push_name accu na e) + in + Proofview.Monad.List.fold_left fold ist el >>= fun ist -> + interp ist e +| GTacLet (true, el, e) -> + let map (na, e) = match e with + | GTacFun (ids, e) -> + let cls = { clos_ref = None; clos_env = ist.env_ist; clos_var = ids; clos_exp = e } in + let f = Tac2ffi.of_closure (interp_app cls) in + na, cls, f + | _ -> anomaly (str "Ill-formed recursive function") + in + let fixs = List.map map el in + let fold accu (na, _, cls) = match na with + | Anonymous -> accu + | Name id -> { env_ist = Id.Map.add id cls accu.env_ist } + in + let ist = List.fold_left fold ist fixs in + (* Hack to make a cycle imperatively in the environment *) + let iter (_, e, _) = e.clos_env <- ist.env_ist in + let () = List.iter iter fixs in + interp ist e +| GTacCst (_, n, []) -> return (Valexpr.make_int n) +| GTacCst (_, n, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + return (Valexpr.make_block n (Array.of_list el)) +| GTacCse (e, _, cse0, cse1) -> + interp ist e >>= fun e -> interp_case ist e cse0 cse1 +| GTacWth { opn_match = e; opn_branch = cse; opn_default = def } -> + interp ist e >>= fun e -> interp_with ist e cse def +| GTacPrj (_, e, p) -> + interp ist e >>= fun e -> interp_proj ist e p +| GTacSet (_, e, p, r) -> + interp ist e >>= fun e -> + interp ist r >>= fun r -> + interp_set ist e p r +| GTacOpn (kn, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + return (Tac2ffi.of_open (kn, Array.of_list el)) +| GTacPrm (ml, el) -> + Proofview.Monad.List.map (fun e -> interp ist e) el >>= fun el -> + with_frame (FrPrim ml) (Tac2ffi.apply (Tac2env.interp_primitive ml) el) +| GTacExt (tag, e) -> + let tpe = Tac2env.interp_ml_object tag in + with_frame (FrExtn (tag, e)) (tpe.Tac2env.ml_interp ist e) + +and interp_app f = + let ans = fun args -> + let { clos_env = ist; clos_var = ids; clos_exp = e; clos_ref = kn } = f in + let frame = match kn with + | None -> FrAnon e + | Some kn -> FrLtac kn + in + let ist = { env_ist = ist } in + let ist = List.fold_left2 push_name ist ids args in + with_frame frame (interp ist e) + in + Tac2ffi.abstract (List.length f.clos_var) ans + +and interp_case ist e cse0 cse1 = + if Valexpr.is_int e then + interp ist cse0.(Tac2ffi.to_int e) + else + let (n, args) = Tac2ffi.to_block e in + let (ids, e) = cse1.(n) in + let ist = CArray.fold_left2 push_name ist ids args in + interp ist e + +and interp_with ist e cse def = + let (kn, args) = Tac2ffi.to_open e in + let br = try Some (KNmap.find kn cse) with Not_found -> None in + begin match br with + | None -> + let (self, def) = def in + let ist = push_name ist self e in + interp ist def + | Some (self, ids, p) -> + let ist = push_name ist self e in + let ist = CArray.fold_left2 push_name ist ids args in + interp ist p + end + +and interp_proj ist e p = + return (Valexpr.field e p) + +and interp_set ist e p r = + let () = Valexpr.set_field e p r in + return (Valexpr.make_int 0) + +and eval_pure kn = function +| GTacAtm (AtmInt n) -> Valexpr.make_int n +| GTacRef kn -> + let { Tac2env.gdata_expr = e } = + try Tac2env.interp_global kn + with Not_found -> assert false + in + eval_pure (Some kn) e +| GTacFun (na, e) -> + let cls = { clos_ref = kn; clos_env = Id.Map.empty; clos_var = na; clos_exp = e } in + let f = interp_app cls in + Tac2ffi.of_closure f +| GTacCst (_, n, []) -> Valexpr.make_int n +| GTacCst (_, n, el) -> Valexpr.make_block n (Array.map_of_list eval_unnamed el) +| GTacOpn (kn, el) -> Tac2ffi.of_open (kn, Array.map_of_list eval_unnamed el) +| GTacAtm (AtmStr _) | GTacLet _ | GTacVar _ | GTacSet _ +| GTacApp _ | GTacCse _ | GTacPrj _ | GTacPrm _ | GTacExt _ | GTacWth _ -> + anomaly (Pp.str "Term is not a syntactical value") + +and eval_unnamed e = eval_pure None e + + +(** Cross-boundary hacks. *) + +open Geninterp + +let val_env : environment Val.typ = Val.create "ltac2:env" +let env_ref = Id.of_string_soft "@@ltac2_env@@" + +let extract_env (Val.Dyn (tag, v)) : environment = +match Val.eq tag val_env with +| None -> assert false +| Some Refl -> v + +let get_env ist = + try extract_env (Id.Map.find env_ref ist) + with Not_found -> empty_environment + +let set_env env ist = + Id.Map.add env_ref (Val.Dyn (val_env, env)) ist diff --git a/user-contrib/Ltac2/tac2interp.mli b/user-contrib/Ltac2/tac2interp.mli new file mode 100644 index 0000000000..21fdcd03af --- /dev/null +++ b/user-contrib/Ltac2/tac2interp.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Tac2expr +open Tac2ffi + +type environment = Tac2env.environment + +val empty_environment : environment + +val interp : environment -> glb_tacexpr -> valexpr Proofview.tactic + +(* val interp_app : closure -> ml_tactic *) + +(** {5 Cross-boundary encodings} *) + +val get_env : Ltac_pretype.unbound_ltac_var_map -> environment +val set_env : environment -> Ltac_pretype.unbound_ltac_var_map -> Ltac_pretype.unbound_ltac_var_map + +(** {5 Exceptions} *) + +exception LtacError of KerName.t * valexpr array +(** Ltac2-defined exceptions seen from OCaml side *) + +(** {5 Backtrace} *) + +val get_backtrace : backtrace Proofview.tactic + +val with_frame : frame -> 'a Proofview.tactic -> 'a Proofview.tactic + +val print_ltac2_backtrace : bool ref diff --git a/user-contrib/Ltac2/tac2match.ml b/user-contrib/Ltac2/tac2match.ml new file mode 100644 index 0000000000..058d02adde --- /dev/null +++ b/user-contrib/Ltac2/tac2match.ml @@ -0,0 +1,232 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration + +type context = EConstr.t + +type result = { + subst : Ltac_pretype.patvar_map ; +} + +type match_pattern = +| MatchPattern of Pattern.constr_pattern +| MatchContext of Pattern.constr_pattern + +(** TODO: handle definitions *) +type match_context_hyps = match_pattern + +type match_rule = match_context_hyps list * match_pattern + +(** {6 Utilities} *) + +(** Tests whether the substitution [s] is empty. *) +let is_empty_subst = Id.Map.is_empty + +(** {6 Non-linear patterns} *) + + +(** The patterns of Ltac are not necessarily linear. Non-linear + pattern are partially handled by the {!Matching} module, however + goal patterns are not primitive to {!Matching}, hence we must deal + with non-linearity between hypotheses and conclusion. Subterms are + considered equal up to the equality implemented in + [equal_instances]. *) +(* spiwack: it doesn't seem to be quite the same rule for non-linear + term patterns and non-linearity between hypotheses and/or + conclusion. Indeed, in [Matching], matching is made modulo + syntactic equality, and here we merge modulo conversion. It may be + a good idea to have an entry point of [Matching] with a partial + substitution as argument instead of merging substitution here. That + would ensure consistency. *) +let equal_instances env sigma c1 c2 = + (* How to compare instances? Do we want the terms to be convertible? + unifiable? Do we want the universe levels to be relevant? + (historically, conv_x is used) *) + Reductionops.is_conv env sigma c1 c2 + +(** Merges two substitutions. Raises [Not_coherent_metas] when + encountering two instances of the same metavariable which are not + equal according to {!equal_instances}. *) +exception Not_coherent_metas +let verify_metas_coherence env sigma s1 s2 = + let merge id oc1 oc2 = match oc1, oc2 with + | None, None -> None + | None, Some c | Some c, None -> Some c + | Some c1, Some c2 -> + if equal_instances env sigma c1 c2 then Some c1 + else raise Not_coherent_metas + in + Id.Map.merge merge s1 s2 + +let matching_error = + CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.") + +let imatching_error = (matching_error, Exninfo.null) + +(** A functor is introduced to share the environment and the + evar_map. They do not change and it would be a pity to introduce + closures everywhere just for the occasional calls to + {!equal_instances}. *) +module type StaticEnvironment = sig + val env : Environ.env + val sigma : Evd.evar_map +end +module PatternMatching (E:StaticEnvironment) = struct + + + (** {6 The pattern-matching monad } *) + + + (** To focus on the algorithmic portion of pattern-matching, the + bookkeeping is relegated to a monad: the composition of the + bactracking monad of {!IStream.t} with a "writer" effect. *) + (* spiwack: as we don't benefit from the various stream optimisations + of Haskell, it may be costly to give the monad in direct style such as + here. We may want to use some continuation passing style. *) + type 'a tac = 'a Proofview.tactic + type 'a m = { stream : 'r. ('a -> result -> 'r tac) -> result -> 'r tac } + + (** The empty substitution. *) + let empty_subst = Id.Map.empty + + (** Composes two substitutions using {!verify_metas_coherence}. It + must be a monoid with neutral element {!empty_subst}. Raises + [Not_coherent_metas] when composition cannot be achieved. *) + let subst_prod s1 s2 = + if is_empty_subst s1 then s2 + else if is_empty_subst s2 then s1 + else verify_metas_coherence E.env E.sigma s1 s2 + + (** Merge two writers (and ignore the first value component). *) + let merge m1 m2 = + try Some { + subst = subst_prod m1.subst m2.subst; + } + with Not_coherent_metas -> None + + (** Monadic [return]: returns a single success with empty substitutions. *) + let return (type a) (lhs:a) : a m = + { stream = fun k ctx -> k lhs ctx } + + (** Monadic bind: each success of [x] is replaced by the successes + of [f x]. The substitutions of [x] and [f x] are composed, + dropping the apparent successes when the substitutions are not + coherent. *) + let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m = + { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx } + + (** A variant of [(>>=)] when the first argument returns [unit]. *) + let (<*>) (type a) (m:unit m) (y:a m) : a m = + { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx } + + (** Failure of the pattern-matching monad: no success. *) + let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error } + + let run (m : 'a m) = + let ctx = { + subst = empty_subst ; + } in + let eval x ctx = Proofview.tclUNIT (x, ctx) in + m.stream eval ctx + + (** Chooses in a list, in the same order as the list *) + let rec pick (l:'a list) (e, info) : 'a m = match l with + | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } + | x :: l -> + { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) } + + let pick l = pick l imatching_error + + let put_subst subst : unit m = + let s = { subst } in + { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } + + (** {6 Pattern-matching} *) + + let pattern_match_term pat term = + match pat with + | MatchPattern p -> + begin + try + put_subst (Constr_matching.matches E.env E.sigma p term) <*> + return None + with Constr_matching.PatternMatchingFailure -> fail + end + | MatchContext p -> + + let rec map s (e, info) = + { stream = fun k ctx -> match IStream.peek s with + | IStream.Nil -> Proofview.tclZERO ~info e + | IStream.Cons ({ Constr_matching.m_sub = (_, subst); m_ctx }, s) -> + let nctx = { subst } in + match merge ctx nctx with + | None -> (map s (e, info)).stream k ctx + | Some nctx -> Proofview.tclOR (k (Some (Lazy.force m_ctx)) nctx) (fun e -> (map s e).stream k ctx) + } + in + map (Constr_matching.match_subterm E.env E.sigma (Id.Set.empty,p) term) imatching_error + + let hyp_match_type pat hyps = + pick hyps >>= fun decl -> + let id = NamedDecl.get_id decl in + pattern_match_term pat (NamedDecl.get_type decl) >>= fun ctx -> + return (id, ctx) + + let _hyp_match_body_and_type bodypat typepat hyps = + pick hyps >>= function + | LocalDef (id,body,hyp) -> + pattern_match_term bodypat body >>= fun ctx_body -> + pattern_match_term typepat hyp >>= fun ctx_typ -> + return (id, ctx_body, ctx_typ) + | LocalAssum (id,hyp) -> fail + + let hyp_match pat hyps = + match pat with + | typepat -> + hyp_match_type typepat hyps +(* | Def ((_,hypname),bodypat,typepat) -> *) +(* hyp_match_body_and_type hypname bodypat typepat hyps *) + + (** [hyp_pattern_list_match pats hyps lhs], matches the list of + patterns [pats] against the hypotheses in [hyps], and eventually + returns [lhs]. *) + let rec hyp_pattern_list_match pats hyps accu = + match pats with + | pat::pats -> + hyp_match pat hyps >>= fun (matched_hyp, hyp_ctx) -> + let select_matched_hyp decl = Id.equal (NamedDecl.get_id decl) matched_hyp in + let hyps = CList.remove_first select_matched_hyp hyps in + hyp_pattern_list_match pats hyps ((matched_hyp, hyp_ctx) :: accu) + | [] -> return accu + + let rule_match_goal hyps concl = function + | (hyppats,conclpat) -> + (* the rules are applied from the topmost one (in the concrete + syntax) to the bottommost. *) + let hyppats = List.rev hyppats in + pattern_match_term conclpat concl >>= fun ctx_concl -> + hyp_pattern_list_match hyppats hyps [] >>= fun hyps -> + return (hyps, ctx_concl) + +end + +let match_goal env sigma concl ~rev rule = + let open Proofview.Notations in + let hyps = EConstr.named_context env in + let hyps = if rev then List.rev hyps else hyps in + let module E = struct + let env = env + let sigma = sigma + end in + let module M = PatternMatching(E) in + M.run (M.rule_match_goal hyps concl rule) >>= fun ((hyps, ctx_concl), subst) -> + Proofview.tclUNIT (hyps, ctx_concl, subst.subst) diff --git a/user-contrib/Ltac2/tac2match.mli b/user-contrib/Ltac2/tac2match.mli new file mode 100644 index 0000000000..c82c40d238 --- /dev/null +++ b/user-contrib/Ltac2/tac2match.mli @@ -0,0 +1,33 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open EConstr + +(** This file extends Matching with the main logic for Ltac2 match goal. *) + +type context = EConstr.t + +type match_pattern = +| MatchPattern of Pattern.constr_pattern +| MatchContext of Pattern.constr_pattern + +(** TODO: handle definitions *) +type match_context_hyps = match_pattern + +type match_rule = match_context_hyps list * match_pattern + +val match_goal: + Environ.env -> + Evd.evar_map -> + constr -> + rev:bool -> + match_rule -> + ((Id.t * context option) list * (* List of hypotheses matching: name + context *) + context option * (* Context for conclusion *) + Ltac_pretype.patvar_map (* Pattern variable substitution *)) Proofview.tactic diff --git a/user-contrib/Ltac2/tac2print.ml b/user-contrib/Ltac2/tac2print.ml new file mode 100644 index 0000000000..f4cb290265 --- /dev/null +++ b/user-contrib/Ltac2/tac2print.ml @@ -0,0 +1,488 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Pp +open Names +open Tac2expr +open Tac2env +open Tac2ffi + +(** Utils *) + +let change_kn_label kn id = + let mp = KerName.modpath kn in + KerName.make mp (Label.of_id id) + +let paren p = hov 2 (str "(" ++ p ++ str ")") + +let t_list = + KerName.make Tac2env.coq_prefix (Label.of_id (Id.of_string "list")) + + +(** Type printing *) + +type typ_level = +| T5_l +| T5_r +| T2 +| T1 +| T0 + +let t_unit = + KerName.make Tac2env.coq_prefix (Label.of_id (Id.of_string "unit")) + +let pr_typref kn = + Libnames.pr_qualid (Tac2env.shortest_qualid_of_type kn) + +let pr_glbtype_gen pr lvl c = + let rec pr_glbtype lvl = function + | GTypVar n -> str "'" ++ str (pr n) + | GTypRef (Other kn, []) -> pr_typref kn + | GTypRef (Other kn, [t]) -> + let paren = match lvl with + | T5_r | T5_l | T2 | T1 -> fun x -> x + | T0 -> paren + in + paren (pr_glbtype T1 t ++ spc () ++ pr_typref kn) + | GTypRef (Other kn, tl) -> + let paren = match lvl with + | T5_r | T5_l | T2 | T1 -> fun x -> x + | T0 -> paren + in + paren (str "(" ++ prlist_with_sep (fun () -> str ", ") (pr_glbtype lvl) tl ++ str ")" ++ spc () ++ pr_typref kn) + | GTypArrow (t1, t2) -> + let paren = match lvl with + | T5_r -> fun x -> x + | T5_l | T2 | T1 | T0 -> paren + in + paren (pr_glbtype T5_l t1 ++ spc () ++ str "->" ++ spc () ++ pr_glbtype T5_r t2) + | GTypRef (Tuple 0, []) -> + Libnames.pr_qualid (Tac2env.shortest_qualid_of_type t_unit) + | GTypRef (Tuple _, tl) -> + let paren = match lvl with + | T5_r | T5_l -> fun x -> x + | T2 | T1 | T0 -> paren + in + paren (prlist_with_sep (fun () -> str " * ") (pr_glbtype T2) tl) + in + hov 0 (pr_glbtype lvl c) + +let pr_glbtype pr c = pr_glbtype_gen pr T5_r c + +let int_name () = + let vars = ref Int.Map.empty in + fun n -> + if Int.Map.mem n !vars then Int.Map.find n !vars + else + let num = Int.Map.cardinal !vars in + let base = num mod 26 in + let rem = num / 26 in + let name = String.make 1 (Char.chr (97 + base)) in + let suff = if Int.equal rem 0 then "" else string_of_int rem in + let name = name ^ suff in + let () = vars := Int.Map.add n name !vars in + name + +(** Term printing *) + +let pr_constructor kn = + Libnames.pr_qualid (Tac2env.shortest_qualid_of_constructor kn) + +let pr_projection kn = + Libnames.pr_qualid (Tac2env.shortest_qualid_of_projection kn) + +type exp_level = Tac2expr.exp_level = +| E5 +| E4 +| E3 +| E2 +| E1 +| E0 + +let pr_atom = function +| AtmInt n -> Pp.int n +| AtmStr s -> qstring s + +let pr_name = function +| Name id -> Id.print id +| Anonymous -> str "_" + +let find_constructor n empty def = + let rec find n = function + | [] -> assert false + | (id, []) as ans :: rem -> + if empty then + if Int.equal n 0 then ans + else find (pred n) rem + else find n rem + | (id, _ :: _) as ans :: rem -> + if not empty then + if Int.equal n 0 then ans + else find (pred n) rem + else find n rem + in + find n def + +let pr_internal_constructor tpe n is_const = + let data = match Tac2env.interp_type tpe with + | (_, GTydAlg data) -> data + | _ -> assert false + in + let (id, _) = find_constructor n is_const data.galg_constructors in + let kn = change_kn_label tpe id in + pr_constructor kn + +let order_branches cbr nbr def = + let rec order cidx nidx def = match def with + | [] -> [] + | (id, []) :: rem -> + let ans = order (succ cidx) nidx rem in + (id, [], cbr.(cidx)) :: ans + | (id, _ :: _) :: rem -> + let ans = order cidx (succ nidx) rem in + let (vars, e) = nbr.(nidx) in + (id, Array.to_list vars, e) :: ans + in + order 0 0 def + +let pr_glbexpr_gen lvl c = + let rec pr_glbexpr lvl = function + | GTacAtm atm -> pr_atom atm + | GTacVar id -> Id.print id + | GTacRef gr -> + let qid = shortest_qualid_of_ltac (TacConstant gr) in + Libnames.pr_qualid qid + | GTacFun (nas, c) -> + let nas = pr_sequence pr_name nas in + let paren = match lvl with + | E0 | E1 | E2 | E3 | E4 -> paren + | E5 -> fun x -> x + in + paren (hov 0 (hov 2 (str "fun" ++ spc () ++ nas) ++ spc () ++ str "=>" ++ spc () ++ + pr_glbexpr E5 c)) + | GTacApp (c, cl) -> + let paren = match lvl with + | E0 -> paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + paren (hov 2 (pr_glbexpr E1 c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) + | GTacLet (mut, bnd, e) -> + let paren = match lvl with + | E0 | E1 | E2 | E3 | E4 -> paren + | E5 -> fun x -> x + in + let mut = if mut then str "rec" ++ spc () else mt () in + let pr_bnd (na, e) = + pr_name na ++ spc () ++ str ":=" ++ spc () ++ hov 2 (pr_glbexpr E5 e) ++ spc () + in + let bnd = prlist_with_sep (fun () -> str "with" ++ spc ()) pr_bnd bnd in + paren (hv 0 (hov 2 (str "let" ++ spc () ++ mut ++ bnd ++ str "in") ++ spc () ++ pr_glbexpr E5 e)) + | GTacCst (Tuple 0, _, _) -> str "()" + | GTacCst (Tuple _, _, cl) -> + let paren = match lvl with + | E0 | E1 -> paren + | E2 | E3 | E4 | E5 -> fun x -> x + in + paren (prlist_with_sep (fun () -> str "," ++ spc ()) (pr_glbexpr E1) cl) + | GTacCst (Other tpe, n, cl) -> + pr_applied_constructor lvl tpe n cl + | GTacCse (e, info, cst_br, ncst_br) -> + let e = pr_glbexpr E5 e in + let br = match info with + | Other kn -> + let def = match Tac2env.interp_type kn with + | _, GTydAlg { galg_constructors = def } -> def + | _, GTydDef _ | _, GTydRec _ | _, GTydOpn -> assert false + in + let br = order_branches cst_br ncst_br def in + let pr_branch (cstr, vars, p) = + let cstr = change_kn_label kn cstr in + let cstr = pr_constructor cstr in + let vars = match vars with + | [] -> mt () + | _ -> spc () ++ pr_sequence pr_name vars + in + hov 4 (str "|" ++ spc () ++ hov 0 (cstr ++ vars ++ spc () ++ str "=>") ++ spc () ++ + hov 2 (pr_glbexpr E5 p)) ++ spc () + in + prlist pr_branch br + | Tuple n -> + let (vars, p) = if Int.equal n 0 then ([||], cst_br.(0)) else ncst_br.(0) in + let p = pr_glbexpr E5 p in + let vars = prvect_with_sep (fun () -> str "," ++ spc ()) pr_name vars in + hov 4 (str "|" ++ spc () ++ hov 0 (paren vars ++ spc () ++ str "=>") ++ spc () ++ p) + in + v 0 (hv 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ br ++ spc () ++ str "end") + | GTacWth wth -> + let e = pr_glbexpr E5 wth.opn_match in + let pr_pattern c self vars p = + let self = match self with + | Anonymous -> mt () + | Name id -> spc () ++ str "as" ++ spc () ++ Id.print id + in + hov 4 (str "|" ++ spc () ++ hov 0 (c ++ vars ++ self ++ spc () ++ str "=>") ++ spc () ++ + hov 2 (pr_glbexpr E5 p)) ++ spc () + in + let pr_branch (cstr, (self, vars, p)) = + let cstr = pr_constructor cstr in + let vars = match Array.to_list vars with + | [] -> mt () + | vars -> spc () ++ pr_sequence pr_name vars + in + pr_pattern cstr self vars p + in + let br = prlist pr_branch (KNmap.bindings wth.opn_branch) in + let (def_as, def_p) = wth.opn_default in + let def = pr_pattern (str "_") def_as (mt ()) def_p in + let br = br ++ def in + v 0 (hv 0 (str "match" ++ spc () ++ e ++ spc () ++ str "with") ++ spc () ++ br ++ str "end") + | GTacPrj (kn, e, n) -> + let def = match Tac2env.interp_type kn with + | _, GTydRec def -> def + | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false + in + let (proj, _, _) = List.nth def n in + let proj = change_kn_label kn proj in + let proj = pr_projection proj in + let e = pr_glbexpr E0 e in + hov 0 (e ++ str "." ++ paren proj) + | GTacSet (kn, e, n, r) -> + let def = match Tac2env.interp_type kn with + | _, GTydRec def -> def + | _, GTydDef _ | _, GTydAlg _ | _, GTydOpn -> assert false + in + let (proj, _, _) = List.nth def n in + let proj = change_kn_label kn proj in + let proj = pr_projection proj in + let e = pr_glbexpr E0 e in + let r = pr_glbexpr E1 r in + hov 0 (e ++ str "." ++ paren proj ++ spc () ++ str ":=" ++ spc () ++ r) + | GTacOpn (kn, cl) -> + let paren = match lvl with + | E0 -> paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + let c = pr_constructor kn in + paren (hov 0 (c ++ spc () ++ (pr_sequence (pr_glbexpr E0) cl))) + | GTacExt (tag, arg) -> + let tpe = interp_ml_object tag in + hov 0 (tpe.ml_print (Global.env ()) arg) (* FIXME *) + | GTacPrm (prm, args) -> + let args = match args with + | [] -> mt () + | _ -> spc () ++ pr_sequence (pr_glbexpr E0) args + in + hov 0 (str "@external" ++ spc () ++ qstring prm.mltac_plugin ++ spc () ++ + qstring prm.mltac_tactic ++ args) + and pr_applied_constructor lvl tpe n cl = + let _, data = Tac2env.interp_type tpe in + if KerName.equal tpe t_list then + let rec factorize accu = function + | GTacCst (_, 0, []) -> accu, None + | GTacCst (_, 0, [e; l]) -> factorize (e :: accu) l + | e -> accu, Some e + in + let l, e = factorize [] (GTacCst (Other tpe, n, cl)) in + match e with + | None -> + let pr e = pr_glbexpr E4 e in + hov 2 (str "[" ++ prlist_with_sep pr_semicolon pr (List.rev l) ++ str "]") + | Some e -> + let paren = match lvl with + | E0 | E1 | E2 -> paren + | E3 | E4 | E5 -> fun x -> x + in + let pr e = pr_glbexpr E1 e in + let pr_cons () = spc () ++ str "::" ++ spc () in + paren (hov 2 (prlist_with_sep pr_cons pr (List.rev (e :: l)))) + else match data with + | GTydAlg def -> + let paren = match lvl with + | E0 -> + if List.is_empty cl then fun x -> x else paren + | E1 | E2 | E3 | E4 | E5 -> fun x -> x + in + let cstr = pr_internal_constructor tpe n (List.is_empty cl) in + let cl = match cl with + | [] -> mt () + | _ -> spc () ++ pr_sequence (pr_glbexpr E0) cl + in + paren (hov 2 (cstr ++ cl)) + | GTydRec def -> + let args = List.combine def cl in + let pr_arg ((id, _, _), arg) = + let kn = change_kn_label tpe id in + pr_projection kn ++ spc () ++ str ":=" ++ spc () ++ pr_glbexpr E1 arg + in + let args = prlist_with_sep pr_semicolon pr_arg args in + hv 0 (str "{" ++ spc () ++ args ++ spc () ++ str "}") + | (GTydDef _ | GTydOpn) -> assert false + in + hov 0 (pr_glbexpr lvl c) + + + +let pr_glbexpr c = + pr_glbexpr_gen E5 c + +(** Toplevel printers *) + +let rec subst_type subst (t : 'a glb_typexpr) = match t with +| GTypVar id -> subst.(id) +| GTypArrow (t1, t2) -> GTypArrow (subst_type subst t1, subst_type subst t2) +| GTypRef (qid, args) -> + GTypRef (qid, List.map (fun t -> subst_type subst t) args) + +let unfold kn args = + let (nparams, def) = Tac2env.interp_type kn in + match def with + | GTydDef (Some def) -> + let args = Array.of_list args in + Some (subst_type args def) + | _ -> None + +let rec kind t = match t with +| GTypVar id -> GTypVar id +| GTypRef (Other kn, tl) -> + begin match unfold kn tl with + | None -> t + | Some t -> kind t + end +| GTypArrow _ | GTypRef (Tuple _, _) -> t + +type val_printer = + { val_printer : 'a. Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr list -> Pp.t } + +let printers = ref KNmap.empty + +let register_val_printer kn pr = + printers := KNmap.add kn pr !printers + +open Tac2ffi + +let rec pr_valexpr env sigma v t = match kind t with +| GTypVar _ -> str "<poly>" +| GTypRef (Other kn, params) -> + let pr = try Some (KNmap.find kn !printers) with Not_found -> None in + begin match pr with + | Some pr -> pr.val_printer env sigma v params + | None -> + let n, repr = Tac2env.interp_type kn in + if KerName.equal kn t_list then + pr_val_list env sigma (to_list (fun v -> repr_to valexpr v) v) (List.hd params) + else match repr with + | GTydDef None -> str "<abstr>" + | GTydDef (Some _) -> + (* Shouldn't happen thanks to kind *) + assert false + | GTydAlg alg -> + if Valexpr.is_int v then + pr_internal_constructor kn (Tac2ffi.to_int v) true + else + let (n, args) = Tac2ffi.to_block v in + let (id, tpe) = find_constructor n false alg.galg_constructors in + let knc = change_kn_label kn id in + let args = pr_constrargs env sigma params args tpe in + hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") + | GTydRec rcd -> + let (_, args) = Tac2ffi.to_block v in + pr_record env sigma params args rcd + | GTydOpn -> + begin match Tac2ffi.to_open v with + | (knc, [||]) -> pr_constructor knc + | (knc, args) -> + let data = Tac2env.interp_constructor knc in + let args = pr_constrargs env sigma params args data.Tac2env.cdata_args in + hv 2 (pr_constructor knc ++ spc () ++ str "(" ++ args ++ str ")") + end + end +| GTypArrow _ -> str "<fun>" +| GTypRef (Tuple 0, []) -> str "()" +| GTypRef (Tuple _, tl) -> + let blk = Array.to_list (snd (to_block v)) in + if List.length blk == List.length tl then + let prs = List.map2 (fun v t -> pr_valexpr env sigma v t) blk tl in + hv 2 (str "(" ++ prlist_with_sep pr_comma (fun p -> p) prs ++ str ")") + else + str "<unknown>" + +and pr_constrargs env sigma params args tpe = + let subst = Array.of_list params in + let tpe = List.map (fun t -> subst_type subst t) tpe in + let args = Array.to_list args in + let args = List.combine args tpe in + prlist_with_sep pr_comma (fun (v, t) -> pr_valexpr env sigma v t) args + +and pr_record env sigma params args rcd = + let subst = Array.of_list params in + let map (id, _, tpe) = (id, subst_type subst tpe) in + let rcd = List.map map rcd in + let args = Array.to_list args in + let fields = List.combine rcd args in + let pr_field ((id, t), arg) = + Id.print id ++ spc () ++ str ":=" ++ spc () ++ pr_valexpr env sigma arg t + in + str "{" ++ spc () ++ prlist_with_sep pr_semicolon pr_field fields ++ spc () ++ str "}" + +and pr_val_list env sigma args tpe = + let pr v = pr_valexpr env sigma v tpe in + str "[" ++ prlist_with_sep pr_semicolon pr args ++ str "]" + +let register_init n f = + let kn = KerName.make Tac2env.coq_prefix (Label.make n) in + register_val_printer kn { val_printer = fun env sigma v _ -> f env sigma v } + +let () = register_init "int" begin fun _ _ n -> + let n = to_int n in + Pp.int n +end + +let () = register_init "string" begin fun _ _ s -> + let s = to_string s in + Pp.quote (str (Bytes.to_string s)) +end + +let () = register_init "ident" begin fun _ _ id -> + let id = to_ident id in + str "@" ++ Id.print id +end + +let () = register_init "constr" begin fun env sigma c -> + let c = to_constr c in + let c = try Printer.pr_leconstr_env env sigma c with _ -> str "..." in + str "constr:(" ++ c ++ str ")" +end + +let () = register_init "pattern" begin fun env sigma c -> + let c = to_pattern c in + let c = try Printer.pr_lconstr_pattern_env env sigma c with _ -> str "..." in + str "pattern:(" ++ c ++ str ")" +end + +let () = register_init "message" begin fun _ _ pp -> + str "message:(" ++ to_pp pp ++ str ")" +end + +let () = register_init "err" begin fun _ _ e -> + let e = to_ext val_exn e in + let (e, _) = ExplainErr.process_vernac_interp_error ~allow_uncaught:true e in + str "err:(" ++ CErrors.print_no_report e ++ str ")" +end + +let () = + let kn = KerName.make Tac2env.coq_prefix (Label.make "array") in + let val_printer env sigma v arg = match arg with + | [arg] -> + let (_, v) = to_block v in + str "[|" ++ spc () ++ + prvect_with_sep pr_semicolon (fun a -> pr_valexpr env sigma a arg) v ++ + spc () ++ str "|]" + | _ -> assert false + in + register_val_printer kn { val_printer } diff --git a/user-contrib/Ltac2/tac2print.mli b/user-contrib/Ltac2/tac2print.mli new file mode 100644 index 0000000000..9b9db2937d --- /dev/null +++ b/user-contrib/Ltac2/tac2print.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Tac2expr +open Tac2ffi + +(** {5 Printing types} *) + +type typ_level = +| T5_l +| T5_r +| T2 +| T1 +| T0 + +val pr_typref : type_constant -> Pp.t +val pr_glbtype_gen : ('a -> string) -> typ_level -> 'a glb_typexpr -> Pp.t +val pr_glbtype : ('a -> string) -> 'a glb_typexpr -> Pp.t + +(** {5 Printing expressions} *) + +val pr_constructor : ltac_constructor -> Pp.t +val pr_internal_constructor : type_constant -> int -> bool -> Pp.t +val pr_projection : ltac_projection -> Pp.t +val pr_glbexpr_gen : exp_level -> glb_tacexpr -> Pp.t +val pr_glbexpr : glb_tacexpr -> Pp.t + +(** {5 Printing values}*) + +type val_printer = + { val_printer : 'a. Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr list -> Pp.t } + +val register_val_printer : type_constant -> val_printer -> unit + +val pr_valexpr : Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr -> Pp.t + +(** {5 Utilities} *) + +val int_name : unit -> (int -> string) +(** Create a function that give names to integers. The names are generated on + the fly, in the order they are encountered. *) diff --git a/user-contrib/Ltac2/tac2qexpr.mli b/user-contrib/Ltac2/tac2qexpr.mli new file mode 100644 index 0000000000..400ab1a092 --- /dev/null +++ b/user-contrib/Ltac2/tac2qexpr.mli @@ -0,0 +1,173 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Tac2expr + +(** Quoted variants of Ltac syntactic categories. Contrarily to the former, they + sometimes allow anti-quotations. Used for notation scopes. *) + +type 'a or_anti = +| QExpr of 'a +| QAnti of Id.t CAst.t + +type reference_r = +| QReference of Libnames.qualid +| QHypothesis of Id.t + +type reference = reference_r CAst.t + +type quantified_hypothesis = +| QAnonHyp of int CAst.t +| QNamedHyp of Id.t CAst.t + +type bindings_r = +| QImplicitBindings of Constrexpr.constr_expr list +| QExplicitBindings of (quantified_hypothesis CAst.t or_anti * Constrexpr.constr_expr) CAst.t list +| QNoBindings + +type bindings = bindings_r CAst.t + +type intro_pattern_r = +| QIntroForthcoming of bool +| QIntroNaming of intro_pattern_naming +| QIntroAction of intro_pattern_action +and intro_pattern_naming_r = +| QIntroIdentifier of Id.t CAst.t or_anti +| QIntroFresh of Id.t CAst.t or_anti +| QIntroAnonymous +and intro_pattern_action_r = +| QIntroWildcard +| QIntroOrAndPattern of or_and_intro_pattern +| QIntroInjection of intro_pattern list CAst.t +(* | QIntroApplyOn of Empty.t (** Not implemented yet *) *) +| QIntroRewrite of bool +and or_and_intro_pattern_r = +| QIntroOrPattern of intro_pattern list CAst.t list +| QIntroAndPattern of intro_pattern list CAst.t + +and intro_pattern = intro_pattern_r CAst.t +and intro_pattern_naming = intro_pattern_naming_r CAst.t +and intro_pattern_action = intro_pattern_action_r CAst.t +and or_and_intro_pattern = or_and_intro_pattern_r CAst.t + +type occurrences_r = +| QAllOccurrences +| QAllOccurrencesBut of int CAst.t or_anti list +| QNoOccurrences +| QOnlyOccurrences of int CAst.t or_anti list + +type occurrences = occurrences_r CAst.t + +type hyp_location = (occurrences * Id.t CAst.t or_anti) * Locus.hyp_location_flag + +type clause_r = + { q_onhyps : hyp_location list option; q_concl_occs : occurrences; } + +type clause = clause_r CAst.t + +type constr_with_bindings = (Constrexpr.constr_expr * bindings) CAst.t + +type destruction_arg_r = +| QElimOnConstr of constr_with_bindings +| QElimOnIdent of Id.t CAst.t +| QElimOnAnonHyp of int CAst.t + +type destruction_arg = destruction_arg_r CAst.t + +type induction_clause_r = { + indcl_arg : destruction_arg; + indcl_eqn : intro_pattern_naming option; + indcl_as : or_and_intro_pattern option; + indcl_in : clause option; +} + +type induction_clause = induction_clause_r CAst.t + +type conversion_r = +| QConvert of Constrexpr.constr_expr +| QConvertWith of Constrexpr.constr_expr * Constrexpr.constr_expr + +type conversion = conversion_r CAst.t + +type multi_r = +| QPrecisely of int CAst.t +| QUpTo of int CAst.t +| QRepeatStar +| QRepeatPlus + +type multi = multi_r CAst.t + +type rewriting_r = { + rew_orient : bool option CAst.t; + rew_repeat : multi; + rew_equatn : constr_with_bindings; +} + +type rewriting = rewriting_r CAst.t + +type dispatch_r = raw_tacexpr option list * (raw_tacexpr option * raw_tacexpr option list) option + +type dispatch = dispatch_r CAst.t + +type red_flag_r = +| QBeta +| QIota +| QMatch +| QFix +| QCofix +| QZeta +| QConst of reference or_anti list CAst.t +| QDeltaBut of reference or_anti list CAst.t + +type red_flag = red_flag_r CAst.t + +type strategy_flag = red_flag list CAst.t + +type constr_match_pattern_r = +| QConstrMatchPattern of Constrexpr.constr_expr +| QConstrMatchContext of Id.t option * Constrexpr.constr_expr + +type constr_match_pattern = constr_match_pattern_r CAst.t + +type constr_match_branch = (constr_match_pattern * raw_tacexpr) CAst.t + +type constr_matching = constr_match_branch list CAst.t + +type goal_match_pattern_r = { + q_goal_match_concl : constr_match_pattern; + q_goal_match_hyps : (Names.lname * constr_match_pattern) list; +} + +type goal_match_pattern = goal_match_pattern_r CAst.t + +type goal_match_branch = (goal_match_pattern * raw_tacexpr) CAst.t + +type goal_matching = goal_match_branch list CAst.t + +type hintdb_r = +| QHintAll +| QHintDbs of Id.t CAst.t or_anti list + +type hintdb = hintdb_r CAst.t + +type move_location_r = +| QMoveAfter of Id.t CAst.t or_anti +| QMoveBefore of Id.t CAst.t or_anti +| QMoveFirst +| QMoveLast + +type move_location = move_location_r CAst.t + +type pose = (Id.t CAst.t or_anti option * Constrexpr.constr_expr) CAst.t + +type assertion_r = +| QAssertType of intro_pattern option * Constrexpr.constr_expr * raw_tacexpr option +| QAssertValue of Id.t CAst.t or_anti * Constrexpr.constr_expr + +type assertion = assertion_r CAst.t diff --git a/user-contrib/Ltac2/tac2quote.ml b/user-contrib/Ltac2/tac2quote.ml new file mode 100644 index 0000000000..a98264745e --- /dev/null +++ b/user-contrib/Ltac2/tac2quote.ml @@ -0,0 +1,465 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open Names +open Util +open CAst +open Tac2dyn +open Tac2expr +open Tac2qexpr + +(** Generic arguments *) + +let wit_pattern = Arg.create "pattern" +let wit_reference = Arg.create "reference" +let wit_ident = Arg.create "ident" +let wit_constr = Arg.create "constr" +let wit_open_constr = Arg.create "open_constr" +let wit_ltac1 = Arg.create "ltac1" +let wit_ltac1val = Arg.create "ltac1val" + +(** Syntactic quoting of expressions. *) + +let prefix_gen n = + MPfile (DirPath.make (List.map Id.of_string [n; "Ltac2"])) + +let control_prefix = prefix_gen "Control" +let pattern_prefix = prefix_gen "Pattern" +let array_prefix = prefix_gen "Array" + +let kername prefix n = KerName.make prefix (Label.of_id (Id.of_string_soft n)) +let std_core n = kername Tac2env.std_prefix n +let coq_core n = kername Tac2env.coq_prefix n +let control_core n = kername control_prefix n +let pattern_core n = kername pattern_prefix n + +let global_ref ?loc kn = + CAst.make ?loc @@ CTacRef (AbsKn (TacConstant kn)) + +let constructor ?loc kn args = + let cst = CAst.make ?loc @@ CTacCst (AbsKn (Other kn)) in + if List.is_empty args then cst + else CAst.make ?loc @@ CTacApp (cst, args) + +let std_constructor ?loc name args = + constructor ?loc (std_core name) args + +let std_proj ?loc name = + AbsKn (std_core name) + +let thunk e = + let t_unit = coq_core "unit" in + let loc = e.loc in + let ty = CAst.make?loc @@ CTypRef (AbsKn (Other t_unit), []) in + let pat = CAst.make ?loc @@ CPatVar (Anonymous) in + let pat = CAst.make ?loc @@ CPatCnv (pat, ty) in + CAst.make ?loc @@ CTacFun ([pat], e) + +let of_pair f g {loc;v=(e1, e2)} = + CAst.make ?loc @@ CTacApp (CAst.make ?loc @@ CTacCst (AbsKn (Tuple 2)), [f e1; g e2]) + +let of_tuple ?loc el = match el with +| [] -> + CAst.make ?loc @@ CTacCst (AbsKn (Tuple 0)) +| [e] -> e +| el -> + let len = List.length el in + CAst.make ?loc @@ CTacApp (CAst.make ?loc @@ CTacCst (AbsKn (Tuple len)), el) + +let of_int {loc;v=n} = + CAst.make ?loc @@ CTacAtm (AtmInt n) + +let of_option ?loc f opt = match opt with +| None -> constructor ?loc (coq_core "None") [] +| Some e -> constructor ?loc (coq_core "Some") [f e] + +let inj_wit ?loc wit x = + CAst.make ?loc @@ CTacExt (wit, x) + +let of_variable {loc;v=id} = + let qid = Libnames.qualid_of_ident ?loc id in + if Tac2env.is_constructor qid then + CErrors.user_err ?loc (str "Invalid identifier") + else CAst.make ?loc @@ CTacRef (RelId qid) + +let of_anti f = function +| QExpr x -> f x +| QAnti id -> of_variable id + +let of_ident {loc;v=id} = inj_wit ?loc wit_ident id + +let of_constr c = + let loc = Constrexpr_ops.constr_loc c in + inj_wit ?loc wit_constr c + +let of_open_constr c = + let loc = Constrexpr_ops.constr_loc c in + inj_wit ?loc wit_open_constr c + +let of_bool ?loc b = + let c = if b then coq_core "true" else coq_core "false" in + constructor ?loc c [] + +let rec of_list ?loc f = function +| [] -> constructor (coq_core "[]") [] +| e :: l -> + constructor ?loc (coq_core "::") [f e; of_list ?loc f l] + +let of_qhyp {loc;v=h} = match h with +| QAnonHyp n -> std_constructor ?loc "AnonHyp" [of_int n] +| QNamedHyp id -> std_constructor ?loc "NamedHyp" [of_ident id] + +let of_bindings {loc;v=b} = match b with +| QNoBindings -> + std_constructor ?loc "NoBindings" [] +| QImplicitBindings tl -> + std_constructor ?loc "ImplicitBindings" [of_list ?loc of_open_constr tl] +| QExplicitBindings tl -> + let map e = of_pair (fun q -> of_anti of_qhyp q) of_open_constr e in + std_constructor ?loc "ExplicitBindings" [of_list ?loc map tl] + +let of_constr_with_bindings c = of_pair of_open_constr of_bindings c + +let rec of_intro_pattern {loc;v=pat} = match pat with +| QIntroForthcoming b -> + std_constructor ?loc "IntroForthcoming" [of_bool b] +| QIntroNaming iname -> + std_constructor ?loc "IntroNaming" [of_intro_pattern_naming iname] +| QIntroAction iact -> + std_constructor ?loc "IntroAction" [of_intro_pattern_action iact] + +and of_intro_pattern_naming {loc;v=pat} = match pat with +| QIntroIdentifier id -> + std_constructor ?loc "IntroIdentifier" [of_anti of_ident id] +| QIntroFresh id -> + std_constructor ?loc "IntroFresh" [of_anti of_ident id] +| QIntroAnonymous -> + std_constructor ?loc "IntroAnonymous" [] + +and of_intro_pattern_action {loc;v=pat} = match pat with +| QIntroWildcard -> + std_constructor ?loc "IntroWildcard" [] +| QIntroOrAndPattern pat -> + std_constructor ?loc "IntroOrAndPattern" [of_or_and_intro_pattern pat] +| QIntroInjection il -> + std_constructor ?loc "IntroInjection" [of_intro_patterns il] +| QIntroRewrite b -> + std_constructor ?loc "IntroRewrite" [of_bool ?loc b] + +and of_or_and_intro_pattern {loc;v=pat} = match pat with +| QIntroOrPattern ill -> + std_constructor ?loc "IntroOrPattern" [of_list ?loc of_intro_patterns ill] +| QIntroAndPattern il -> + std_constructor ?loc "IntroAndPattern" [of_intro_patterns il] + +and of_intro_patterns {loc;v=l} = + of_list ?loc of_intro_pattern l + +let of_hyp_location_flag ?loc = function +| Locus.InHyp -> std_constructor ?loc "InHyp" [] +| Locus.InHypTypeOnly -> std_constructor ?loc "InHypTypeOnly" [] +| Locus.InHypValueOnly -> std_constructor ?loc "InHypValueOnly" [] + +let of_occurrences {loc;v=occ} = match occ with +| QAllOccurrences -> std_constructor ?loc "AllOccurrences" [] +| QAllOccurrencesBut occs -> + let map occ = of_anti of_int occ in + let occs = of_list ?loc map occs in + std_constructor ?loc "AllOccurrencesBut" [occs] +| QNoOccurrences -> std_constructor ?loc "NoOccurrences" [] +| QOnlyOccurrences occs -> + let map occ = of_anti of_int occ in + let occs = of_list ?loc map occs in + std_constructor ?loc "OnlyOccurrences" [occs] + +let of_hyp_location ?loc ((occs, id), flag) = + of_tuple ?loc [ + of_anti of_ident id; + of_occurrences occs; + of_hyp_location_flag ?loc flag; + ] + +let of_clause {loc;v=cl} = + let hyps = of_option ?loc (fun l -> of_list ?loc of_hyp_location l) cl.q_onhyps in + let concl = of_occurrences cl.q_concl_occs in + CAst.make ?loc @@ CTacRec ([ + std_proj "on_hyps", hyps; + std_proj "on_concl", concl; + ]) + +let of_destruction_arg {loc;v=arg} = match arg with +| QElimOnConstr c -> + let arg = thunk (of_constr_with_bindings c) in + std_constructor ?loc "ElimOnConstr" [arg] +| QElimOnIdent id -> std_constructor ?loc "ElimOnIdent" [of_ident id] +| QElimOnAnonHyp n -> std_constructor ?loc "ElimOnAnonHyp" [of_int n] + +let of_induction_clause {loc;v=cl} = + let arg = of_destruction_arg cl.indcl_arg in + let eqn = of_option ?loc of_intro_pattern_naming cl.indcl_eqn in + let as_ = of_option ?loc of_or_and_intro_pattern cl.indcl_as in + let in_ = of_option ?loc of_clause cl.indcl_in in + CAst.make ?loc @@ CTacRec ([ + std_proj "indcl_arg", arg; + std_proj "indcl_eqn", eqn; + std_proj "indcl_as", as_; + std_proj "indcl_in", in_; + ]) + +let check_pattern_id ?loc id = + if Tac2env.is_constructor (Libnames.qualid_of_ident id) then + CErrors.user_err ?loc (str "Invalid pattern binding name " ++ Id.print id) + +let pattern_vars pat = + let rec aux () accu pat = match pat.CAst.v with + | Constrexpr.CPatVar id + | Constrexpr.CEvar (id, []) -> + let () = check_pattern_id ?loc:pat.CAst.loc id in + Id.Set.add id accu + | _ -> + Constrexpr_ops.fold_constr_expr_with_binders (fun _ () -> ()) aux () accu pat + in + aux () Id.Set.empty pat + +let abstract_vars loc vars tac = + let get_name = function Name id -> Some id | Anonymous -> None in + let def = try Some (List.find_map get_name vars) with Not_found -> None in + let na, tac = match def with + | None -> (Anonymous, tac) + | Some id0 -> + (* Trick: in order not to shadow a variable nor to choose an arbitrary + name, we reuse one which is going to be shadowed by the matched + variables anyways. *) + let build_bindings (n, accu) na = match na with + | Anonymous -> (n + 1, accu) + | Name _ -> + let get = global_ref ?loc (kername array_prefix "get") in + let args = [of_variable CAst.(make ?loc id0); of_int CAst.(make ?loc n)] in + let e = CAst.make ?loc @@ CTacApp (get, args) in + let accu = (CAst.make ?loc @@ CPatVar na, e) :: accu in + (n + 1, accu) + in + let (_, bnd) = List.fold_left build_bindings (0, []) vars in + let tac = CAst.make ?loc @@ CTacLet (false, bnd, tac) in + (Name id0, tac) + in + CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar na], tac) + +let of_pattern p = + inj_wit ?loc:p.CAst.loc wit_pattern p + +let of_conversion {loc;v=c} = match c with +| QConvert c -> + let pat = of_option ?loc of_pattern None in + let c = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar Anonymous], of_constr c) in + of_tuple ?loc [pat; c] +| QConvertWith (pat, c) -> + let vars = pattern_vars pat in + let pat = of_option ?loc of_pattern (Some pat) in + let c = of_constr c in + (* Order is critical here *) + let vars = List.map (fun id -> Name id) (Id.Set.elements vars) in + let c = abstract_vars loc vars c in + of_tuple [pat; c] + +let of_repeat {loc;v=r} = match r with +| QPrecisely n -> std_constructor ?loc "Precisely" [of_int n] +| QUpTo n -> std_constructor ?loc "UpTo" [of_int n] +| QRepeatStar -> std_constructor ?loc "RepeatStar" [] +| QRepeatPlus -> std_constructor ?loc "RepeatPlus" [] + +let of_orient loc b = + if b then std_constructor ?loc "LTR" [] + else std_constructor ?loc "RTL" [] + +let of_rewriting {loc;v=rew} = + let orient = + let {loc;v=orient} = rew.rew_orient in + of_option ?loc (fun b -> of_orient loc b) orient + in + let repeat = of_repeat rew.rew_repeat in + let equatn = thunk (of_constr_with_bindings rew.rew_equatn) in + CAst.make ?loc @@ CTacRec ([ + std_proj "rew_orient", orient; + std_proj "rew_repeat", repeat; + std_proj "rew_equatn", equatn; + ]) + +let of_hyp ?loc id = + let hyp = global_ref ?loc (control_core "hyp") in + CAst.make ?loc @@ CTacApp (hyp, [of_ident id]) + +let of_exact_hyp ?loc id = + let refine = global_ref ?loc (control_core "refine") in + CAst.make ?loc @@ CTacApp (refine, [thunk (of_hyp ?loc id)]) + +let of_exact_var ?loc id = + let refine = global_ref ?loc (control_core "refine") in + CAst.make ?loc @@ CTacApp (refine, [thunk (of_variable id)]) + +let of_dispatch tacs = + let loc = tacs.loc in + let default = function + | Some e -> thunk e + | None -> thunk (CAst.make ?loc @@ CTacCst (AbsKn (Tuple 0))) + in + let map e = of_pair default (fun l -> of_list ?loc default l) (CAst.make ?loc e) in + of_pair (fun l -> of_list ?loc default l) (fun r -> of_option ?loc map r) tacs + +let make_red_flag l = + let open Genredexpr in + let rec add_flag red = function + | [] -> red + | {v=flag} :: lf -> + let red = match flag with + | QBeta -> { red with rBeta = true } + | QMatch -> { red with rMatch = true } + | QFix -> { red with rFix = true } + | QCofix -> { red with rCofix = true } + | QZeta -> { red with rZeta = true } + | QConst {loc;v=l} -> + if red.rDelta then + CErrors.user_err ?loc Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); + { red with rConst = red.rConst @ l } + | QDeltaBut {loc;v=l} -> + if red.rConst <> [] && not red.rDelta then + CErrors.user_err ?loc Pp.(str + "Cannot set both constants to unfold and constants not to unfold"); + { red with rConst = red.rConst @ l; rDelta = true } + | QIota -> + { red with rMatch = true; rFix = true; rCofix = true } + in + add_flag red lf + in + add_flag + {rBeta = false; rMatch = false; rFix = false; rCofix = false; + rZeta = false; rDelta = false; rConst = []} + l + +let of_reference r = + let of_ref ref = + inj_wit ?loc:ref.loc wit_reference ref + in + of_anti of_ref r + +let of_strategy_flag {loc;v=flag} = + let open Genredexpr in + let flag = make_red_flag flag in + CAst.make ?loc @@ CTacRec ([ + std_proj "rBeta", of_bool ?loc flag.rBeta; + std_proj "rMatch", of_bool ?loc flag.rMatch; + std_proj "rFix", of_bool ?loc flag.rFix; + std_proj "rCofix", of_bool ?loc flag.rCofix; + std_proj "rZeta", of_bool ?loc flag.rZeta; + std_proj "rDelta", of_bool ?loc flag.rDelta; + std_proj "rConst", of_list ?loc of_reference flag.rConst; + ]) + +let of_hintdb {loc;v=hdb} = match hdb with +| QHintAll -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) None +| QHintDbs ids -> of_option ?loc (fun l -> of_list (fun id -> of_anti of_ident id) l) (Some ids) + +let extract_name ?loc oid = match oid with +| None -> Anonymous +| Some id -> + let () = check_pattern_id ?loc id in + Name id + +(** For every branch in the matching, generate a corresponding term of type + [(match_kind * pattern * (context -> constr array -> 'a))] + where the function binds the names from the pattern to the contents of the + constr array. *) +let of_constr_matching {loc;v=m} = + let map {loc;v=({loc=ploc;v=pat}, tac)} = + let (knd, pat, na) = match pat with + | QConstrMatchPattern pat -> + let knd = constructor ?loc (pattern_core "MatchPattern") [] in + (knd, pat, Anonymous) + | QConstrMatchContext (id, pat) -> + let na = extract_name ?loc id in + let knd = constructor ?loc (pattern_core "MatchContext") [] in + (knd, pat, na) + in + let vars = pattern_vars pat in + (* Order of elements is crucial here! *) + let vars = Id.Set.elements vars in + let vars = List.map (fun id -> Name id) vars in + let e = abstract_vars loc vars tac in + let e = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar na], e) in + let pat = inj_wit ?loc:ploc wit_pattern pat in + of_tuple [knd; pat; e] + in + of_list ?loc map m + +(** From the patterns and the body of the branch, generate: + - a goal pattern: (constr_match list * constr_match) + - a branch function (ident array -> context array -> constr array -> context -> 'a) +*) +let of_goal_matching {loc;v=gm} = + let mk_pat {loc;v=p} = match p with + | QConstrMatchPattern pat -> + let knd = constructor ?loc (pattern_core "MatchPattern") [] in + (Anonymous, pat, knd) + | QConstrMatchContext (id, pat) -> + let na = extract_name ?loc id in + let knd = constructor ?loc (pattern_core "MatchContext") [] in + (na, pat, knd) + in + let mk_gpat {loc;v=p} = + let concl_pat = p.q_goal_match_concl in + let hyps_pats = p.q_goal_match_hyps in + let (concl_ctx, concl_pat, concl_knd) = mk_pat concl_pat in + let vars = pattern_vars concl_pat in + let map accu (na, pat) = + let (ctx, pat, knd) = mk_pat pat in + let vars = pattern_vars pat in + (Id.Set.union vars accu, (na, ctx, pat, knd)) + in + let (vars, hyps_pats) = List.fold_left_map map vars hyps_pats in + let map (_, _, pat, knd) = of_tuple [knd; of_pattern pat] in + let concl = of_tuple [concl_knd; of_pattern concl_pat] in + let r = of_tuple [of_list ?loc map hyps_pats; concl] in + let hyps = List.map (fun ({CAst.v=na}, _, _, _) -> na) hyps_pats in + let map (_, na, _, _) = na in + let hctx = List.map map hyps_pats in + (* Order of elements is crucial here! *) + let vars = Id.Set.elements vars in + let subst = List.map (fun id -> Name id) vars in + (r, hyps, hctx, subst, concl_ctx) + in + let map {loc;v=(pat, tac)} = + let (pat, hyps, hctx, subst, cctx) = mk_gpat pat in + let tac = CAst.make ?loc @@ CTacFun ([CAst.make ?loc @@ CPatVar cctx], tac) in + let tac = abstract_vars loc subst tac in + let tac = abstract_vars loc hctx tac in + let tac = abstract_vars loc hyps tac in + of_tuple ?loc [pat; tac] + in + of_list ?loc map gm + +let of_move_location {loc;v=mv} = match mv with +| QMoveAfter id -> std_constructor ?loc "MoveAfter" [of_anti of_ident id] +| QMoveBefore id -> std_constructor ?loc "MoveBefore" [of_anti of_ident id] +| QMoveFirst -> std_constructor ?loc "MoveFirst" [] +| QMoveLast -> std_constructor ?loc "MoveLast" [] + +let of_pose p = + of_pair (fun id -> of_option (fun id -> of_anti of_ident id) id) of_open_constr p + +let of_assertion {loc;v=ast} = match ast with +| QAssertType (ipat, c, tac) -> + let ipat = of_option of_intro_pattern ipat in + let c = of_constr c in + let tac = of_option thunk tac in + std_constructor ?loc "AssertType" [ipat; c; tac] +| QAssertValue (id, c) -> + let id = of_anti of_ident id in + let c = of_constr c in + std_constructor ?loc "AssertValue" [id; c] diff --git a/user-contrib/Ltac2/tac2quote.mli b/user-contrib/Ltac2/tac2quote.mli new file mode 100644 index 0000000000..1b03dad8ec --- /dev/null +++ b/user-contrib/Ltac2/tac2quote.mli @@ -0,0 +1,102 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Tac2dyn +open Tac2qexpr +open Tac2expr + +(** Syntactic quoting of expressions. *) + +(** Contrarily to Tac2ffi, which lives on the semantic level, this module + manipulates pure syntax of Ltac2. Its main purpose is to write notations. *) + +val constructor : ?loc:Loc.t -> ltac_constructor -> raw_tacexpr list -> raw_tacexpr + +val thunk : raw_tacexpr -> raw_tacexpr + +val of_anti : ('a -> raw_tacexpr) -> 'a or_anti -> raw_tacexpr + +val of_int : int CAst.t -> raw_tacexpr + +val of_pair : ('a -> raw_tacexpr) -> ('b -> raw_tacexpr) -> ('a * 'b) CAst.t -> raw_tacexpr + +val of_tuple : ?loc:Loc.t -> raw_tacexpr list -> raw_tacexpr + +val of_variable : Id.t CAst.t -> raw_tacexpr + +val of_ident : Id.t CAst.t -> raw_tacexpr + +val of_constr : Constrexpr.constr_expr -> raw_tacexpr + +val of_open_constr : Constrexpr.constr_expr -> raw_tacexpr + +val of_list : ?loc:Loc.t -> ('a -> raw_tacexpr) -> 'a list -> raw_tacexpr + +val of_bindings : bindings -> raw_tacexpr + +val of_intro_pattern : intro_pattern -> raw_tacexpr + +val of_intro_patterns : intro_pattern list CAst.t -> raw_tacexpr + +val of_clause : clause -> raw_tacexpr + +val of_destruction_arg : destruction_arg -> raw_tacexpr + +val of_induction_clause : induction_clause -> raw_tacexpr + +val of_conversion : conversion -> raw_tacexpr + +val of_rewriting : rewriting -> raw_tacexpr + +val of_occurrences : occurrences -> raw_tacexpr + +val of_hintdb : hintdb -> raw_tacexpr + +val of_move_location : move_location -> raw_tacexpr + +val of_reference : reference or_anti -> raw_tacexpr + +val of_hyp : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr +(** id ↦ 'Control.hyp @id' *) + +val of_exact_hyp : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr +(** id ↦ 'Control.refine (fun () => Control.hyp @id') *) + +val of_exact_var : ?loc:Loc.t -> Id.t CAst.t -> raw_tacexpr +(** id ↦ 'Control.refine (fun () => Control.hyp @id') *) + +val of_dispatch : dispatch -> raw_tacexpr + +val of_strategy_flag : strategy_flag -> raw_tacexpr + +val of_pose : pose -> raw_tacexpr + +val of_assertion : assertion -> raw_tacexpr + +val of_constr_matching : constr_matching -> raw_tacexpr + +val of_goal_matching : goal_matching -> raw_tacexpr + +(** {5 Generic arguments} *) + +val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern) Arg.tag + +val wit_ident : (Id.t, Id.t) Arg.tag + +val wit_reference : (reference, GlobRef.t) Arg.tag + +val wit_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag + +val wit_open_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag + +val wit_ltac1 : (Ltac_plugin.Tacexpr.raw_tactic_expr, Ltac_plugin.Tacexpr.glob_tactic_expr) Arg.tag +(** Ltac1 AST quotation, seen as a 'tactic'. Its type is unit in Ltac2. *) + +val wit_ltac1val : (Ltac_plugin.Tacexpr.raw_tactic_expr, Ltac_plugin.Tacexpr.glob_tactic_expr) Arg.tag +(** Ltac1 AST quotation, seen as a value-returning expression, with type Ltac1.t. *) diff --git a/user-contrib/Ltac2/tac2stdlib.ml b/user-contrib/Ltac2/tac2stdlib.ml new file mode 100644 index 0000000000..fb51fc965b --- /dev/null +++ b/user-contrib/Ltac2/tac2stdlib.ml @@ -0,0 +1,572 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Genredexpr +open Tac2expr +open Tac2ffi +open Tac2types +open Tac2extffi +open Proofview.Notations + +module Value = Tac2ffi + +(** Make a representation with a dummy from function *) +let make_to_repr f = Tac2ffi.make_repr (fun _ -> assert false) f + +let return x = Proofview.tclUNIT x +let v_unit = Value.of_unit () +let thaw r f = Tac2ffi.app_fun1 f unit r () +let uthaw r f = Tac2ffi.app_fun1 (to_fun1 unit r f) unit r () +let thunk r = fun1 unit r + +let to_name c = match Value.to_option Value.to_ident c with +| None -> Anonymous +| Some id -> Name id + +let name = make_to_repr to_name + +let to_occurrences = function +| ValInt 0 -> AllOccurrences +| ValBlk (0, [| vl |]) -> AllOccurrencesBut (Value.to_list Value.to_int vl) +| ValInt 1 -> NoOccurrences +| ValBlk (1, [| vl |]) -> OnlyOccurrences (Value.to_list Value.to_int vl) +| _ -> assert false + +let occurrences = make_to_repr to_occurrences + +let to_hyp_location_flag v = match Value.to_int v with +| 0 -> InHyp +| 1 -> InHypTypeOnly +| 2 -> InHypValueOnly +| _ -> assert false + +let to_clause v = match Value.to_tuple v with +| [| hyps; concl |] -> + let cast v = match Value.to_tuple v with + | [| hyp; occ; flag |] -> + (Value.to_ident hyp, to_occurrences occ, to_hyp_location_flag flag) + | _ -> assert false + in + let hyps = Value.to_option (fun h -> Value.to_list cast h) hyps in + { onhyps = hyps; concl_occs = to_occurrences concl; } +| _ -> assert false + +let clause = make_to_repr to_clause + +let to_red_flag v = match Value.to_tuple v with +| [| beta; iota; fix; cofix; zeta; delta; const |] -> + { + rBeta = Value.to_bool beta; + rMatch = Value.to_bool iota; + rFix = Value.to_bool fix; + rCofix = Value.to_bool cofix; + rZeta = Value.to_bool zeta; + rDelta = Value.to_bool delta; + rConst = Value.to_list Value.to_reference const; + } +| _ -> assert false + +let red_flags = make_to_repr to_red_flag + +let pattern_with_occs = pair pattern occurrences + +let constr_with_occs = pair constr occurrences + +let reference_with_occs = pair reference occurrences + +let rec to_intro_pattern v = match Value.to_block v with +| (0, [| b |]) -> IntroForthcoming (Value.to_bool b) +| (1, [| pat |]) -> IntroNaming (to_intro_pattern_naming pat) +| (2, [| act |]) -> IntroAction (to_intro_pattern_action act) +| _ -> assert false + +and to_intro_pattern_naming = function +| ValBlk (0, [| id |]) -> IntroIdentifier (Value.to_ident id) +| ValBlk (1, [| id |]) -> IntroFresh (Value.to_ident id) +| ValInt 0 -> IntroAnonymous +| _ -> assert false + +and to_intro_pattern_action = function +| ValInt 0 -> IntroWildcard +| ValBlk (0, [| op |]) -> IntroOrAndPattern (to_or_and_intro_pattern op) +| ValBlk (1, [| inj |]) -> + let map ipat = to_intro_pattern ipat in + IntroInjection (Value.to_list map inj) +| ValBlk (2, [| c; ipat |]) -> + let c = Value.to_fun1 Value.unit Value.constr c in + IntroApplyOn (c, to_intro_pattern ipat) +| ValBlk (3, [| b |]) -> IntroRewrite (Value.to_bool b) +| _ -> assert false + +and to_or_and_intro_pattern v = match Value.to_block v with +| (0, [| ill |]) -> + IntroOrPattern (Value.to_list to_intro_patterns ill) +| (1, [| il |]) -> + IntroAndPattern (to_intro_patterns il) +| _ -> assert false + +and to_intro_patterns il = + Value.to_list to_intro_pattern il + +let intro_pattern = make_to_repr to_intro_pattern + +let intro_patterns = make_to_repr to_intro_patterns + +let to_destruction_arg v = match Value.to_block v with +| (0, [| c |]) -> + let c = uthaw constr_with_bindings c in + ElimOnConstr c +| (1, [| id |]) -> ElimOnIdent (Value.to_ident id) +| (2, [| n |]) -> ElimOnAnonHyp (Value.to_int n) +| _ -> assert false + +let destruction_arg = make_to_repr to_destruction_arg + +let to_induction_clause v = match Value.to_tuple v with +| [| arg; eqn; as_; in_ |] -> + let arg = to_destruction_arg arg in + let eqn = Value.to_option to_intro_pattern_naming eqn in + let as_ = Value.to_option to_or_and_intro_pattern as_ in + let in_ = Value.to_option to_clause in_ in + (arg, eqn, as_, in_) +| _ -> + assert false + +let induction_clause = make_to_repr to_induction_clause + +let to_assertion v = match Value.to_block v with +| (0, [| ipat; t; tac |]) -> + let to_tac t = Value.to_fun1 Value.unit Value.unit t in + let ipat = Value.to_option to_intro_pattern ipat in + let t = Value.to_constr t in + let tac = Value.to_option to_tac tac in + AssertType (ipat, t, tac) +| (1, [| id; c |]) -> + AssertValue (Value.to_ident id, Value.to_constr c) +| _ -> assert false + +let assertion = make_to_repr to_assertion + +let to_multi = function +| ValBlk (0, [| n |]) -> Precisely (Value.to_int n) +| ValBlk (1, [| n |]) -> UpTo (Value.to_int n) +| ValInt 0 -> RepeatStar +| ValInt 1 -> RepeatPlus +| _ -> assert false + +let to_rewriting v = match Value.to_tuple v with +| [| orient; repeat; c |] -> + let orient = Value.to_option Value.to_bool orient in + let repeat = to_multi repeat in + let c = uthaw constr_with_bindings c in + (orient, repeat, c) +| _ -> assert false + +let rewriting = make_to_repr to_rewriting + +let to_debug v = match Value.to_int v with +| 0 -> Hints.Off +| 1 -> Hints.Info +| 2 -> Hints.Debug +| _ -> assert false + +let debug = make_to_repr to_debug + +let to_strategy v = match Value.to_int v with +| 0 -> Class_tactics.Bfs +| 1 -> Class_tactics.Dfs +| _ -> assert false + +let strategy = make_to_repr to_strategy + +let to_inversion_kind v = match Value.to_int v with +| 0 -> Inv.SimpleInversion +| 1 -> Inv.FullInversion +| 2 -> Inv.FullInversionClear +| _ -> assert false + +let inversion_kind = make_to_repr to_inversion_kind + +let to_move_location = function +| ValInt 0 -> Logic.MoveFirst +| ValInt 1 -> Logic.MoveLast +| ValBlk (0, [|id|]) -> Logic.MoveAfter (Value.to_ident id) +| ValBlk (1, [|id|]) -> Logic.MoveBefore (Value.to_ident id) +| _ -> assert false + +let move_location = make_to_repr to_move_location + +let to_generalize_arg v = match Value.to_tuple v with +| [| c; occs; na |] -> + (Value.to_constr c, to_occurrences occs, to_name na) +| _ -> assert false + +let generalize_arg = make_to_repr to_generalize_arg + +(** Standard tactics sharing their implementation with Ltac1 *) + +let pname s = { mltac_plugin = "ltac2"; mltac_tactic = s } + +let lift tac = tac <*> return v_unit + +let define_prim0 name tac = + let tac _ = lift tac in + Tac2env.define_primitive (pname name) (mk_closure arity_one tac) + +let define_prim1 name r0 f = + let tac x = lift (f (Value.repr_to r0 x)) in + Tac2env.define_primitive (pname name) (mk_closure arity_one tac) + +let define_prim2 name r0 r1 f = + let tac x y = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc arity_one) tac) + +let define_prim3 name r0 r1 r2 f = + let tac x y z = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc arity_one)) tac) + +let define_prim4 name r0 r1 r2 r3 f = + let tac x y z u = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) (Value.repr_to r3 u)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc (arity_suc arity_one))) tac) + +let define_prim5 name r0 r1 r2 r3 r4 f = + let tac x y z u v = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z) (Value.repr_to r3 u) (Value.repr_to r4 v)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc (arity_suc (arity_suc arity_one)))) tac) + +(** Tactics from Tacexpr *) + +let () = define_prim2 "tac_intros" bool intro_patterns begin fun ev ipat -> + Tac2tactics.intros_patterns ev ipat +end + +let () = define_prim4 "tac_apply" bool bool (list (thunk constr_with_bindings)) (option (pair ident (option intro_pattern))) begin fun adv ev cb ipat -> + Tac2tactics.apply adv ev cb ipat +end + +let () = define_prim3 "tac_elim" bool constr_with_bindings (option constr_with_bindings) begin fun ev c copt -> + Tac2tactics.elim ev c copt +end + +let () = define_prim2 "tac_case" bool constr_with_bindings begin fun ev c -> + Tac2tactics.general_case_analysis ev c +end + +let () = define_prim1 "tac_generalize" (list generalize_arg) begin fun cl -> + Tac2tactics.generalize cl +end + +let () = define_prim1 "tac_assert" assertion begin fun ast -> + Tac2tactics.assert_ ast +end + +let () = define_prim3 "tac_enough" constr (option (option (thunk unit))) (option intro_pattern) begin fun c tac ipat -> + let tac = Option.map (fun o -> Option.map (fun f -> thaw unit f) o) tac in + Tac2tactics.forward false tac ipat c +end + +let () = define_prim2 "tac_pose" name constr begin fun na c -> + Tactics.letin_tac None na c None Locusops.nowhere +end + +let () = define_prim3 "tac_set" bool (thunk (pair name constr)) clause begin fun ev p cl -> + Proofview.tclEVARMAP >>= fun sigma -> + thaw (pair name constr) p >>= fun (na, c) -> + Tac2tactics.letin_pat_tac ev None na (sigma, c) cl +end + +let () = define_prim5 "tac_remember" bool name (thunk constr) (option intro_pattern) clause begin fun ev na c eqpat cl -> + let eqpat = Option.default (IntroNaming IntroAnonymous) eqpat in + match eqpat with + | IntroNaming eqpat -> + Proofview.tclEVARMAP >>= fun sigma -> + thaw constr c >>= fun c -> + Tac2tactics.letin_pat_tac ev (Some (true, eqpat)) na (sigma, c) cl + | _ -> + Tacticals.New.tclZEROMSG (Pp.str "Invalid pattern for remember") +end + +let () = define_prim3 "tac_destruct" bool (list induction_clause) (option constr_with_bindings) begin fun ev ic using -> + Tac2tactics.induction_destruct false ev ic using +end + +let () = define_prim3 "tac_induction" bool (list induction_clause) (option constr_with_bindings) begin fun ev ic using -> + Tac2tactics.induction_destruct true ev ic using +end + +let () = define_prim1 "tac_red" clause begin fun cl -> + Tac2tactics.reduce (Red false) cl +end + +let () = define_prim1 "tac_hnf" clause begin fun cl -> + Tac2tactics.reduce Hnf cl +end + +let () = define_prim3 "tac_simpl" red_flags (option pattern_with_occs) clause begin fun flags where cl -> + Tac2tactics.simpl flags where cl +end + +let () = define_prim2 "tac_cbv" red_flags clause begin fun flags cl -> + Tac2tactics.cbv flags cl +end + +let () = define_prim2 "tac_cbn" red_flags clause begin fun flags cl -> + Tac2tactics.cbn flags cl +end + +let () = define_prim2 "tac_lazy" red_flags clause begin fun flags cl -> + Tac2tactics.lazy_ flags cl +end + +let () = define_prim2 "tac_unfold" (list reference_with_occs) clause begin fun refs cl -> + Tac2tactics.unfold refs cl +end + +let () = define_prim2 "tac_fold" (list constr) clause begin fun args cl -> + Tac2tactics.reduce (Fold args) cl +end + +let () = define_prim2 "tac_pattern" (list constr_with_occs) clause begin fun where cl -> + Tac2tactics.pattern where cl +end + +let () = define_prim2 "tac_vm" (option pattern_with_occs) clause begin fun where cl -> + Tac2tactics.vm where cl +end + +let () = define_prim2 "tac_native" (option pattern_with_occs) clause begin fun where cl -> + Tac2tactics.native where cl +end + +(** Reduction functions *) + +let lift tac = tac >>= fun c -> Proofview.tclUNIT (Value.of_constr c) + +let define_red1 name r0 f = + let tac x = lift (f (Value.repr_to r0 x)) in + Tac2env.define_primitive (pname name) (mk_closure arity_one tac) + +let define_red2 name r0 r1 f = + let tac x y = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc arity_one) tac) + +let define_red3 name r0 r1 r2 f = + let tac x y z = lift (f (Value.repr_to r0 x) (Value.repr_to r1 y) (Value.repr_to r2 z)) in + Tac2env.define_primitive (pname name) (mk_closure (arity_suc (arity_suc arity_one)) tac) + +let () = define_red1 "eval_red" constr begin fun c -> + Tac2tactics.eval_red c +end + +let () = define_red1 "eval_hnf" constr begin fun c -> + Tac2tactics.eval_hnf c +end + +let () = define_red3 "eval_simpl" red_flags (option pattern_with_occs) constr begin fun flags where c -> + Tac2tactics.eval_simpl flags where c +end + +let () = define_red2 "eval_cbv" red_flags constr begin fun flags c -> + Tac2tactics.eval_cbv flags c +end + +let () = define_red2 "eval_cbn" red_flags constr begin fun flags c -> + Tac2tactics.eval_cbn flags c +end + +let () = define_red2 "eval_lazy" red_flags constr begin fun flags c -> + Tac2tactics.eval_lazy flags c +end + +let () = define_red2 "eval_unfold" (list reference_with_occs) constr begin fun refs c -> + Tac2tactics.eval_unfold refs c +end + +let () = define_red2 "eval_fold" (list constr) constr begin fun args c -> + Tac2tactics.eval_fold args c +end + +let () = define_red2 "eval_pattern" (list constr_with_occs) constr begin fun where c -> + Tac2tactics.eval_pattern where c +end + +let () = define_red2 "eval_vm" (option pattern_with_occs) constr begin fun where c -> + Tac2tactics.eval_vm where c +end + +let () = define_red2 "eval_native" (option pattern_with_occs) constr begin fun where c -> + Tac2tactics.eval_native where c +end + +let () = define_prim3 "tac_change" (option pattern) (fun1 (array constr) constr) clause begin fun pat c cl -> + Tac2tactics.change pat c cl +end + +let () = define_prim4 "tac_rewrite" bool (list rewriting) clause (option (thunk unit)) begin fun ev rw cl by -> + Tac2tactics.rewrite ev rw cl by +end + +let () = define_prim4 "tac_inversion" inversion_kind destruction_arg (option intro_pattern) (option (list ident)) begin fun knd arg pat ids -> + Tac2tactics.inversion knd arg pat ids +end + +(** Tactics from coretactics *) + +let () = define_prim0 "tac_reflexivity" Tactics.intros_reflexivity + +let () = define_prim2 "tac_move" ident move_location begin fun id mv -> + Tactics.move_hyp id mv +end + +let () = define_prim2 "tac_intro" (option ident) (option move_location) begin fun id mv -> + let mv = Option.default Logic.MoveLast mv in + Tactics.intro_move id mv +end + +(* + +TACTIC EXTEND exact + [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] +END + +*) + +let () = define_prim0 "tac_assumption" Tactics.assumption + +let () = define_prim1 "tac_transitivity" constr begin fun c -> + Tactics.intros_transitivity (Some c) +end + +let () = define_prim0 "tac_etransitivity" (Tactics.intros_transitivity None) + +let () = define_prim1 "tac_cut" constr begin fun c -> + Tactics.cut c +end + +let () = define_prim2 "tac_left" bool bindings begin fun ev bnd -> + Tac2tactics.left_with_bindings ev bnd +end +let () = define_prim2 "tac_right" bool bindings begin fun ev bnd -> + Tac2tactics.right_with_bindings ev bnd +end + +let () = define_prim1 "tac_introsuntil" qhyp begin fun h -> + Tactics.intros_until h +end + +let () = define_prim1 "tac_exactnocheck" constr begin fun c -> + Tactics.exact_no_check c +end + +let () = define_prim1 "tac_vmcastnocheck" constr begin fun c -> + Tactics.vm_cast_no_check c +end + +let () = define_prim1 "tac_nativecastnocheck" constr begin fun c -> + Tactics.native_cast_no_check c +end + +let () = define_prim1 "tac_constructor" bool begin fun ev -> + Tactics.any_constructor ev None +end + +let () = define_prim3 "tac_constructorn" bool int bindings begin fun ev n bnd -> + Tac2tactics.constructor_tac ev None n bnd +end + +let () = define_prim2 "tac_specialize" constr_with_bindings (option intro_pattern) begin fun c ipat -> + Tac2tactics.specialize c ipat +end + +let () = define_prim1 "tac_symmetry" clause begin fun cl -> + Tac2tactics.symmetry cl +end + +let () = define_prim2 "tac_split" bool bindings begin fun ev bnd -> + Tac2tactics.split_with_bindings ev bnd +end + +let () = define_prim1 "tac_rename" (list (pair ident ident)) begin fun ids -> + Tactics.rename_hyp ids +end + +let () = define_prim1 "tac_revert" (list ident) begin fun ids -> + Tactics.revert ids +end + +let () = define_prim0 "tac_admit" Proofview.give_up + +let () = define_prim2 "tac_fix" ident int begin fun ident n -> + Tactics.fix ident n +end + +let () = define_prim1 "tac_cofix" ident begin fun ident -> + Tactics.cofix ident +end + +let () = define_prim1 "tac_clear" (list ident) begin fun ids -> + Tactics.clear ids +end + +let () = define_prim1 "tac_keep" (list ident) begin fun ids -> + Tactics.keep ids +end + +let () = define_prim1 "tac_clearbody" (list ident) begin fun ids -> + Tactics.clear_body ids +end + +(** Tactics from extratactics *) + +let () = define_prim2 "tac_discriminate" bool (option destruction_arg) begin fun ev arg -> + Tac2tactics.discriminate ev arg +end + +let () = define_prim3 "tac_injection" bool (option intro_patterns) (option destruction_arg) begin fun ev ipat arg -> + Tac2tactics.injection ev ipat arg +end + +let () = define_prim1 "tac_absurd" constr begin fun c -> + Contradiction.absurd c +end + +let () = define_prim1 "tac_contradiction" (option constr_with_bindings) begin fun c -> + Tac2tactics.contradiction c +end + +let () = define_prim4 "tac_autorewrite" bool (option (thunk unit)) (list ident) clause begin fun all by ids cl -> + Tac2tactics.autorewrite ~all by ids cl +end + +let () = define_prim1 "tac_subst" (list ident) begin fun ids -> + Equality.subst ids +end + +let () = define_prim0 "tac_substall" (return () >>= fun () -> Equality.subst_all ()) + +(** Auto *) + +let () = define_prim3 "tac_trivial" debug (list (thunk constr)) (option (list ident)) begin fun dbg lems dbs -> + Tac2tactics.trivial dbg lems dbs +end + +let () = define_prim5 "tac_eauto" debug (option int) (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n p lems dbs -> + Tac2tactics.eauto dbg n p lems dbs +end + +let () = define_prim4 "tac_auto" debug (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n lems dbs -> + Tac2tactics.auto dbg n lems dbs +end + +let () = define_prim4 "tac_newauto" debug (option int) (list (thunk constr)) (option (list ident)) begin fun dbg n lems dbs -> + Tac2tactics.new_auto dbg n lems dbs +end + +let () = define_prim3 "tac_typeclasses_eauto" (option strategy) (option int) (option (list ident)) begin fun str n dbs -> + Tac2tactics.typeclasses_eauto str n dbs +end diff --git a/user-contrib/Ltac2/tac2stdlib.mli b/user-contrib/Ltac2/tac2stdlib.mli new file mode 100644 index 0000000000..927b57074d --- /dev/null +++ b/user-contrib/Ltac2/tac2stdlib.mli @@ -0,0 +1,9 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Standard tactics sharing their implementation with Ltac1 *) diff --git a/user-contrib/Ltac2/tac2tactics.ml b/user-contrib/Ltac2/tac2tactics.ml new file mode 100644 index 0000000000..a8c1a67f6f --- /dev/null +++ b/user-contrib/Ltac2/tac2tactics.ml @@ -0,0 +1,447 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open Util +open Names +open Globnames +open Tac2types +open Tac2extffi +open Genredexpr +open Proofview.Notations + +let return = Proofview.tclUNIT +let thaw r f = Tac2ffi.app_fun1 f Tac2ffi.unit r () + +let tactic_infer_flags with_evar = { + Pretyping.use_typeclasses = true; + Pretyping.solve_unification_constraints = true; + Pretyping.fail_evar = not with_evar; + Pretyping.expand_evars = true; + Pretyping.program_mode = false; + Pretyping.polymorphic = false; +} + +(** FIXME: export a better interface in Tactics *) +let delayed_of_tactic tac env sigma = + let _, pv = Proofview.init sigma [] in + let name, poly = Id.of_string "ltac2_delayed", false in + let c, pv, _, _ = Proofview.apply ~name ~poly env tac pv in + (sigma, c) + +let delayed_of_thunk r tac env sigma = + delayed_of_tactic (thaw r tac) env sigma + +let mk_bindings = function +| ImplicitBindings l -> Tactypes.ImplicitBindings l +| ExplicitBindings l -> + let l = List.map CAst.make l in + Tactypes.ExplicitBindings l +| NoBindings -> Tactypes.NoBindings + +let mk_with_bindings (x, b) = (x, mk_bindings b) + +let rec mk_intro_pattern = function +| IntroForthcoming b -> CAst.make @@ Tactypes.IntroForthcoming b +| IntroNaming ipat -> CAst.make @@ Tactypes.IntroNaming (mk_intro_pattern_naming ipat) +| IntroAction ipat -> CAst.make @@ Tactypes.IntroAction (mk_intro_pattern_action ipat) + +and mk_intro_pattern_naming = function +| IntroIdentifier id -> Namegen.IntroIdentifier id +| IntroFresh id -> Namegen.IntroFresh id +| IntroAnonymous -> Namegen.IntroAnonymous + +and mk_intro_pattern_action = function +| IntroWildcard -> Tactypes.IntroWildcard +| IntroOrAndPattern ipat -> Tactypes.IntroOrAndPattern (mk_or_and_intro_pattern ipat) +| IntroInjection ipats -> Tactypes.IntroInjection (List.map mk_intro_pattern ipats) +| IntroApplyOn (c, ipat) -> + let c = CAst.make @@ delayed_of_thunk Tac2ffi.constr c in + Tactypes.IntroApplyOn (c, mk_intro_pattern ipat) +| IntroRewrite b -> Tactypes.IntroRewrite b + +and mk_or_and_intro_pattern = function +| IntroOrPattern ipatss -> + Tactypes.IntroOrPattern (List.map (fun ipat -> List.map mk_intro_pattern ipat) ipatss) +| IntroAndPattern ipats -> + Tactypes.IntroAndPattern (List.map mk_intro_pattern ipats) + +let mk_intro_patterns ipat = List.map mk_intro_pattern ipat + +let mk_occurrences f = function +| AllOccurrences -> Locus.AllOccurrences +| AllOccurrencesBut l -> Locus.AllOccurrencesBut (List.map f l) +| NoOccurrences -> Locus.NoOccurrences +| OnlyOccurrences l -> Locus.OnlyOccurrences (List.map f l) + +let mk_occurrences_expr occ = + mk_occurrences (fun i -> Locus.ArgArg i) occ + +let mk_hyp_location (id, occs, h) = + ((mk_occurrences_expr occs, id), h) + +let mk_clause cl = { + Locus.onhyps = Option.map (fun l -> List.map mk_hyp_location l) cl.onhyps; + Locus.concl_occs = mk_occurrences_expr cl.concl_occs; +} + +let intros_patterns ev ipat = + let ipat = mk_intro_patterns ipat in + Tactics.intros_patterns ev ipat + +let apply adv ev cb cl = + let map c = + let c = thaw constr_with_bindings c >>= fun p -> return (mk_with_bindings p) in + None, CAst.make (delayed_of_tactic c) + in + let cb = List.map map cb in + match cl with + | None -> Tactics.apply_with_delayed_bindings_gen adv ev cb + | Some (id, cl) -> + let cl = Option.map mk_intro_pattern cl in + Tactics.apply_delayed_in adv ev id cb cl + +let mk_destruction_arg = function +| ElimOnConstr c -> + let c = c >>= fun c -> return (mk_with_bindings c) in + Tactics.ElimOnConstr (delayed_of_tactic c) +| ElimOnIdent id -> Tactics.ElimOnIdent CAst.(make id) +| ElimOnAnonHyp n -> Tactics.ElimOnAnonHyp n + +let mk_induction_clause (arg, eqn, as_, occ) = + let eqn = Option.map (fun ipat -> CAst.make @@ mk_intro_pattern_naming ipat) eqn in + let as_ = Option.map (fun ipat -> CAst.make @@ mk_or_and_intro_pattern ipat) as_ in + let occ = Option.map mk_clause occ in + ((None, mk_destruction_arg arg), (eqn, as_), occ) + +let induction_destruct isrec ev (ic : induction_clause list) using = + let ic = List.map mk_induction_clause ic in + let using = Option.map mk_with_bindings using in + Tactics.induction_destruct isrec ev (ic, using) + +let elim ev c copt = + let c = mk_with_bindings c in + let copt = Option.map mk_with_bindings copt in + Tactics.elim ev None c copt + +let generalize pl = + let mk_occ occs = mk_occurrences (fun i -> i) occs in + let pl = List.map (fun (c, occs, na) -> (mk_occ occs, c), na) pl in + Tactics.new_generalize_gen pl + +let general_case_analysis ev c = + let c = mk_with_bindings c in + Tactics.general_case_analysis ev None c + +let constructor_tac ev n i bnd = + let bnd = mk_bindings bnd in + Tactics.constructor_tac ev n i bnd + +let left_with_bindings ev bnd = + let bnd = mk_bindings bnd in + Tactics.left_with_bindings ev bnd + +let right_with_bindings ev bnd = + let bnd = mk_bindings bnd in + Tactics.right_with_bindings ev bnd + +let split_with_bindings ev bnd = + let bnd = mk_bindings bnd in + Tactics.split_with_bindings ev [bnd] + +let specialize c pat = + let c = mk_with_bindings c in + let pat = Option.map mk_intro_pattern pat in + Tactics.specialize c pat + +let change pat c cl = + let open Tac2ffi in + Proofview.Goal.enter begin fun gl -> + let c subst env sigma = + let subst = Array.map_of_list snd (Id.Map.bindings subst) in + delayed_of_tactic (Tac2ffi.app_fun1 c (array constr) constr subst) env sigma + in + let cl = mk_clause cl in + Tactics.change ~check:true pat c cl + end + +let rewrite ev rw cl by = + let map_rw (orient, repeat, c) = + let c = c >>= fun c -> return (mk_with_bindings c) in + (Option.default true orient, repeat, None, delayed_of_tactic c) + in + let rw = List.map map_rw rw in + let cl = mk_clause cl in + let by = Option.map (fun tac -> Tacticals.New.tclCOMPLETE (thaw Tac2ffi.unit tac), Equality.Naive) by in + Equality.general_multi_rewrite ev rw cl by + +let symmetry cl = + let cl = mk_clause cl in + Tactics.intros_symmetry cl + +let forward fst tac ipat c = + let ipat = Option.map mk_intro_pattern ipat in + Tactics.forward fst tac ipat c + +let assert_ = function +| AssertValue (id, c) -> + let ipat = CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id) in + Tactics.forward true None (Some ipat) c +| AssertType (ipat, c, tac) -> + let ipat = Option.map mk_intro_pattern ipat in + let tac = Option.map (fun tac -> thaw Tac2ffi.unit tac) tac in + Tactics.forward true (Some tac) ipat c + +let letin_pat_tac ev ipat na c cl = + let ipat = Option.map (fun (b, ipat) -> (b, CAst.make @@ mk_intro_pattern_naming ipat)) ipat in + let cl = mk_clause cl in + Tactics.letin_pat_tac ev ipat na c cl + +(** Ltac interface treats differently global references than other term + arguments in reduction expressions. In Ltac1, this is done at parsing time. + Instead, we parse indifferently any pattern and dispatch when the tactic is + called. *) +let map_pattern_with_occs (pat, occ) = match pat with +| Pattern.PRef (ConstRef cst) -> (mk_occurrences_expr occ, Inl (EvalConstRef cst)) +| Pattern.PRef (VarRef id) -> (mk_occurrences_expr occ, Inl (EvalVarRef id)) +| _ -> (mk_occurrences_expr occ, Inr pat) + +let get_evaluable_reference = function +| VarRef id -> Proofview.tclUNIT (EvalVarRef id) +| ConstRef cst -> Proofview.tclUNIT (EvalConstRef cst) +| r -> + Tacticals.New.tclZEROMSG (str "Cannot coerce" ++ spc () ++ + Nametab.pr_global_env Id.Set.empty r ++ spc () ++ + str "to an evaluable reference.") + +let reduce r cl = + let cl = mk_clause cl in + Tactics.reduce r cl + +let simpl flags where cl = + let where = Option.map map_pattern_with_occs where in + let cl = mk_clause cl in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Simpl (flags, where)) cl + +let cbv flags cl = + let cl = mk_clause cl in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Cbv flags) cl + +let cbn flags cl = + let cl = mk_clause cl in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Cbn flags) cl + +let lazy_ flags cl = + let cl = mk_clause cl in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + Tactics.reduce (Lazy flags) cl + +let unfold occs cl = + let cl = mk_clause cl in + let map (gr, occ) = + let occ = mk_occurrences_expr occ in + get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) + in + Proofview.Monad.List.map map occs >>= fun occs -> + Tactics.reduce (Unfold occs) cl + +let pattern where cl = + let where = List.map (fun (c, occ) -> (mk_occurrences_expr occ, c)) where in + let cl = mk_clause cl in + Tactics.reduce (Pattern where) cl + +let vm where cl = + let where = Option.map map_pattern_with_occs where in + let cl = mk_clause cl in + Tactics.reduce (CbvVm where) cl + +let native where cl = + let where = Option.map map_pattern_with_occs where in + let cl = mk_clause cl in + Tactics.reduce (CbvNative where) cl + +let eval_fun red c = + Tac2core.pf_apply begin fun env sigma -> + let (redfun, _) = Redexpr.reduction_of_red_expr env red in + let (sigma, ans) = redfun env sigma c in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT ans + end + +let eval_red c = + eval_fun (Red false) c + +let eval_hnf c = + eval_fun Hnf c + +let eval_simpl flags where c = + let where = Option.map map_pattern_with_occs where in + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Simpl (flags, where)) c + +let eval_cbv flags c = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Cbv flags) c + +let eval_cbn flags c = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Cbn flags) c + +let eval_lazy flags c = + Proofview.Monad.List.map get_evaluable_reference flags.rConst >>= fun rConst -> + let flags = { flags with rConst } in + eval_fun (Lazy flags) c + +let eval_unfold occs c = + let map (gr, occ) = + let occ = mk_occurrences_expr occ in + get_evaluable_reference gr >>= fun gr -> Proofview.tclUNIT (occ, gr) + in + Proofview.Monad.List.map map occs >>= fun occs -> + eval_fun (Unfold occs) c + +let eval_fold cl c = + eval_fun (Fold cl) c + +let eval_pattern where c = + let where = List.map (fun (pat, occ) -> (mk_occurrences_expr occ, pat)) where in + eval_fun (Pattern where) c + +let eval_vm where c = + let where = Option.map map_pattern_with_occs where in + eval_fun (CbvVm where) c + +let eval_native where c = + let where = Option.map map_pattern_with_occs where in + eval_fun (CbvNative where) c + +let on_destruction_arg tac ev arg = + Proofview.Goal.enter begin fun gl -> + match arg with + | None -> tac ev None + | Some (clear, arg) -> + let arg = match arg with + | ElimOnConstr c -> + let env = Proofview.Goal.env gl in + Proofview.tclEVARMAP >>= fun sigma -> + c >>= fun (c, lbind) -> + let lbind = mk_bindings lbind in + Proofview.tclEVARMAP >>= fun sigma' -> + let flags = tactic_infer_flags ev in + let (sigma', c) = Unification.finish_evar_resolution ~flags env sigma' (sigma, c) in + Proofview.tclUNIT (Some sigma', Tactics.ElimOnConstr (c, lbind)) + | ElimOnIdent id -> Proofview.tclUNIT (None, Tactics.ElimOnIdent CAst.(make id)) + | ElimOnAnonHyp n -> Proofview.tclUNIT (None, Tactics.ElimOnAnonHyp n) + in + arg >>= fun (sigma', arg) -> + let arg = Some (clear, arg) in + match sigma' with + | None -> tac ev arg + | Some sigma' -> + Tacticals.New.tclWITHHOLES ev (tac ev arg) sigma' + end + +let discriminate ev arg = + let arg = Option.map (fun arg -> None, arg) arg in + on_destruction_arg Equality.discr_tac ev arg + +let injection ev ipat arg = + let arg = Option.map (fun arg -> None, arg) arg in + let ipat = Option.map mk_intro_patterns ipat in + let tac ev arg = Equality.injClause None ipat ev arg in + on_destruction_arg tac ev arg + +let autorewrite ~all by ids cl = + let conds = if all then Some Equality.AllMatches else None in + let ids = List.map Id.to_string ids in + let cl = mk_clause cl in + match by with + | None -> Autorewrite.auto_multi_rewrite ?conds ids cl + | Some by -> + let by = thaw Tac2ffi.unit by in + Autorewrite.auto_multi_rewrite_with ?conds by ids cl + +(** Auto *) + +let trivial debug lems dbs = + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in + let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in + Auto.h_trivial ~debug lems dbs + +let auto debug n lems dbs = + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in + let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in + Auto.h_auto ~debug n lems dbs + +let new_auto debug n lems dbs = + let make_depth n = snd (Eauto.make_dimension n None) in + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in + match dbs with + | None -> Auto.new_full_auto ~debug (make_depth n) lems + | Some dbs -> + let dbs = List.map Id.to_string dbs in + Auto.new_auto ~debug (make_depth n) lems dbs + +let eauto debug n p lems dbs = + let lems = List.map (fun c -> delayed_of_thunk Tac2ffi.constr c) lems in + let dbs = Option.map (fun l -> List.map Id.to_string l) dbs in + Eauto.gen_eauto (Eauto.make_dimension n p) lems dbs + +let typeclasses_eauto strategy depth dbs = + let only_classes, dbs = match dbs with + | None -> + true, [Class_tactics.typeclasses_db] + | Some dbs -> + let dbs = List.map Id.to_string dbs in + false, dbs + in + Class_tactics.typeclasses_eauto ~only_classes ?strategy ~depth dbs + +(** Inversion *) + +let inversion knd arg pat ids = + let ids = match ids with + | None -> [] + | Some l -> l + in + begin match pat with + | None -> Proofview.tclUNIT None + | Some (IntroAction (IntroOrAndPattern p)) -> + Proofview.tclUNIT (Some (CAst.make @@ mk_or_and_intro_pattern p)) + | Some _ -> + Tacticals.New.tclZEROMSG (str "Inversion only accept disjunctive patterns") + end >>= fun pat -> + let inversion _ arg = + begin match arg with + | None -> assert false + | Some (_, Tactics.ElimOnAnonHyp n) -> + Inv.inv_clause knd pat ids (AnonHyp n) + | Some (_, Tactics.ElimOnIdent {CAst.v=id}) -> + Inv.inv_clause knd pat ids (NamedHyp id) + | Some (_, Tactics.ElimOnConstr c) -> + let open Tactypes in + let anon = CAst.make @@ IntroNaming Namegen.IntroAnonymous in + Tactics.specialize c (Some anon) >>= fun () -> + Tacticals.New.onLastHypId (fun id -> Inv.inv_clause knd pat ids (NamedHyp id)) + end + in + on_destruction_arg inversion true (Some (None, arg)) + +let contradiction c = + let c = Option.map mk_with_bindings c in + Contradiction.contradiction c diff --git a/user-contrib/Ltac2/tac2tactics.mli b/user-contrib/Ltac2/tac2tactics.mli new file mode 100644 index 0000000000..e56544cd68 --- /dev/null +++ b/user-contrib/Ltac2/tac2tactics.mli @@ -0,0 +1,122 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Tac2expr +open EConstr +open Genredexpr +open Tac2types +open Proofview + +(** Local reimplementations of tactics variants from Coq *) + +val intros_patterns : evars_flag -> intro_pattern list -> unit tactic + +val apply : advanced_flag -> evars_flag -> + constr_with_bindings thunk list -> + (Id.t * intro_pattern option) option -> unit tactic + +val induction_destruct : rec_flag -> evars_flag -> + induction_clause list -> constr_with_bindings option -> unit tactic + +val elim : evars_flag -> constr_with_bindings -> constr_with_bindings option -> + unit tactic + +val general_case_analysis : evars_flag -> constr_with_bindings -> unit tactic + +val generalize : (constr * occurrences * Name.t) list -> unit tactic + +val constructor_tac : evars_flag -> int option -> int -> bindings -> unit tactic + +val left_with_bindings : evars_flag -> bindings -> unit tactic +val right_with_bindings : evars_flag -> bindings -> unit tactic +val split_with_bindings : evars_flag -> bindings -> unit tactic + +val specialize : constr_with_bindings -> intro_pattern option -> unit tactic + +val change : Pattern.constr_pattern option -> (constr array, constr) Tac2ffi.fun1 -> clause -> unit tactic + +val rewrite : + evars_flag -> rewriting list -> clause -> unit thunk option -> unit tactic + +val symmetry : clause -> unit tactic + +val forward : bool -> unit tactic option option -> + intro_pattern option -> constr -> unit tactic + +val assert_ : assertion -> unit tactic + +val letin_pat_tac : evars_flag -> (bool * intro_pattern_naming) option -> + Name.t -> (Evd.evar_map * constr) -> clause -> unit tactic + +val reduce : Redexpr.red_expr -> clause -> unit tactic + +val simpl : GlobRef.t glob_red_flag -> + (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic + +val cbv : GlobRef.t glob_red_flag -> clause -> unit tactic + +val cbn : GlobRef.t glob_red_flag -> clause -> unit tactic + +val lazy_ : GlobRef.t glob_red_flag -> clause -> unit tactic + +val unfold : (GlobRef.t * occurrences) list -> clause -> unit tactic + +val pattern : (constr * occurrences) list -> clause -> unit tactic + +val vm : (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic + +val native : (Pattern.constr_pattern * occurrences) option -> clause -> unit tactic + +val eval_red : constr -> constr tactic + +val eval_hnf : constr -> constr tactic + +val eval_simpl : GlobRef.t glob_red_flag -> + (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic + +val eval_cbv : GlobRef.t glob_red_flag -> constr -> constr tactic + +val eval_cbn : GlobRef.t glob_red_flag -> constr -> constr tactic + +val eval_lazy : GlobRef.t glob_red_flag -> constr -> constr tactic + +val eval_unfold : (GlobRef.t * occurrences) list -> constr -> constr tactic + +val eval_fold : constr list -> constr -> constr tactic + +val eval_pattern : (EConstr.t * occurrences) list -> constr -> constr tactic + +val eval_vm : (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic + +val eval_native : (Pattern.constr_pattern * occurrences) option -> constr -> constr tactic + +val discriminate : evars_flag -> destruction_arg option -> unit tactic + +val injection : evars_flag -> intro_pattern list option -> destruction_arg option -> unit tactic + +val autorewrite : all:bool -> unit thunk option -> Id.t list -> clause -> unit tactic + +val trivial : Hints.debug -> constr thunk list -> Id.t list option -> + unit Proofview.tactic + +val auto : Hints.debug -> int option -> constr thunk list -> + Id.t list option -> unit Proofview.tactic + +val new_auto : Hints.debug -> int option -> constr thunk list -> + Id.t list option -> unit Proofview.tactic + +val eauto : Hints.debug -> int option -> int option -> constr thunk list -> + Id.t list option -> unit Proofview.tactic + +val typeclasses_eauto : Class_tactics.search_strategy option -> int option -> + Id.t list option -> unit Proofview.tactic + +val inversion : Inv.inversion_kind -> destruction_arg -> intro_pattern option -> Id.t list option -> unit tactic + +val contradiction : constr_with_bindings option -> unit tactic diff --git a/user-contrib/Ltac2/tac2types.mli b/user-contrib/Ltac2/tac2types.mli new file mode 100644 index 0000000000..fa31153a27 --- /dev/null +++ b/user-contrib/Ltac2/tac2types.mli @@ -0,0 +1,92 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open EConstr +open Proofview + +(** Redefinition of Ltac1 data structures because of impedance mismatch *) + +type evars_flag = bool +type advanced_flag = bool + +type 'a thunk = (unit, 'a) Tac2ffi.fun1 + +type quantified_hypothesis = Tactypes.quantified_hypothesis = +| AnonHyp of int +| NamedHyp of Id.t + +type explicit_bindings = (quantified_hypothesis * EConstr.t) list + +type bindings = +| ImplicitBindings of EConstr.t list +| ExplicitBindings of explicit_bindings +| NoBindings + +type constr_with_bindings = EConstr.constr * bindings + +type core_destruction_arg = +| ElimOnConstr of constr_with_bindings tactic +| ElimOnIdent of Id.t +| ElimOnAnonHyp of int + +type destruction_arg = core_destruction_arg + +type intro_pattern = +| IntroForthcoming of bool +| IntroNaming of intro_pattern_naming +| IntroAction of intro_pattern_action +and intro_pattern_naming = +| IntroIdentifier of Id.t +| IntroFresh of Id.t +| IntroAnonymous +and intro_pattern_action = +| IntroWildcard +| IntroOrAndPattern of or_and_intro_pattern +| IntroInjection of intro_pattern list +| IntroApplyOn of EConstr.t thunk * intro_pattern +| IntroRewrite of bool +and or_and_intro_pattern = +| IntroOrPattern of intro_pattern list list +| IntroAndPattern of intro_pattern list + +type occurrences = +| AllOccurrences +| AllOccurrencesBut of int list +| NoOccurrences +| OnlyOccurrences of int list + +type hyp_location_flag = Locus.hyp_location_flag = +| InHyp | InHypTypeOnly | InHypValueOnly + +type hyp_location = Id.t * occurrences * hyp_location_flag + +type clause = + { onhyps : hyp_location list option; + concl_occs : occurrences } + +type induction_clause = + destruction_arg * + intro_pattern_naming option * + or_and_intro_pattern option * + clause option + +type multi = Equality.multi = +| Precisely of int +| UpTo of int +| RepeatStar +| RepeatPlus + +type rewriting = + bool option * + multi * + constr_with_bindings tactic + +type assertion = +| AssertType of intro_pattern option * constr * unit thunk option +| AssertValue of Id.t * constr diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index feaf47df18..12df3215ad 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -12,7 +12,6 @@ open Pp open Util open Entries open Redexpr -open Declare open Constrintern open Pretyping @@ -42,10 +41,9 @@ let check_imps ~impsty ~impsbody = if not b then warn_implicits_in_term () let interp_definition ~program_mode pl bl poly red_option c ctypopt = - let open EConstr in let env = Global.env() in (* Explicitly bound universes and constraints *) - let evd, decl = Constrexpr_ops.interp_univ_decl_opt env pl in + let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env pl in (* Build the parameters *) let evd, (impls, ((env_bl, ctx), imps1)) = interp_context_evars ~program_mode env evd bl in (* Build the type *) @@ -66,24 +64,15 @@ let interp_definition ~program_mode pl bl poly red_option c ctypopt = in (* Do the reduction *) let evd, c = red_constant_body red_option env_bl evd c in - (* universe minimization *) - let evd = Evd.minimize_universes evd in - (* Substitute evars and universes, and add parameters. - Note: in program mode some evars may remain. *) - let ctx = List.map Termops.(map_rel_decl (to_constr ~abort_on_undefined_evars:false evd)) ctx in - let c = Term.it_mkLambda_or_LetIn (EConstr.to_constr ~abort_on_undefined_evars:false evd c) ctx in - let tyopt = Option.map (fun ty -> Term.it_mkProd_or_LetIn (EConstr.to_constr ~abort_on_undefined_evars:false evd ty) ctx) tyopt in - (* Keep only useful universes. *) - let uvars_fold uvars c = - Univ.LSet.union uvars (universes_of_constr evd (of_constr c)) - in - let uvars = List.fold_left uvars_fold Univ.LSet.empty (Option.List.cons tyopt [c]) in - let evd = Evd.restrict_universe_context evd uvars in - (* Check we conform to declared universes *) - let uctx = Evd.check_univ_decl ~poly evd decl in - (* We're done! *) - let ce = definition_entry ?types:tyopt ~univs:uctx c in - (ce, evd, decl, imps) + + (* Declare the definition *) + let c = EConstr.it_mkLambda_or_LetIn c ctx in + let tyopt = Option.map (fun ty -> EConstr.it_mkProd_or_LetIn ty ctx) tyopt in + + let evd, ce = DeclareDef.prepare_definition ~allow_evars:program_mode + ~opaque:false ~poly evd udecl ~types:tyopt ~body:c in + + (ce, evd, udecl, imps) let check_definition ~program_mode (ce, evd, _, imps) = let env = Global.env () in diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 3f491d1dd4..59d2a66259 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -77,11 +77,11 @@ let parse_compat_version = let open Flags in function GRAMMAR EXTEND Gram GLOBAL: vernac_control gallina_ext noedit_mode subprf; vernac_control: FIRST - [ [ IDENT "Time"; c = located_vernac -> { VernacTime (false,c) } - | IDENT "Redirect"; s = ne_string; c = located_vernac -> { VernacRedirect (s, c) } - | IDENT "Timeout"; n = natural; v = located_vernac -> { VernacTimeout(n,v) } - | IDENT "Fail"; v = located_vernac -> { VernacFail v } - | v = decorated_vernac -> { let (f, v) = v in VernacExpr(f, v) } ] + [ [ IDENT "Time"; c = vernac_control -> { CAst.make ~loc @@ VernacTime (false,c) } + | IDENT "Redirect"; s = ne_string; c = vernac_control -> { CAst.make ~loc @@ VernacRedirect (s, c) } + | IDENT "Timeout"; n = natural; v = vernac_control -> { CAst.make ~loc @@ VernacTimeout(n,v) } + | IDENT "Fail"; v = vernac_control -> { CAst.make ~loc @@ VernacFail v } + | v = decorated_vernac -> { let (f, v) = v in CAst.make ~loc @@ VernacExpr(f, v) } ] ] ; decorated_vernac: @@ -147,9 +147,6 @@ GRAMMAR EXTEND Gram ] ] ; - located_vernac: - [ [ v = vernac_control -> { CAst.make ~loc v } ] ] - ; END { @@ -450,8 +447,10 @@ GRAMMAR EXTEND Gram *) (* ... with coercions *) record_field: - [ [ bd = record_binder; pri = OPT [ "|"; n = natural -> { n } ]; - ntn = decl_notation -> { (bd,pri),ntn } ] ] + [ [ bd = record_binder; rf_priority = OPT [ "|"; n = natural -> { n } ]; + rf_notation = decl_notation -> { + let rf_subclass, rf_decl = bd in + rf_decl, { rf_subclass ; rf_priority ; rf_notation } } ] ] ; record_fields: [ [ f = record_field; ";"; fs = record_fields -> { f :: fs } diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 082b22b373..f58eeae6dc 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -150,6 +150,7 @@ let explicit_flags = [print_universes; print_implicits; print_coercions; print_no_symbol] (* and more! *) ] let with_diffs pm pn = + if not (Proof_diffs.show_diffs ()) then pm, pn else try let tokenize_string = Proof_diffs.tokenize_string in Pp_diff.diff_pp ~tokenize_string pm pn diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 4e4d431e89..889dbafabd 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -446,15 +446,15 @@ open Pputils | Some true -> str" :>" | Some false -> str" :>>" - let pr_record_field ((x, pri), ntn) = + let pr_record_field (x, { rf_subclass = oc ; rf_priority = pri ; rf_notation = ntn }) = let env = Global.env () in let sigma = Evd.from_env env in let prx = match x with - | (oc,AssumExpr (id,t)) -> + | AssumExpr (id,t) -> hov 1 (pr_lname id ++ pr_oc oc ++ spc() ++ pr_lconstr_expr env sigma t) - | (oc,DefExpr(id,b,opt)) -> (match opt with + | DefExpr(id,b,opt) -> (match opt with | Some t -> hov 1 (pr_lname id ++ pr_oc oc ++ spc() ++ @@ -1262,15 +1262,15 @@ let pr_vernac_attributes = let rec pr_vernac_control v = let return = tag_vernac v in - match v with + match v.v with | VernacExpr (f, v') -> pr_vernac_attributes f ++ pr_vernac_expr v' ++ sep_end v' - | VernacTime (_,{v}) -> + | VernacTime (_,v) -> return (keyword "Time" ++ spc() ++ pr_vernac_control v) - | VernacRedirect (s, {v}) -> + | VernacRedirect (s, v) -> return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_control v) - | VernacTimeout(n,{v}) -> + | VernacTimeout(n,v) -> return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac_control v) - | VernacFail {v} -> + | VernacFail v-> return (keyword "Fail" ++ spc() ++ pr_vernac_control v) let pr_vernac v = diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index d474ef8637..4d9157089c 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -52,7 +52,7 @@ module Vernac_ = let () = let open Extend in - let act_vernac v loc = Some CAst.(make ~loc v) in + let act_vernac v loc = Some v in let act_eoi _ loc = None in let rule = [ Rule (Next (Stop, Atoken Tok.PEOI), act_eoi); diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index 4bf7c9f7bd..41a2e7fd6f 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -26,7 +26,7 @@ module Vernac_ : val rec_definition : (fixpoint_expr * decl_notation list) Entry.t val noedit_mode : vernac_expr Entry.t val command_entry : vernac_expr Entry.t - val main_entry : vernac_control CAst.t option Entry.t + val main_entry : vernac_control option Entry.t val red_expr : raw_red_expr Entry.t val hint_info : Hints.hint_info_expr Entry.t end @@ -40,7 +40,7 @@ module Unsafe : sig end (** The main entry: reads an optional vernac command *) -val main_entry : proof_mode option -> vernac_control CAst.t option Entry.t +val main_entry : proof_mode option -> vernac_control option Entry.t (** Grammar entry for tactics: proof mode(s). By default Coq's grammar has an empty entry (non-terminal) for diff --git a/vernac/record.ml b/vernac/record.ml index 74e5a03659..f489707eb3 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -634,7 +634,7 @@ let declare_existing_class g = open Vernacexpr let check_unique_names records = - let extract_name acc (((_, bnd), _), _) = match bnd with + let extract_name acc (rf_decl, _) = match rf_decl with Vernacexpr.AssumExpr({CAst.v=Name id},_) -> id::acc | Vernacexpr.DefExpr ({CAst.v=Name id},_,_) -> id::acc | _ -> acc in @@ -649,15 +649,15 @@ let check_unique_names records = let check_priorities kind records = let isnot_class = match kind with Class false -> false | _ -> true in let has_priority (_, _, _, cfs, _, _) = - List.exists (fun ((_, pri), _) -> not (Option.is_empty pri)) cfs + List.exists (fun (_, { rf_priority }) -> not (Option.is_empty rf_priority)) cfs in if isnot_class && List.exists has_priority records then user_err Pp.(str "Priorities only allowed for type class substructures") let extract_record_data records = let map (is_coe, id, _, cfs, idbuild, s) = - let fs = List.map (fun (((_, f), _), _) -> f) cfs in - id.CAst.v, s, List.map snd cfs, fs + let fs = List.map fst cfs in + id.CAst.v, s, List.map (fun (_, { rf_notation }) -> rf_notation) cfs, fs in let data = List.map map records in let pss = List.map (fun (_, _, ps, _, _, _) -> ps) records in @@ -691,16 +691,15 @@ let definition_structure udecl kind ~template cum poly finite records = | [r], [d] -> r, d | _, _ -> CErrors.user_err (str "Mutual definitional classes are not handled") in - let priorities = List.map (fun ((_, id), _) -> {hint_priority = id; hint_pattern = None}) cfs in - let coers = List.map (fun (((coe, _), _), _) -> coe) cfs 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 cum ubinders univs id.CAst.v idbuild implpars params arity template implfs fields coers priorities | _ -> let map impls = implpars @ Impargs.lift_implicits (succ (List.length params)) impls in 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 coers = List.map (fun (((coe, _), _), _) -> coe) cfs in - let coe = List.map (fun coe -> not (Option.is_empty coe)) coers in + let coe = List.map (fun (_, { rf_subclass }) -> not (Option.is_empty rf_subclass)) cfs in id.CAst.v, idbuild, arity, implfs, fields, is_coe, coe in let data = List.map2 map data records in diff --git a/vernac/record.mli b/vernac/record.mli index 12a2a765b5..d6e63901cd 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -33,7 +33,7 @@ val definition_structure : (coercion_flag * Names.lident * local_binder_expr list * - (local_decl_expr with_instance with_priority with_notation) list * + (local_decl_expr * record_field_attr) list * Id.t * constr_expr option) list -> GlobRef.t list diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 60b0bdc7e7..118c126970 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -196,6 +196,18 @@ let init_tag_map styles = let default_styles () = init_tag_map (default_tag_map ()) +let set_emacs_print_strings () = + let open Terminal in + let diff = "diff." in + List.iter (fun b -> + let (name, attrs) = b in + if diff = (String.sub name 0 (String.length diff)) then + tag_map := CString.Map.add name + { attrs with prefix = Some (Printf.sprintf "<%s>" name); + suffix = Some (Printf.sprintf "</%s>" name) } + !tag_map) + (CString.Map.bindings !tag_map) + let parse_color_config str = let styles = Terminal.parse str in init_tag_map styles @@ -264,13 +276,13 @@ let make_printing_functions () = let (tpfx, ttag) = split_tag tag in if tpfx <> end_pfx then let style = get_style ttag in - match style.Terminal.prefix with Some s -> Format.pp_print_string ft s | None -> () in + match style.Terminal.prefix with Some s -> Format.pp_print_as ft 0 s | None -> () in let print_suffix ft tag = let (tpfx, ttag) = split_tag tag in if tpfx <> start_pfx then let style = get_style ttag in - match style.Terminal.suffix with Some s -> Format.pp_print_string ft s | None -> () in + match style.Terminal.suffix with Some s -> Format.pp_print_as ft 0 s | None -> () in print_prefix, print_suffix @@ -413,7 +425,7 @@ let with_output_to_file fname func input = (* For coqtop -time, we display the position in the file, and a glimpse of the executed command *) -let pr_cmd_header {CAst.loc;v=com} = +let pr_cmd_header com = let shorten s = if Unicode.utf8_length s > 33 then (Unicode.utf8_sub s 0 30) ^ "..." else s in @@ -423,7 +435,7 @@ let pr_cmd_header {CAst.loc;v=com} = | x -> x ) s in - let (start,stop) = Option.cata Loc.unloc (0,0) loc in + let (start,stop) = Option.cata Loc.unloc (0,0) com.CAst.loc in let safe_pr_vernac x = try Ppvernac.pr_vernac x with e -> str (Printexc.to_string e) in diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index b0e3b3772c..3d522a9e0f 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -46,6 +46,7 @@ val emacs_logger : ?pre_hdr:Pp.t -> Feedback.level -> Pp.t -> unit val default_styles : unit -> unit val parse_color_config : string -> unit val dump_tags : unit -> (string * Terminal.style) list +val set_emacs_print_strings : unit -> unit (** Initialization of interpretation of tags *) val init_terminal_output : color:bool -> unit @@ -72,4 +73,4 @@ val print_err_exn : exn -> unit redirected to a file [file] *) val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b -val pr_cmd_header : Vernacexpr.vernac_control CAst.t -> Pp.t +val pr_cmd_header : Vernacexpr.vernac_control -> Pp.t diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index e44d68b87d..279d4f0935 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -684,7 +684,7 @@ let vernac_record ~template udecl cum k poly finite records = let () = if Dumpglob.dump () then let () = Dumpglob.dump_definition id false "rec" in - let iter (((_, x), _), _) = match x with + let iter (x, _) = match x with | Vernacexpr.AssumExpr ({loc;v=Name id}, _) -> Dumpglob.dump_definition (make ?loc id) false "proj" | _ -> () @@ -743,7 +743,8 @@ let vernac_inductive ~atts cum lo finite indl = let (id, bl, c, l) = Option.get is_defclass in let (coe, (lid, ce)) = l in let coe' = if coe then Some true else None in - let f = (((coe', AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce)), None), []) in + let f = AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce), + { rf_subclass = coe' ; rf_priority = None ; rf_notation = [] } in vernac_record ~template udecl cum (Class true) poly finite [id, bl, c, None, [f]] else if List.for_all is_record indl then (* Mutual record case *) @@ -1230,16 +1231,13 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red let clear_implicits_flag = List.mem `ClearImplicits flags in let default_implicits_flag = List.mem `DefaultImplicits flags in let never_unfold_flag = List.mem `ReductionNeverUnfold flags in + let nomatch_flag = List.mem `ReductionDontExposeCase flags in let err_incompat x y = user_err Pp.(str ("Options \""^x^"\" and \""^y^"\" are incompatible.")) in if assert_flag && rename_flag then err_incompat "assert" "rename"; - if Option.has_some nargs_for_red && never_unfold_flag then - err_incompat "simpl never" "/"; - if never_unfold_flag && List.mem `ReductionDontExposeCase flags then - err_incompat "simpl never" "simpl nomatch"; if clear_scopes_flag && extra_scopes_flag then err_incompat "clear scopes" "extra scopes"; if clear_implicits_flag && default_implicits_flag then @@ -1384,19 +1382,24 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red (Util.List.map_i (fun i { recarg_like = b } -> i, b) 0 args) in - let rec narrow = function - | #Reductionops.ReductionBehaviour.flag as x :: tl -> x :: narrow tl - | [] -> [] | _ :: tl -> narrow tl - in - let red_flags = narrow flags in - let red_modifiers_specified = - not (List.is_empty rargs) || Option.has_some nargs_for_red - || not (List.is_empty red_flags) + let red_behavior = + let open Reductionops.ReductionBehaviour in + match never_unfold_flag, nomatch_flag, rargs, nargs_for_red with + | true, false, [], None -> Some NeverUnfold + | true, true, _, _ -> err_incompat "simpl never" "simpl nomatch" + | true, _, _::_, _ -> err_incompat "simpl never" "!" + | true, _, _, Some _ -> err_incompat "simpl never" "/" + | false, false, [], None -> None + | false, false, _, _ -> Some (UnfoldWhen { nargs = nargs_for_red; + recargs = rargs; + }) + | false, true, _, _ -> Some (UnfoldWhenNoMatch { nargs = nargs_for_red; + recargs = rargs; + }) in - if not (List.is_empty rargs) && never_unfold_flag then - err_incompat "simpl never" "!"; + let red_modifiers_specified = Option.has_some red_behavior in (* Actions *) @@ -1423,8 +1426,8 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red match sr with | ConstRef _ as c -> Reductionops.ReductionBehaviour.set - section_local c - (rargs, Option.default ~-1 nargs_for_red, red_flags) + ~local:section_local c (Option.get red_behavior) + | _ -> user_err (strbrk "Modifiers of the behavior of the simpl tactic "++ strbrk "are relevant for constants only.") @@ -1732,29 +1735,29 @@ let vernac_set_option ~local export table v = match v with let vernac_add_option key lv = let f = function - | StringRefValue s -> (get_string_table key)#add s - | QualidRefValue locqid -> (get_ref_table key)#add locqid + | StringRefValue s -> (get_string_table key).add (Global.env()) s + | QualidRefValue locqid -> (get_ref_table key).add (Global.env()) locqid in try List.iter f lv with Not_found -> error_undeclared_key key let vernac_remove_option key lv = let f = function - | StringRefValue s -> (get_string_table key)#remove s - | QualidRefValue locqid -> (get_ref_table key)#remove locqid + | StringRefValue s -> (get_string_table key).remove (Global.env()) s + | QualidRefValue locqid -> (get_ref_table key).remove (Global.env()) locqid in try List.iter f lv with Not_found -> error_undeclared_key key let vernac_mem_option key lv = let f = function - | StringRefValue s -> (get_string_table key)#mem s - | QualidRefValue locqid -> (get_ref_table key)#mem locqid + | StringRefValue s -> (get_string_table key).mem (Global.env()) s + | QualidRefValue locqid -> (get_ref_table key).mem (Global.env()) locqid in try List.iter f lv with Not_found -> error_undeclared_key key let vernac_print_option key = - try (get_ref_table key)#print + try (get_ref_table key).print () with Not_found -> - try (get_string_table key)#print + try (get_string_table key).print () with Not_found -> try print_option_value key with Not_found -> error_undeclared_key key @@ -2599,7 +2602,7 @@ and vernac_load ?proof ~verbosely ~st fname = CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); pstate -and interp_control ?proof ~st = function +and interp_control ?proof ~st v = match v with | { v=VernacExpr (atts, cmd) } -> interp_expr ?proof ~atts ~st cmd | { v=VernacFail v } -> diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 71cc29b6e1..12451370c8 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -23,7 +23,7 @@ val vernac_require : val interp : ?verbosely:bool -> ?proof:Proof_global.closed_proof -> - st:Vernacstate.t -> Vernacexpr.vernac_control CAst.t -> Vernacstate.t + st:Vernacstate.t -> Vernacexpr.vernac_control -> Vernacstate.t (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index d0dae1aa53..34a9b9394a 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -143,13 +143,16 @@ type decl_notation = lstring * constr_expr * scope_name option type simple_binder = lident list * constr_expr type class_binder = lident * constr_expr list type 'a with_coercion = coercion_flag * 'a -type 'a with_instance = instance_flag * 'a -type 'a with_notation = 'a * decl_notation list -type 'a with_priority = 'a * int option +(* Attributes of a record field declaration *) +type record_field_attr = { + rf_subclass: instance_flag; (* the projection is an implicit coercion or an instance *) + rf_priority: int option; (* priority of the instance, if relevant *) + rf_notation: decl_notation list; + } type constructor_expr = (lident * constr_expr) with_coercion type constructor_list_or_record_decl_expr = | Constructors of constructor_expr list - | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list + | RecordDecl of lident option * (local_decl_expr * record_field_attr) list type inductive_expr = ident_decl with_coercion * local_binder_expr list * constr_expr option * inductive_kind * constructor_list_or_record_decl_expr @@ -398,11 +401,12 @@ type nonrec vernac_expr = (* For extension *) | VernacExtend of extend_name * Genarg.raw_generic_argument list -type vernac_control = +type vernac_control_r = | VernacExpr of Attributes.vernac_flags * vernac_expr (* boolean is true when the `-time` batch-mode command line flag was set. the flag is used to print differently in `-time` vs `Time foo` *) - | VernacTime of bool * vernac_control CAst.t - | VernacRedirect of string * vernac_control CAst.t - | VernacTimeout of int * vernac_control CAst.t - | VernacFail of vernac_control CAst.t + | VernacTime of bool * vernac_control + | VernacRedirect of string * vernac_control + | VernacTimeout of int * vernac_control + | VernacFail of vernac_control +and vernac_control = vernac_control_r CAst.t diff --git a/vernac/vernacprop.ml b/vernac/vernacprop.ml index 704c5b2170..b3490c7dc6 100644 --- a/vernac/vernacprop.ml +++ b/vernac/vernacprop.ml @@ -13,19 +13,20 @@ open Vernacexpr -let rec under_control = function +let rec under_control v = v |> CAst.with_val (function | VernacExpr (_, c) -> c - | VernacRedirect (_,{CAst.v=c}) - | VernacTime (_,{CAst.v=c}) - | VernacFail {CAst.v=c} - | VernacTimeout (_,{CAst.v=c}) -> under_control c + | VernacRedirect (_,c) + | VernacTime (_,c) + | VernacFail c + | VernacTimeout (_,c) -> under_control c + ) -let rec has_Fail = function +let rec has_Fail v = v |> CAst.with_val (function | VernacExpr _ -> false - | VernacRedirect (_,{CAst.v=c}) - | VernacTime (_,{CAst.v=c}) - | VernacTimeout (_,{CAst.v=c}) -> has_Fail c - | VernacFail _ -> true + | VernacRedirect (_,c) + | VernacTime (_,c) + | VernacTimeout (_,c) -> has_Fail c + | VernacFail _ -> true) (* Navigation commands are allowed in a coqtop session but not in a .v file *) let is_navigation_vernac_expr = function @@ -38,17 +39,17 @@ let is_navigation_vernac_expr = function let is_navigation_vernac c = is_navigation_vernac_expr (under_control c) -let rec is_deep_navigation_vernac = function - | VernacTime (_,{CAst.v=c}) -> is_deep_navigation_vernac c - | VernacRedirect (_, {CAst.v=c}) - | VernacTimeout (_,{CAst.v=c}) | VernacFail {CAst.v=c} -> is_navigation_vernac c - | VernacExpr _ -> false +let rec is_deep_navigation_vernac v = v |> CAst.with_val (function + | VernacTime (_,c) -> is_deep_navigation_vernac c + | VernacRedirect (_, c) + | VernacTimeout (_, c) | VernacFail c -> is_navigation_vernac c + | VernacExpr _ -> false) (* NB: Reset is now allowed again as asked by A. Chlipala *) -let is_reset = function +let is_reset = CAst.with_val (function | VernacExpr ( _, VernacResetInitial) | VernacExpr (_, VernacResetName _) -> true - | _ -> false + | _ -> false) let is_debug cmd = match under_control cmd with | VernacSetOption (_, ["Ltac";"Debug"], _) -> true |