diff options
87 files changed, 2921 insertions, 2917 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index b7418f54bd..56bd34f6fd 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -160,7 +160,7 @@ /plugins/nsatz/ @coq/nsatz-maintainers /theories/nsatz/ @coq/nsatz-maintainers -/plugins/setoid_ring/ @coq/ring-maintainers +/plugins/ring/ @coq/ring-maintainers /theories/setoid_ring/ @coq/ring-maintainers /plugins/ssrmatching/ @coq/ssreflect-maintainers @@ -46,7 +46,7 @@ plugins/omega developed by Pierre Crégut (France Telecom R&D, 1996) plugins/rtauto developed by Pierre Corbineau (LRI, 2005) -plugins/setoid_ring +plugins/ring developed by Benjamin Grégoire (INRIA-Everest, 2005-2006), Assia Mahboubi, Laurent Théry (INRIA-Marelle, 2006) and Bruno Barras (INRIA LogiCal, 2005-2006), diff --git a/META.coq.in b/META.coq.in index a6747c614b..29b3ecbcb3 100644 --- a/META.coq.in +++ b/META.coq.in @@ -352,19 +352,19 @@ package "plugins" ( plugin(native) = "zify_plugin.cmxs" ) - package "setoid_ring" ( + package "ring" ( - description = "Coq newring plugin" + description = "Coq ring plugin" version = "8.13" requires = "" - directory = "setoid_ring" + directory = "ring" - archive(byte) = "newring_plugin.cmo" - archive(native) = "newring_plugin.cmx" + archive(byte) = "ring_plugin.cmo" + archive(native) = "ring_plugin.cmx" - plugin(byte) = "newring_plugin.cmo" - plugin(native) = "newring_plugin.cmxs" + plugin(byte) = "ring_plugin.cmo" + plugin(native) = "ring_plugin.cmxs" ) package "extraction" ( diff --git a/Makefile.common b/Makefile.common index 8f880e93fb..a482b9b963 100644 --- a/Makefile.common +++ b/Makefile.common @@ -103,7 +103,7 @@ CORESRCDIRS:=\ PLUGINDIRS:=\ omega micromega \ - setoid_ring extraction \ + ring extraction \ cc funind firstorder derive \ rtauto nsatz syntax btauto \ ssrmatching ltac ssr ssrsearch @@ -140,7 +140,7 @@ CORECMA:=config/config.cma clib/clib.cma lib/lib.cma kernel/kernel.cma library/l OMEGACMO:=plugins/omega/omega_plugin.cmo MICROMEGACMO:=plugins/micromega/micromega_plugin.cmo -RINGCMO:=plugins/setoid_ring/newring_plugin.cmo +RINGCMO:=plugins/ring/ring_plugin.cmo NSATZCMO:=plugins/nsatz/nsatz_plugin.cmo EXTRACTIONCMO:=plugins/extraction/extraction_plugin.cmo FUNINDCMO:=plugins/funind/recdef_plugin.cmo diff --git a/Makefile.dev b/Makefile.dev index f48a6f0d8f..5825a884c2 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -154,7 +154,7 @@ LTACVO:=$(filter theories/ltac/%, $(THEORIESVO)) omega: $(OMEGAVO) $(OMEGACMO) micromega: $(MICROMEGAVO) $(MICROMEGACMO) $(CSDPCERT) -setoid_ring: $(RINGVO) $(RINGCMO) +ring: $(RINGVO) $(RINGCMO) nsatz: $(NSATZVO) $(NSATZCMO) extraction: $(EXTRACTIONCMO) $(EXTRACTIONVO) funind: $(FUNINDCMO) $(FUNINDVO) @@ -163,7 +163,7 @@ rtauto: $(RTAUTOVO) $(RTAUTOCMO) btauto: $(BTAUTOVO) $(BTAUTOCMO) ltac: $(LTACVO) $(LTACCMO) -.PHONY: omega micromega setoid_ring nsatz extraction +.PHONY: omega micromega ring nsatz extraction .PHONY: funind cc rtauto btauto ltac # For emacs: diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 7d2100515d..59c1623a2d 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -4,6 +4,12 @@ comes from a notation. Use `None` if not and `Some foo` to tell to print such TacGeneric surrounded with `foo:( )`. +### Code formatting + +- The automatic code formatting tool `ocamlformat` has been disabled and its + git hook removed. If desired, automatic formatting can be achieved by calling + the `fmt` target of the dune build system. + ## Changes between Coq 8.11 and Coq 8.12 ### Code formatting diff --git a/dev/doc/parsing.md b/dev/doc/parsing.md index f8b4537e77..4982e3e94d 100644 --- a/dev/doc/parsing.md +++ b/dev/doc/parsing.md @@ -73,7 +73,7 @@ very specific to Coq (not so similar to Camlp5): END ``` - Global nonterminals are declared in `pcoq.ml`, e.g. `let bignat = Entry.create "Prim.bignat"`. + Global nonterminals are declared in `pcoq.ml`, e.g. `let bignat = Entry.create "bignat"`. All the `*.mlg` files include `open Pcoq` and often its modules, e.g. `open Pcoq.Prim`. `GRAMMAR EXTEND` should be used only for large syntax additions. To add new commands diff --git a/dev/lint-repository.sh b/dev/lint-repository.sh index 553696410c..2e8a7455de 100755 --- a/dev/lint-repository.sh +++ b/dev/lint-repository.sh @@ -32,7 +32,4 @@ find . "(" -path ./.git -prune ")" -o -type f -print0 | echo Checking overlays dev/tools/check-overlays.sh || CODE=1 -echo Checking ocamlformat -make -f Makefile.dune fmt || CODE=1 - exit $CODE diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index 91cb6168e1..534f20f85b 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -30,7 +30,7 @@ exec $OCAMLDEBUG \ -I $COQTOP/plugins/interface -I $COQTOP/plugins/micromega \ -I $COQTOP/plugins/omega -I $COQTOP/plugins/quote \ -I $COQTOP/plugins/ring \ - -I $COQTOP/plugins/rtauto -I $COQTOP/plugins/setoid_ring \ + -I $COQTOP/plugins/rtauto \ -I $COQTOP/plugins/subtac -I $COQTOP/plugins/syntax \ -I $COQTOP/plugins/xml -I $COQTOP/plugins/ltac \ -I $COQTOP/ide \ diff --git a/dev/tools/pre-commit b/dev/tools/pre-commit index 448e224f2e..74fcceb038 100755 --- a/dev/tools/pre-commit +++ b/dev/tools/pre-commit @@ -7,25 +7,7 @@ set -e dev/tools/check-overlays.sh -# Can we check and fix formatting? -# NB: we will ignore errors from ocamlformat as it fails when -# encountering OCaml syntax errors -ocamlformat=$(command -v ocamlformat || echo true) -if [ "$ocamlformat" = true ] -then - 1>&2 echo "Warning: ocamlformat is not in path. Cannot check formatting." -fi - -# Verify that the version of ocamlformat matches the one in .ocamlformat -# The following command will print an error message if that's not the case -# (and will print nothing if the versions match) -if ! echo "let () = ()" | "$ocamlformat" --impl - > /dev/null -then - 1>&2 echo "Warning: Cannot check formatting." - ocamlformat=true -fi - -1>&2 echo "Auto fixing whitespace and formatting issues..." +1>&2 echo "Auto fixing whitespace issues..." # We fix whitespace in the index and in the working tree # separately to preserve non-added changes. @@ -52,7 +34,6 @@ if [ -s "$index" ]; then git apply --cached --whitespace=fix "$index" git apply --whitespace=fix "$index" 2>/dev/null # no need to repeat yourself git diff --cached --name-only -z | xargs -0 dev/tools/check-eof-newline.sh --fix - { git diff --cached --name-only -z | grep -E '.*\.mli?$' -z | xargs -0 "$ocamlformat" -i || true; } 2> /dev/null git add -u 1>&2 echo #newline fi @@ -68,12 +49,11 @@ if [ -s "$tree" ]; then 1>&2 echo "Fixing unstaged changes..." git apply --whitespace=fix "$tree" git diff --name-only -z | xargs -0 dev/tools/check-eof-newline.sh --fix - { git diff --name-only -z | grep -E '.*\.mli?$' -z | xargs -0 "$ocamlformat" -i || true; } 2> /dev/null 1>&2 echo #newline fi if [ -s "$index" ] && ! [ -s "$fixed_index" ]; then - 1>&2 echo "Fixing whitespace and formatting issues cancelled all changes." + 1>&2 echo "Fixing whitespace issues cancelled all changes." exit 1 fi @@ -84,7 +64,7 @@ if ! git diff-index --check --cached HEAD; then 1>&2 echo "(Consider whether the number of errors decreases after each run.)" exit 1 fi -1>&2 echo "Whitespace and formatting pass complete." +1>&2 echo "Whitespace pass complete." # clean up temporary files rm "$index" "$tree" "$fixed_index" diff --git a/doc/changelog/02-specification-language/13106-doc-and-changelog-for-13106.rst b/doc/changelog/02-specification-language/13106-doc-and-changelog-for-13106.rst new file mode 100644 index 0000000000..7fe69c39c1 --- /dev/null +++ b/doc/changelog/02-specification-language/13106-doc-and-changelog-for-13106.rst @@ -0,0 +1,5 @@ +- **Removed:** + Undocumented and experimental forward class hint feature ``:>>``. + Use ``:>`` (see :n:`@of_type`) instead + (`#13106 <https://github.com/coq/coq/pull/13106>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/07-commands-and-options/13096-drop-grammar-prefixes.rst b/doc/changelog/07-commands-and-options/13096-drop-grammar-prefixes.rst new file mode 100644 index 0000000000..0ab9a58e6f --- /dev/null +++ b/doc/changelog/07-commands-and-options/13096-drop-grammar-prefixes.rst @@ -0,0 +1,6 @@ +- **Changed:** + Drop prefixes from grammar non-terminal names, + e.g. "constr:global" -> "global", "Prim.name" -> "name". + Visible in the output of :cmd:`Print Grammar` and :cmd:`Print Custom Grammar`. + (`#13096 <https://github.com/coq/coq/pull/13096>`_, + by Jim Fehrle). diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index 479fa674f5..cda8a1b679 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -387,8 +387,8 @@ The syntax for adding a new ring is interpretation via ``Cp_phi`` (the evaluation function of power coefficient) is the original term, or returns ``InitialRing.NotConstant`` if not a constant coefficient (i.e. |L_tac| is the inverse function of - ``Cp_phi``). See files ``plugins/setoid_ring/ZArithRing.v`` - and ``plugins/setoid_ring/RealField.v`` for examples. By default the tactic + ``Cp_phi``). See files ``plugins/ring/ZArithRing.v`` + and ``plugins/ring/RealField.v`` for examples. By default the tactic does not recognize power expressions as ring expressions. :n:`sign @one_term` @@ -396,7 +396,7 @@ The syntax for adding a new ring is outputting its normal form, i.e writing ``x − y`` instead of ``x + (− y)``. The term :token:`term` is a proof that a given sign function indicates expressions that are signed (:token:`term` has to be a proof of ``Ring_theory.get_sign``). See - ``plugins/setoid_ring/InitialRing.v`` for examples of sign function. + ``plugins/ring/InitialRing.v`` for examples of sign function. :n:`div @one_term` allows :tacn:`ring` and :tacn:`ring_simplify` to use monomials with @@ -405,7 +405,7 @@ The syntax for adding a new ring is euclidean division function (:n:`@one_term` has to be a proof of ``Ring_theory.div_theory``). For example, this function is called when trying to rewrite :math:`7x` by :math:`2x = z` to tell that :math:`7 = 3 \times 2 + 1`. See - ``plugins/setoid_ring/InitialRing.v`` for examples of div function. + ``plugins/ring/InitialRing.v`` for examples of div function. :n:`closed [ {+ @qualid } ]` to be documented @@ -538,7 +538,7 @@ Dealing with fields The tactic must be loaded by ``Require Import Field``. New field structures can be declared to the system with the ``Add Field`` command (see below). The field of real numbers is defined in module ``RealField`` - (in ``plugins/setoid_ring``). It is exported by module ``Rbase``, so + (in ``plugins/ring``). It is exported by module ``Rbase``, so that requiring ``Rbase`` or ``Reals`` is enough to use the field tactics on real numbers. Rational numbers in canonical form are also declared as a field in the module ``Qcanon``. diff --git a/doc/sphinx/language/core/assumptions.rst b/doc/sphinx/language/core/assumptions.rst index fe10e345cd..41e1c30f0d 100644 --- a/doc/sphinx/language/core/assumptions.rst +++ b/doc/sphinx/language/core/assumptions.rst @@ -138,7 +138,7 @@ has type :n:`@type`. | {| Variable | Variables } assumpt ::= {+ @ident_decl } @of_type ident_decl ::= @ident {? @univ_decl } - of_type ::= {| : | :> | :>> } @type + of_type ::= {| : | :> } @type These commands bind one or more :n:`@ident`\(s) to specified :n:`@type`\(s) as their specifications in the global context. The fact asserted by the :n:`@type` (or, equivalently, the existence diff --git a/doc/sphinx/language/core/primitive.rst b/doc/sphinx/language/core/primitive.rst index 727177b23a..48647deeff 100644 --- a/doc/sphinx/language/core/primitive.rst +++ b/doc/sphinx/language/core/primitive.rst @@ -133,7 +133,7 @@ follows: Axiom get_set_same : forall A t i (a:A), (i < length t) = true -> t.[i<-a].[i] = a. Axiom get_set_other : forall A t i j (a:A), i <> j -> t.[i<-a].[j] = t.[j]. -The complete set of such operators can be obtained looking at the :g:`PArray` module. +The rest of these operators can be found in the :g:`PArray` module. These primitive declarations are regular axioms. As such, they must be trusted and are listed by the :g:`Print Assumptions` command. @@ -150,7 +150,16 @@ extraction. Instead, it has to be provided by the user (if they want to compile or execute the extracted code). For instance, an implementation of this module can be taken from the kernel of Coq (see ``kernel/parray.ml``). -Primitive arrays expose a functional interface, but they are internally -implemented using a persistent data structure :cite:`ConchonFilliatre07wml`. -Update and access to an element in the most recent copy of an array are -constant time operations. +Coq's primitive arrays are persistent data structures. Semantically, a set operation +``t.[i <- a]`` represents a new array that has the same values as ``t``, except +at position ``i`` where its value is ``a``. The array ``t`` still exists, can +still be used and its values were not modified. Operationally, the implementation +of Coq's primitive arrays is optimized so that the new array ``t.[i <- a]`` does not +copy all of ``t``. The details are in section 2.3 of :cite:`ConchonFilliatre07wml`. +In short, the implementation keeps one version of ``t`` as an OCaml native array and +other versions as lists of modifications to ``t``. Accesses to the native array +version are constant time operations. However, accesses to versions where all the cells of +the array are modified have O(n) access time, the same as a list. The version that is kept as the native array +changes dynamically upon each get and set call: the current list of modifications +is applied to the native array and the lists of modifications of the other versions +are updated so that they still represent the same values. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index e276a0edcb..4b1f312105 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -4726,7 +4726,7 @@ Automating .. seealso:: - File plugins/setoid_ring/RealField.v for an example of instantiation, + File plugins/ring/RealField.v for an example of instantiation, theory theories/Reals for many examples of use of field. Non-logical tactics diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 6ba53b581b..5148fa84c9 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -429,10 +429,6 @@ Displaying information about notations productions shown by `Print Grammar tactic` refer to nonterminals `tactic_then_locality` and `tactic_then_gen` which are not shown and can't be printed. - The prefixes `tactic:`, `prim:`, `constr:` appearing in the output are meant to identify - what part of the grammar a nonterminal is from. If you examine nonterminal definitions - in the source code, they are identified only by the name following the colon. - Most of the grammar in the documentation was updated in 8.12 to make it accurate and readable. This was done using a new developer tool that extracts the grammar from the source code, edits it and inserts it into the documentation files. While the @@ -467,11 +463,11 @@ Displaying information about notations `tactic_expr`, designated as "5", "4" and "3". Level 3 is right-associative, which applies to the productions within it, such as the `try` construct:: - Entry tactic:tactic_expr is + Entry tactic_expr is [ "5" RIGHTA - [ tactic:binder_tactic ] + [ binder_tactic ] | "4" LEFTA - [ SELF; ";"; tactic:binder_tactic + [ SELF; ";"; binder_tactic | SELF; ";"; SELF | SELF; ";"; tactic_then_locality; tactic_then_gen; "]" ] | "3" RIGHTA diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index a22f7ae9f3..a9f9c805d8 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -615,7 +615,7 @@ of_type_with_opt_coercion: [ ] of_type_with_opt_coercion: [ -| [ ":" | ":>" | ":>>" ] type +| [ ":" | ":>" ] type ] attribute_value: [ diff --git a/doc/tools/docgram/dune b/doc/tools/docgram/dune index ba07e6df0d..2a7b283f55 100644 --- a/doc/tools/docgram/dune +++ b/doc/tools/docgram/dune @@ -24,7 +24,7 @@ (glob_files %{project_root}/plugins/nsatz/*.mlg) (glob_files %{project_root}/plugins/omega/*.mlg) (glob_files %{project_root}/plugins/rtauto/*.mlg) - (glob_files %{project_root}/plugins/setoid_ring/*.mlg) + (glob_files %{project_root}/plugins/ring/*.mlg) (glob_files %{project_root}/plugins/syntax/*.mlg) (glob_files %{project_root}/user-contrib/Ltac2/*.mlg) ; Sphinx files diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 2ee8e4347e..067050b4f5 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -685,10 +685,10 @@ command: [ | "Show" "Zify" "UnOpSpec" (* micromega plugin *) | "Show" "Zify" "BinOpSpec" (* micromega plugin *) | "Show" "Zify" "Spec" (* micromega plugin *) -| "Add" "Ring" ident ":" constr OPT ring_mods (* setoid_ring plugin *) -| "Print" "Rings" (* setoid_ring plugin *) -| "Add" "Field" ident ":" constr OPT field_mods (* setoid_ring plugin *) -| "Print" "Fields" (* setoid_ring plugin *) +| "Add" "Ring" ident ":" constr OPT ring_mods (* ring plugin *) +| "Print" "Rings" (* ring plugin *) +| "Add" "Field" ident ":" constr OPT field_mods (* ring plugin *) +| "Print" "Fields" (* ring plugin *) | "Number" "Notation" reference reference reference ":" ident numnotoption | "Numeral" "Notation" reference reference reference ":" ident numnotoption | "String" "Notation" reference reference reference ":" ident @@ -986,10 +986,7 @@ constructor: [ ] of_type_with_opt_coercion: [ -| ":>>" -| ":>" ">" | ":>" -| ":" ">" ">" | ":" ">" | ":" ] @@ -1744,10 +1741,10 @@ simple_tactic: [ | "nsatz_compute" constr (* nsatz plugin *) | "omega" (* omega plugin *) | "rtauto" -| "protect_fv" string "in" ident (* setoid_ring plugin *) -| "protect_fv" string (* setoid_ring plugin *) -| "ring_lookup" tactic0 "[" LIST0 constr "]" LIST1 constr (* setoid_ring plugin *) -| "field_lookup" tactic "[" LIST0 constr "]" LIST1 constr (* setoid_ring plugin *) +| "protect_fv" string "in" ident (* ring plugin *) +| "protect_fv" string (* ring plugin *) +| "ring_lookup" tactic0 "[" LIST0 constr "]" LIST1 constr (* ring plugin *) +| "field_lookup" tactic "[" LIST0 constr "]" LIST1 constr (* ring plugin *) ] mlname: [ @@ -1761,7 +1758,6 @@ int_or_id: [ ] language: [ -| "Ocaml" (* extraction plugin *) | "OCaml" (* extraction plugin *) | "Haskell" (* extraction plugin *) | "Scheme" (* extraction plugin *) @@ -2532,31 +2528,31 @@ induction_clause_list: [ ] ring_mod: [ -| "decidable" constr (* setoid_ring plugin *) -| "abstract" (* setoid_ring plugin *) -| "morphism" constr (* setoid_ring plugin *) -| "constants" "[" tactic "]" (* setoid_ring plugin *) -| "closed" "[" LIST1 global "]" (* setoid_ring plugin *) -| "preprocess" "[" tactic "]" (* setoid_ring plugin *) -| "postprocess" "[" tactic "]" (* setoid_ring plugin *) -| "setoid" constr constr (* setoid_ring plugin *) -| "sign" constr (* setoid_ring plugin *) -| "power" constr "[" LIST1 global "]" (* setoid_ring plugin *) -| "power_tac" constr "[" tactic "]" (* setoid_ring plugin *) -| "div" constr (* setoid_ring plugin *) +| "decidable" constr (* ring plugin *) +| "abstract" (* ring plugin *) +| "morphism" constr (* ring plugin *) +| "constants" "[" tactic "]" (* ring plugin *) +| "closed" "[" LIST1 global "]" (* ring plugin *) +| "preprocess" "[" tactic "]" (* ring plugin *) +| "postprocess" "[" tactic "]" (* ring plugin *) +| "setoid" constr constr (* ring plugin *) +| "sign" constr (* ring plugin *) +| "power" constr "[" LIST1 global "]" (* ring plugin *) +| "power_tac" constr "[" tactic "]" (* ring plugin *) +| "div" constr (* ring plugin *) ] ring_mods: [ -| "(" LIST1 ring_mod SEP "," ")" (* setoid_ring plugin *) +| "(" LIST1 ring_mod SEP "," ")" (* ring plugin *) ] field_mod: [ -| ring_mod (* setoid_ring plugin *) -| "completeness" constr (* setoid_ring plugin *) +| ring_mod (* ring plugin *) +| "completeness" constr (* ring plugin *) ] field_mods: [ -| "(" LIST1 field_mod SEP "," ")" (* setoid_ring plugin *) +| "(" LIST1 field_mod SEP "," ")" (* ring plugin *) ] numnotoption: [ diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index aae96fc966..cbef29fb39 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -114,7 +114,7 @@ ident_decl: [ ] of_type: [ -| [ ":" | ":>" | ":>>" ] type +| [ ":" | ":>" ] type ] qualid: [ @@ -892,10 +892,10 @@ command: [ | "Show" "Zify" "UnOpSpec" (* micromega plugin *) | "Show" "Zify" "BinOpSpec" (* micromega plugin *) | "Show" "Zify" "Spec" (* micromega plugin *) -| "Add" "Ring" ident ":" one_term OPT ( "(" LIST1 ring_mod SEP "," ")" ) (* setoid_ring plugin *) -| "Print" "Rings" (* setoid_ring plugin *) -| "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* setoid_ring plugin *) -| "Print" "Fields" (* setoid_ring plugin *) +| "Add" "Ring" ident ":" one_term OPT ( "(" LIST1 ring_mod SEP "," ")" ) (* ring plugin *) +| "Print" "Rings" (* ring plugin *) +| "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* ring plugin *) +| "Print" "Fields" (* ring plugin *) | "Number" "Notation" qualid qualid qualid ":" ident OPT numeral_modifier | "Hint" "Cut" "[" hints_path "]" OPT ( ":" LIST1 ident ) | "Typeclasses" "Transparent" LIST0 qualid @@ -1268,7 +1268,6 @@ int_or_id: [ ] language: [ -| "Ocaml" (* extraction plugin *) | "OCaml" (* extraction plugin *) | "Haskell" (* extraction plugin *) | "Scheme" (* extraction plugin *) @@ -1280,23 +1279,23 @@ fun_scheme_arg: [ ] ring_mod: [ -| "decidable" one_term (* setoid_ring plugin *) -| "abstract" (* setoid_ring plugin *) -| "morphism" one_term (* setoid_ring plugin *) -| "constants" "[" ltac_expr "]" (* setoid_ring plugin *) -| "preprocess" "[" ltac_expr "]" (* setoid_ring plugin *) -| "postprocess" "[" ltac_expr "]" (* setoid_ring plugin *) -| "setoid" one_term one_term (* setoid_ring plugin *) -| "sign" one_term (* setoid_ring plugin *) -| "power" one_term "[" LIST1 qualid "]" (* setoid_ring plugin *) -| "power_tac" one_term "[" ltac_expr "]" (* setoid_ring plugin *) -| "div" one_term (* setoid_ring plugin *) -| "closed" "[" LIST1 qualid "]" (* setoid_ring plugin *) +| "decidable" one_term (* ring plugin *) +| "abstract" (* ring plugin *) +| "morphism" one_term (* ring plugin *) +| "constants" "[" ltac_expr "]" (* ring plugin *) +| "preprocess" "[" ltac_expr "]" (* ring plugin *) +| "postprocess" "[" ltac_expr "]" (* ring plugin *) +| "setoid" one_term one_term (* ring plugin *) +| "sign" one_term (* ring plugin *) +| "power" one_term "[" LIST1 qualid "]" (* ring plugin *) +| "power_tac" one_term "[" ltac_expr "]" (* ring plugin *) +| "div" one_term (* ring plugin *) +| "closed" "[" LIST1 qualid "]" (* ring plugin *) ] field_mod: [ -| ring_mod (* setoid_ring plugin *) -| "completeness" one_term (* setoid_ring plugin *) +| ring_mod (* ring plugin *) +| "completeness" one_term (* ring plugin *) ] numeral_modifier: [ @@ -1642,8 +1641,8 @@ simple_tactic: [ | "nsatz_compute" one_term (* nsatz plugin *) | "omega" (* omega plugin *) | "protect_fv" string OPT ( "in" ident ) -| "ring_lookup" ltac_expr0 "[" LIST0 one_term "]" LIST1 one_term (* setoid_ring plugin *) -| "field_lookup" ltac_expr "[" LIST0 one_term "]" LIST1 one_term (* setoid_ring plugin *) +| "ring_lookup" ltac_expr0 "[" LIST0 one_term "]" LIST1 one_term (* ring plugin *) +| "field_lookup" ltac_expr "[" LIST0 one_term "]" LIST1 one_term (* ring plugin *) | match_key OPT "reverse" "goal" "with" OPT "|" LIST1 ( goal_pattern "=>" ltac_expr ) SEP "|" "end" | match_key ltac_expr "with" OPT "|" LIST1 ( match_pattern "=>" ltac_expr ) SEP "|" "end" | "classical_left" diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 1d3b1bbb24..48fb4a4a5d 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -2530,12 +2530,12 @@ let intern_context env impl_env binders = binder_block_names = Some (Some AbsPi,ids)}, []) binders in (lenv.impls, List.map glob_local_binder_of_extended bl) -let interp_glob_context_evars ?(program_mode=false) env sigma k bl = +let interp_glob_context_evars ?(program_mode=false) env sigma bl = let open EConstr in let flags = { Pretyping.all_no_fail_flags with program_mode } in - let env, sigma, par, _, impls = + let env, sigma, par, impls = List.fold_left - (fun (env,sigma,params,n,impls) (na, k, b, t) -> + (fun (env,sigma,params,impls) (na, k, b, t) -> let t' = if Option.is_empty b then locate_if_hole ?loc:(loc_of_glob_constr t) na t else t @@ -2551,16 +2551,17 @@ let interp_glob_context_evars ?(program_mode=false) env sigma k bl = | MaxImplicit -> CAst.make (Some (na,true)) :: impls | Explicit -> CAst.make None :: impls in - (push_rel d env, sigma, d::params, succ n, impls) + (push_rel d env, sigma, d::params, impls) | Some b -> let sigma, c = understand_tcc ~flags env sigma ~expected_type:(OfType t) b in let r = Retyping.relevance_of_type env sigma t in let d = LocalDef (make_annot na r, c, t) in - (push_rel d env, sigma, d::params, n, impls)) - (env,sigma,[],k+1,[]) (List.rev bl) - in sigma, ((env, par), List.rev impls) + (push_rel d env, sigma, d::params, impls)) + (env,sigma,[],[]) (List.rev bl) + in + sigma, ((env, par), List.rev impls) -let interp_context_evars ?program_mode ?(impl_env=empty_internalization_env) ?(shift=0) env sigma params = +let interp_context_evars ?program_mode ?(impl_env=empty_internalization_env) env sigma params = let int_env,bl = intern_context env impl_env params in - let sigma, x = interp_glob_context_evars ?program_mode env sigma shift bl in + let sigma, x = interp_glob_context_evars ?program_mode env sigma bl in sigma, (int_env, x) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 2eb96aad56..898a3e09c8 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -156,7 +156,7 @@ val interp_binder_evars : env -> evar_map -> Name.t -> constr_expr -> evar_map * (** Interpret contexts: returns extended env and context *) val interp_context_evars : - ?program_mode:bool -> ?impl_env:internalization_env -> ?shift:int -> + ?program_mode:bool -> ?impl_env:internalization_env -> env -> evar_map -> local_binder_expr list -> evar_map * (internalization_env * ((env * rel_context) * Impargs.manual_implicits)) diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index ada0fc9780..3e8916673d 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -159,7 +159,7 @@ val inject : constr -> fconstr (** mk_atom: prevents a term from being evaluated *) val mk_atom : constr -> fconstr -(** mk_red: makes a reducible term (used in newring) *) +(** mk_red: makes a reducible term (used in ring) *) val mk_red : fterm -> fconstr val fterm_of : fconstr -> fterm diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 0d74ad928c..723f08413e 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -202,6 +202,7 @@ let parse_string f ?loc x = let strm = Stream.of_string x in Entry.parse f (Parsable.make ?loc strm) +(* universes not used by Coq build but still used by some plugins *) type gram_universe = string let utables : (string, unit) Hashtbl.t = @@ -211,21 +212,18 @@ let create_universe u = let () = Hashtbl.add utables u () in u -let uprim = create_universe "prim" -let uconstr = create_universe "constr" -let utactic = create_universe "tactic" +let uprim = create_universe "prim" [@@deprecated "Deprecated in 8.13"] +let uconstr = create_universe "constr" [@@deprecated "Deprecated in 8.13"] +let utactic = create_universe "tactic" [@@deprecated "Deprecated in 8.13"] let get_univ u = if Hashtbl.mem utables u then u else raise Not_found -let new_entry u s = - let ename = u ^ ":" ^ s in - let e = Entry.make ename in +let new_entry _ s = + let e = Entry.make s in e -let make_gen_entry u s = new_entry u s - module GrammarObj = struct type ('r, _, _) obj = 'r Entry.t @@ -251,52 +249,54 @@ let genarg_grammar x = check_compatibility x; Grammar.obj x -let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Entry.t = - let e = new_entry u s in +let create_generic_entry2 (type a) s (etyp : a raw_abstract_argument_type) : a Entry.t = + let e = Entry.create s in let Rawwit t = etyp in let () = Grammar.register0 t e in e +let create_generic_entry (type a) _ s (etyp : a raw_abstract_argument_type) : a Entry.t = + create_generic_entry2 s etyp + (* Initial grammar entries *) module Prim = struct - let gec_gen n = make_gen_entry uprim n (* Entries that can be referred via the string -> Entry.t table *) (* Typically for tactic or vernac extensions *) - let preident = gec_gen "preident" - let ident = gec_gen "ident" - let natural = gec_gen "natural" - let integer = gec_gen "integer" - let bignat = Entry.create "Prim.bignat" - let bigint = Entry.create "Prim.bigint" - let string = gec_gen "string" - let lstring = Entry.create "Prim.lstring" - let reference = make_gen_entry uprim "reference" + let preident = Entry.create "preident" + let ident = Entry.create "ident" + let natural = Entry.create "natural" + let integer = Entry.create "integer" + let bignat = Entry.create "bignat" + let bigint = Entry.create "bigint" + let string = Entry.create "string" + let lstring = Entry.create "lstring" + let reference = Entry.create "reference" let by_notation = Entry.create "by_notation" let smart_global = Entry.create "smart_global" - let strategy_level = gec_gen "strategy_level" + let strategy_level = Entry.create "strategy_level" (* parsed like ident but interpreted as a term *) - let var = gec_gen "var" + let var = Entry.create "var" - let name = Entry.create "Prim.name" - let identref = Entry.create "Prim.identref" - let univ_decl = Entry.create "Prim.univ_decl" - let ident_decl = Entry.create "Prim.ident_decl" + let name = Entry.create "name" + let identref = Entry.create "identref" + let univ_decl = Entry.create "univ_decl" + let ident_decl = Entry.create "ident_decl" let pattern_ident = Entry.create "pattern_ident" let pattern_identref = Entry.create "pattern_identref" (* A synonym of ident - maybe ident will be located one day *) - let base_ident = Entry.create "Prim.base_ident" + let base_ident = Entry.create "base_ident" - let qualid = Entry.create "Prim.qualid" - let fullyqualid = Entry.create "Prim.fullyqualid" - let dirpath = Entry.create "Prim.dirpath" + let qualid = Entry.create "qualid" + let fullyqualid = Entry.create "fullyqualid" + let dirpath = Entry.create "dirpath" - let ne_string = Entry.create "Prim.ne_string" - let ne_lstring = Entry.create "Prim.ne_lstring" + let ne_string = Entry.create "ne_string" + let ne_lstring = Entry.create "ne_lstring" let bar_cbrace = Entry.create "'|}'" @@ -304,32 +304,31 @@ module Prim = module Constr = struct - let gec_constr = make_gen_entry uconstr (* Entries that can be referred via the string -> Entry.t table *) - let constr = gec_constr "constr" - let operconstr = gec_constr "operconstr" + let constr = Entry.create "constr" + let operconstr = Entry.create "operconstr" let constr_eoi = eoi_entry constr - let lconstr = gec_constr "lconstr" - let binder_constr = gec_constr "binder_constr" - let ident = make_gen_entry uconstr "ident" - let global = make_gen_entry uconstr "global" - let universe_name = make_gen_entry uconstr "universe_name" - let universe_level = make_gen_entry uconstr "universe_level" - let sort = make_gen_entry uconstr "sort" - let sort_family = make_gen_entry uconstr "sort_family" - let pattern = Entry.create "constr:pattern" - let constr_pattern = gec_constr "constr_pattern" - let lconstr_pattern = gec_constr "lconstr_pattern" - let closed_binder = Entry.create "constr:closed_binder" - let binder = Entry.create "constr:binder" - let binders = Entry.create "constr:binders" - let open_binders = Entry.create "constr:open_binders" - let binders_fixannot = Entry.create "constr:binders_fixannot" - let typeclass_constraint = Entry.create "constr:typeclass_constraint" - let record_declaration = Entry.create "constr:record_declaration" - let appl_arg = Entry.create "constr:appl_arg" - let type_cstr = Entry.create "constr:type_cstr" + let lconstr = Entry.create "lconstr" + let binder_constr = Entry.create "binder_constr" + let ident = Entry.create "ident" + let global = Entry.create "global" + let universe_name = Entry.create "universe_name" + let universe_level = Entry.create "universe_level" + let sort = Entry.create "sort" + let sort_family = Entry.create "sort_family" + let pattern = Entry.create "pattern" + let constr_pattern = Entry.create "constr_pattern" + let lconstr_pattern = Entry.create "lconstr_pattern" + let closed_binder = Entry.create "closed_binder" + let binder = Entry.create "binder" + let binders = Entry.create "binders" + let open_binders = Entry.create "open_binders" + let binders_fixannot = Entry.create "binders_fixannot" + let typeclass_constraint = Entry.create "typeclass_constraint" + let record_declaration = Entry.create "record_declaration" + let appl_arg = Entry.create "appl_arg" + let type_cstr = Entry.create "type_cstr" end module Module = diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index bd64d21518..ae9a7423c2 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -123,24 +123,29 @@ val parse_string : 'a Entry.t -> ?loc:Loc.t -> string -> 'a val eoi_entry : 'a Entry.t -> 'a Entry.t val map_entry : ('a -> 'b) -> 'a Entry.t -> 'b Entry.t -type gram_universe +type gram_universe [@@deprecated "Deprecated in 8.13"] +[@@@ocaml.warning "-3"] +val get_univ : string -> gram_universe [@@deprecated "Deprecated in 8.13"] +val create_universe : string -> gram_universe [@@deprecated "Deprecated in 8.13"] -val get_univ : string -> gram_universe -val create_universe : string -> gram_universe +val new_entry : gram_universe -> string -> 'a Entry.t [@@deprecated "Deprecated in 8.13"] -val new_entry : gram_universe -> string -> 'a Entry.t +val uprim : gram_universe [@@deprecated "Deprecated in 8.13"] +val uconstr : gram_universe [@@deprecated "Deprecated in 8.13"] +val utactic : gram_universe [@@deprecated "Deprecated in 8.13"] -val uprim : gram_universe -val uconstr : gram_universe -val utactic : gram_universe +val create_generic_entry : gram_universe -> string -> + ('a, rlevel) abstract_argument_type -> 'a Entry.t + [@@deprecated "Deprecated in 8.13. Use create_generic_entry2 instead."] +[@@@ocaml.warning "+3"] + +val create_generic_entry2 : string -> + ('a, rlevel) abstract_argument_type -> 'a Entry.t val register_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Entry.t -> unit val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Entry.t -val create_generic_entry : gram_universe -> string -> - ('a, rlevel) abstract_argument_type -> 'a Entry.t - module Prim : sig open Names diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 72e6006b7e..e50c6087bb 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + open Printer open CErrors open Util @@ -8,9 +18,7 @@ open Vars open Namegen open Names open Pp -open Tacmach open Termops -open Tacticals open Tactics open Indfun_common open Libnames @@ -27,7 +35,7 @@ let make_refl_eq constructor type_of_t t = mkApp (constructor, [|type_of_t; t|]) type pte_info = - {proving_tac : Id.t list -> Tacmach.tactic; is_valid : constr -> bool} + {proving_tac : Id.t list -> unit Proofview.tactic; is_valid : constr -> bool} type ptes_info = pte_info Id.Map.t @@ -36,16 +44,12 @@ type 'a dynamic_info = type body_info = constr dynamic_info -let observe_tac s = observe_tac (fun _ _ -> Pp.str s) - -let finish_proof dynamic_infos g = - observe_tac "finish" (Proofview.V82.of_tactic assumption) g +let observe_tac s = + New.observe_tac ~header:(str "observation") (fun _ _ -> Pp.str s) -let refine c = - Proofview.V82.of_tactic - (Logic.refiner ~check:true EConstr.Unsafe.(to_constr c)) - -let thin l = Proofview.V82.of_tactic (Tactics.clear l) +let finish_proof dynamic_infos = observe_tac "finish" assumption +let refine c = Logic.refiner ~check:true EConstr.Unsafe.(to_constr c) +let thin = clear let eq_constr sigma u v = EConstr.eq_constr_nounivs sigma u v let is_trivial_eq sigma t = @@ -83,37 +87,42 @@ let is_incompatible_eq env sigma t = if res then observe (str "is_incompatible_eq " ++ pr_leconstr_env env sigma t); res -let change_hyp_with_using msg hyp_id t tac : tactic = - fun g -> - let prov_id = pf_get_new_id hyp_id g in - tclTHENS - ((* observe_tac msg *) Proofview.V82.of_tactic - (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac)))) - [ tclTHENLIST - [ (* observe_tac "change_hyp_with_using thin" *) - thin [hyp_id] - ; (* observe_tac "change_hyp_with_using rename " *) - Proofview.V82.of_tactic (rename_hyp [(prov_id, hyp_id)]) ] ] - g +let pf_get_new_id id env = + next_ident_away id (Id.Set.of_list (Termops.ids_of_named_context env)) + +let change_hyp_with_using msg hyp_id t tac = + Proofview.Goal.enter (fun gl -> + let prov_id = pf_get_new_id hyp_id (Proofview.Goal.hyps gl) in + Tacticals.New.tclTHENS + ((* observe_tac msg *) + assert_by (Name prov_id) t + (Tacticals.New.tclCOMPLETE tac)) + [ Tacticals.New.tclTHENLIST + [ (* observe_tac "change_hyp_with_using thin" *) + Tactics.clear [hyp_id] + ; (* observe_tac "change_hyp_with_using rename " *) + rename_hyp [(prov_id, hyp_id)] ] ]) exception TOREMOVE let prove_trivial_eq h_id context (constructor, type_of_term, term) = let nb_intros = List.length context in - tclTHENLIST - [ tclDO nb_intros (Proofview.V82.of_tactic intro) + Tacticals.New.tclTHENLIST + [ Tacticals.New.tclDO nb_intros intro ; (* introducing context *) - (fun g -> - let context_hyps = - fst - (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) - in - let context_hyps' = - mkApp (constructor, [|type_of_term; term|]) - :: List.map mkVar context_hyps - in - let to_refine = applist (mkVar h_id, List.rev context_hyps') in - refine to_refine g) ] + Proofview.Goal.enter (fun g -> + let hyps = Proofview.Goal.hyps g in + let context_hyps = + fst + (list_chop ~msg:"prove_trivial_eq : " nb_intros + (ids_of_named_context hyps)) + in + let context_hyps' = + mkApp (constructor, [|type_of_term; term|]) + :: List.map mkVar context_hyps + in + let to_refine = applist (mkVar h_id, List.rev context_hyps') in + refine to_refine) ] let find_rectype env sigma c = let t, l = decompose_app sigma (Reductionops.whd_betaiotazeta env sigma c) in @@ -255,13 +264,11 @@ let change_eq env sigma hyp_id (context : rel_context) x t end_of_type = Typing.type_of (Proofview.Goal.env g) (Proofview.Goal.sigma g) to_refine in - tclTHEN - (Proofview.Unsafe.tclEVARS evm) - (Proofview.V82.tactic (refine to_refine)))) + tclTHEN (Proofview.Unsafe.tclEVARS evm) (refine to_refine))) in let simpl_eq_tac = change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp - (Proofview.V82.of_tactic prove_new_hyp) + prove_new_hyp in (* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) (* str "removing an equation " ++ fnl ()++ *) @@ -294,30 +301,30 @@ let isLetIn sigma t = match EConstr.kind sigma t with LetIn _ -> true | _ -> false let h_reduce_with_zeta cl = - Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) - cl) + reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) cl -let rewrite_until_var arg_num eq_ids : tactic = +let rewrite_until_var arg_num eq_ids : unit Proofview.tactic = + let open Tacticals.New in (* tests if the declares recursive argument is neither a Constructor nor an applied Constructor since such a form for the recursive argument will break the Guard when trying to save the Lemma. *) let test_var g = - let sigma = project g in - let _, args = destApp sigma (pf_concl g) in + let sigma = Proofview.Goal.sigma g in + let _, args = destApp sigma (Proofview.Goal.concl g) in not (isConstruct sigma args.(arg_num) || isAppConstruct sigma args.(arg_num)) in - let rec do_rewrite eq_ids g = - if test_var g then tclIDTAC g - else - match eq_ids with - | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property.") - | eq_id :: eq_ids -> - tclTHEN - (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) - (do_rewrite eq_ids) g + let rec do_rewrite eq_ids = + Proofview.Goal.enter (fun g -> + if test_var g then Proofview.tclUNIT () + else + match eq_ids with + | [] -> + anomaly (Pp.str "Cannot find a way to prove recursive property.") + | eq_id :: eq_ids -> + tclTHEN + (tclTRY (Equality.rewriteRL (mkVar eq_id))) + (do_rewrite eq_ids)) in do_rewrite eq_ids @@ -336,7 +343,8 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") in - let rec scan_type context type_of_hyp : tactic = + let open Tacticals.New in + let rec scan_type context type_of_hyp : unit Proofview.tactic = if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in let reduced_type_of_hyp = @@ -362,28 +370,27 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = let prove_new_type_of_hyp = let context_length = List.length context in tclTHENLIST - [ tclDO context_length (Proofview.V82.of_tactic intro) - ; (fun g -> - let context_hyps_ids = - fst - (list_chop ~msg:"rec hyp : context_hyps" context_length - (pf_ids_of_hyps g)) - in - let rec_pte_id = pf_get_new_id rec_pte_id g in - let to_refine = - applist - ( mkVar hyp_id - , List.rev_map mkVar (rec_pte_id :: context_hyps_ids) ) - in - (* observe_tac "rec hyp " *) - (tclTHENS - (Proofview.V82.of_tactic - (assert_before (Name rec_pte_id) t_x)) - [ (* observe_tac "prove rec hyp" *) - prove_rec_hyp eq_hyps - ; (* observe_tac "prove rec hyp" *) - refine to_refine ]) - g) ] + [ tclDO context_length intro + ; Proofview.Goal.enter (fun g -> + let hyps = Proofview.Goal.hyps g in + let context_hyps_ids = + fst + (list_chop ~msg:"rec hyp : context_hyps" context_length + (ids_of_named_context hyps)) + in + let rec_pte_id = pf_get_new_id rec_pte_id hyps in + let to_refine = + applist + ( mkVar hyp_id + , List.rev_map mkVar (rec_pte_id :: context_hyps_ids) ) + in + (* observe_tac "rec hyp " *) + tclTHENS + (assert_before (Name rec_pte_id) t_x) + [ (* observe_tac "prove rec hyp" *) + prove_rec_hyp eq_hyps + ; (* observe_tac "prove rec hyp" *) + refine to_refine ]) ] in tclTHENLIST [ (* observe_tac "hyp rec" *) @@ -408,19 +415,20 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = let prove_trivial = let nb_intro = List.length context in tclTHENLIST - [ tclDO nb_intro (Proofview.V82.of_tactic intro) - ; (fun g -> - let context_hyps = - fst - (list_chop ~msg:"removing True : context_hyps " nb_intro - (pf_ids_of_hyps g)) - in - let to_refine = - applist - ( mkVar hyp_id - , List.rev (coq_I :: List.map mkVar context_hyps) ) - in - refine to_refine g) ] + [ tclDO nb_intro intro + ; Proofview.Goal.enter (fun g -> + let hyps = Proofview.Goal.hyps g in + let context_hyps = + fst + (list_chop ~msg:"removing True : context_hyps " nb_intro + (ids_of_named_context hyps)) + in + let to_refine = + applist + ( mkVar hyp_id + , List.rev (coq_I :: List.map mkVar context_hyps) ) + in + refine to_refine) ] in tclTHENLIST [ change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp @@ -455,103 +463,103 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = try (scan_type [] (Typing.type_of_variable env hyp_id), [hyp_id]) with TOREMOVE -> (thin [hyp_id], []) -let clean_goal_with_heq ptes_infos continue_tac (dyn_infos : body_info) g = - let env = pf_env g and sigma = project g in - let tac, new_hyps = - List.fold_left - (fun (hyps_tac, new_hyps) hyp_id -> - let hyp_tac, new_hyp = - clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma - in - (tclTHEN hyp_tac hyps_tac, new_hyp @ new_hyps)) - (tclIDTAC, []) dyn_infos.rec_hyps - in - let new_infos = - {dyn_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps} - in - tclTHENLIST - [tac; (* observe_tac "clean_hyp_with_heq continue" *) continue_tac new_infos] - g +let clean_goal_with_heq ptes_infos continue_tac (dyn_infos : body_info) = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let env = Proofview.Goal.env g in + let sigma = Proofview.Goal.sigma g in + let tac, new_hyps = + List.fold_left + (fun (hyps_tac, new_hyps) hyp_id -> + let hyp_tac, new_hyp = + clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + in + (tclTHEN hyp_tac hyps_tac, new_hyp @ new_hyps)) + (tclIDTAC, []) dyn_infos.rec_hyps + in + let new_infos = + {dyn_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps} + in + tclTHENLIST + [ tac + ; (* observe_tac "clean_hyp_with_heq continue" *) + continue_tac new_infos ]) let heq_id = Id.of_string "Heq" -let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos g = - let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in - tclTHENLIST - [ (* We first introduce the variables *) - tclDO nb_first_intro - (Proofview.V82.of_tactic - (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))) - ; (* Then the equation itself *) - Proofview.V82.of_tactic - (intro_using_then heq_id - (* we get the fresh name with onLastHypId *) - (fun _ -> Proofview.tclUNIT ())) - ; onLastHypId (fun heq_id -> - tclTHENLIST - [ (* Then the new hypothesis *) - tclMAP - (fun id -> Proofview.V82.of_tactic (introduction id)) - dyn_infos.rec_hyps - ; observe_tac "after_introduction" (fun g' -> - (* We get infos on the equations introduced*) - let new_term_value_eq = pf_get_hyp_typ g' heq_id in - (* compute the new value of the body *) - let new_term_value = - match EConstr.kind (project g') new_term_value_eq with - | App (f, [|_; _; args2|]) -> args2 - | _ -> - observe - ( str "cannot compute new term value : " - ++ pr_gls g' ++ fnl () ++ str "last hyp is" - ++ pr_leconstr_env (pf_env g') (project g') - new_term_value_eq ); - anomaly (Pp.str "cannot compute new term value.") - in - let g', termtyp = tac_type_of g' term in - let fun_body = - mkLambda - ( make_annot Anonymous Sorts.Relevant - , termtyp - , Termops.replace_term (project g') term (mkRel 1) - dyn_infos.info ) - in - let new_body = - pf_nf_betaiota g' (mkApp (fun_body, [|new_term_value|])) - in - let new_infos = - { dyn_infos with - info = new_body - ; eq_hyps = heq_id :: dyn_infos.eq_hyps } - in - clean_goal_with_heq ptes_infos continue_tac new_infos g') ]) - ] - g - -let my_orelse tac1 tac2 g = - try tac1 g - with e when CErrors.noncritical e -> - (* observe (str "using snd tac since : " ++ CErrors.print e); *) - tac2 g +let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in + tclTHENLIST + [ (* We first introduce the variables *) + tclDO nb_first_intro + (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps)) + ; (* Then the equation itself *) + intro_using_then heq_id + (* we get the fresh name with onLastHypId *) + (fun _ -> Proofview.tclUNIT ()) + ; onLastHypId (fun heq_id -> + tclTHENLIST + [ (* Then the new hypothesis *) + tclMAP introduction dyn_infos.rec_hyps + ; observe_tac "after_introduction" + (Proofview.Goal.enter (fun g' -> + let env = Proofview.Goal.env g' in + let sigma = Proofview.Goal.sigma g' in + (* We get infos on the equations introduced*) + let new_term_value_eq = + Tacmach.New.pf_get_hyp_typ heq_id g' + in + (* compute the new value of the body *) + let new_term_value = + match EConstr.kind sigma new_term_value_eq with + | App (f, [|_; _; args2|]) -> args2 + | _ -> + observe + ( str "cannot compute new term value : " + ++ Tacmach.New.pr_gls g' ++ fnl () + ++ str "last hyp is" + ++ pr_leconstr_env env sigma new_term_value_eq ); + anomaly (Pp.str "cannot compute new term value.") + in + tclTYPEOFTHEN term (fun sigma termtyp -> + let fun_body = + mkLambda + ( make_annot Anonymous Sorts.Relevant + , termtyp + , Termops.replace_term sigma term (mkRel 1) + dyn_infos.info ) + in + let new_body = + Reductionops.nf_betaiota env sigma + (mkApp (fun_body, [|new_term_value|])) + in + let new_infos = + { dyn_infos with + info = new_body + ; eq_hyps = heq_id :: dyn_infos.eq_hyps } + in + clean_goal_with_heq ptes_infos continue_tac + new_infos))) ]) ]) -let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = +let instantiate_hyps_with_args (do_prove : Id.t list -> unit Proofview.tactic) + hyps args_id = let args = Array.of_list (List.map mkVar args_id) in + let open Tacticals.New in let instantiate_one_hyp hid = - my_orelse - (fun (* we instantiate the hyp if possible *) - g -> - let prov_hid = pf_get_new_id hid g in - let c = mkApp (mkVar hid, args) in - let evm, _ = pf_apply Typing.type_of g c in - let open Tacticals.New in - Proofview.V82.of_tactic - (tclTHENLIST - [ Proofview.Unsafe.tclEVARS evm - ; pose_proof (Name prov_hid) c - ; clear [hid] - ; rename_hyp [(prov_hid, hid)] ]) - g) - (fun (* + tclORELSE0 + (* we instantiate the hyp if possible *) + (Proofview.Goal.enter (fun g -> + let prov_hid = Tacmach.New.pf_get_new_id hid g in + let c = mkApp (mkVar hid, args) in + (* Check typing *) + tclTYPEOFTHEN c (fun _ _ -> + tclTHENLIST + [ pose_proof (Name prov_hid) c + ; thin [hid] + ; rename_hyp [(prov_hid, hid)] ]))) + (* if not then we are in a mutual function block and this hyp is a recursive hyp on an other function. @@ -559,9 +567,8 @@ let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = principle so that we can trash it *) - g -> - (* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) - thin [hid] g) + (* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) + (thin [hid]) in if List.is_empty args_id then tclTHENLIST @@ -571,172 +578,178 @@ let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = tclTHENLIST [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps ; tclMAP instantiate_one_hyp hyps - ; (fun g -> - let all_g_hyps_id = - List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty - in - let remaining_hyps = - List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps - in - do_prove remaining_hyps g) ] + ; Proofview.Goal.enter (fun g -> + let all_g_hyps_id = + List.fold_right Id.Set.add + (Tacmach.New.pf_ids_of_hyps g) + Id.Set.empty + in + let remaining_hyps = + List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps + in + do_prove remaining_hyps) ] let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos - dyn_infos : tactic = - let rec build_proof_aux do_finalize dyn_infos : tactic = - fun g -> - let env = pf_env g in - let sigma = project g in - (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match EConstr.kind sigma dyn_infos.info with - | Case (ci, ct, iv, t, cb) -> - let do_finalize_t dyn_info' g = - let t = dyn_info'.info in - let dyn_infos = {dyn_info' with info = mkCase (ci, ct, iv, t, cb)} in - let g_nb_prod = nb_prod (project g) (pf_concl g) in - let g, type_of_term = tac_type_of g t in - let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in - tclTHENLIST - [ Proofview.V82.of_tactic - (generalize (term_eq :: List.map mkVar dyn_infos.rec_hyps)) - ; thin dyn_infos.rec_hyps - ; Proofview.V82.of_tactic - (pattern_option [(Locus.AllOccurrencesBut [1], t)] None) - ; (fun g -> - observe_tac "toto" - (tclTHENLIST - [ Proofview.V82.of_tactic (Simple.case t) - ; (fun g' -> - let g'_nb_prod = nb_prod (project g') (pf_concl g') in - let nb_instantiate_partial = g'_nb_prod - g_nb_prod in - observe_tac "treat_new_case" - (treat_new_case ptes_infos nb_instantiate_partial - (build_proof do_finalize) t dyn_infos) - g') ]) - g) ] - g - in - build_proof do_finalize_t {dyn_infos with info = t} g - | Lambda (n, t, b) -> ( - match EConstr.kind sigma (pf_concl g) with - | Prod _ -> - tclTHEN - (Proofview.V82.of_tactic intro) - (fun g' -> - let open Context.Named.Declaration in - let id = pf_last_hyp g' |> get_id in - let new_term = - pf_nf_betaiota g' (mkApp (dyn_infos.info, [|mkVar id|])) + dyn_infos : unit Proofview.tactic = + let open Tacticals.New in + let rec build_proof_aux do_finalize dyn_infos : unit Proofview.tactic = + Proofview.Goal.enter (fun g -> + let env = Proofview.Goal.env g in + let sigma = Proofview.Goal.sigma g in + (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) + match EConstr.kind sigma dyn_infos.info with + | Case (ci, ct, iv, t, cb) -> + let do_finalize_t dyn_info' = + Proofview.Goal.enter (fun g -> + let t = dyn_info'.info in + let dyn_infos = + {dyn_info' with info = mkCase (ci, ct, iv, t, cb)} + in + let g_nb_prod = + nb_prod (Proofview.Goal.sigma g) (Proofview.Goal.concl g) + in + tclTYPEOFTHEN t (fun _ type_of_term -> + let term_eq = + make_refl_eq (Lazy.force refl_equal) type_of_term t + in + tclTHENLIST + [ generalize (term_eq :: List.map mkVar dyn_infos.rec_hyps) + ; thin dyn_infos.rec_hyps + ; pattern_option [(Locus.AllOccurrencesBut [1], t)] None + ; observe_tac "toto" + (tclTHENLIST + [ Simple.case t + ; Proofview.Goal.enter (fun g' -> + let g'_nb_prod = + nb_prod (Proofview.Goal.sigma g') + (Proofview.Goal.concl g') + in + let nb_instantiate_partial = + g'_nb_prod - g_nb_prod + in + observe_tac "treat_new_case" + (treat_new_case ptes_infos + nb_instantiate_partial + (build_proof do_finalize) t dyn_infos)) + ]) ])) + in + build_proof do_finalize_t {dyn_infos with info = t} + | Lambda (n, t, b) -> ( + match EConstr.kind sigma (Proofview.Goal.concl g) with + | Prod _ -> + tclTHEN intro + (Proofview.Goal.enter (fun g' -> + let open Context.Named.Declaration in + let id = Tacmach.New.pf_last_hyp g' |> get_id in + let new_term = + Reductionops.nf_betaiota (Proofview.Goal.env g') + (Proofview.Goal.sigma g') + (mkApp (dyn_infos.info, [|mkVar id|])) + in + let new_infos = {dyn_infos with info = new_term} in + let do_prove new_hyps = + build_proof do_finalize + { new_infos with + rec_hyps = new_hyps + ; nb_rec_hyps = List.length new_hyps } + in + (* observe_tac "Lambda" *) + instantiate_hyps_with_args do_prove new_infos.rec_hyps [id] + (* build_proof do_finalize new_infos g' *))) + | _ -> do_finalize dyn_infos ) + | Cast (t, _, _) -> build_proof do_finalize {dyn_infos with info = t} + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ + |Int _ | Float _ -> + do_finalize dyn_infos + | App (_, _) -> ( + let f, args = decompose_app sigma dyn_infos.info in + match EConstr.kind sigma f with + | Int _ -> user_err Pp.(str "integer cannot be applied") + | Float _ -> user_err Pp.(str "float cannot be applied") + | Array _ -> user_err Pp.(str "array cannot be applied") + | App _ -> + assert false (* we have collected all the app in decompose_app *) + | Proj _ -> assert false (*FIXME*) + | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ + |Prod _ -> + let new_infos = {dyn_infos with info = (f, args)} in + build_proof_args env sigma do_finalize new_infos + | Const (c, _) when not (List.mem_f Constant.equal c fnames) -> + let new_infos = {dyn_infos with info = (f, args)} in + (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) + build_proof_args env sigma do_finalize new_infos + | Const _ -> do_finalize dyn_infos + | Lambda _ -> + let new_term = Reductionops.nf_beta env sigma dyn_infos.info in + build_proof do_finalize {dyn_infos with info = new_term} + | LetIn _ -> + let new_infos = + { dyn_infos with + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } in - let new_infos = {dyn_infos with info = new_term} in - let do_prove new_hyps = - build_proof do_finalize - { new_infos with - rec_hyps = new_hyps - ; nb_rec_hyps = List.length new_hyps } + tclTHENLIST + [ tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps + ; h_reduce_with_zeta Locusops.onConcl + ; build_proof do_finalize new_infos ] + | Cast (b, _, _) -> build_proof do_finalize {dyn_infos with info = b} + | Case _ | Fix _ | CoFix _ -> + let new_finalize dyn_infos = + let new_infos = {dyn_infos with info = (dyn_infos.info, args)} in + build_proof_args env sigma do_finalize new_infos in - (* observe_tac "Lambda" *) - (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' - (* build_proof do_finalize new_infos g' *)) - g - | _ -> do_finalize dyn_infos g ) - | Cast (t, _, _) -> build_proof do_finalize {dyn_infos with info = t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ - |Float _ -> - do_finalize dyn_infos g - | App (_, _) -> ( - let f, args = decompose_app sigma dyn_infos.info in - match EConstr.kind sigma f with - | Int _ -> user_err Pp.(str "integer cannot be applied") - | Float _ -> user_err Pp.(str "float cannot be applied") - | Array _ -> user_err Pp.(str "array cannot be applied") - | App _ -> - assert false (* we have collected all the app in decompose_app *) - | Proj _ -> assert false (*FIXME*) - | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ - -> - let new_infos = {dyn_infos with info = (f, args)} in - build_proof_args env sigma do_finalize new_infos g - | Const (c, _) when not (List.mem_f Constant.equal c fnames) -> - let new_infos = {dyn_infos with info = (f, args)} in - (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) - build_proof_args env sigma do_finalize new_infos g - | Const _ -> do_finalize dyn_infos g - | Lambda _ -> - let new_term = Reductionops.nf_beta env sigma dyn_infos.info in - build_proof do_finalize {dyn_infos with info = new_term} g - | LetIn _ -> - let new_infos = - { dyn_infos with - info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } - in - tclTHENLIST - [ tclMAP - (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps - ; h_reduce_with_zeta Locusops.onConcl - ; build_proof do_finalize new_infos ] - g - | Cast (b, _, _) -> build_proof do_finalize {dyn_infos with info = b} g - | Case _ | Fix _ | CoFix _ -> - let new_finalize dyn_infos = - let new_infos = {dyn_infos with info = (dyn_infos.info, args)} in - build_proof_args env sigma do_finalize new_infos - in - build_proof new_finalize {dyn_infos with info = f} g ) - | Fix _ | CoFix _ -> - user_err Pp.(str "Anonymous local (co)fixpoints are not handled yet") - | Proj _ -> user_err Pp.(str "Prod") - | Prod _ -> do_finalize dyn_infos g - | LetIn _ -> - let new_infos = - { dyn_infos with - info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } - in - tclTHENLIST - [ tclMAP - (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps - ; h_reduce_with_zeta Locusops.onConcl - ; build_proof do_finalize new_infos ] - g - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - | Array _ -> CErrors.user_err Pp.(str "Arrays not handled yet") - and build_proof do_finalize dyn_infos g = + build_proof new_finalize {dyn_infos with info = f} ) + | Fix _ | CoFix _ -> + user_err Pp.(str "Anonymous local (co)fixpoints are not handled yet") + | Proj _ -> user_err Pp.(str "Prod") + | Prod _ -> do_finalize dyn_infos + | LetIn _ -> + let new_infos = + { dyn_infos with + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } + in + tclTHENLIST + [ tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps + ; h_reduce_with_zeta Locusops.onConcl + ; build_proof do_finalize new_infos ] + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + | Array _ -> CErrors.user_err Pp.(str "Arrays not handled yet")) + and build_proof do_finalize dyn_infos = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - Indfun_common.observe_tac + Indfun_common.New.observe_tac ~header:(str "observation") (fun env sigma -> str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info) (build_proof_aux do_finalize dyn_infos) - g - and build_proof_args env sigma do_finalize dyn_infos : tactic = - (* f_args' args *) - fun g -> - let f_args', args = dyn_infos.info in - let tac : tactic = - fun g -> - match args with - | [] -> do_finalize {dyn_infos with info = f_args'} g - | arg :: args -> - (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) - (* fnl () ++ *) - (* pr_goal (Tacmach.sig_it g) *) - (* ); *) - let do_finalize dyn_infos = - let new_arg = dyn_infos.info in - (* tclTRYD *) - build_proof_args env sigma do_finalize - {dyn_infos with info = (mkApp (f_args', [|new_arg|]), args)} + and build_proof_args env sigma do_finalize dyn_infos : unit Proofview.tactic = + (* f_args' args *) + Proofview.Goal.enter (fun g -> + let f_args', args = dyn_infos.info in + let tac = + match args with + | [] -> do_finalize {dyn_infos with info = f_args'} + | arg :: args -> + (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) + (* fnl () ++ *) + (* pr_goal (Tacmach.sig_it g) *) + (* ); *) + let do_finalize dyn_infos = + let new_arg = dyn_infos.info in + (* tclTRYD *) + build_proof_args env sigma do_finalize + {dyn_infos with info = (mkApp (f_args', [|new_arg|]), args)} + in + build_proof do_finalize {dyn_infos with info = arg} in - build_proof do_finalize {dyn_infos with info = arg} g - in - (* observe_tac "build_proof_args" *) tac g + (* observe_tac "build_proof_args" *) tac) in let do_finish_proof dyn_infos = (* tclTRYD *) clean_goal_with_heq ptes_infos finish_proof dyn_infos in (* observe_tac "build_proof" *) - fun g -> - build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos g + build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos (* Proof of principles from structural functions *) @@ -750,52 +763,59 @@ type static_fix_info = ; num_in_block : int } let prove_rec_hyp_for_struct fix_info eq_hyps = - tclTHEN (rewrite_until_var fix_info.idx eq_hyps) (fun g -> - let _, pte_args = destApp (project g) (pf_concl g) in - let rec_hyp_proof = - mkApp (mkVar fix_info.name, array_get_start pte_args) - in - refine rec_hyp_proof g) + let open Tacticals.New in + tclTHEN + (rewrite_until_var fix_info.idx eq_hyps) + (Proofview.Goal.enter (fun g -> + let _, pte_args = + destApp (Proofview.Goal.sigma g) (Proofview.Goal.concl g) + in + let rec_hyp_proof = + mkApp (mkVar fix_info.name, array_get_start pte_args) + in + refine rec_hyp_proof)) let prove_rec_hyp fix_info = {proving_tac = prove_rec_hyp_for_struct fix_info; is_valid = (fun _ -> true)} -let generalize_non_dep hyp g = - (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) - let hyps = [hyp] in - let env = Global.env () in - let hyp_typ = pf_get_hyp_typ g hyp in - let to_revert, _ = - let open Context.Named.Declaration in - Environ.fold_named_context_reverse - (fun (clear, keep) decl -> - let decl = map_named_decl EConstr.of_constr decl in - let hyp = get_id decl in - if - Id.List.mem hyp hyps - || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep - || Termops.occur_var env (project g) hyp hyp_typ - || Termops.is_section_variable hyp - (* should be dangerous *) - then (clear, decl :: keep) - else (hyp :: clear, keep)) - ~init:([], []) (pf_env g) - in - (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) - tclTHEN - ((* observe_tac "h_generalize" *) Proofview.V82.of_tactic - (generalize (List.map mkVar to_revert))) - ((* observe_tac "thin" *) thin to_revert) - g +let generalize_non_dep hyp = + Proofview.Goal.enter (fun g -> + (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) + let hyps = [hyp] in + let env = Global.env () in + let sigma = Proofview.Goal.sigma g in + let hyp_typ = Tacmach.New.pf_get_hyp_typ hyp g in + let to_revert, _ = + let open Context.Named.Declaration in + Environ.fold_named_context_reverse + (fun (clear, keep) decl -> + let decl = map_named_decl EConstr.of_constr decl in + let hyp = get_id decl in + if + Id.List.mem hyp hyps + || List.exists (Termops.occur_var_in_decl env sigma hyp) keep + || Termops.occur_var env sigma hyp hyp_typ + || Termops.is_section_variable hyp + (* should be dangerous *) + then (clear, decl :: keep) + else (hyp :: clear, keep)) + ~init:([], []) (Proofview.Goal.env g) + in + (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) + Tacticals.New.tclTHEN + ((* observe_tac "h_generalize" *) + generalize (List.map mkVar to_revert)) + ((* observe_tac "thin" *) clear to_revert)) let id_of_decl = RelDecl.get_name %> Nameops.Name.get_id let var_of_decl = id_of_decl %> mkVar let revert idl = - tclTHEN (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) (thin idl) + Tacticals.New.tclTHEN (generalize (List.map mkVar idl)) (clear idl) let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num = + let open Tacticals.New in (* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) (* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) @@ -843,16 +863,14 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let f_id = Label.to_id (Constant.label (fst (destConst evd f))) in let prove_replacement = tclTHENLIST - [ tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro) - ; observe_tac "" (fun g -> - let rec_id = pf_nth_hyp_id g 1 in - tclTHENLIST - [ observe_tac "generalize_non_dep in generate_equation_lemma" - (generalize_non_dep rec_id) - ; observe_tac "h_case" - (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))) - ; Proofview.V82.of_tactic intros_reflexivity ] - g) ] + [ tclDO (nb_params + rec_args_num + 1) intro + ; observe_tac "" + (onNthHypId 1 (fun rec_id -> + tclTHENLIST + [ observe_tac "generalize_non_dep in generate_equation_lemma" + (generalize_non_dep rec_id) + ; observe_tac "h_case" (simplest_case (mkVar rec_id)) + ; intros_reflexivity ])) ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) @@ -863,9 +881,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num Declare.CInfo.make ~name:(mk_equation_id f_id) ~typ:lemma_type () in let lemma = Declare.Proof.start ~cinfo ~info evd in - let lemma, _ = - Declare.Proof.by (Proofview.V82.tactic prove_replacement) lemma - in + let lemma, _ = Declare.Proof.by prove_replacement lemma in let (_ : _ list) = Declare.Proof.save_regular ~proof:lemma ~opaque:Vernacexpr.Transparent ~idopt:None @@ -873,377 +889,398 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num evd let do_replace (evd : Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num - all_funs g = - let equation_lemma = - try - let finfos = - match find_Function_infos (fst (destConst !evd f)) (*FIXME*) with - | None -> raise Not_found - | Some finfos -> finfos - in - mkConst (Option.get finfos.equation_lemma) - with (Not_found | Option.IsNone) as e -> - let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in - (*i The next call to mk_equation_id is valid since we will construct the lemma - Ensures by: obvious - i*) - let equation_lemma_id = mk_equation_id f_id in - evd := - generate_equation_lemma !evd all_funs f fun_num (List.length params) - (List.length rev_args_id) rec_arg_num; - let _ = - match e with - | Option.IsNone -> + all_funs = + Proofview.Goal.enter (fun g -> + let equation_lemma = + try let finfos = - match find_Function_infos (fst (destConst !evd f)) with + match find_Function_infos (fst (destConst !evd f)) (*FIXME*) with | None -> raise Not_found | Some finfos -> finfos in - update_Function - { finfos with - equation_lemma = - Some - ( match Nametab.locate (qualid_of_ident equation_lemma_id) with - | GlobRef.ConstRef c -> c - | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) } - | _ -> () + mkConst (Option.get finfos.equation_lemma) + with (Not_found | Option.IsNone) as e -> + let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in + (*i The next call to mk_equation_id is valid since we will construct the lemma + Ensures by: obvious + i*) + let equation_lemma_id = mk_equation_id f_id in + evd := + generate_equation_lemma !evd all_funs f fun_num (List.length params) + (List.length rev_args_id) rec_arg_num; + let _ = + match e with + | Option.IsNone -> + let finfos = + match find_Function_infos (fst (destConst !evd f)) with + | None -> raise Not_found + | Some finfos -> finfos + in + update_Function + { finfos with + equation_lemma = + Some + ( match + Nametab.locate (qualid_of_ident equation_lemma_id) + with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) } + | _ -> () + in + (* let res = Constrintern.construct_reference (pf_hyps g) equation_lemma_id in *) + let evd', res = + Evd.fresh_global (Global.env ()) !evd + (Constrintern.locate_reference + (qualid_of_ident equation_lemma_id)) + in + evd := evd'; + let sigma, _ = + Typing.type_of ~refresh:true (Global.env ()) !evd res + in + evd := sigma; + res in - (* let res = Constrintern.construct_reference (pf_hyps g) equation_lemma_id in *) - let evd', res = - Evd.fresh_global (Global.env ()) !evd - (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) + let nb_intro_to_do = + nb_prod (Proofview.Goal.sigma g) (Proofview.Goal.concl g) in - evd := evd'; - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd res in - evd := sigma; - res - in - let nb_intro_to_do = nb_prod (project g) (pf_concl g) in - tclTHEN - (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) - (fun g' -> - let just_introduced = nLastDecls nb_intro_to_do g' in - let open Context.Named.Declaration in - let just_introduced_id = List.map get_id just_introduced in + let open Tacticals.New in tclTHEN - (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) - (revert just_introduced_id) - g') - g + (tclDO nb_intro_to_do intro) + (Proofview.Goal.enter (fun g' -> + let just_introduced = Tacticals.New.nLastDecls g' nb_intro_to_do in + let open Context.Named.Declaration in + let just_introduced_id = List.map get_id just_introduced in + tclTHEN + (* Hack to synchronize the goal with the global env *) + (Proofview.V82.tactic + (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma))) + (revert just_introduced_id)))) let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num - fnames all_funs _nparams : tactic = - fun g -> - let princ_type = pf_concl g in - (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) - (* Pp.msgnl (str "all_funs "); *) - (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) - let princ_info = compute_elim_sig (project g) princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps g) in - fun na -> - let new_id = - match na with - | Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" + fnames all_funs _nparams : unit Proofview.tactic = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let princ_type = Proofview.Goal.concl g in + let env = Proofview.Goal.env g in + let sigma = Proofview.Goal.sigma g in + (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) + (* Pp.msgnl (str "all_funs "); *) + (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) + let princ_info = compute_elim_sig sigma princ_type in + let fresh_id = + let avoid = ref (Tacmach.New.pf_ids_of_hyps g) in + fun na -> + let new_id = + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + Name new_id in - avoid := new_id :: !avoid; - Name new_id - in - let fresh_decl = RelDecl.map_name fresh_id in - let princ_info : elim_scheme = - { princ_info with - params = List.map fresh_decl princ_info.params - ; predicates = List.map fresh_decl princ_info.predicates - ; branches = List.map fresh_decl princ_info.branches - ; args = List.map fresh_decl princ_info.args } - in - let get_body const = - match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _, _) -> - let env = Global.env () in - let sigma = Evd.from_env env in - Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - env sigma (EConstr.of_constr body) - | None -> user_err Pp.(str "Cannot define a principle over an axiom ") - in - let fbody = get_body fnames.(fun_num) in - let f_ctxt, f_body = decompose_lam (project g) fbody in - let f_ctxt_length = List.length f_ctxt in - let diff_params = princ_info.nparams - f_ctxt_length in - let full_params, princ_params, fbody_with_full_params = - if diff_params > 0 then - let princ_params, full_params = list_chop diff_params princ_info.params in - ( full_params - , (* real params *) - princ_params - , (* the params of the principle which are not params of the function *) - substl (* function instantiated with real params *) - (List.map var_of_decl full_params) - f_body ) - else - let f_ctxt_other, f_ctxt_params = list_chop (-diff_params) f_ctxt in - let f_body = compose_lam f_ctxt_other f_body in - ( princ_info.params - , (* real params *) - [] - , (* all params are full params *) - substl (* function instantiated with real params *) - (List.map var_of_decl princ_info.params) - f_body ) - in - observe - ( str "full_params := " - ++ prlist_with_sep spc - (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - full_params ); - observe - ( str "princ_params := " - ++ prlist_with_sep spc - (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - princ_params ); - observe - ( str "fbody_with_full_params := " - ++ pr_leconstr_env (Global.env ()) !evd fbody_with_full_params ); - let all_funs_with_full_params = - Array.map - (fun f -> applist (f, List.rev_map var_of_decl full_params)) - all_funs - in - let fix_offset = List.length princ_params in - let ptes_to_fix, infos = - match EConstr.kind (project g) fbody_with_full_params with - | Fix ((idxs, i), (names, typess, bodies)) -> - let bodies_with_all_params = - Array.map - (fun body -> - Reductionops.nf_betaiota (pf_env g) (project g) - (applist - ( substl - (List.rev (Array.to_list all_funs_with_full_params)) - body - , List.rev_map var_of_decl princ_params ))) - bodies + let fresh_decl = RelDecl.map_name fresh_id in + let princ_info : elim_scheme = + { princ_info with + params = List.map fresh_decl princ_info.params + ; predicates = List.map fresh_decl princ_info.predicates + ; branches = List.map fresh_decl princ_info.branches + ; args = List.map fresh_decl princ_info.args } in - let info_array = - Array.mapi - (fun i types -> - let types = - prod_applist (project g) types - (List.rev_map var_of_decl princ_params) - in - { idx = idxs.(i) - fix_offset - ; name = Nameops.Name.get_id (fresh_id names.(i).binder_name) - ; types - ; offset = fix_offset - ; nb_realargs = - List.length (fst (decompose_lam (project g) bodies.(i))) - - fix_offset - ; body_with_param = bodies_with_all_params.(i) - ; num_in_block = i }) - typess + let get_body const = + match Global.body_of_constant Library.indirect_accessor const with + | Some (body, _, _) -> + let env = Global.env () in + let sigma = Evd.from_env env in + Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + env sigma (EConstr.of_constr body) + | None -> user_err Pp.(str "Cannot define a principle over an axiom ") in - let pte_to_fix, rev_info = - List.fold_left_i - (fun i (acc_map, acc_info) decl -> - let pte = RelDecl.get_name decl in - let infos = info_array.(i) in - let type_args, _ = decompose_prod (project g) infos.types in - let nargs = List.length type_args in - let f = - applist - (mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) - in - let first_args = Array.init nargs (fun i -> mkRel (nargs - i)) in - let app_f = mkApp (f, first_args) in - let pte_args = Array.to_list first_args @ [app_f] in - let app_pte = applist (mkVar (Nameops.Name.get_id pte), pte_args) in - let body_with_param, num = - let body = get_body fnames.(i) in - let body_with_full_params = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist (body, List.rev_map var_of_decl full_params)) - in - match EConstr.kind (project g) body_with_full_params with - | Fix ((_, num), (_, _, bs)) -> - ( Reductionops.nf_betaiota (pf_env g) (project g) - (applist - ( substl - (List.rev (Array.to_list all_funs_with_full_params)) - bs.(num) - , List.rev_map var_of_decl princ_params )) - , num ) - | _ -> user_err Pp.(str "Not a mutual block") - in - let info = - { infos with - types = compose_prod type_args app_pte - ; body_with_param - ; num_in_block = num } - in - (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) - (* str " to " ++ Ppconstr.pr_id info.name); *) - (Id.Map.add (Nameops.Name.get_id pte) info acc_map, info :: acc_info)) - 0 (Id.Map.empty, []) - (List.rev princ_info.predicates) + let fbody = get_body fnames.(fun_num) in + let f_ctxt, f_body = decompose_lam sigma fbody in + let f_ctxt_length = List.length f_ctxt in + let diff_params = princ_info.nparams - f_ctxt_length in + let full_params, princ_params, fbody_with_full_params = + if diff_params > 0 then + let princ_params, full_params = + list_chop diff_params princ_info.params + in + ( full_params + , (* real params *) + princ_params + , (* the params of the principle which are not params of the function *) + substl (* function instantiated with real params *) + (List.map var_of_decl full_params) + f_body ) + else + let f_ctxt_other, f_ctxt_params = list_chop (-diff_params) f_ctxt in + let f_body = compose_lam f_ctxt_other f_body in + ( princ_info.params + , (* real params *) + [] + , (* all params are full params *) + substl (* function instantiated with real params *) + (List.map var_of_decl princ_info.params) + f_body ) in - (pte_to_fix, List.rev rev_info) - | _ -> (Id.Map.empty, []) - in - let mk_fixes : tactic = - let pre_info, infos = list_chop fun_num infos in - match (pre_info, infos) with - | _, [] -> tclIDTAC - | _, this_fix_info :: others_infos -> - let other_fix_infos = - List.map - (fun fi -> (fi.name, fi.idx + 1, fi.types)) - (pre_info @ others_infos) + observe + ( str "full_params := " + ++ prlist_with_sep spc + (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + full_params ); + observe + ( str "princ_params := " + ++ prlist_with_sep spc + (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + princ_params ); + observe + ( str "fbody_with_full_params := " + ++ pr_leconstr_env (Global.env ()) !evd fbody_with_full_params ); + let all_funs_with_full_params = + Array.map + (fun f -> applist (f, List.rev_map var_of_decl full_params)) + all_funs in - if List.is_empty other_fix_infos then - if this_fix_info.idx + 1 = 0 then tclIDTAC - (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) - else - Indfun_common.observe_tac - (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx + 1)) - (Proofview.V82.of_tactic - (fix this_fix_info.name (this_fix_info.idx + 1))) - else - Proofview.V82.of_tactic - (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) - other_fix_infos 0) - in - let first_tac : tactic = - (* every operations until fix creations *) - (* names are already refreshed *) - tclTHENLIST - [ observe_tac "introducing params" - (Proofview.V82.of_tactic - (intros_mustbe_force (List.rev_map id_of_decl princ_info.params))) - ; observe_tac "introducing predictes" - (Proofview.V82.of_tactic - (intros_mustbe_force - (List.rev_map id_of_decl princ_info.predicates))) - ; observe_tac "introducing branches" - (Proofview.V82.of_tactic - (intros_mustbe_force (List.rev_map id_of_decl princ_info.branches))) - ; observe_tac "building fixes" mk_fixes ] - in - let intros_after_fixes : tactic = - fun gl -> - let ctxt, pte_app = decompose_prod_assum (project gl) (pf_concl gl) in - let pte, pte_args = decompose_app (project gl) pte_app in - try - let pte = - try destVar (project gl) pte - with DestKO -> anomaly (Pp.str "Property is not a variable.") + let fix_offset = List.length princ_params in + let ptes_to_fix, infos = + match EConstr.kind sigma fbody_with_full_params with + | Fix ((idxs, i), (names, typess, bodies)) -> + let bodies_with_all_params = + Array.map + (fun body -> + Reductionops.nf_betaiota env sigma + (applist + ( substl + (List.rev (Array.to_list all_funs_with_full_params)) + body + , List.rev_map var_of_decl princ_params ))) + bodies + in + let info_array = + Array.mapi + (fun i types -> + let types = + prod_applist sigma types + (List.rev_map var_of_decl princ_params) + in + { idx = idxs.(i) - fix_offset + ; name = Nameops.Name.get_id (fresh_id names.(i).binder_name) + ; types + ; offset = fix_offset + ; nb_realargs = + List.length (fst (decompose_lam sigma bodies.(i))) + - fix_offset + ; body_with_param = bodies_with_all_params.(i) + ; num_in_block = i }) + typess + in + let pte_to_fix, rev_info = + List.fold_left_i + (fun i (acc_map, acc_info) decl -> + let pte = RelDecl.get_name decl in + let infos = info_array.(i) in + let type_args, _ = decompose_prod sigma infos.types in + let nargs = List.length type_args in + let f = + applist + ( mkConst fnames.(i) + , List.rev_map var_of_decl princ_info.params ) + in + let first_args = + Array.init nargs (fun i -> mkRel (nargs - i)) + in + let app_f = mkApp (f, first_args) in + let pte_args = Array.to_list first_args @ [app_f] in + let app_pte = + applist (mkVar (Nameops.Name.get_id pte), pte_args) + in + let body_with_param, num = + let body = get_body fnames.(i) in + let body_with_full_params = + Reductionops.nf_betaiota env sigma + (applist (body, List.rev_map var_of_decl full_params)) + in + match EConstr.kind sigma body_with_full_params with + | Fix ((_, num), (_, _, bs)) -> + ( Reductionops.nf_betaiota env sigma + (applist + ( substl + (List.rev + (Array.to_list all_funs_with_full_params)) + bs.(num) + , List.rev_map var_of_decl princ_params )) + , num ) + | _ -> user_err Pp.(str "Not a mutual block") + in + let info = + { infos with + types = compose_prod type_args app_pte + ; body_with_param + ; num_in_block = num } + in + (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) + (* str " to " ++ Ppconstr.pr_id info.name); *) + ( Id.Map.add (Nameops.Name.get_id pte) info acc_map + , info :: acc_info )) + 0 (Id.Map.empty, []) + (List.rev princ_info.predicates) + in + (pte_to_fix, List.rev rev_info) + | _ -> (Id.Map.empty, []) in - let fix_info = Id.Map.find pte ptes_to_fix in - let nb_args = fix_info.nb_realargs in - tclTHENLIST - [ (* observe_tac ("introducing args") *) - tclDO nb_args (Proofview.V82.of_tactic intro) - ; (fun g -> - (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let fix_body = fix_info.body_with_param in - (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) - let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { nb_rec_hyps = -100 - ; rec_hyps = [] - ; info = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist (fix_body, List.rev_map mkVar args_id)) - ; eq_hyps = [] } - in - tclTHENLIST - [ observe_tac "do_replace" - (do_replace evd full_params - (fix_info.idx + List.length princ_params) - ( args_id - @ List.map - (RelDecl.get_name %> Nameops.Name.get_id) - princ_params ) - all_funs.(fix_info.num_in_block) - fix_info.num_in_block all_funs) - ; (let do_prove = - build_proof interactive_proof (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - { dyn_infos with - rec_hyps = branches - ; nb_rec_hyps = List.length branches } - in - observe_tac "cleaning" - (clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove dyn_infos) - in - (* observe (str "branches := " ++ *) - (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) - (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) + let mk_fixes : unit Proofview.tactic = + let pre_info, infos = list_chop fun_num infos in + match (pre_info, infos) with + | _, [] -> Proofview.tclUNIT () + | _, this_fix_info :: others_infos -> + let other_fix_infos = + List.map + (fun fi -> (fi.name, fi.idx + 1, fi.types)) + (pre_info @ others_infos) + in + if List.is_empty other_fix_infos then + if this_fix_info.idx + 1 = 0 then Proofview.tclUNIT () + (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) + else + Indfun_common.New.observe_tac ~header:(str "observation") + (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx + 1)) + (fix this_fix_info.name (this_fix_info.idx + 1)) + else + Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) + other_fix_infos 0 + in + let first_tac : unit Proofview.tactic = + (* every operations until fix creations *) + (* names are already refreshed *) + tclTHENLIST + [ observe_tac "introducing params" + (intros_mustbe_force (List.rev_map id_of_decl princ_info.params)) + ; observe_tac "introducing predicates" + (intros_mustbe_force + (List.rev_map id_of_decl princ_info.predicates)) + ; observe_tac "introducing branches" + (intros_mustbe_force + (List.rev_map id_of_decl princ_info.branches)) + ; observe_tac "building fixes" mk_fixes ] + in + let intros_after_fixes : unit Proofview.tactic = + Proofview.Goal.enter (fun gl -> + let sigma = Proofview.Goal.sigma gl in + let ccl = Proofview.Goal.concl gl in + let ctxt, pte_app = decompose_prod_assum sigma ccl in + let pte, pte_args = decompose_app sigma pte_app in + try + let pte = + try destVar sigma pte + with DestKO -> anomaly (Pp.str "Property is not a variable.") + in + let fix_info = Id.Map.find pte ptes_to_fix in + let nb_args = fix_info.nb_realargs in + tclTHENLIST + [ (* observe_tac ("introducing args") *) + tclDO nb_args intro + ; Proofview.Goal.enter (fun g -> + (* replacement of the function by its body *) + let args = Tacticals.New.nLastDecls g nb_args in + let fix_body = fix_info.body_with_param in + (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) + let open Context.Named.Declaration in + let args_id = List.map get_id args in + let dyn_infos = + { nb_rec_hyps = -100 + ; rec_hyps = [] + ; info = + Reductionops.nf_betaiota (Proofview.Goal.env g) + (Proofview.Goal.sigma g) + (applist (fix_body, List.rev_map mkVar args_id)) + ; eq_hyps = [] } + in + tclTHENLIST + [ observe_tac "do_replace" + (do_replace evd full_params + (fix_info.idx + List.length princ_params) + ( args_id + @ List.map + (RelDecl.get_name %> Nameops.Name.get_id) + princ_params ) + all_funs.(fix_info.num_in_block) + fix_info.num_in_block all_funs) + ; (let do_prove = + build_proof interactive_proof + (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + { dyn_infos with + rec_hyps = branches + ; nb_rec_hyps = List.length branches } + in + observe_tac "cleaning" + (clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos) + in + (* observe (str "branches := " ++ *) + (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) + (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) - (* ); *) - (* observe_tac "instancing" *) - instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id)) ] - g) ] - gl - with Not_found -> - let nb_args = min princ_info.nargs (List.length ctxt) in - tclTHENLIST - [ tclDO nb_args (Proofview.V82.of_tactic intro) - ; (fun g -> - (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { nb_rec_hyps = -100 - ; rec_hyps = [] - ; info = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist - ( fbody_with_full_params - , List.rev_map var_of_decl princ_params - @ List.rev_map mkVar args_id )) - ; eq_hyps = [] } - in - let fname = - destConst (project g) - (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) - in - tclTHENLIST - [ Proofview.V82.of_tactic - (unfold_in_concl - [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]) - ; (let do_prove = - build_proof interactive_proof (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - { dyn_infos with - rec_hyps = branches - ; nb_rec_hyps = List.length branches } - in - clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove dyn_infos - in - instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id)) ] - g) ] - gl - in - tclTHEN first_tac intros_after_fixes g + (* ); *) + (* observe_tac "instancing" *) + instantiate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) ]) ] + with Not_found -> + let nb_args = min princ_info.nargs (List.length ctxt) in + tclTHENLIST + [ tclDO nb_args intro + ; Proofview.Goal.enter (fun g -> + let env = Proofview.Goal.env g in + let sigma = Proofview.Goal.sigma g in + (* replacement of the function by its body *) + let args = Tacticals.New.nLastDecls g nb_args in + let open Context.Named.Declaration in + let args_id = List.map get_id args in + let dyn_infos = + { nb_rec_hyps = -100 + ; rec_hyps = [] + ; info = + Reductionops.nf_betaiota env sigma + (applist + ( fbody_with_full_params + , List.rev_map var_of_decl princ_params + @ List.rev_map mkVar args_id )) + ; eq_hyps = [] } + in + let fname = + destConst sigma + (fst + (decompose_app sigma (List.hd (List.rev pte_args)))) + in + tclTHENLIST + [ unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalConstRef (fst fname) ) ] + ; (let do_prove = + build_proof interactive_proof + (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + { dyn_infos with + rec_hyps = branches + ; nb_rec_hyps = List.length branches } + in + clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos + in + instantiate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) ]) ]) + in + tclTHEN first_tac intros_after_fixes) (* Proof of principles of general functions *) (* let hrec_id = Recdef.hrec_id *) @@ -1254,97 +1291,95 @@ let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num (* and list_rewrite = Recdef.list_rewrite *) (* and evaluable_of_global_reference = Recdef.evaluable_of_global_reference *) -let prove_with_tcc tcc_lemma_constr eqs : tactic = +let prove_with_tcc tcc_lemma_constr eqs : unit Proofview.tactic = + let open Tacticals.New in match !tcc_lemma_constr with | Undefined -> anomaly (Pp.str "No tcc proof !!") | Value lemma -> - fun gls -> - (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) - (* let ids = hid::pf_ids_of_hyps gls in *) - tclTHENLIST - [ (* generalize [lemma]; *) - (* h_intro hid; *) - (* Elim.h_decompose_and (mkVar hid); *) - tclTRY (list_rewrite true eqs) - ; (* (fun g -> *) - (* let ids' = pf_ids_of_hyps g in *) - (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) - (* rewrite *) - (* ) *) - Proofview.V82.of_tactic (Eauto.gen_eauto (false, 5) [] (Some [])) ] - gls - | Not_needed -> tclIDTAC + (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) + (* let ids = hid::pf_ids_of_hyps gls in *) + tclTHENLIST + [ (* generalize [lemma]; *) + (* h_intro hid; *) + (* Elim.h_decompose_and (mkVar hid); *) + tclTRY (list_rewrite true eqs) + ; (* (fun g -> *) + (* let ids' = pf_ids_of_hyps g in *) + (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) + (* rewrite *) + (* ) *) + Eauto.gen_eauto (false, 5) [] (Some []) ] + | Not_needed -> Proofview.tclUNIT () -let backtrack_eqs_until_hrec hrec eqs : tactic = - fun gls -> - let eqs = List.map mkVar eqs in - let rewrite = - tclFIRST - (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs) - in - let _, hrec_concl = decompose_prod (project gls) (pf_get_hyp_typ gls hrec) in - let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in - let f = fst (destApp (project gls) f_app) in - let rec backtrack : tactic = - fun g -> - let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in - match EConstr.kind (project g) f_app with - | App (f', _) when eq_constr (project g) f' f -> tclIDTAC g - | _ -> tclTHEN rewrite backtrack g - in - backtrack gls +let backtrack_eqs_until_hrec hrec eqs : unit Proofview.tactic = + let open Tacticals.New in + Proofview.Goal.enter (fun gls -> + let sigma = Proofview.Goal.sigma gls in + let eqs = List.map mkVar eqs in + let rewrite = tclFIRST (List.map Equality.rewriteRL eqs) in + let _, hrec_concl = + decompose_prod sigma (Tacmach.New.pf_get_hyp_typ hrec gls) + in + let f_app = Array.last (snd (destApp sigma hrec_concl)) in + let f = fst (destApp sigma f_app) in + let rec backtrack () : unit Proofview.tactic = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma gls in + let f_app = + Array.last (snd (destApp sigma (Proofview.Goal.concl g))) + in + match EConstr.kind sigma f_app with + | App (f', _) when eq_constr sigma f' f -> Proofview.tclUNIT () + | _ -> tclTHEN rewrite (backtrack ())) + in + backtrack ()) let rec rewrite_eqs_in_eqs eqs = + let open Tacticals.New in match eqs with - | [] -> tclIDTAC + | [] -> Proofview.tclUNIT () | eq :: eqs -> tclTHEN (tclMAP - (fun id gl -> + (fun id -> observe_tac (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id)) (tclTRY - (Proofview.V82.of_tactic - (Equality.general_rewrite_in true Locus.AllOccurrences true - (* dep proofs also: *) true id (mkVar eq) false))) - gl) + (Equality.general_rewrite_in true Locus.AllOccurrences true + (* dep proofs also: *) true id (mkVar eq) false))) eqs) (rewrite_eqs_in_eqs eqs) -let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = - fun gls -> - (tclTHENLIST - [ backtrack_eqs_until_hrec hrec eqs - ; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) - tclTHENS (* We must have exactly ONE subgoal !*) - (Proofview.V82.of_tactic (apply (mkVar hrec))) - [ tclTHENLIST - [ Proofview.V82.of_tactic (keep (tcc_hyps @ eqs)) - ; Proofview.V82.of_tactic (apply (Lazy.force acc_inv)) - ; (fun g -> - if is_mes then - Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.AllOccurrences - , evaluable_of_global_reference - (delayed_force ltof_ref) ) ]) - g - else tclIDTAC g) - ; observe_tac "rew_and_finish" - (tclTHENLIST - [ tclTRY - (list_rewrite false - (List.map (fun v -> (mkVar v, true)) eqs)) - ; observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs) - ; observe_tac "finishing using" - (tclCOMPLETE - ( Proofview.V82.of_tactic - @@ Eauto.eauto_with_bases (true, 5) - [(fun _ sigma -> (sigma, Lazy.force refl_equal))] - [ Hints.Hint_db.empty TransparentState.empty - false ] )) ]) ] ] ]) - gls +let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : unit Proofview.tactic + = + let open Tacticals.New in + tclTHENLIST + [ backtrack_eqs_until_hrec hrec eqs + ; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) + tclTHENS (* We must have exactly ONE subgoal !*) + (apply (mkVar hrec)) + [ tclTHENLIST + [ keep (tcc_hyps @ eqs) + ; apply (Lazy.force acc_inv) + ; ( if is_mes then + unfold_in_concl + [ ( Locus.AllOccurrences + , evaluable_of_global_reference (delayed_force ltof_ref) ) + ] + else Proofview.tclUNIT () ) + ; observe_tac "rew_and_finish" + (tclTHENLIST + [ tclTRY + (list_rewrite false + (List.map (fun v -> (mkVar v, true)) eqs)) + ; observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs) + ; observe_tac "finishing using" + (tclCOMPLETE + (Eauto.eauto_with_bases (true, 5) + [(fun _ sigma -> (sigma, Lazy.force refl_equal))] + [Hints.Hint_db.empty TransparentState.empty false])) + ]) ] ] ] let is_valid_hypothesis sigma predicates_name = let predicates_name = @@ -1367,199 +1402,204 @@ let is_valid_hypothesis sigma predicates_name = is_valid_hypothesis let prove_principle_for_gen (f_ref, functional_ref, eq_ref) tcc_lemma_ref is_mes - rec_arg_num rec_arg_type relation gl = - let princ_type = pf_concl gl in - let princ_info = compute_elim_sig (project gl) princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps gl) in - fun na -> - let new_id = - match na with - | Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" + rec_arg_num rec_arg_type relation = + Proofview.Goal.enter (fun gl -> + let sigma = Proofview.Goal.sigma gl in + let princ_type = Proofview.Goal.concl gl in + let princ_info = compute_elim_sig sigma princ_type in + let fresh_id = + let avoid = ref (Tacmach.New.pf_ids_of_hyps gl) in + fun na -> + let new_id = + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + Name new_id in - avoid := new_id :: !avoid; - Name new_id - in - let fresh_decl = map_name fresh_id in - let princ_info : elim_scheme = - { princ_info with - params = List.map fresh_decl princ_info.params - ; predicates = List.map fresh_decl princ_info.predicates - ; branches = List.map fresh_decl princ_info.branches - ; args = List.map fresh_decl princ_info.args } - in - let wf_tac = - if is_mes then fun b -> - Proofview.V82.of_tactic - @@ Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None - else fun _ -> prove_with_tcc tcc_lemma_ref [] - in - let real_rec_arg_num = rec_arg_num - princ_info.nparams in - let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in - (* observe ( *) - (* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) - (* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) + let fresh_decl = map_name fresh_id in + let princ_info : elim_scheme = + { princ_info with + params = List.map fresh_decl princ_info.params + ; predicates = List.map fresh_decl princ_info.predicates + ; branches = List.map fresh_decl princ_info.branches + ; args = List.map fresh_decl princ_info.args } + in + let wf_tac = + if is_mes then fun b -> + Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None + else fun _ -> prove_with_tcc tcc_lemma_ref [] + in + let real_rec_arg_num = rec_arg_num - princ_info.nparams in + let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in + (* observe ( *) + (* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) + (* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) - (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) - (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) - (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) - (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) - let post_rec_arg, pre_rec_arg = - Util.List.chop npost_rec_arg princ_info.args - in - let rec_arg_id = - match List.rev post_rec_arg with - | ( LocalAssum ({binder_name = Name id}, _) - | LocalDef ({binder_name = Name id}, _, _) ) - :: _ -> - id - | _ -> assert false - in - (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = - List.map - (get_name %> Nameops.Name.get_id %> mkVar) - (pre_rec_arg @ princ_info.params) - in - let relation = substl subst_constrs relation in - let input_type = substl subst_constrs rec_arg_type in - let wf_thm_id = Nameops.Name.get_id (fresh_id (Name (Id.of_string "wf_R"))) in - let acc_rec_arg_id = - Nameops.Name.get_id - (fresh_id (Name (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)))) - in - let revert l = - tclTHEN - (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) - (Proofview.V82.of_tactic (clear l)) - in - let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in - let prove_rec_arg_acc g = - ((* observe_tac "prove_rec_arg_acc" *) - tclCOMPLETE - (tclTHEN - (Proofview.V82.of_tactic + (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) + (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) + (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) + (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) + let post_rec_arg, pre_rec_arg = + Util.List.chop npost_rec_arg princ_info.args + in + let rec_arg_id = + match List.rev post_rec_arg with + | ( LocalAssum ({binder_name = Name id}, _) + | LocalDef ({binder_name = Name id}, _, _) ) + :: _ -> + id + | _ -> assert false + in + (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) + let subst_constrs = + List.map + (get_name %> Nameops.Name.get_id %> mkVar) + (pre_rec_arg @ princ_info.params) + in + let relation = substl subst_constrs relation in + let input_type = substl subst_constrs rec_arg_type in + let wf_thm_id = + Nameops.Name.get_id (fresh_id (Name (Id.of_string "wf_R"))) + in + let acc_rec_arg_id = + Nameops.Name.get_id + (fresh_id (Name (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)))) + in + let open Tacticals.New in + let revert l = + tclTHEN (Tactics.generalize (List.map mkVar l)) (clear l) + in + let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in + let prove_rec_arg_acc = + (* observe_tac "prove_rec_arg_acc" *) + tclCOMPLETE + (tclTHEN (assert_by (Name wf_thm_id) (mkApp (delayed_force well_founded, [|input_type; relation|])) - (Proofview.V82.tactic (fun g -> - (* observe_tac "prove wf" *) - (tclCOMPLETE (wf_tac is_mes)) g)))) - ((* observe_tac *) - (* "apply wf_thm" *) - Proofview.V82.of_tactic - (Tactics.Simple.apply - (mkApp (mkVar wf_thm_id, [|mkVar rec_arg_id|])))))) - g - in - let args_ids = List.map (get_name %> Nameops.Name.get_id) princ_info.args in - let lemma = - match !tcc_lemma_ref with - | Undefined -> user_err Pp.(str "No tcc proof !!") - | Value lemma -> EConstr.of_constr lemma - | Not_needed -> - EConstr.of_constr - (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") - in - (* let rec list_diff del_list check_list = *) - (* match del_list with *) - (* [] -> *) - (* [] *) - (* | f::r -> *) - (* if List.mem f check_list then *) - (* list_diff r check_list *) - (* else *) - (* f::(list_diff r check_list) *) - (* in *) - let tcc_list = ref [] in - let start_tac gls = - let hyps = pf_ids_of_hyps gls in - let hid = - next_ident_away_in_goal (Id.of_string "prov") (Id.Set.of_list hyps) - in - tclTHENLIST - [ Proofview.V82.of_tactic (generalize [lemma]) - ; Proofview.V82.of_tactic (Simple.intro hid) - ; Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)) - ; (fun g -> - let new_hyps = pf_ids_of_hyps g in - tcc_list := List.rev (List.subtract Id.equal new_hyps (hid :: hyps)); - if List.is_empty !tcc_list then begin - tcc_list := [hid]; - tclIDTAC g - end - else thin [hid] g) ] - gls - in - tclTHENLIST - [ observe_tac "start_tac" start_tac - ; h_intros - (List.rev_map - (get_name %> Nameops.Name.get_id) - ( princ_info.args @ princ_info.branches @ princ_info.predicates - @ princ_info.params )) - ; Proofview.V82.of_tactic - (assert_by (Name acc_rec_arg_id) - (mkApp - (delayed_force acc_rel, [|input_type; relation; mkVar rec_arg_id|])) - (Proofview.V82.tactic prove_rec_arg_acc)) - ; revert (List.rev (acc_rec_arg_id :: args_ids)) - ; Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1)) - ; h_intros (List.rev (acc_rec_arg_id :: args_ids)) - ; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)) - ; (fun gl' -> - let body = - let _, args = destApp (project gl') (pf_concl gl') in - Array.last args - in - let body_info rec_hyps = - { nb_rec_hyps = List.length rec_hyps - ; rec_hyps - ; eq_hyps = [] - ; info = body } - in - let acc_inv = - lazy + (* observe_tac "prove wf" *) + (tclCOMPLETE (wf_tac is_mes))) + ((* observe_tac *) + (* "apply wf_thm" *) + Tactics.Simple.apply + (mkApp (mkVar wf_thm_id, [|mkVar rec_arg_id|])))) + in + let args_ids = + List.map (get_name %> Nameops.Name.get_id) princ_info.args + in + let lemma = + match !tcc_lemma_ref with + | Undefined -> user_err Pp.(str "No tcc proof !!") + | Value lemma -> EConstr.of_constr lemma + | Not_needed -> + EConstr.of_constr + ( UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.True.I" ) + in + (* let rec list_diff del_list check_list = *) + (* match del_list with *) + (* [] -> *) + (* [] *) + (* | f::r -> *) + (* if List.mem f check_list then *) + (* list_diff r check_list *) + (* else *) + (* f::(list_diff r check_list) *) + (* in *) + let tcc_list = ref [] in + let start_tac = + Proofview.Goal.enter (fun gls -> + let hyps = Tacmach.New.pf_ids_of_hyps gls in + let hid = + next_ident_away_in_goal (Id.of_string "prov") + (Id.Set.of_list hyps) + in + tclTHENLIST + [ generalize [lemma] + ; Simple.intro hid + ; Elim.h_decompose_and (mkVar hid) + ; Proofview.Goal.enter (fun g -> + let new_hyps = Tacmach.New.pf_ids_of_hyps g in + tcc_list := + List.rev (List.subtract Id.equal new_hyps (hid :: hyps)); + if List.is_empty !tcc_list then begin + tcc_list := [hid]; + Proofview.tclUNIT () + end + else clear [hid]) ]) + in + tclTHENLIST + [ observe_tac "start_tac" start_tac + ; h_intros + (List.rev_map + (get_name %> Nameops.Name.get_id) + ( princ_info.args @ princ_info.branches @ princ_info.predicates + @ princ_info.params )) + ; assert_by (Name acc_rec_arg_id) (mkApp - ( delayed_force acc_inv_id + ( delayed_force acc_rel , [|input_type; relation; mkVar rec_arg_id|] )) - in - let acc_inv = - lazy (mkApp (Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) - in - let predicates_names = - List.map (get_name %> Nameops.Name.get_id) princ_info.predicates - in - let pte_info = - { proving_tac = - (fun eqs -> - (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) - (* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) - (* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) - (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) - (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) + prove_rec_arg_acc + ; revert (List.rev (acc_rec_arg_id :: args_ids)) + ; fix fix_id (List.length args_ids + 1) + ; h_intros (List.rev (acc_rec_arg_id :: args_ids)) + ; Equality.rewriteLR (mkConst eq_ref) + ; Proofview.Goal.enter (fun gl' -> + let body = + let _, args = + destApp (Proofview.Goal.sigma gl') (Proofview.Goal.concl gl') + in + Array.last args + in + let body_info rec_hyps = + { nb_rec_hyps = List.length rec_hyps + ; rec_hyps + ; eq_hyps = [] + ; info = body } + in + let acc_inv = + lazy + (mkApp + ( delayed_force acc_inv_id + , [|input_type; relation; mkVar rec_arg_id|] )) + in + let acc_inv = + lazy (mkApp (Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) + in + let predicates_names = + List.map (get_name %> Nameops.Name.get_id) princ_info.predicates + in + let pte_info = + { proving_tac = + (fun eqs -> + (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) + (* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) + (* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) + (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) + (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) - (* observe_tac "new_prove_with_tcc" *) - new_prove_with_tcc is_mes acc_inv fix_id - ( !tcc_list - @ List.map - (get_name %> Nameops.Name.get_id) - (princ_info.args @ princ_info.params) - @ [acc_rec_arg_id] ) - eqs) - ; is_valid = is_valid_hypothesis (project gl') predicates_names } - in - let ptes_info : pte_info Id.Map.t = - List.fold_left - (fun map pte_id -> Id.Map.add pte_id pte_info map) - Id.Map.empty predicates_names - in - let make_proof rec_hyps = - build_proof false [f_ref] ptes_info (body_info rec_hyps) - in - (* observe_tac "instantiate_hyps_with_args" *) - (instantiate_hyps_with_args make_proof - (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) - (List.rev args_ids)) - gl') ] - gl + (* observe_tac "new_prove_with_tcc" *) + new_prove_with_tcc is_mes acc_inv fix_id + ( !tcc_list + @ List.map + (get_name %> Nameops.Name.get_id) + (princ_info.args @ princ_info.params) + @ [acc_rec_arg_id] ) + eqs) + ; is_valid = + is_valid_hypothesis (Proofview.Goal.sigma gl') + predicates_names } + in + let ptes_info : pte_info Id.Map.t = + List.fold_left + (fun map pte_id -> Id.Map.add pte_id pte_info map) + Id.Map.empty predicates_names + in + let make_proof rec_hyps = + build_proof false [f_ref] ptes_info (body_info rec_hyps) + in + (* observe_tac "instantiate_hyps_with_args" *) + instantiate_hyps_with_args make_proof + (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) + (List.rev args_ids)) ]) diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index 52089ca7fb..096ea5fed5 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + open Names val prove_princ_for_struct : @@ -7,7 +17,7 @@ val prove_princ_for_struct : -> Constant.t array -> EConstr.constr array -> int - -> Tacmach.tactic + -> unit Proofview.tactic val prove_principle_for_gen : Constant.t * Constant.t * Constant.t @@ -22,6 +32,6 @@ val prove_principle_for_gen : -> (* the type of the recursive argument *) EConstr.constr -> (* the wf relation used to prove the function *) - Tacmach.tactic + unit Proofview.tactic (* val is_pte : rel_declaration -> bool *) diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index a1094e39a4..bbc4df7dde 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -151,7 +151,7 @@ let (wit_function_rec_definition_loc : Vernacexpr.fixpoint_expr Loc.located Gena Genarg.create_arg "function_rec_definition_loc" let function_rec_definition_loc = - Pcoq.create_generic_entry Pcoq.utactic "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) + Pcoq.create_generic_entry2 "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) } diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 45b1713441..1ea803f561 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -13,7 +13,8 @@ open Names open Indfun_common module RelDecl = Context.Rel.Declaration -let observe_tac s = observe_tac (fun _ _ -> Pp.str s) +let observe_tac s = + New.observe_tac ~header:(Pp.str "observation") (fun _ _ -> Pp.str s) (* Construct a fixpoint as a Glob_term @@ -210,9 +211,7 @@ let build_functional_principle (sigma : Evd.evar_map) old_princ_type sorts funs (EConstr.of_constr new_principle_type) in let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - let ftac = - Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams) - in + let ftac = proof_tac (Array.map map funs) mutr_nparams in let env = Global.env () in let uctx = Evd.evar_universe_context sigma in let typ = EConstr.of_constr new_principle_type in @@ -335,7 +334,7 @@ let generate_principle (evd : Evd.evar_map ref) pconstants on_error is_general -> Names.Constant.t array -> EConstr.constr array -> int - -> Tacmach.tactic) : unit = + -> unit Proofview.tactic) : unit = let names = List.map (function {Vernacexpr.fname = {CAst.v = name}} -> name) fix_rec_l in @@ -442,7 +441,7 @@ let register_struct is_rec fixpoint_exprl = let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type relation (_ : int) (_ : Names.Constant.t array) (_ : EConstr.constr array) (_ : int) : - Tacmach.tactic = + unit Proofview.tactic = Functional_principles_proofs.prove_principle_for_gen (f_ref, functional_ref, eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation @@ -593,250 +592,241 @@ let rec generate_fresh_id x avoid i = id :: generate_fresh_id x (id :: avoid) (pred i) let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : - Tacmach.tactic = + unit Proofview.tactic = let open Constr in let open EConstr in let open Context.Rel.Declaration in - let open Tacmach in + let open Tacmach.New in let open Tactics in - let open Tacticals in - fun g -> - (* first of all we recreate the lemmas types to be used as predicates of the induction principle - that is~: - \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] - *) - (* we the get the definition of the graphs block *) - let graph_ind, u = destInd evd graphs_constr.(i) in - let kn = fst graph_ind in - let mib, _ = Global.lookup_inductive graph_ind in - (* and the principle to use in this lemma in $\zeta$ normal form *) - let f_principle, princ_type = schemes.(i) in - let princ_type = Reductionops.nf_zeta (Global.env ()) evd princ_type in - let princ_infos = Tactics.compute_elim_sig evd princ_type in - (* The number of args of the function is then easily computable *) - let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in - let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names @ pf_ids_of_hyps g in - (* Since we cannot ensure that the functional principle is defined in the - environment and due to the bug #1174, we will need to pose the principle - using a name - *) - let principle_id = - Namegen.next_ident_away_in_goal (Id.of_string "princ") - (Id.Set.of_list ids) - in - let ids = principle_id :: ids in - (* We get the branches of the principle *) - let branches = List.rev princ_infos.Tactics.branches in - (* and built the intro pattern for each of them *) - let intro_pats = - List.map - (fun decl -> - List.map - (fun id -> - CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids - (List.length - (fst (decompose_prod_assum evd (RelDecl.get_type decl)))))) - branches - in - (* before building the full intro pattern for the principle *) - let eq_ind = make_eq () in - let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in - (* The next to referencies will be used to find out which constructor to apply in each branch *) - let ind_number = ref 0 and min_constr_number = ref 0 in - (* The tactic to prove the ith branch of the principle *) - let prove_branche i g = - (* We get the identifiers of this branch *) - let pre_args = - List.fold_right - (fun {CAst.v = pat} acc -> - match pat with - | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id :: acc - | _ -> CErrors.anomaly (Pp.str "Not an identifier.")) - (List.nth intro_pats (pred i)) - [] + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + (* first of all we recreate the lemmas types to be used as predicates of the induction principle + that is~: + \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] + *) + (* we the get the definition of the graphs block *) + let graph_ind, u = destInd evd graphs_constr.(i) in + let kn = fst graph_ind in + let mib, _ = Global.lookup_inductive graph_ind in + (* and the principle to use in this lemma in $\zeta$ normal form *) + let f_principle, princ_type = schemes.(i) in + let princ_type = Reductionops.nf_zeta (Global.env ()) evd princ_type in + let princ_infos = Tactics.compute_elim_sig evd princ_type in + (* The number of args of the function is then easily computable *) + let nb_fun_args = + Termops.nb_prod (Proofview.Goal.sigma g) (Proofview.Goal.concl g) - 2 + in + let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in + let ids = args_names @ pf_ids_of_hyps g in + (* Since we cannot ensure that the functional principle is defined in the + environment and due to the bug #1174, we will need to pose the principle + using a name + *) + let principle_id = + Namegen.next_ident_away_in_goal (Id.of_string "princ") + (Id.Set.of_list ids) + in + let ids = principle_id :: ids in + (* We get the branches of the principle *) + let branches = List.rev princ_infos.Tactics.branches in + (* and built the intro pattern for each of them *) + let intro_pats = + List.map + (fun decl -> + List.map + (fun id -> + CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) + (generate_fresh_id (Id.of_string "y") ids + (List.length + (fst (decompose_prod_assum evd (RelDecl.get_type decl)))))) + branches in - (* and get the real args of the branch by unfolding the defined constant *) - (* + (* before building the full intro pattern for the principle *) + let eq_ind = make_eq () in + let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in + (* The next to referencies will be used to find out which constructor to apply in each branch *) + let ind_number = ref 0 and min_constr_number = ref 0 in + (* The tactic to prove the ith branch of the principle *) + let prove_branch i pat = + (* We get the identifiers of this branch *) + let pre_args = + List.fold_right + (fun {CAst.v = pat} acc -> + match pat with + | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id :: acc + | _ -> CErrors.anomaly (Pp.str "Not an identifier.")) + pat [] + in + (* and get the real args of the branch by unfolding the defined constant *) + (* We can then recompute the arguments of the constructor. For each [hid] introduced by this branch, if [hid] has type $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are [ fv (hid fv (refl_equal fv)) ]. If [hid] has another type the corresponding argument of the constructor is [hid] *) - let constructor_args g = - List.fold_right - (fun hid acc -> - let type_of_hid = pf_get_hyp_typ g hid in - let sigma = project g in - match EConstr.kind sigma type_of_hid with - | Prod (_, _, t') -> ( - match EConstr.kind sigma t' with - | Prod (_, t'', t''') -> ( - match (EConstr.kind sigma t'', EConstr.kind sigma t''') with - | App (eq, args), App (graph', _) - when EConstr.eq_constr sigma eq eq_ind - && Array.exists - (EConstr.eq_constr_nounivs sigma graph') - graphs_constr -> - args.(2) - :: mkApp - ( mkVar hid - , [| args.(2) - ; mkApp (eq_construct, [|args.(0); args.(2)|]) |] ) - :: acc + let constructor_args g = + List.fold_right + (fun hid acc -> + let type_of_hid = pf_get_hyp_typ hid g in + let sigma = Proofview.Goal.sigma g in + match EConstr.kind sigma type_of_hid with + | Prod (_, _, t') -> ( + match EConstr.kind sigma t' with + | Prod (_, t'', t''') -> ( + match (EConstr.kind sigma t'', EConstr.kind sigma t''') with + | App (eq, args), App (graph', _) + when EConstr.eq_constr sigma eq eq_ind + && Array.exists + (EConstr.eq_constr_nounivs sigma graph') + graphs_constr -> + args.(2) + :: mkApp + ( mkVar hid + , [| args.(2) + ; mkApp (eq_construct, [|args.(0); args.(2)|]) |] ) + :: acc + | _ -> mkVar hid :: acc ) | _ -> mkVar hid :: acc ) - | _ -> mkVar hid :: acc ) - | _ -> mkVar hid :: acc) - pre_args [] - in - (* in fact we must also add the parameters to the constructor args *) - let constructor_args g = - let params_id = - fst (List.chop princ_infos.Tactics.nparams args_names) + | _ -> mkVar hid :: acc) + pre_args [] in - List.map mkVar params_id @ constructor_args g - in - (* We then get the constructor corresponding to this branch and - modifies the references has needed i.e. - if the constructor is the last one of the current inductive then - add one the number of the inductive to take and add the number of constructor of the previous - graph to the minimal constructor number - *) - let constructor = - let constructor_num = i - !min_constr_number in - let length = - Array.length - mib.Declarations.mind_packets.(!ind_number) - .Declarations.mind_consnames + (* in fact we must also add the parameters to the constructor args *) + let constructor_args g = + let params_id = + fst (List.chop princ_infos.Tactics.nparams args_names) + in + List.map mkVar params_id @ constructor_args g in - if constructor_num <= length then ((kn, !ind_number), constructor_num) - else begin - incr ind_number; - min_constr_number := !min_constr_number + length; - ((kn, !ind_number), 1) - end - in - (* we can then build the final proof term *) - let app_constructor g = - applist (mkConstructU (constructor, u), constructor_args g) + (* We then get the constructor corresponding to this branch and + modifies the references has needed i.e. + if the constructor is the last one of the current inductive then + add one the number of the inductive to take and add the number of constructor of the previous + graph to the minimal constructor number + *) + let constructor = + let constructor_num = i - !min_constr_number in + let length = + Array.length + mib.Declarations.mind_packets.(!ind_number) + .Declarations.mind_consnames + in + if constructor_num <= length then ((kn, !ind_number), constructor_num) + else begin + incr ind_number; + min_constr_number := !min_constr_number + length; + ((kn, !ind_number), 1) + end + in + (* we can then build the final proof term *) + let app_constructor g = + applist (mkConstructU (constructor, u), constructor_args g) + in + (* an apply the tactic *) + let res, hres = + match + generate_fresh_id (Id.of_string "z") ids (* @this_branche_ids *) 2 + with + | [res; hres] -> (res, hres) + | _ -> assert false + in + (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) + tclTHENLIST + [ observe_tac "h_intro_patterns " + (match pat with [] -> tclIDTAC | _ -> intro_patterns false pat) + ; (* unfolding of all the defined variables introduced by this branch *) + (* observe_tac "unfolding" pre_tac; *) + (* $zeta$ normalizing of the conclusion *) + reduce + (Genredexpr.Cbv + { Redops.all_flags with + Genredexpr.rDelta = false + ; Genredexpr.rConst = [] }) + Locusops.onConcl + ; observe_tac "toto " (Proofview.tclUNIT ()) + ; (* introducing the result of the graph and the equality hypothesis *) + observe_tac "introducing" (tclMAP Simple.intro [res; hres]) + ; (* replacing [res] with its value *) + observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres)) + ; (* Conclusion *) + observe_tac "exact" + (Proofview.Goal.enter (fun g -> exact_check (app_constructor g))) + ] in - (* an apply the tactic *) - let res, hres = - match - generate_fresh_id (Id.of_string "z") ids (* @this_branche_ids *) 2 - with - | [res; hres] -> (res, hres) - | _ -> assert false + (* end of branche proof *) + let lemmas = + Array.map + (fun (_, (ctxt, concl)) -> + match ctxt with + | [] | [_] | [_; _] -> CErrors.anomaly (Pp.str "bad context.") + | hres :: res :: decl :: ctxt -> + let res = + EConstr.it_mkLambda_or_LetIn + (EConstr.it_mkProd_or_LetIn concl [hres; res]) + ( LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) + :: ctxt ) + in + res) + lemmas_types_infos in - (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) - (tclTHENLIST - [ observe_tac "h_intro_patterns " - (let l = List.nth intro_pats (pred i) in - match l with - | [] -> tclIDTAC - | _ -> Proofview.V82.of_tactic (intro_patterns false l)) - ; (* unfolding of all the defined variables introduced by this branch *) - (* observe_tac "unfolding" pre_tac; *) - (* $zeta$ normalizing of the conclusion *) - Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv - { Redops.all_flags with - Genredexpr.rDelta = false - ; Genredexpr.rConst = [] }) - Locusops.onConcl) - ; observe_tac "toto " tclIDTAC - ; (* introducing the result of the graph and the equality hypothesis *) - observe_tac "introducing" - (tclMAP - (fun x -> Proofview.V82.of_tactic (Simple.intro x)) - [res; hres]) - ; (* replacing [res] with its value *) - observe_tac "rewriting res value" - (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))) - ; (* Conclusion *) - observe_tac "exact" (fun g -> - Proofview.V82.of_tactic (exact_check (app_constructor g)) g) ]) - g - in - (* end of branche proof *) - let lemmas = - Array.map - (fun (_, (ctxt, concl)) -> - match ctxt with - | [] | [_] | [_; _] -> CErrors.anomaly (Pp.str "bad context.") - | hres :: res :: decl :: ctxt -> - let res = - EConstr.it_mkLambda_or_LetIn - (EConstr.it_mkProd_or_LetIn concl [hres; res]) - ( LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) - :: ctxt ) - in - res) - lemmas_types_infos - in - let param_names = fst (List.chop princ_infos.nparams args_names) in - let params = List.map mkVar param_names in - let lemmas = - Array.to_list (Array.map (fun c -> applist (c, params)) lemmas) - in - (* The bindings of the principle - that is the params of the principle and the different lemma types - *) - let bindings = - let params_bindings, avoid = - List.fold_left2 - (fun (bindings, avoid) decl p -> - let id = - Namegen.next_ident_away - (Nameops.Name.get_id (RelDecl.get_name decl)) - (Id.Set.of_list avoid) - in - (p :: bindings, id :: avoid)) - ([], pf_ids_of_hyps g) - princ_infos.params (List.rev params) + let param_names = fst (List.chop princ_infos.nparams args_names) in + let params = List.map mkVar param_names in + let lemmas = + Array.to_list (Array.map (fun c -> applist (c, params)) lemmas) in - let lemmas_bindings = - List.rev - (fst - (List.fold_left2 - (fun (bindings, avoid) decl p -> - let id = - Namegen.next_ident_away - (Nameops.Name.get_id (RelDecl.get_name decl)) - (Id.Set.of_list avoid) - in - ( Reductionops.nf_zeta (pf_env g) (project g) p :: bindings - , id :: avoid )) - ([], avoid) princ_infos.predicates lemmas)) + (* The bindings of the principle + that is the params of the principle and the different lemma types + *) + let bindings = + let params_bindings, avoid = + List.fold_left2 + (fun (bindings, avoid) decl p -> + let id = + Namegen.next_ident_away + (Nameops.Name.get_id (RelDecl.get_name decl)) + (Id.Set.of_list avoid) + in + (p :: bindings, id :: avoid)) + ([], pf_ids_of_hyps g) + princ_infos.params (List.rev params) + in + let lemmas_bindings = + List.rev + (fst + (List.fold_left2 + (fun (bindings, avoid) decl p -> + let id = + Namegen.next_ident_away + (Nameops.Name.get_id (RelDecl.get_name decl)) + (Id.Set.of_list avoid) + in + ( Reductionops.nf_zeta (Proofview.Goal.env g) + (Proofview.Goal.sigma g) p + :: bindings + , id :: avoid )) + ([], avoid) princ_infos.predicates lemmas)) + in + params_bindings @ lemmas_bindings in - params_bindings @ lemmas_bindings - in - tclTHENLIST - [ observe_tac "principle" - (Proofview.V82.of_tactic - (assert_by (Name principle_id) princ_type - (exact_check f_principle))) - ; observe_tac "intro args_names" - (tclMAP - (fun id -> Proofview.V82.of_tactic (Simple.intro id)) - args_names) - ; (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) - observe_tac "idtac" tclIDTAC - ; tclTHEN_i - (observe_tac "functional_induction" (fun gl -> - let term = mkApp (mkVar principle_id, Array.of_list bindings) in - let gl', _ty = - pf_eapply (Typing.type_of ~refresh:true) gl term - in - Proofview.V82.of_tactic (apply term) gl')) - (fun i g -> - observe_tac - ("proving branche " ^ string_of_int i) - (prove_branche i) g) ] - g + tclTHENLIST + [ observe_tac "principle" + (assert_by (Name principle_id) princ_type (exact_check f_principle)) + ; observe_tac "intro args_names" (tclMAP Simple.intro args_names) + ; (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) + observe_tac "idtac" tclIDTAC + ; tclTHENS + (observe_tac "functional_induction" + (Proofview.Goal.enter (fun gl -> + let term = + mkApp (mkVar principle_id, Array.of_list bindings) + in + tclTYPEOFTHEN ~refresh:true term (fun _ _ -> apply term)))) + (List.map_i + (fun i pat -> + observe_tac + ("proving branch " ^ string_of_int i) + (prove_branch i pat)) + 1 intro_pats) ]) (* [prove_fun_complete funs graphs schemes lemmas_types_infos i] is the tactic used to prove completeness lemma. @@ -865,7 +855,7 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : *) -let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl +let thin = Tactics.clear (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis (unfolding, substituting, destructing cases \ldots) @@ -882,347 +872,343 @@ let tauto = (* [generalize_dependent_of x hyp g] generalize every hypothesis which depends of [x] but [hyp] *) -let generalize_dependent_of x hyp g = +let generalize_dependent_of x hyp = let open Context.Named.Declaration in - let open Tacmach in - let open Tacticals in - tclMAP - (function - | LocalAssum ({Context.binder_name = id}, t) - when (not (Id.equal id hyp)) - && Termops.occur_var (pf_env g) (project g) x t -> - tclTHEN - (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) - (thin [id]) - | _ -> tclIDTAC) - (pf_hyps g) g - -let rec intros_with_rewrite g = - observe_tac "intros_with_rewrite" intros_with_rewrite_aux g - -and intros_with_rewrite_aux : Tacmach.tactic = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + tclMAP + (function + | LocalAssum ({Context.binder_name = id}, t) + when (not (Id.equal id hyp)) + && Termops.occur_var (Proofview.Goal.env g) + (Proofview.Goal.sigma g) x t -> + tclTHEN (Tactics.generalize [EConstr.mkVar id]) (thin [id]) + | _ -> Proofview.tclUNIT ()) + (Proofview.Goal.hyps g)) + +let rec intros_with_rewrite () = + observe_tac "intros_with_rewrite" (intros_with_rewrite_aux ()) + +and intros_with_rewrite_aux () : unit Proofview.tactic = let open Constr in let open EConstr in - let open Tacmach in + let open Tacmach.New in let open Tactics in - let open Tacticals in - fun g -> - let eq_ind = make_eq () in - let sigma = project g in - match EConstr.kind sigma (pf_concl g) with - | Prod (_, t, t') -> ( - match EConstr.kind sigma t with - | App (eq, args) when EConstr.eq_constr sigma eq eq_ind -> - if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST - [ Proofview.V82.of_tactic (Simple.intro id) - ; thin [id] - ; intros_with_rewrite ] - g - else if - isVar sigma args.(1) - && Environ.evaluable_named (destVar sigma args.(1)) (pf_env g) - then - tclTHENLIST - [ Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(1)) ) ]) - ; tclMAP - (fun id -> - tclTRY - (Proofview.V82.of_tactic - (unfold_in_hyp - [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(1)) ) ] - (destVar sigma args.(1), Locus.InHyp)))) - (pf_ids_of_hyps g) - ; intros_with_rewrite ] - g - else if - isVar sigma args.(2) - && Environ.evaluable_named (destVar sigma args.(2)) (pf_env g) - then - tclTHENLIST - [ Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(2)) ) ]) - ; tclMAP - (fun id -> - tclTRY - (Proofview.V82.of_tactic - (unfold_in_hyp - [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(2)) ) ] - (destVar sigma args.(2), Locus.InHyp)))) - (pf_ids_of_hyps g) - ; intros_with_rewrite ] - g - else if isVar sigma args.(1) then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST - [ Proofview.V82.of_tactic (Simple.intro id) - ; generalize_dependent_of (destVar sigma args.(1)) id - ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))) - ; intros_with_rewrite ] - g - else if isVar sigma args.(2) then - let id = pf_get_new_id (Id.of_string "y") g in + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let eq_ind = make_eq () in + let sigma = Proofview.Goal.sigma g in + match EConstr.kind sigma (Proofview.Goal.concl g) with + | Prod (_, t, t') -> ( + match EConstr.kind sigma t with + | App (eq, args) when EConstr.eq_constr sigma eq eq_ind -> + if + Reductionops.is_conv (Proofview.Goal.env g) (Proofview.Goal.sigma g) + args.(1) args.(2) + then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST [Simple.intro id; thin [id]; intros_with_rewrite ()] + else if + isVar sigma args.(1) + && Environ.evaluable_named + (destVar sigma args.(1)) + (Proofview.Goal.env g) + then + tclTHENLIST + [ unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(1)) ) ] + ; tclMAP + (fun id -> + tclTRY + (unfold_in_hyp + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(1)) ) ] + (destVar sigma args.(1), Locus.InHyp))) + (pf_ids_of_hyps g) + ; intros_with_rewrite () ] + else if + isVar sigma args.(2) + && Environ.evaluable_named + (destVar sigma args.(2)) + (Proofview.Goal.env g) + then + tclTHENLIST + [ unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(2)) ) ] + ; tclMAP + (fun id -> + tclTRY + (unfold_in_hyp + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(2)) ) ] + (destVar sigma args.(2), Locus.InHyp))) + (pf_ids_of_hyps g) + ; intros_with_rewrite () ] + else if isVar sigma args.(1) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Simple.intro id + ; generalize_dependent_of (destVar sigma args.(1)) id + ; tclTRY (Equality.rewriteLR (mkVar id)) + ; intros_with_rewrite () ] + else if isVar sigma args.(2) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Simple.intro id + ; generalize_dependent_of (destVar sigma args.(2)) id + ; tclTRY (Equality.rewriteRL (mkVar id)) + ; intros_with_rewrite () ] + else + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Simple.intro id + ; tclTRY (Equality.rewriteLR (mkVar id)) + ; intros_with_rewrite () ] + | Ind _ + when EConstr.eq_constr sigma t + (EConstr.of_constr + ( UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.False.type" )) -> + tauto + | Case (_, _, _, v, _) -> + tclTHENLIST [simplest_case v; intros_with_rewrite ()] + | LetIn _ -> tclTHENLIST - [ Proofview.V82.of_tactic (Simple.intro id) - ; generalize_dependent_of (destVar sigma args.(2)) id - ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))) - ; intros_with_rewrite ] - g - else + [ reduce + (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl + ; intros_with_rewrite () ] + | _ -> let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST - [ Proofview.V82.of_tactic (Simple.intro id) - ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))) - ; intros_with_rewrite ] - g - | Ind _ - when EConstr.eq_constr sigma t - (EConstr.of_constr - ( UnivGen.constr_of_monomorphic_global - @@ Coqlib.lib_ref "core.False.type" )) -> - Proofview.V82.of_tactic tauto g - | Case (_, _, _, v, _) -> - tclTHENLIST - [Proofview.V82.of_tactic (simplest_case v); intros_with_rewrite] - g + tclTHENLIST [Simple.intro id; intros_with_rewrite ()] ) | LetIn _ -> tclTHENLIST - [ Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv - {Redops.all_flags with Genredexpr.rDelta = false}) - Locusops.onConcl) - ; intros_with_rewrite ] - g - | _ -> - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST - [Proofview.V82.of_tactic (Simple.intro id); intros_with_rewrite] - g ) - | LetIn _ -> - tclTHENLIST - [ Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) - Locusops.onConcl) - ; intros_with_rewrite ] - g - | _ -> tclIDTAC g - -let rec reflexivity_with_destruct_cases g = + [ reduce + (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl + ; intros_with_rewrite () ] + | _ -> Proofview.tclUNIT ()) + +let rec reflexivity_with_destruct_cases () = let open Constr in let open EConstr in - let open Tacmach in + let open Tacmach.New in let open Tactics in - let open Tacticals in - let destruct_case () = - try - match - EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) - with - | Case (_, _, _, v, _) -> - tclTHENLIST - [ Proofview.V82.of_tactic (simplest_case v) - ; Proofview.V82.of_tactic intros - ; observe_tac "reflexivity_with_destruct_cases" - reflexivity_with_destruct_cases ] - | _ -> Proofview.V82.of_tactic reflexivity - with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity - in - let eq_ind = make_eq () in - let my_inj_flags = - Some - { Equality.keep_proof_equalities = false - ; injection_in_context = false - ; (* for compatibility, necessary *) - injection_pattern_l2r_order = - false (* probably does not matter; except maybe with dependent hyps *) - } - in - let discr_inject = - Tacticals.onAllHypsAndConcl (fun sc g -> - match sc with - | None -> tclIDTAC g - | Some id -> ( - match EConstr.kind (project g) (pf_get_hyp_typ g id) with - | App (eq, [|_; t1; t2|]) when EConstr.eq_constr (project g) eq eq_ind - -> - if Equality.discriminable (pf_env g) (project g) t1 t2 then - Proofview.V82.of_tactic (Equality.discrHyp id) g - else if - Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 - then - tclTHENLIST - [ Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id) - ; thin [id] - ; intros_with_rewrite ] - g - else tclIDTAC g - | _ -> tclIDTAC g )) - in - (tclFIRST - [ observe_tac "reflexivity_with_destruct_cases : reflexivity" - (Proofview.V82.of_tactic reflexivity) - ; observe_tac "reflexivity_with_destruct_cases : destruct_case" - (destruct_case ()) - ; (* We reach this point ONLY if - the same value is matched (at least) two times - along binding path. - In this case, either we have a discriminable hypothesis and we are done, - either at least an injectable one and we do the injection before continuing - *) - observe_tac "reflexivity_with_destruct_cases : others" - (tclTHEN (tclPROGRESS discr_inject) reflexivity_with_destruct_cases) ]) - g + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let destruct_case () = + try + match + EConstr.kind (Proofview.Goal.sigma g) + (snd (destApp (Proofview.Goal.sigma g) (Proofview.Goal.concl g))).( + 2) + with + | Case (_, _, _, v, _) -> + tclTHENLIST + [ simplest_case v + ; intros + ; observe_tac "reflexivity_with_destruct_cases" + (reflexivity_with_destruct_cases ()) ] + | _ -> reflexivity + with e when CErrors.noncritical e -> reflexivity + in + let eq_ind = make_eq () in + let my_inj_flags = + Some + { Equality.keep_proof_equalities = false + ; injection_in_context = false + ; (* for compatibility, necessary *) + injection_pattern_l2r_order = + false + (* probably does not matter; except maybe with dependent hyps *) + } + in + let discr_inject = + onAllHypsAndConcl (fun sc -> + match sc with + | None -> Proofview.tclUNIT () + | Some id -> + Proofview.Goal.enter (fun g -> + match + EConstr.kind (Proofview.Goal.sigma g) (pf_get_hyp_typ id g) + with + | App (eq, [|_; t1; t2|]) + when EConstr.eq_constr (Proofview.Goal.sigma g) eq eq_ind -> + if + Equality.discriminable (Proofview.Goal.env g) + (Proofview.Goal.sigma g) t1 t2 + then Equality.discrHyp id + else if + Equality.injectable (Proofview.Goal.env g) + (Proofview.Goal.sigma g) ~keep_proofs:None t1 t2 + then + tclTHENLIST + [ Equality.injHyp my_inj_flags None id + ; thin [id] + ; intros_with_rewrite () ] + else Proofview.tclUNIT () + | _ -> Proofview.tclUNIT ())) + in + tclFIRST + [ observe_tac "reflexivity_with_destruct_cases : reflexivity" reflexivity + ; observe_tac "reflexivity_with_destruct_cases : destruct_case" + (destruct_case ()) + ; (* We reach this point ONLY if + the same value is matched (at least) two times + along binding path. + In this case, either we have a discriminable hypothesis and we are done, + either at least an injectable one and we do the injection before continuing + *) + observe_tac "reflexivity_with_destruct_cases : others" + (tclTHEN (tclPROGRESS discr_inject) + (reflexivity_with_destruct_cases ())) ]) let prove_fun_complete funcs graphs schemes lemmas_types_infos i : - Tacmach.tactic = + unit Proofview.tactic = let open EConstr in - let open Tacmach in + let open Tacmach.New in let open Tactics in - let open Tacticals in - fun g -> - (* We compute the types of the different mutually recursive lemmas - in $\zeta$ normal form - *) - let lemmas = - Array.map - (fun (_, (ctxt, concl)) -> - Reductionops.nf_zeta (pf_env g) (project g) - (EConstr.it_mkLambda_or_LetIn concl ctxt)) - lemmas_types_infos - in - (* We get the constant and the principle corresponding to this lemma *) - let f = funcs.(i) in - let graph_principle = - Reductionops.nf_zeta (pf_env g) (project g) - (EConstr.of_constr schemes.(i)) - in - let g, princ_type = tac_type_of g graph_principle in - let princ_infos = Tactics.compute_elim_sig (project g) princ_type in - (* Then we get the number of argument of the function - and compute a fresh name for each of them - *) - let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in - let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names @ pf_ids_of_hyps g in - (* and fresh names for res H and the principle (cf bug bug #1174) *) - let res, hres, graph_principle_id = - match generate_fresh_id (Id.of_string "z") ids 3 with - | [res; hres; graph_principle_id] -> (res, hres, graph_principle_id) - | _ -> assert false - in - let ids = res :: hres :: graph_principle_id :: ids in - (* we also compute fresh names for each hyptohesis of each branch - of the principle *) - let branches = List.rev princ_infos.branches in - let intro_pats = - List.map - (fun decl -> - List.map - (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids - (Termops.nb_prod (project g) (RelDecl.get_type decl)))) - branches - in - (* We will need to change the function by its body - using [f_equation] if it is recursive (that is the graph is infinite - or unfold if the graph is finite - *) - let rewrite_tac j ids : Tacmach.tactic = - let graph_def = graphs.(j) in - let infos = - match find_Function_infos (fst (destConst (project g) funcs.(j))) with - | None -> CErrors.user_err Pp.(str "No graph found") - | Some infos -> infos + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + (* We compute the types of the different mutually recursive lemmas + in $\zeta$ normal form + *) + let lemmas = + Array.map + (fun (_, (ctxt, concl)) -> + Reductionops.nf_zeta (Proofview.Goal.env g) (Proofview.Goal.sigma g) + (EConstr.it_mkLambda_or_LetIn concl ctxt)) + lemmas_types_infos in - if - infos.is_general - || Rtree.is_infinite Declareops.eq_recarg - graph_def.Declarations.mind_recargs - then - let eq_lemma = - try Option.get infos.equation_lemma - with Option.IsNone -> - CErrors.anomaly (Pp.str "Cannot find equation lemma.") - in - tclTHENLIST - [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids - ; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)) - ; (* Don't forget to $\zeta$ normlize the term since the principles - have been $\zeta$-normalized *) - Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv - {Redops.all_flags with Genredexpr.rDelta = false}) - Locusops.onConcl) - ; Proofview.V82.of_tactic (generalize (List.map mkVar ids)) - ; thin ids ] - else - Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.AllOccurrences - , Names.EvalConstRef (fst (destConst (project g) f)) ) ]) - in - (* The proof of each branche itself *) - let ind_number = ref 0 in - let min_constr_number = ref 0 in - let prove_branche i g = - (* we fist compute the inductive corresponding to the branch *) - let this_ind_number = - let constructor_num = i - !min_constr_number in - let length = - Array.length graphs.(!ind_number).Declarations.mind_consnames - in - if constructor_num <= length then !ind_number - else begin - incr ind_number; - min_constr_number := !min_constr_number + length; - !ind_number - end + (* We get the constant and the principle corresponding to this lemma *) + let f = funcs.(i) in + let graph_principle = + Reductionops.nf_zeta (Proofview.Goal.env g) (Proofview.Goal.sigma g) + (EConstr.of_constr schemes.(i)) in - let this_branche_ids = List.nth intro_pats (pred i) in - tclTHENLIST - [ (* we expand the definition of the function *) - observe_tac "rewrite_tac" - (rewrite_tac this_ind_number this_branche_ids) - ; (* introduce hypothesis with some rewrite *) - observe_tac "intros_with_rewrite (all)" intros_with_rewrite - ; (* The proof is (almost) complete *) - observe_tac "reflexivity" reflexivity_with_destruct_cases ] - g - in - let params_names = fst (List.chop princ_infos.nparams args_names) in - let open EConstr in - let params = List.map mkVar params_names in - tclTHENLIST - [ tclMAP - (fun id -> Proofview.V82.of_tactic (Simple.intro id)) - (args_names @ [res; hres]) - ; observe_tac "h_generalize" - (Proofview.V82.of_tactic - (generalize - [ mkApp - ( applist (graph_principle, params) - , Array.map (fun c -> applist (c, params)) lemmas ) ])) - ; Proofview.V82.of_tactic (Simple.intro graph_principle_id) - ; observe_tac "" - (tclTHEN_i - (observe_tac "elim" - (Proofview.V82.of_tactic - (elim false None - (mkVar hres, Tactypes.NoBindings) - (Some (mkVar graph_principle_id, Tactypes.NoBindings))))) - (fun i g -> observe_tac "prove_branche" (prove_branche i) g)) ] - g + tclTYPEOFTHEN graph_principle (fun sigma princ_type -> + let princ_infos = Tactics.compute_elim_sig sigma princ_type in + (* Then we get the number of argument of the function + and compute a fresh name for each of them + *) + let nb_fun_args = + Termops.nb_prod sigma (Proofview.Goal.concl g) - 2 + in + let args_names = + generate_fresh_id (Id.of_string "x") [] nb_fun_args + in + let ids = args_names @ pf_ids_of_hyps g in + (* and fresh names for res H and the principle (cf bug bug #1174) *) + let res, hres, graph_principle_id = + match generate_fresh_id (Id.of_string "z") ids 3 with + | [res; hres; graph_principle_id] -> (res, hres, graph_principle_id) + | _ -> assert false + in + let ids = res :: hres :: graph_principle_id :: ids in + (* we also compute fresh names for each hyptohesis of each branch + of the principle *) + let branches = List.rev princ_infos.branches in + let intro_pats = + List.map + (fun decl -> + List.map + (fun id -> id) + (generate_fresh_id (Id.of_string "y") ids + (Termops.nb_prod (Proofview.Goal.sigma g) + (RelDecl.get_type decl)))) + branches + in + (* We will need to change the function by its body + using [f_equation] if it is recursive (that is the graph is infinite + or unfold if the graph is finite + *) + let rewrite_tac j ids : unit Proofview.tactic = + let graph_def = graphs.(j) in + let infos = + match + find_Function_infos + (fst (destConst (Proofview.Goal.sigma g) funcs.(j))) + with + | None -> CErrors.user_err Pp.(str "No graph found") + | Some infos -> infos + in + if + infos.is_general + || Rtree.is_infinite Declareops.eq_recarg + graph_def.Declarations.mind_recargs + then + let eq_lemma = + try Option.get infos.equation_lemma + with Option.IsNone -> + CErrors.anomaly (Pp.str "Cannot find equation lemma.") + in + tclTHENLIST + [ tclMAP Simple.intro ids + ; Equality.rewriteLR (mkConst eq_lemma) + ; (* Don't forget to $\zeta$ normlize the term since the principles + have been $\zeta$-normalized *) + reduce + (Genredexpr.Cbv + {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl + ; generalize (List.map mkVar ids) + ; thin ids ] + else + unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalConstRef + (fst (destConst (Proofview.Goal.sigma g) f)) ) ] + in + (* The proof of each branche itself *) + let ind_number = ref 0 in + let min_constr_number = ref 0 in + let prove_branch i this_branche_ids = + (* we fist compute the inductive corresponding to the branch *) + let this_ind_number = + let constructor_num = i - !min_constr_number in + let length = + Array.length graphs.(!ind_number).Declarations.mind_consnames + in + if constructor_num <= length then !ind_number + else begin + incr ind_number; + min_constr_number := !min_constr_number + length; + !ind_number + end + in + tclTHENLIST + [ (* we expand the definition of the function *) + observe_tac "rewrite_tac" + (rewrite_tac this_ind_number this_branche_ids) + ; (* introduce hypothesis with some rewrite *) + observe_tac "intros_with_rewrite (all)" (intros_with_rewrite ()) + ; (* The proof is (almost) complete *) + observe_tac "reflexivity" (reflexivity_with_destruct_cases ()) + ] + in + let params_names = fst (List.chop princ_infos.nparams args_names) in + let open EConstr in + let params = List.map mkVar params_names in + tclTHENLIST + [ tclMAP Simple.intro (args_names @ [res; hres]) + ; observe_tac "h_generalize" + (generalize + [ mkApp + ( applist (graph_principle, params) + , Array.map (fun c -> applist (c, params)) lemmas ) ]) + ; Simple.intro graph_principle_id + ; observe_tac "" + (tclTHENS + (observe_tac "elim" + (elim false None + (mkVar hres, Tactypes.NoBindings) + (Some (mkVar graph_principle_id, Tactypes.NoBindings)))) + (List.map_i + (fun i pat -> + observe_tac "prove_branch" (prove_branch i pat)) + 1 intro_pats)) ])) exception No_graph_found @@ -1523,9 +1509,7 @@ let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) let info = Declare.Info.make () in let cinfo = Declare.CInfo.make ~name:lem_id ~typ () in let lemma = Declare.Proof.start ~cinfo ~info !evd in - let lemma = - fst @@ Declare.Proof.by (Proofview.V82.tactic (proving_tac i)) lemma - in + let lemma = fst @@ Declare.Proof.by (proving_tac i) lemma in let (_ : _ list) = Declare.Proof.save_regular ~proof:lemma ~opaque:Vernacexpr.Transparent ~idopt:None @@ -1592,10 +1576,9 @@ let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) let lemma = fst (Declare.Proof.by - (Proofview.V82.tactic - (observe_tac - ("prove completeness (" ^ Id.to_string f_id ^ ")") - (proving_tac i))) + (observe_tac + ("prove completeness (" ^ Id.to_string f_id ^ ")") + (proving_tac i)) lemma) in let (_ : _ list) = diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index af53f16e1f..0179215d6a 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -394,10 +394,7 @@ let jmeq_refl () = @@ Coqlib.lib_ref "core.JMeq.refl" with e when CErrors.noncritical e -> raise (ToShow e) -let h_intros l = - Proofview.V82.of_tactic - (Tacticals.New.tclMAP (fun x -> Tactics.Simple.intro x) l) - +let h_intros l = Tacticals.New.tclMAP (fun x -> Tactics.Simple.intro x) l let h_id = Id.of_string "h" let hrec_id = Id.of_string "hrec" @@ -428,13 +425,12 @@ let evaluable_of_global_reference r = | _ -> assert false let list_rewrite (rev : bool) (eqs : (EConstr.constr * bool) list) = - let open Tacticals in + let open Tacticals.New in (tclREPEAT (List.fold_right (fun (eq, b) i -> tclORELSE - (Proofview.V82.of_tactic - ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) + ((if b then Equality.rewriteLR else Equality.rewriteRL) eq) i) (if rev then List.rev eqs else eqs) (tclFAIL 0 (mt ()))) [@ocaml.warning "-3"]) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 396db55458..7b7044fdaf 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -90,7 +90,7 @@ exception Defining_principle of exn exception ToShow of exn val is_strict_tcc : unit -> bool -val h_intros : Names.Id.t list -> Tacmach.tactic +val h_intros : Names.Id.t list -> unit Proofview.tactic val h_id : Names.Id.t val hrec_id : Names.Id.t val acc_inv_id : EConstr.constr Util.delayed @@ -102,7 +102,7 @@ val well_founded : EConstr.constr Util.delayed val evaluable_of_global_reference : GlobRef.t -> Names.evaluable_global_reference -val list_rewrite : bool -> (EConstr.constr * bool) list -> Tacmach.tactic +val list_rewrite : bool -> (EConstr.constr * bool) list -> unit Proofview.tactic val decompose_lam_n : Evd.evar_map diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 066ade07d2..33076a876b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -23,8 +23,7 @@ open Nameops open CErrors open Util open UnivGen -open Tacticals -open Tacmach +open Tacticals.New open Tactics open Nametab open Tacred @@ -94,7 +93,7 @@ let const_of_ref = function (* Generic values *) let pf_get_new_ids idl g = - let ids = pf_ids_of_hyps g in + let ids = Tacmach.New.pf_ids_of_hyps g in let ids = Id.Set.of_list ids in List.fold_right (fun id acc -> @@ -105,8 +104,9 @@ let next_ident_away_in_goal ids avoid = next_ident_away_in_goal ids (Id.Set.of_list avoid) let compute_renamed_type gls id = - rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty - (*no rels*) [] (pf_get_hyp_typ gls id) + rename_bound_vars_as_displayed (Proofview.Goal.sigma gls) + (*no avoid*) Id.Set.empty (*no rels*) [] + (Tacmach.New.pf_get_hyp_typ id gls) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" @@ -218,20 +218,6 @@ let (declare_f : fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref) -let observe_tclTHENLIST s tacl = - if do_observe () then - let rec aux n = function - | [] -> tclIDTAC - | [tac] -> - observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac - | tac :: tacl -> - observe_tac - (fun env sigma -> s env sigma ++ spc () ++ int n) - (tclTHEN tac (aux (succ n) tacl)) - in - aux 0 tacl - else tclTHENLIST tacl - module New = struct open Tacticals.New @@ -364,11 +350,11 @@ type ('a, 'b) journey_info_tac = -> (* the arguments of the constructor *) 'b infos -> (* infos of the caller *) - ('b infos -> tactic) + ('b infos -> unit Proofview.tactic) -> (* the continuation tactic of the caller *) 'b infos -> (* argument of the tactic *) - tactic + unit Proofview.tactic (* journey_info : specifies the actions to do on the different term constructors during the traveling of the term *) @@ -376,7 +362,9 @@ type journey_info = { letiN : (Name.t * constr * types * constr, constr) journey_info_tac ; lambdA : (Name.t * types * constr, constr) journey_info_tac ; casE : - ((constr infos -> tactic) -> constr infos -> tactic) + ( (constr infos -> unit Proofview.tactic) + -> constr infos + -> unit Proofview.tactic) -> ( case_info * constr * (constr, EInstance.t) case_invert @@ -397,133 +385,131 @@ let add_vars sigma forbidden e = in aux forbidden e -let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = - fun g -> - let rev_context, b = decompose_lam_n (project g) nb_lam e in - let ids = - List.fold_left - (fun acc (na, _) -> - let pre_id = - match na.binder_name with Name x -> x | Anonymous -> ano_id - in - pre_id :: acc) - [] rev_context - in - let rev_ids = pf_get_new_ids (List.rev ids) g in - let new_b = substl (List.map mkVar rev_ids) b in - observe_tclTHENLIST - (fun _ _ -> str "treat_case1") - [ h_intros (List.rev rev_ids) - ; Proofview.V82.of_tactic - (intro_using_then teq_id (fun _ -> Proofview.tclUNIT ())) - ; onLastHypId (fun heq -> - observe_tclTHENLIST - (fun _ _ -> str "treat_case2") - [ Proofview.V82.of_tactic (clear to_intros) - ; h_intros to_intros - ; (fun g' -> - let ty_teq = pf_get_hyp_typ g' heq in - let teq_lhs, teq_rhs = - let _, args = - try destApp (project g') ty_teq - with DestKO -> assert false - in - (args.(1), args.(2)) - in - let new_b' = - Termops.replace_term (project g') teq_lhs teq_rhs new_b - in - let new_infos = - { infos with - info = new_b' - ; eqs = heq :: infos.eqs - ; forbidden_ids = - ( if forbid_new_ids then - add_vars (project g') infos.forbidden_ids new_b' - else infos.forbidden_ids ) } - in - finalize_tac new_infos g') ]) ] - g - -let rec travel_aux jinfo continuation_tac (expr_info : constr infos) g = - let sigma = project g in - let env = pf_env g in - match EConstr.kind sigma expr_info.info with - | CoFix _ | Fix _ -> - user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") - | Array _ -> user_err Pp.(str "Function cannot treat arrays") - | Proj _ -> user_err Pp.(str "Function cannot treat projections") - | LetIn (na, b, t, e) -> - let new_continuation_tac = - jinfo.letiN (na.binder_name, b, t, e) expr_info continuation_tac - in - travel jinfo new_continuation_tac - {expr_info with info = b; is_final = false} - g - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - | Prod _ -> ( - try - check_not_nested env sigma - (expr_info.f_id :: expr_info.forbidden_ids) - expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" - ( str "the term " - ++ Printer.pr_leconstr_env env sigma expr_info.info - ++ str " can not contain a recursive call to " - ++ Id.print expr_info.f_id ) ) - | Lambda (n, t, b) -> ( - try - check_not_nested env sigma - (expr_info.f_id :: expr_info.forbidden_ids) - expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" - ( str "the term " - ++ Printer.pr_leconstr_env env sigma expr_info.info - ++ str " can not contain a recursive call to " - ++ Id.print expr_info.f_id ) ) - | Case (ci, t, iv, a, l) -> - let continuation_tac_a = - jinfo.casE (travel jinfo) (ci, t, iv, a, l) expr_info continuation_tac - in - travel jinfo continuation_tac_a - {expr_info with info = a; is_main_branch = false; is_final = false} - g - | App _ -> ( - let f, args = decompose_app sigma expr_info.info in - if EConstr.eq_constr sigma f expr_info.f_constr then - jinfo.app_reC (f, args) expr_info continuation_tac expr_info g - else - match EConstr.kind sigma f with - | App _ -> assert false (* f is coming from a decompose_app *) - | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ - |Prod _ | Var _ -> - let new_infos = {expr_info with info = (f, args)} in +let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : + unit Proofview.tactic = + Proofview.Goal.enter (fun g -> + let rev_context, b = decompose_lam_n (Proofview.Goal.sigma g) nb_lam e in + let ids = + List.fold_left + (fun acc (na, _) -> + let pre_id = + match na.binder_name with Name x -> x | Anonymous -> ano_id + in + pre_id :: acc) + [] rev_context + in + let rev_ids = pf_get_new_ids (List.rev ids) g in + let new_b = substl (List.map mkVar rev_ids) b in + New.observe_tclTHENLIST + (fun _ _ -> str "treat_case1") + [ h_intros (List.rev rev_ids) + ; intro_using_then teq_id (fun _ -> Proofview.tclUNIT ()) + ; Tacticals.New.onLastHypId (fun heq -> + New.observe_tclTHENLIST + (fun _ _ -> str "treat_case2") + [ clear to_intros + ; h_intros to_intros + ; Proofview.Goal.enter (fun g' -> + let sigma = Proofview.Goal.sigma g' in + let ty_teq = Tacmach.New.pf_get_hyp_typ heq g' in + let teq_lhs, teq_rhs = + let _, args = + try destApp sigma ty_teq with DestKO -> assert false + in + (args.(1), args.(2)) + in + let new_b' = + Termops.replace_term sigma teq_lhs teq_rhs new_b + in + let new_infos = + { infos with + info = new_b' + ; eqs = heq :: infos.eqs + ; forbidden_ids = + ( if forbid_new_ids then + add_vars sigma infos.forbidden_ids new_b' + else infos.forbidden_ids ) } + in + finalize_tac new_infos) ]) ]) + +let rec travel_aux jinfo continuation_tac (expr_info : constr infos) = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let env = Proofview.Goal.env g in + match EConstr.kind sigma expr_info.info with + | CoFix _ | Fix _ -> + user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") + | Array _ -> user_err Pp.(str "Function cannot treat arrays") + | Proj _ -> user_err Pp.(str "Function cannot treat projections") + | LetIn (na, b, t, e) -> let new_continuation_tac = - jinfo.apP (f, args) expr_info continuation_tac + jinfo.letiN (na.binder_name, b, t, e) expr_info continuation_tac + in + travel jinfo new_continuation_tac + {expr_info with info = b; is_final = false} + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + | Prod _ -> ( + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info + with e when CErrors.noncritical e -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str " can not contain a recursive call to " + ++ Id.print expr_info.f_id ) ) + | Lambda (n, t, b) -> ( + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info + with e when CErrors.noncritical e -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str " can not contain a recursive call to " + ++ Id.print expr_info.f_id ) ) + | Case (ci, t, iv, a, l) -> + let continuation_tac_a = + jinfo.casE (travel jinfo) (ci, t, iv, a, l) expr_info continuation_tac in - travel_args jinfo expr_info.is_main_branch new_continuation_tac - new_infos g - | Case _ -> - user_err ~hdr:"Recdef.travel" - ( str "the term " - ++ Printer.pr_leconstr_env env sigma expr_info.info - ++ str - " can not contain an applied match (See Limitation in Section \ - 2.3 of refman)" ) - | _ -> - anomaly - ( Pp.str "travel_aux : unexpected " - ++ Printer.pr_leconstr_env env sigma expr_info.info - ++ Pp.str "." ) ) - | Cast (t, _, _) -> travel jinfo continuation_tac {expr_info with info = t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ - |Float _ -> - let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in - new_continuation_tac expr_info g + travel jinfo continuation_tac_a + {expr_info with info = a; is_main_branch = false; is_final = false} + | App _ -> ( + let f, args = decompose_app sigma expr_info.info in + if EConstr.eq_constr sigma f expr_info.f_constr then + jinfo.app_reC (f, args) expr_info continuation_tac expr_info + else + match EConstr.kind sigma f with + | App _ -> assert false (* f is coming from a decompose_app *) + | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ + |Prod _ | Var _ -> + let new_infos = {expr_info with info = (f, args)} in + let new_continuation_tac = + jinfo.apP (f, args) expr_info continuation_tac + in + travel_args jinfo expr_info.is_main_branch new_continuation_tac + new_infos + | Case _ -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str + " can not contain an applied match (See Limitation in \ + Section 2.3 of refman)" ) + | _ -> + anomaly + ( Pp.str "travel_aux : unexpected " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ Pp.str "." ) ) + | Cast (t, _, _) -> travel jinfo continuation_tac {expr_info with info = t} + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ + |Int _ | Float _ -> + let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in + new_continuation_tac expr_info) and travel_args jinfo is_final continuation_tac infos = let f_args', args = infos.info in @@ -538,139 +524,131 @@ and travel_args jinfo is_final continuation_tac infos = travel jinfo new_continuation_tac {infos with info = arg; is_final = false} and travel jinfo continuation_tac expr_info = - observe_tac + New.observe_tac (fun env sigma -> str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) -let rec prove_lt hyple g = - let sigma = project g in - begin - try - let varx, varz = - match decompose_app sigma (pf_concl g) with - | _, x :: z :: _ when isVar sigma x && isVar sigma z -> (x, z) - | _ -> assert false - in - let h = - List.find - (fun id -> - match decompose_app sigma (pf_get_hyp_typ g id) with - | _, t :: _ -> EConstr.eq_constr sigma t varx - | _ -> false) - hyple - in - let y = - List.hd (List.tl (snd (decompose_app sigma (pf_get_hyp_typ g h)))) - in - observe_tclTHENLIST - (fun _ _ -> str "prove_lt1") - [ Proofview.V82.of_tactic - (apply (mkApp (le_lt_trans (), [|varx; y; varz; mkVar h|]))) - ; observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) ] - with Not_found -> - observe_tclTHENLIST - (fun _ _ -> str "prove_lt2") - [ Proofview.V82.of_tactic (apply (delayed_force lt_S_n)) - ; observe_tac - (fun _ _ -> str "assumption: " ++ Printer.pr_goal g) - (Proofview.V82.of_tactic assumption) ] - end - g - -let rec destruct_bounds_aux infos (bound, hyple, rechyps) lbounds g = - match lbounds with - | [] -> - let ids = pf_ids_of_hyps g in - let s_max = mkApp (delayed_force coq_S, [|bound|]) in - let k = next_ident_away_in_goal k_id ids in - let ids = k :: ids in - let h' = next_ident_away_in_goal h'_id ids in - let ids = h' :: ids in - let def = next_ident_away_in_goal def_id ids in - observe_tclTHENLIST - (fun _ _ -> str "destruct_bounds_aux1") - [ Proofview.V82.of_tactic (split (ImplicitBindings [s_max])) - ; Proofview.V82.of_tactic - (intro_then (fun id -> - Proofview.V82.tactic - (observe_tac - (fun _ _ -> str "destruct_bounds_aux") - (tclTHENS - (Proofview.V82.of_tactic (simplest_case (mkVar id))) - [ observe_tclTHENLIST - (fun _ _ -> str "") - [ Proofview.V82.of_tactic - (intro_using_then h_id - (* We don't care about the refreshed name, - accessed only through auto? *) - (fun _ -> Proofview.tclUNIT ())) - ; Proofview.V82.of_tactic - (simplest_elim - (mkApp (delayed_force lt_n_O, [|s_max|]))) - ; Proofview.V82.of_tactic default_full_auto ] - ; observe_tclTHENLIST - (fun _ _ -> str "destruct_bounds_aux2") - [ observe_tac - (fun _ _ -> str "clearing k ") - (Proofview.V82.of_tactic (clear [id])) - ; h_intros [k; h'; def] - ; observe_tac - (fun _ _ -> str "simple_iter") - (Proofview.V82.of_tactic - (simpl_iter Locusops.onConcl)) - ; observe_tac - (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.OnlyOccurrences [1] - , evaluable_of_global_reference - infos.func ) ])) - ; observe_tclTHENLIST - (fun _ _ -> str "test") - [ list_rewrite true - (List.fold_right - (fun e acc -> (mkVar e, true) :: acc) - infos.eqs - (List.map (fun e -> (e, true)) rechyps)) - ; (* list_rewrite true *) - (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) - (* ; *) - observe_tac - (fun _ _ -> str "finishing") - (tclORELSE - (Proofview.V82.of_tactic - intros_reflexivity) - (observe_tac - (fun _ _ -> str "calling prove_lt") - (prove_lt hyple))) ] ] ])))) ] - g - | (_, v_bound) :: l -> - observe_tclTHENLIST - (fun _ _ -> str "destruct_bounds_aux3") - [ Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)) - ; Proofview.V82.of_tactic (clear [v_bound]) - ; tclDO 2 (Proofview.V82.of_tactic intro) - ; onNthHypId 1 (fun p_hyp -> - onNthHypId 2 (fun p -> - observe_tclTHENLIST - (fun _ _ -> str "destruct_bounds_aux4") - [ Proofview.V82.of_tactic - (simplest_elim - (mkApp (delayed_force max_constr, [|bound; mkVar p|]))) - ; tclDO 3 (Proofview.V82.of_tactic intro) - ; onNLastHypsId 3 (fun lids -> - match lids with - | [hle2; hle1; pmax] -> - destruct_bounds_aux infos - ( mkVar pmax - , hle1 :: hle2 :: hyple - , mkVar p_hyp :: rechyps ) - l - | _ -> assert false) ])) ] - g +let rec prove_lt hyple = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + try + let varx, varz = + match decompose_app sigma (Proofview.Goal.concl g) with + | _, x :: z :: _ when isVar sigma x && isVar sigma z -> (x, z) + | _ -> assert false + in + let h = + List.find + (fun id -> + match decompose_app sigma (Tacmach.New.pf_get_hyp_typ id g) with + | _, t :: _ -> EConstr.eq_constr sigma t varx + | _ -> false) + hyple + in + let y = + List.hd + (List.tl + (snd (decompose_app sigma (Tacmach.New.pf_get_hyp_typ h g)))) + in + New.observe_tclTHENLIST + (fun _ _ -> str "prove_lt1") + [ apply (mkApp (le_lt_trans (), [|varx; y; varz; mkVar h|])) + ; New.observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) ] + with Not_found -> + New.observe_tclTHENLIST + (fun _ _ -> str "prove_lt2") + [ apply (delayed_force lt_S_n) + ; New.observe_tac + (fun _ _ -> + str "assumption: " + ++ Printer.pr_goal Evd.{it = Proofview.Goal.goal g; sigma}) + assumption ]) + +let rec destruct_bounds_aux infos (bound, hyple, rechyps) lbounds = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + match lbounds with + | [] -> + let ids = Tacmach.New.pf_ids_of_hyps g in + let s_max = mkApp (delayed_force coq_S, [|bound|]) in + let k = next_ident_away_in_goal k_id ids in + let ids = k :: ids in + let h' = next_ident_away_in_goal h'_id ids in + let ids = h' :: ids in + let def = next_ident_away_in_goal def_id ids in + New.observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux1") + [ split (ImplicitBindings [s_max]) + ; intro_then (fun id -> + New.observe_tac + (fun _ _ -> str "destruct_bounds_aux") + (tclTHENS + (simplest_case (mkVar id)) + [ New.observe_tclTHENLIST + (fun _ _ -> str "") + [ intro_using_then h_id + (* We don't care about the refreshed name, + accessed only through auto? *) + (fun _ -> Proofview.tclUNIT ()) + ; simplest_elim + (mkApp (delayed_force lt_n_O, [|s_max|])) + ; default_full_auto ] + ; New.observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux2") + [ New.observe_tac + (fun _ _ -> str "clearing k ") + (clear [id]) + ; h_intros [k; h'; def] + ; New.observe_tac + (fun _ _ -> str "simple_iter") + (simpl_iter Locusops.onConcl) + ; New.observe_tac + (fun _ _ -> str "unfold functional") + (unfold_in_concl + [ ( Locus.OnlyOccurrences [1] + , evaluable_of_global_reference infos.func ) + ]) + ; New.observe_tclTHENLIST + (fun _ _ -> str "test") + [ list_rewrite true + (List.fold_right + (fun e acc -> (mkVar e, true) :: acc) + infos.eqs + (List.map (fun e -> (e, true)) rechyps)) + ; (* list_rewrite true *) + (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) + (* ; *) + New.observe_tac + (fun _ _ -> str "finishing") + (tclORELSE intros_reflexivity + (New.observe_tac + (fun _ _ -> str "calling prove_lt") + (prove_lt hyple))) ] ] ])) ] + | (_, v_bound) :: l -> + New.observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux3") + [ simplest_elim (mkVar v_bound) + ; clear [v_bound] + ; tclDO 2 intro + ; onNthHypId 1 (fun p_hyp -> + onNthHypId 2 (fun p -> + New.observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux4") + [ simplest_elim + (mkApp (delayed_force max_constr, [|bound; mkVar p|])) + ; tclDO 3 intro + ; onNLastHypsId 3 (fun lids -> + match lids with + | [hle2; hle1; pmax] -> + destruct_bounds_aux infos + ( mkVar pmax + , hle1 :: hle2 :: hyple + , mkVar p_hyp :: rechyps ) + l + | _ -> assert false) ])) ]) let destruct_bounds infos = destruct_bounds_aux infos @@ -679,47 +657,51 @@ let destruct_bounds infos = let terminate_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "terminate_app1") [ continuation_tac infos - ; observe_tac + ; New.observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))) - ; observe_tac + (split (ImplicitBindings [infos.info])) + ; New.observe_tac (fun _ _ -> str "destruct_bounds (1)") (destruct_bounds infos) ] else continuation_tac infos let terminate_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "terminate_others") [ continuation_tac infos - ; observe_tac + ; New.observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))) - ; observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) - ] + (split (ImplicitBindings [infos.info])) + ; New.observe_tac + (fun _ _ -> str "destruct_bounds") + (destruct_bounds infos) ] else continuation_tac infos -let terminate_letin (na, b, t, e) expr_info continuation_tac info g = - let sigma = project g in - let env = pf_env g in - let new_e = subst1 info.info e in - let new_forbidden = - let forbid = - try - check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids) b; - true - with e when CErrors.noncritical e -> false - in - if forbid then - match na with - | Anonymous -> info.forbidden_ids - | Name id -> id :: info.forbidden_ids - else info.forbidden_ids - in - continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} g +let terminate_letin (na, b, t, e) expr_info continuation_tac info = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let env = Proofview.Goal.env g in + let new_e = subst1 info.info e in + let new_forbidden = + let forbid = + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + b; + true + with e when CErrors.noncritical e -> false + in + if forbid then + match na with + | Anonymous -> info.forbidden_ids + | Name id -> id :: info.forbidden_ids + else info.forbidden_ids + in + continuation_tac {info with info = new_e; forbidden_ids = new_forbidden}) let pf_type c tac = let open Tacticals.New in @@ -729,9 +711,6 @@ let pf_type c tac = let evars, ty = Typing.type_of env sigma c in tclTHEN (Proofview.Unsafe.tclEVARS evars) (tac ty)) -let pf_type c tac = - Proofview.V82.of_tactic (pf_type c (fun ty -> Proofview.V82.tactic (tac ty))) - let pf_typel l tac = let rec aux tys l = match l with @@ -745,8 +724,8 @@ let pf_typel l tac = modified hypotheses are generalized in the process and should be introduced back later; the result is the pair of the tactic and the list of hypotheses that have been generalized and cleared. *) -let mkDestructEq not_on_hyp expr g = - let hyps = pf_hyps g in +let mkDestructEq not_on_hyp env sigma expr = + let hyps = EConstr.named_context env in let to_revert = Util.List.map_filter (fun decl -> @@ -754,173 +733,169 @@ let mkDestructEq not_on_hyp expr g = let id = get_id decl in if Id.List.mem id not_on_hyp - || not (Termops.dependent (project g) expr (get_type decl)) + || not (Termops.dependent sigma expr (get_type decl)) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in - let g, type_of_expr = tac_type_of g expr in + let sigma, type_of_expr = Typing.type_of env sigma expr in let new_hyps = mkApp (Lazy.force refl_equal, [|type_of_expr; expr|]) :: to_revert_constr in let tac = pf_typel new_hyps (fun _ -> - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "mkDestructEq") - [ Proofview.V82.of_tactic (generalize new_hyps) - ; (fun g2 -> - 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 ~check:true None changefun) - g2) - ; Proofview.V82.of_tactic (simplest_case expr) ]) + [ generalize new_hyps + ; Proofview.Goal.enter (fun g2 -> + let changefun patvars env sigma = + pattern_occs + [(Locus.AllOccurrencesBut [1], expr)] + (Proofview.Goal.env g2) sigma (Proofview.Goal.concl g2) + in + change_in_concl ~check:true None changefun) + ; simplest_case expr ]) in - (g, tac, to_revert) + (sigma, tac, to_revert) let terminate_case next_step (ci, a, iv, t, l) expr_info continuation_tac infos - g = - let sigma = project g in - let env = pf_env g in - let f_is_present = - try - check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids) a; - false - with e when CErrors.noncritical e -> true - in - let a' = infos.info in - let new_info = - { infos with - info = mkCase (ci, t, iv, a', l) - ; is_main_branch = expr_info.is_main_branch - ; is_final = expr_info.is_final } - in - let g, destruct_tac, rev_to_thin_intro = - mkDestructEq [expr_info.rec_arg_id] a' g - in - let to_thin_intro = List.rev rev_to_thin_intro in - observe_tac - (fun _ _ -> - str "treating cases (" - ++ int (Array.length l) - ++ str ")" ++ spc () - ++ Printer.pr_leconstr_env (pf_env g) sigma a') - ( try - tclTHENS destruct_tac - (List.map_i - (fun i e -> - observe_tac - (fun _ _ -> str "do treat case") - (treat_case f_is_present to_thin_intro - (next_step continuation_tac) - ci.ci_cstr_ndecls.(i) e new_info)) - 0 (Array.to_list l)) - with - | UserError (Some "Refiner.thensn_tac3", _) - |UserError (Some "Refiner.tclFAIL_s", _) - -> - observe_tac - (fun _ _ -> - str "is computable " - ++ Printer.pr_leconstr_env env sigma new_info.info) - (next_step continuation_tac - { new_info with - info = - Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info }) - ) - g - -let terminate_app_rec (f, args) expr_info continuation_tac _ g = - let sigma = project g in - let env = pf_env g in - List.iter - (check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids)) - args; - try - let v = - List.assoc_f - (List.equal (EConstr.eq_constr sigma)) - args expr_info.args_assoc - in - let new_infos = {expr_info with info = v} in - observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec") - [ continuation_tac new_infos - ; ( if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec1") - [ observe_tac - (fun _ _ -> str "first split") - (Proofview.V82.of_tactic - (split (ImplicitBindings [new_infos.info]))) - ; observe_tac - (fun _ _ -> str "destruct_bounds (3)") - (destruct_bounds new_infos) ] - else tclIDTAC ) ] - g - with Not_found -> - observe_tac - (fun _ _ -> str "terminate_app_rec not found") - (tclTHENS - (Proofview.V82.of_tactic - (simplest_elim (mkApp (mkVar expr_info.ih, Array.of_list args)))) - [ observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec2") - [ Proofview.V82.of_tactic - (intro_using_then rec_res_id - (* refreshed name gotten from onNthHypId *) - (fun _ -> Proofview.tclUNIT ())) - ; Proofview.V82.of_tactic intro - ; onNthHypId 1 (fun v_bound -> - onNthHypId 2 (fun v -> - let new_infos = - { expr_info with - info = mkVar v - ; values_and_bounds = - (v, v_bound) :: expr_info.values_and_bounds - ; args_assoc = (args, mkVar v) :: expr_info.args_assoc - } - in - observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec3") - [ continuation_tac new_infos - ; ( if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec4") - [ observe_tac - (fun _ _ -> str "first split") - (Proofview.V82.of_tactic - (split - (ImplicitBindings [new_infos.info]))) - ; observe_tac - (fun _ _ -> str "destruct_bounds (2)") - (destruct_bounds new_infos) ] - else tclIDTAC ) ])) ] - ; observe_tac - (fun _ _ -> str "proving decreasing") - (tclTHENS (* proof of args < formal args *) - (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) - [ observe_tac - (fun _ _ -> str "assumption") - (Proofview.V82.of_tactic assumption) - ; observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec5") - [ tclTRY - (list_rewrite true - (List.map (fun e -> (mkVar e, true)) expr_info.eqs)) - ; Proofview.V82.of_tactic - @@ tclUSER expr_info.concl_tac true - (Some - ( expr_info.ih :: expr_info.acc_id - :: (fun (x, y) -> y) - (List.split expr_info.values_and_bounds) )) - ] ]) ]) - g + = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let env = Proofview.Goal.env g in + let f_is_present = + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + a; + false + with e when CErrors.noncritical e -> true + in + let a' = infos.info in + let new_info = + { infos with + info = mkCase (ci, t, iv, a', l) + ; is_main_branch = expr_info.is_main_branch + ; is_final = expr_info.is_final } + in + let sigma, destruct_tac, rev_to_thin_intro = + mkDestructEq [expr_info.rec_arg_id] env sigma a' + in + let to_thin_intro = List.rev rev_to_thin_intro in + New.observe_tac + (fun _ _ -> + str "treating cases (" + ++ int (Array.length l) + ++ str ")" ++ spc () + ++ Printer.pr_leconstr_env env sigma a') + ( try + tclTHENS destruct_tac + (List.map_i + (fun i e -> + New.observe_tac + (fun _ _ -> str "do treat case") + (treat_case f_is_present to_thin_intro + (next_step continuation_tac) + ci.ci_cstr_ndecls.(i) e new_info)) + 0 (Array.to_list l)) + with + | UserError (Some "Refiner.thensn_tac3", _) + |UserError (Some "Refiner.tclFAIL_s", _) + -> + New.observe_tac + (fun _ _ -> + str "is computable " + ++ Printer.pr_leconstr_env env sigma new_info.info) + (next_step continuation_tac + { new_info with + info = Reductionops.nf_betaiotazeta env sigma new_info.info + }) )) + +let terminate_app_rec (f, args) expr_info continuation_tac _ = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let env = Proofview.Goal.env g in + List.iter + (check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids)) + args; + try + let v = + List.assoc_f + (List.equal (EConstr.eq_constr sigma)) + args expr_info.args_assoc + in + let new_infos = {expr_info with info = v} in + New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec") + [ continuation_tac new_infos + ; ( if expr_info.is_final && expr_info.is_main_branch then + New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec1") + [ New.observe_tac + (fun _ _ -> str "first split") + (split (ImplicitBindings [new_infos.info])) + ; New.observe_tac + (fun _ _ -> str "destruct_bounds (3)") + (destruct_bounds new_infos) ] + else Proofview.tclUNIT () ) ] + with Not_found -> + New.observe_tac + (fun _ _ -> str "terminate_app_rec not found") + (tclTHENS + (simplest_elim (mkApp (mkVar expr_info.ih, Array.of_list args))) + [ New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec2") + [ intro_using_then rec_res_id + (* refreshed name gotten from onNthHypId *) + (fun _ -> Proofview.tclUNIT ()) + ; intro + ; onNthHypId 1 (fun v_bound -> + onNthHypId 2 (fun v -> + let new_infos = + { expr_info with + info = mkVar v + ; values_and_bounds = + (v, v_bound) :: expr_info.values_and_bounds + ; args_assoc = + (args, mkVar v) :: expr_info.args_assoc } + in + New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec3") + [ continuation_tac new_infos + ; ( if + expr_info.is_final && expr_info.is_main_branch + then + New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec4") + [ New.observe_tac + (fun _ _ -> str "first split") + (split + (ImplicitBindings [new_infos.info])) + ; New.observe_tac + (fun _ _ -> str "destruct_bounds (2)") + (destruct_bounds new_infos) ] + else Proofview.tclUNIT () ) ])) ] + ; New.observe_tac + (fun _ _ -> str "proving decreasing") + (tclTHENS (* proof of args < formal args *) + (apply (Lazy.force expr_info.acc_inv)) + [ New.observe_tac (fun _ _ -> str "assumption") assumption + ; New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec5") + [ tclTRY + (list_rewrite true + (List.map + (fun e -> (mkVar e, true)) + expr_info.eqs)) + ; tclUSER expr_info.concl_tac true + (Some + ( expr_info.ih :: expr_info.acc_id + :: (fun (x, y) -> y) + (List.split expr_info.values_and_bounds) )) + ] ]) ])) let terminate_info = { message = "prove_terminate with term " @@ -936,194 +911,197 @@ let prove_terminate = travel terminate_info (* Equation proof *) let equation_case next_step case expr_info continuation_tac infos = - observe_tac + New.observe_tac (fun _ _ -> str "equation case") (terminate_case next_step case expr_info continuation_tac infos) -let rec prove_le g = - let sigma = project g in - let x, z = - let _, args = decompose_app sigma (pf_concl g) in - (List.hd args, List.hd (List.tl args)) - in - tclFIRST - [ Proofview.V82.of_tactic assumption - ; Proofview.V82.of_tactic (apply (delayed_force le_n)) - ; begin - try - let matching_fun c = - match EConstr.kind sigma c with - | App (c, [|x0; _|]) -> - EConstr.isVar sigma x0 - && Id.equal (destVar sigma x0) (destVar sigma x) - && EConstr.isRefX sigma (le ()) c - | _ -> false - in - let h, t = - List.find (fun (_, t) -> matching_fun t) (pf_hyps_types g) - in - let h = h.binder_name in - let y = - let _, args = decompose_app sigma t in - List.hd (List.tl args) - in - observe_tclTHENLIST - (fun _ _ -> str "prove_le") - [ Proofview.V82.of_tactic - (apply (mkApp (le_trans (), [|x; y; z; mkVar h|]))) - ; observe_tac (fun _ _ -> str "prove_le (rec)") prove_le ] - with Not_found -> tclFAIL 0 (mt ()) - end ] - g +let rec prove_le () = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let x, z = + let _, args = decompose_app sigma (Proofview.Goal.concl g) in + (List.hd args, List.hd (List.tl args)) + in + tclFIRST + [ assumption + ; apply (delayed_force le_n) + ; begin + try + let matching_fun c = + match EConstr.kind sigma c with + | App (c, [|x0; _|]) -> + EConstr.isVar sigma x0 + && Id.equal (destVar sigma x0) (destVar sigma x) + && EConstr.isRefX sigma (le ()) c + | _ -> false + in + let h, t = + List.find + (fun (_, t) -> matching_fun t) + (Tacmach.New.pf_hyps_types g) + in + let y = + let _, args = decompose_app sigma t in + List.hd (List.tl args) + in + New.observe_tclTHENLIST + (fun _ _ -> str "prove_le") + [ apply (mkApp (le_trans (), [|x; y; z; mkVar h|])) + ; New.observe_tac + (fun _ _ -> str "prove_le (rec)") + (prove_le ()) ] + with Not_found -> Tacticals.New.tclFAIL 0 (mt ()) + end ]) let rec make_rewrite_list expr_info max = function - | [] -> tclIDTAC + | [] -> Proofview.tclUNIT () | (_, p, hp) :: l -> - observe_tac + let open Tacticals.New in + New.observe_tac (fun _ _ -> str "make_rewrite_list") (tclTHENS - (observe_tac + (New.observe_tac (fun _ _ -> str "rewrite heq on " ++ Id.print p) - (fun g -> - let sigma = project g in - let t_eq = compute_renamed_type g hp in - let k, def = - let k_na, _, t = destProd sigma t_eq in - let _, _, t = destProd sigma t in - let def_na, _, _ = destProd sigma t in - ( Nameops.Name.get_id k_na.binder_name - , Nameops.Name.get_id def_na.binder_name ) - in - Proofview.V82.of_tactic - (general_rewrite_bindings false Locus.AllOccurrences true + (Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let t_eq = compute_renamed_type g hp in + let k, def = + let k_na, _, t = destProd sigma t_eq in + let _, _, t = destProd sigma t in + let def_na, _, _ = destProd sigma t in + ( Nameops.Name.get_id k_na.binder_name + , Nameops.Name.get_id def_na.binder_name ) + in + general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true ( mkVar hp , ExplicitBindings [ CAst.make @@ (NamedHyp def, expr_info.f_constr) ; CAst.make @@ (NamedHyp k, f_S max) ] ) - false) - g)) + false))) [ make_rewrite_list expr_info max l - ; observe_tclTHENLIST + ; New.observe_tclTHENLIST (fun _ _ -> str "make_rewrite_list") [ (* x < S max proof *) - Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)) - ; observe_tac (fun _ _ -> str "prove_le(2)") prove_le ] ]) + apply (delayed_force le_lt_n_Sm) + ; New.observe_tac (fun _ _ -> str "prove_le(2)") (prove_le ()) ] ]) let make_rewrite expr_info l hp max = + let open Tacticals.New in tclTHENFIRST - (observe_tac + (New.observe_tac (fun _ _ -> str "make_rewrite") (make_rewrite_list expr_info max l)) - (observe_tac + (New.observe_tac (fun _ _ -> str "make_rewrite") (tclTHENS - (fun g -> - let sigma = project g in - let t_eq = compute_renamed_type g hp in - let k, def = - let k_na, _, t = destProd sigma t_eq in - let _, _, t = destProd sigma t in - let def_na, _, _ = destProd sigma t in - ( Nameops.Name.get_id k_na.binder_name - , Nameops.Name.get_id def_na.binder_name ) - in - observe_tac - (fun _ _ -> str "general_rewrite_bindings") - (Proofview.V82.of_tactic + (Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let t_eq = compute_renamed_type g hp in + let k, def = + let k_na, _, t = destProd sigma t_eq in + let _, _, t = destProd sigma t in + let def_na, _, _ = destProd sigma t in + ( Nameops.Name.get_id k_na.binder_name + , Nameops.Name.get_id def_na.binder_name ) + in + New.observe_tac + (fun _ _ -> str "general_rewrite_bindings") (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true ( mkVar hp , ExplicitBindings [ CAst.make @@ (NamedHyp def, expr_info.f_constr) ; CAst.make @@ (NamedHyp k, f_S (f_S max)) ] ) - false)) - g) - [ observe_tac + false))) + [ New.observe_tac (fun _ _ -> str "make_rewrite finalize") ((* tclORELSE( h_reflexivity) *) - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "make_rewrite") - [ Proofview.V82.of_tactic (simpl_iter Locusops.onConcl) - ; observe_tac + [ simpl_iter Locusops.onConcl + ; New.observe_tac (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.OnlyOccurrences [1] - , evaluable_of_global_reference expr_info.func ) ])) + (unfold_in_concl + [ ( Locus.OnlyOccurrences [1] + , evaluable_of_global_reference expr_info.func ) ]) ; list_rewrite true (List.map (fun e -> (mkVar e, true)) expr_info.eqs) - ; observe_tac + ; New.observe_tac (fun _ _ -> str "h_reflexivity") - (Proofview.V82.of_tactic intros_reflexivity) ]) - ; observe_tclTHENLIST + intros_reflexivity ]) + ; New.observe_tclTHENLIST (fun _ _ -> str "make_rewrite1") [ (* x < S (S max) proof *) - Proofview.V82.of_tactic - (apply (EConstr.of_constr (delayed_force le_lt_SS))) - ; observe_tac (fun _ _ -> str "prove_le (3)") prove_le ] ])) + apply (EConstr.of_constr (delayed_force le_lt_SS)) + ; New.observe_tac (fun _ _ -> str "prove_le (3)") (prove_le ()) ] + ])) let rec compute_max rew_tac max l = match l with | [] -> rew_tac max | (_, p, _) :: l -> - observe_tclTHENLIST + let open Tacticals.New in + New.observe_tclTHENLIST (fun _ _ -> str "compute_max") - [ Proofview.V82.of_tactic - (simplest_elim (mkApp (delayed_force max_constr, [|max; mkVar p|]))) - ; tclDO 3 (Proofview.V82.of_tactic intro) + [ simplest_elim (mkApp (delayed_force max_constr, [|max; mkVar p|])) + ; tclDO 3 intro ; onNLastHypsId 3 (fun lids -> match lids with | [hle2; hle1; pmax] -> compute_max rew_tac (mkVar pmax) l | _ -> assert false) ] let rec destruct_hex expr_info acc l = + let open Tacticals.New in match l with | [] -> ( match List.rev acc with - | [] -> tclIDTAC + | [] -> Proofview.tclUNIT () | (_, p, hp) :: tl -> - observe_tac + New.observe_tac (fun _ _ -> str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) ) | (v, hex) :: l -> - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "destruct_hex") - [ Proofview.V82.of_tactic (simplest_case (mkVar hex)) - ; Proofview.V82.of_tactic (clear [hex]) - ; tclDO 2 (Proofview.V82.of_tactic intro) + [ simplest_case (mkVar hex) + ; clear [hex] + ; tclDO 2 intro ; onNthHypId 1 (fun hp -> onNthHypId 2 (fun p -> - observe_tac + New.observe_tac (fun _ _ -> str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) (destruct_hex expr_info ((v, p, hp) :: acc) l))) ] let rec intros_values_eq expr_info acc = + let open Tacticals.New in tclORELSE - (observe_tclTHENLIST + (New.observe_tclTHENLIST (fun _ _ -> str "intros_values_eq") - [ tclDO 2 (Proofview.V82.of_tactic intro) + [ tclDO 2 intro ; onNthHypId 1 (fun hex -> onNthHypId 2 (fun v -> intros_values_eq expr_info ((v, hex) :: acc))) ]) (tclCOMPLETE (destruct_hex expr_info [] acc)) let equation_others _ expr_info continuation_tac infos = + let open Tacticals.New in if expr_info.is_final && expr_info.is_main_branch then - observe_tac + New.observe_tac (fun env sigma -> str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (tclTHEN (continuation_tac infos) - (observe_tac + (New.observe_tac (fun env sigma -> str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []))) else - observe_tac + New.observe_tac (fun env sigma -> str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) @@ -1131,47 +1109,46 @@ let equation_others _ expr_info continuation_tac infos = let equation_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tac + New.observe_tac (fun _ _ -> str "intros_values_eq equation_app") (intros_values_eq expr_info []) else continuation_tac infos -let equation_app_rec (f, args) expr_info continuation_tac info g = - let sigma = project g in - try - let v = - List.assoc_f - (List.equal (EConstr.eq_constr sigma)) - args expr_info.args_assoc - in - let new_infos = {expr_info with info = v} in - observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g - with Not_found -> - if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST - (fun _ _ -> str "equation_app_rec") - [ Proofview.V82.of_tactic - (simplest_case (mkApp (expr_info.f_terminate, Array.of_list args))) - ; continuation_tac - { expr_info with - args_assoc = (args, delayed_force coq_O) :: expr_info.args_assoc - } - ; observe_tac - (fun _ _ -> str "app_rec intros_values_eq") - (intros_values_eq expr_info []) ] - g - else - observe_tclTHENLIST - (fun _ _ -> str "equation_app_rec1") - [ Proofview.V82.of_tactic - (simplest_case (mkApp (expr_info.f_terminate, Array.of_list args))) - ; observe_tac - (fun _ _ -> str "app_rec not_found") - (continuation_tac - { expr_info with - args_assoc = - (args, delayed_force coq_O) :: expr_info.args_assoc }) ] - g +let equation_app_rec (f, args) expr_info continuation_tac info = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + try + let v = + List.assoc_f + (List.equal (EConstr.eq_constr sigma)) + args expr_info.args_assoc + in + let new_infos = {expr_info with info = v} in + New.observe_tac + (fun _ _ -> str "app_rec found") + (continuation_tac new_infos) + with Not_found -> + if expr_info.is_final && expr_info.is_main_branch then + New.observe_tclTHENLIST + (fun _ _ -> str "equation_app_rec") + [ simplest_case (mkApp (expr_info.f_terminate, Array.of_list args)) + ; continuation_tac + { expr_info with + args_assoc = + (args, delayed_force coq_O) :: expr_info.args_assoc } + ; New.observe_tac + (fun _ _ -> str "app_rec intros_values_eq") + (intros_values_eq expr_info []) ] + else + New.observe_tclTHENLIST + (fun _ _ -> str "equation_app_rec1") + [ simplest_case (mkApp (expr_info.f_terminate, Array.of_list args)) + ; New.observe_tac + (fun _ _ -> str "app_rec not_found") + (continuation_tac + { expr_info with + args_assoc = + (args, delayed_force coq_O) :: expr_info.args_assoc }) ]) let equation_info = { message = "prove_equation with term " @@ -1231,73 +1208,68 @@ let compute_terminate_type nb_args func = compose_prod rev_args value let termination_proof_header is_mes input_type ids args_id relation rec_arg_num - rec_arg_id tac wf_tac : tactic = - fun g -> - let nargs = List.length args_id in - let pre_rec_args = - List.rev_map mkVar (fst (List.chop (rec_arg_num - 1) args_id)) - in - let relation = substl pre_rec_args relation in - let input_type = substl pre_rec_args input_type in - let wf_thm = next_ident_away_in_goal (Id.of_string "wf_R") ids in - let wf_rec_arg = - next_ident_away_in_goal - (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)) - (wf_thm :: ids) - in - let hrec = next_ident_away_in_goal hrec_id (wf_rec_arg :: wf_thm :: ids) in - let acc_inv = - lazy - (mkApp - (delayed_force acc_inv_id, [|input_type; relation; mkVar rec_arg_id|])) - in - tclTHEN (h_intros args_id) - (tclTHENS - (observe_tac - (fun _ _ -> str "first assert") - (Proofview.V82.of_tactic - (assert_before (Name wf_rec_arg) - (mkApp - ( delayed_force acc_rel - , [|input_type; relation; mkVar rec_arg_id|] ))))) - [ (* accesibility proof *) - tclTHENS - (observe_tac - (fun _ _ -> str "second assert") - (Proofview.V82.of_tactic - (assert_before (Name wf_thm) - (mkApp - (delayed_force well_founded, [|input_type; relation|]))))) - [ (* interactive proof that the relation is well_founded *) - observe_tac - (fun _ _ -> str "wf_tac") - (wf_tac is_mes (Some args_id)) - ; (* this gives the accessibility argument *) - observe_tac - (fun _ _ -> str "apply wf_thm") - (Proofview.V82.of_tactic - (Simple.apply (mkApp (mkVar wf_thm, [|mkVar rec_arg_id|])))) - ] - ; (* rest of the proof *) - observe_tclTHENLIST - (fun _ _ -> str "rest of proof") - [ observe_tac - (fun _ _ -> str "generalize") - (onNLastHypsId (nargs + 1) - (tclMAP (fun id -> - tclTHEN - (Proofview.V82.of_tactic - (Tactics.generalize [mkVar id])) - (Proofview.V82.of_tactic (clear [id]))))) - ; observe_tac - (fun _ _ -> str "fix") - (Proofview.V82.of_tactic (fix hrec (nargs + 1))) - ; h_intros args_id - ; Proofview.V82.of_tactic (Simple.intro wf_rec_arg) - ; observe_tac - (fun _ _ -> str "tac") - (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ]) - g + rec_arg_id tac wf_tac : unit Proofview.tactic = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let nargs = List.length args_id in + let pre_rec_args = + List.rev_map mkVar (fst (List.chop (rec_arg_num - 1) args_id)) + in + let relation = substl pre_rec_args relation in + let input_type = substl pre_rec_args input_type in + let wf_thm = next_ident_away_in_goal (Id.of_string "wf_R") ids in + let wf_rec_arg = + next_ident_away_in_goal + (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)) + (wf_thm :: ids) + in + let hrec = + next_ident_away_in_goal hrec_id (wf_rec_arg :: wf_thm :: ids) + in + let acc_inv = + lazy + (mkApp + ( delayed_force acc_inv_id + , [|input_type; relation; mkVar rec_arg_id|] )) + in + tclTHEN (h_intros args_id) + (tclTHENS + (New.observe_tac + (fun _ _ -> str "first assert") + (assert_before (Name wf_rec_arg) + (mkApp + ( delayed_force acc_rel + , [|input_type; relation; mkVar rec_arg_id|] )))) + [ (* accesibility proof *) + tclTHENS + (New.observe_tac + (fun _ _ -> str "second assert") + (assert_before (Name wf_thm) + (mkApp + (delayed_force well_founded, [|input_type; relation|])))) + [ (* interactive proof that the relation is well_founded *) + New.observe_tac + (fun _ _ -> str "wf_tac") + (wf_tac is_mes (Some args_id)) + ; (* this gives the accessibility argument *) + New.observe_tac + (fun _ _ -> str "apply wf_thm") + (Simple.apply (mkApp (mkVar wf_thm, [|mkVar rec_arg_id|]))) + ] + ; (* rest of the proof *) + New.observe_tclTHENLIST + (fun _ _ -> str "rest of proof") + [ New.observe_tac + (fun _ _ -> str "generalize") + (onNLastHypsId (nargs + 1) + (tclMAP (fun id -> + tclTHEN (Tactics.generalize [mkVar id]) (clear [id])))) + ; New.observe_tac (fun _ _ -> str "fix") (fix hrec (nargs + 1)) + ; h_intros args_id + ; Simple.intro wf_rec_arg + ; New.observe_tac + (fun _ _ -> str "tac") + (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ])) let rec instantiate_lambda sigma t l = match l with @@ -1307,62 +1279,61 @@ let rec instantiate_lambda sigma t l = instantiate_lambda sigma (subst1 a body) l let whole_start concl_tac nb_args is_mes func input_type relation rec_arg_num : - tactic = - fun g -> - let sigma = project g in - let ids = Termops.ids_of_named_context (pf_hyps g) in - let func_body = def_of_const (constr_of_monomorphic_global func) in - let func_body = EConstr.of_constr func_body in - let f_name, _, body1 = destLambda sigma func_body in - let f_id = - match f_name.binder_name with - | Name f_id -> next_ident_away_in_goal f_id ids - | Anonymous -> anomaly (Pp.str "Anonymous function.") - in - let n_names_types, _ = decompose_lam_n sigma nb_args body1 in - let n_ids, ids = - List.fold_left - (fun (n_ids, ids) (n_name, _) -> - match n_name.binder_name with - | Name id -> - let n_id = next_ident_away_in_goal id ids in - (n_id :: n_ids, n_id :: ids) - | _ -> anomaly (Pp.str "anonymous argument.")) - ([], f_id :: ids) - n_names_types - in - let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in - let expr = - instantiate_lambda sigma func_body (mkVar f_id :: List.map mkVar n_ids) - in - termination_proof_header is_mes input_type ids n_ids relation rec_arg_num - rec_arg_id - (fun rec_arg_id hrec acc_id acc_inv g -> - (prove_terminate - (fun infos -> tclIDTAC) - { is_main_branch = true - ; (* we are on the main branche (i.e. still on a match ... with .... end *) - is_final = true - ; (* and on leaf (more or less) *) - f_terminate = delayed_force coq_O - ; nb_arg = nb_args - ; concl_tac - ; rec_arg_id - ; is_mes - ; ih = hrec - ; f_id - ; f_constr = mkVar f_id - ; func - ; info = expr - ; acc_inv - ; acc_id - ; values_and_bounds = [] - ; eqs = [] - ; forbidden_ids = [] - ; args_assoc = [] }) - g) - (fun b ids -> Proofview.V82.of_tactic (tclUSER_if_not_mes concl_tac b ids)) - g + unit Proofview.tactic = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let hyps = Proofview.Goal.hyps g in + let ids = Termops.ids_of_named_context hyps in + let func_body = def_of_const (constr_of_monomorphic_global func) in + let func_body = EConstr.of_constr func_body in + let f_name, _, body1 = destLambda sigma func_body in + let f_id = + match f_name.binder_name with + | Name f_id -> next_ident_away_in_goal f_id ids + | Anonymous -> anomaly (Pp.str "Anonymous function.") + in + let n_names_types, _ = decompose_lam_n sigma nb_args body1 in + let n_ids, ids = + List.fold_left + (fun (n_ids, ids) (n_name, _) -> + match n_name.binder_name with + | Name id -> + let n_id = next_ident_away_in_goal id ids in + (n_id :: n_ids, n_id :: ids) + | _ -> anomaly (Pp.str "anonymous argument.")) + ([], f_id :: ids) + n_names_types + in + let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in + let expr = + instantiate_lambda sigma func_body (mkVar f_id :: List.map mkVar n_ids) + in + termination_proof_header is_mes input_type ids n_ids relation rec_arg_num + rec_arg_id + (fun rec_arg_id hrec acc_id acc_inv -> + prove_terminate + (fun infos -> Proofview.tclUNIT ()) + { is_main_branch = true + ; (* we are on the main branche (i.e. still on a match ... with .... end *) + is_final = true + ; (* and on leaf (more or less) *) + f_terminate = delayed_force coq_O + ; nb_arg = nb_args + ; concl_tac + ; rec_arg_id + ; is_mes + ; ih = hrec + ; f_id + ; f_constr = mkVar f_id + ; func + ; info = expr + ; acc_inv + ; acc_id + ; values_and_bounds = [] + ; eqs = [] + ; forbidden_ids = [] + ; args_assoc = [] }) + (fun b ids -> tclUSER_if_not_mes concl_tac b ids)) let get_current_subgoals_types pstate = let p = Declare.Proof.get pstate in @@ -1397,9 +1368,7 @@ let build_and_l sigma l = let c, tac, nb = f pl in ( mk_and p1 c , tclTHENS - (Proofview.V82.of_tactic - (apply - (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) + (apply (EConstr.of_constr (constr_of_monomorphic_global conj_constr))) [tclIDTAC; tac] , nb + 1 ) in @@ -1521,29 +1490,23 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name let lemma = Declare.Proof.start ~cinfo ~info sigma in let lemma = if Indfun_common.is_strict_tcc () then - fst @@ Declare.Proof.by (Proofview.V82.tactic tclIDTAC) lemma + fst @@ Declare.Proof.by tclIDTAC lemma else fst @@ Declare.Proof.by - (Proofview.V82.tactic (fun g -> - tclTHEN decompose_and_tac - (tclORELSE - (tclFIRST - (List.map - (fun c -> - Proofview.V82.of_tactic - (Tacticals.New.tclTHENLIST - [ intros - ; Simple.apply - (fst - (interp_constr (Global.env ()) - Evd.empty c)) - (*FIXME*) - ; Tacticals.New.tclCOMPLETE Auto.default_auto - ])) - using_lemmas)) - tclIDTAC) - g)) + (tclTHEN decompose_and_tac + (tclORELSE + (tclFIRST + (List.map + (fun c -> + Tacticals.New.tclTHENLIST + [ intros + ; Simple.apply + (fst (interp_constr (Global.env ()) Evd.empty c)) + (*FIXME*) + ; Tacticals.New.tclCOMPLETE Auto.default_auto ]) + using_lemmas)) + tclIDTAC)) lemma in if Declare.Proof.get_open_goals lemma = 0 then (defined lemma; None) @@ -1568,11 +1531,10 @@ let com_terminate interactive_proof tcc_lemma_name tcc_lemma_ref is_mes in fst @@ Declare.Proof.by - (Proofview.V82.tactic - (observe_tac - (fun _ _ -> str "whole_start") - (whole_start tac_end nb_args is_mes fonctional_ref input_type - relation rec_arg_num))) + (New.observe_tac + (fun _ _ -> str "whole_start") + (whole_start tac_end nb_args is_mes fonctional_ref input_type + relation rec_arg_num)) lemma in let lemma = @@ -1591,31 +1553,28 @@ let com_terminate interactive_proof tcc_lemma_name tcc_lemma_ref is_mes if interactive_proof then Some lemma else (defined lemma; None) let start_equation (f : GlobRef.t) (term_f : GlobRef.t) - (cont_tactic : Id.t list -> tactic) g = - let sigma = project g in - let ids = pf_ids_of_hyps g in - let terminate_constr = constr_of_monomorphic_global term_f in - let terminate_constr = EConstr.of_constr terminate_constr in - let nargs = - nb_prod (project g) - (EConstr.of_constr (type_of_const sigma terminate_constr)) - in - let x = n_x_id ids nargs in - observe_tac - (fun _ _ -> str "start_equation") - (observe_tclTHENLIST - (fun _ _ -> str "start_equation") - [ h_intros x - ; Proofview.V82.of_tactic - (unfold_in_concl - [(Locus.AllOccurrences, evaluable_of_global_reference f)]) - ; observe_tac - (fun _ _ -> str "simplest_case") - (Proofview.V82.of_tactic - (simplest_case - (mkApp (terminate_constr, Array.of_list (List.map mkVar x))))) - ; observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x) ]) - g + (cont_tactic : Id.t list -> unit Proofview.tactic) = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let ids = Tacmach.New.pf_ids_of_hyps g in + let terminate_constr = constr_of_monomorphic_global term_f in + let terminate_constr = EConstr.of_constr terminate_constr in + let nargs = + nb_prod sigma (EConstr.of_constr (type_of_const sigma terminate_constr)) + in + let x = n_x_id ids nargs in + New.observe_tac + (fun _ _ -> str "start_equation") + (New.observe_tclTHENLIST + (fun _ _ -> str "start_equation") + [ h_intros x + ; unfold_in_concl + [(Locus.AllOccurrences, evaluable_of_global_reference f)] + ; New.observe_tac + (fun _ _ -> str "simplest_case") + (simplest_case + (mkApp (terminate_constr, Array.of_list (List.map mkVar x)))) + ; New.observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x) ])) let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type = @@ -1638,35 +1597,34 @@ let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref let lemma = fst @@ Declare.Proof.by - (Proofview.V82.tactic - (start_equation f_ref terminate_ref (fun x -> - prove_eq - (fun _ -> tclIDTAC) - { nb_arg - ; f_terminate = - EConstr.of_constr - (constr_of_monomorphic_global terminate_ref) - ; f_constr = EConstr.of_constr f_constr - ; concl_tac = Tacticals.New.tclIDTAC - ; func = functional_ref - ; info = - instantiate_lambda Evd.empty - (EConstr.of_constr - (def_of_const - (constr_of_monomorphic_global functional_ref))) - (EConstr.of_constr f_constr :: List.map mkVar x) - ; is_main_branch = true - ; is_final = true - ; values_and_bounds = [] - ; eqs = [] - ; forbidden_ids = [] - ; acc_inv = lazy (assert false) - ; acc_id = Id.of_string "____" - ; args_assoc = [] - ; f_id = Id.of_string "______" - ; rec_arg_id = Id.of_string "______" - ; is_mes = false - ; ih = Id.of_string "______" }))) + (start_equation f_ref terminate_ref (fun x -> + prove_eq + (fun _ -> Proofview.tclUNIT ()) + { nb_arg + ; f_terminate = + EConstr.of_constr + (constr_of_monomorphic_global terminate_ref) + ; f_constr = EConstr.of_constr f_constr + ; concl_tac = Tacticals.New.tclIDTAC + ; func = functional_ref + ; info = + instantiate_lambda Evd.empty + (EConstr.of_constr + (def_of_const + (constr_of_monomorphic_global functional_ref))) + (EConstr.of_constr f_constr :: List.map mkVar x) + ; is_main_branch = true + ; is_final = true + ; values_and_bounds = [] + ; eqs = [] + ; forbidden_ids = [] + ; acc_inv = lazy (assert false) + ; acc_id = Id.of_string "____" + ; args_assoc = [] + ; f_id = Id.of_string "______" + ; rec_arg_id = Id.of_string "______" + ; is_mes = false + ; ih = Id.of_string "______" })) lemma in let _ = diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index d88cda177e..be0d71ad46 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -48,14 +48,14 @@ let reference_to_id qid = CErrors.user_err ?loc:qid.CAst.loc (str "This expression should be a simple identifier.") -let tactic_mode = Entry.create "vernac:tactic_command" +let tactic_mode = Entry.create "tactic_command" let new_entry name = let e = Entry.create name in e -let toplevel_selector = new_entry "vernac:toplevel_selector" -let tacdef_body = new_entry "tactic:tacdef_body" +let toplevel_selector = new_entry "toplevel_selector" +let tacdef_body = new_entry "tacdef_body" (* Registers [tactic_mode] as a parser for proof editing *) let classic_proof_mode = Pvernac.register_proof_mode "Classic" tactic_mode diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index a6673699af..fc24475a62 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -56,7 +56,7 @@ type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_a let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = Genarg.create_arg "withtac" -let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) +let withtac = Pcoq.create_generic_entry2 "withtac" (Genarg.rawwit wit_withtac) } diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 09cdc997ab..8331927cda 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -219,7 +219,7 @@ type binders_argtype = local_binder_expr list let wit_binders = (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) -let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) +let binders = Pcoq.create_generic_entry2 "binders" (Genarg.rawwit wit_binders) let () = let raw_printer env sigma _ _ _ l = Pp.pr_non_empty_arg (Ppconstr.pr_binders env sigma) l in diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml index 5b5ee64a56..b7b54143df 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -11,39 +11,37 @@ open Pcoq (* Main entry for extensions *) -let simple_tactic = Entry.create "tactic:simple_tactic" - -let make_gen_entry _ name = Entry.create ("tactic:" ^ name) +let simple_tactic = Entry.create "simple_tactic" (* Typically for tactic user extensions *) let open_constr = - make_gen_entry utactic "open_constr" + Entry.create "open_constr" let constr_with_bindings = - make_gen_entry utactic "constr_with_bindings" + Entry.create "constr_with_bindings" let bindings = - make_gen_entry utactic "bindings" + Entry.create "bindings" let hypident = Entry.create "hypident" -let constr_may_eval = make_gen_entry utactic "constr_may_eval" -let constr_eval = make_gen_entry utactic "constr_eval" +let constr_may_eval = Entry.create "constr_may_eval" +let constr_eval = Entry.create "constr_eval" let uconstr = - make_gen_entry utactic "uconstr" + Entry.create "uconstr" let quantified_hypothesis = - make_gen_entry utactic "quantified_hypothesis" -let destruction_arg = make_gen_entry utactic "destruction_arg" -let int_or_var = make_gen_entry utactic "int_or_var" + Entry.create "quantified_hypothesis" +let destruction_arg = Entry.create "destruction_arg" +let int_or_var = Entry.create "int_or_var" let simple_intropattern = - make_gen_entry utactic "simple_intropattern" -let in_clause = make_gen_entry utactic "in_clause" + Entry.create "simple_intropattern" +let in_clause = Entry.create "in_clause" let clause_dft_concl = - make_gen_entry utactic "clause" + Entry.create "clause" (* Main entries for ltac *) -let tactic_arg = Entry.create "tactic:tactic_arg" -let tactic_expr = make_gen_entry utactic "tactic_expr" -let binder_tactic = make_gen_entry utactic "binder_tactic" +let tactic_arg = Entry.create "tactic_arg" +let tactic_expr = Entry.create "tactic_expr" +let binder_tactic = Entry.create "binder_tactic" -let tactic = make_gen_entry utactic "tactic" +let tactic = Entry.create "tactic" (* Main entry for quotations *) let tactic_eoi = eoi_entry tactic diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 75517818cb..5ef76dbdc1 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -181,7 +181,7 @@ end) = struct fun env sigma -> class_info env sigma (Lazy.force r) let proper_proj env sigma = - mkConst (Option.get (pi3 (List.hd (proper_class env sigma).cl_projs))) + mkConst (Option.get (List.hd (proper_class env sigma).cl_projs).meth_const) let proper_type env (sigma,cstrs) = let l = (proper_class env sigma).cl_impl in diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index fcd60ea250..f0ca813b08 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -869,7 +869,7 @@ let argument_extend (type a b c) ~name (arg : (a, b, c) tactic_argument) = let () = Pcoq.register_grammar wit e in e | Vernacextend.Arg_rules rules -> - let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in + let e = Pcoq.create_generic_entry2 name (Genarg.rawwit wit) in let () = Pcoq.grammar_extend e {pos=None; data=[(None, None, rules)]} in e in diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index f3021f4ee6..c24bafc761 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -127,14 +127,14 @@ let mul = function let gen_constant n = lazy (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref n)) -let tpexpr = gen_constant "plugins.setoid_ring.pexpr" -let ttconst = gen_constant "plugins.setoid_ring.const" -let ttvar = gen_constant "plugins.setoid_ring.var" -let ttadd = gen_constant "plugins.setoid_ring.add" -let ttsub = gen_constant "plugins.setoid_ring.sub" -let ttmul = gen_constant "plugins.setoid_ring.mul" -let ttopp = gen_constant "plugins.setoid_ring.opp" -let ttpow = gen_constant "plugins.setoid_ring.pow" +let tpexpr = gen_constant "plugins.ring.pexpr" +let ttconst = gen_constant "plugins.ring.const" +let ttvar = gen_constant "plugins.ring.var" +let ttadd = gen_constant "plugins.ring.add" +let ttsub = gen_constant "plugins.ring.sub" +let ttmul = gen_constant "plugins.ring.mul" +let ttopp = gen_constant "plugins.ring.opp" +let ttpow = gen_constant "plugins.ring.pow" let tlist = gen_constant "core.list.type" let lnil = gen_constant "core.list.nil" diff --git a/plugins/ring/dune b/plugins/ring/dune new file mode 100644 index 0000000000..080d8c672e --- /dev/null +++ b/plugins/ring/dune @@ -0,0 +1,7 @@ +(library + (name ring_plugin) + (public_name coq.plugins.ring) + (synopsis "Coq's ring plugin") + (libraries coq.plugins.ltac)) + +(coq.pp (modules g_ring)) diff --git a/plugins/setoid_ring/g_newring.mlg b/plugins/ring/g_ring.mlg index eb7710bbc2..3c800987ac 100644 --- a/plugins/setoid_ring/g_newring.mlg +++ b/plugins/ring/g_ring.mlg @@ -13,8 +13,8 @@ open Ltac_plugin open Pp open Util -open Newring_ast -open Newring +open Ring_ast +open Ring open Stdarg open Tacarg open Pcoq.Constr @@ -22,7 +22,7 @@ open Pltac } -DECLARE PLUGIN "newring_plugin" +DECLARE PLUGIN "ring_plugin" TACTIC EXTEND protect_fv | [ "protect_fv" string(map) "in" ident(id) ] -> diff --git a/plugins/setoid_ring/newring.ml b/plugins/ring/ring.ml index 5f5a974b6a..9c75175889 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/ring/ring.ml @@ -28,7 +28,7 @@ open Libobject open Printer open Declare open Entries -open Newring_ast +open Ring_ast open Proofview.Notations let error msg = CErrors.user_err Pp.(str msg) @@ -115,7 +115,7 @@ let closed_term args _ = match args with let closed_term_ast = let tacname = { - mltac_plugin = "newring_plugin"; + mltac_plugin = "ring_plugin"; mltac_tactic = "closed_term"; } in let () = Tacenv.register_ml_tactic tacname [|closed_term|] in @@ -178,7 +178,7 @@ let tactic_res = ref [||] let get_res = let open Tacexpr in - let name = { mltac_plugin = "newring_plugin"; mltac_tactic = "get_res"; } in + let name = { mltac_plugin = "ring_plugin"; mltac_tactic = "get_res"; } in let entry = { mltac_name = name; mltac_index = 0 } in let tac args ist = let n = Tacinterp.Value.cast (Genarg.topwit Stdarg.wit_int) (List.hd args) in @@ -212,7 +212,7 @@ let exec_tactic env evd n f args = let gen_constant n = lazy (EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref n))) let gen_reference n = lazy (Coqlib.lib_ref n) -let coq_mk_Setoid = gen_constant "plugins.setoid_ring.Build_Setoid_Theory" +let coq_mk_Setoid = gen_constant "plugins.ring.Build_Setoid_Theory" let coq_None = gen_reference "core.option.None" let coq_Some = gen_reference "core.option.Some" let coq_eq = gen_constant "core.eq.type" @@ -265,7 +265,7 @@ let znew_ring_path = let zltac s = lazy(KerName.make (ModPath.MPfile znew_ring_path) (Label.make s)) -let mk_cst l s = lazy (Coqlib.coq_reference "newring" l s) [@@ocaml.warning "-3"] +let mk_cst l s = lazy (Coqlib.coq_reference "ring" l s) [@@ocaml.warning "-3"] let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s (* Ring theory *) diff --git a/plugins/setoid_ring/newring.mli b/plugins/ring/ring.mli index 73d6d91434..6d24ae84d7 100644 --- a/plugins/setoid_ring/newring.mli +++ b/plugins/ring/ring.mli @@ -11,7 +11,7 @@ open Names open EConstr open Constrexpr -open Newring_ast +open Ring_ast val protect_tac_in : string -> Id.t -> unit Proofview.tactic diff --git a/plugins/setoid_ring/newring_ast.ml b/plugins/ring/ring_ast.ml index 8b82783db9..8b82783db9 100644 --- a/plugins/setoid_ring/newring_ast.ml +++ b/plugins/ring/ring_ast.ml diff --git a/plugins/setoid_ring/newring_ast.mli b/plugins/ring/ring_ast.mli index 8b82783db9..8b82783db9 100644 --- a/plugins/setoid_ring/newring_ast.mli +++ b/plugins/ring/ring_ast.mli diff --git a/plugins/ring/ring_plugin.mlpack b/plugins/ring/ring_plugin.mlpack new file mode 100644 index 0000000000..91d7199f9b --- /dev/null +++ b/plugins/ring/ring_plugin.mlpack @@ -0,0 +1,3 @@ +Ring_ast +Ring +G_ring diff --git a/plugins/setoid_ring/dune b/plugins/setoid_ring/dune deleted file mode 100644 index 60522cd3f5..0000000000 --- a/plugins/setoid_ring/dune +++ /dev/null @@ -1,7 +0,0 @@ -(library - (name newring_plugin) - (public_name coq.plugins.setoid_ring) - (synopsis "Coq's setoid ring plugin") - (libraries coq.plugins.ltac)) - -(coq.pp (modules g_newring)) diff --git a/plugins/setoid_ring/newring_plugin.mlpack b/plugins/setoid_ring/newring_plugin.mlpack deleted file mode 100644 index 5aa79b5868..0000000000 --- a/plugins/setoid_ring/newring_plugin.mlpack +++ /dev/null @@ -1,3 +0,0 @@ -Newring_ast -Newring -G_newring diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index b32b58062a..89e0c9fcbe 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -403,7 +403,7 @@ END let pr_mmod = function May -> str "?" | Must -> str "!" | Once -> mt () let wit_ssrmmod = add_genarg "ssrmmod" (fun env sigma -> pr_mmod) -let ssrmmod = Pcoq.create_generic_entry Pcoq.utactic "ssrmmod" (Genarg.rawwit wit_ssrmmod);; +let ssrmmod = Pcoq.create_generic_entry2 "ssrmmod" (Genarg.rawwit wit_ssrmmod);; } diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4d5715a391..715b80f428 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -1196,8 +1196,8 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = let filter_compatible_candidates unify flags env evd evi args rhs c = let c' = instantiate_evar_array evi c args in match unify flags TermUnification env evd Reduction.CONV rhs c' with - | Success evd -> Some (c,evd) - | UnifFailure _ -> None + | Success evd -> Inl (c,evd) + | UnifFailure _ -> Inr c' (* [restrict_candidates ... filter ev1 ev2] restricts the candidates of ev1, removing those not compatible with the filter, as well as @@ -1218,8 +1218,8 @@ let restrict_candidates unify flags env evd filter1 (evk1,argsv1) (evk2,argsv2) let filter c2 = let compatibility = filter_compatible_candidates unify flags env evd evi2 argsv2 c1' c2 in match compatibility with - | None -> false - | Some _ -> true + | Inl _ -> true + | Inr _ -> false in let filtered = List.filter filter l2 in match filtered with [] -> false | _ -> true) l1 in @@ -1440,29 +1440,33 @@ let solve_refl ?(can_drop=false) unify flags env evd pbty evk argsv1 argsv2 = in advance, we check which of them apply *) exception NoCandidates -exception IncompatibleCandidates +exception IncompatibleCandidates of EConstr.t let solve_candidates unify flags env evd (evk,argsv) rhs = let evi = Evd.find evd evk in match evi.evar_candidates with | None -> raise NoCandidates | Some l -> - let l' = - List.map_filter - (fun c -> filter_compatible_candidates unify flags env evd evi argsv rhs c) l in - match l' with - | [] -> raise IncompatibleCandidates - | [c,evd] -> + let rec aux = function + | [] -> [], [] + | c::l -> + let compatl, disjointl = aux l in + match filter_compatible_candidates unify flags env evd evi argsv rhs c with + | Inl c -> c::compatl, disjointl + | Inr c -> compatl, c::disjointl in + match aux l with + | [], c::_ -> raise (IncompatibleCandidates c) + | [c,evd], _ -> (* solve_candidates might have been called recursively in the mean *) (* time and the evar been solved by the filtering process *) if Evd.is_undefined evd evk then let evd' = Evd.define evk c evd in check_evar_instance unify flags env evd' evk c else evd - | l when List.length l < List.length l' -> + | l, _::_ (* At least one discarded candidate *) -> let candidates = List.map fst l in restrict_evar evd evk None (UpdateWith candidates) - | l -> evd + | l, [] -> evd let occur_evar_upto_types sigma n c = let c = EConstr.Unsafe.to_constr c in @@ -1794,6 +1798,6 @@ let solve_simple_eqn unify flags ?(choose=false) ?(imitate_defs=true) UnifFailure (evd,MetaOccurInBody evk1) | IllTypedInstance (env,t,u) -> UnifFailure (evd,InstanceNotSameType (evk1,env,t,u)) - | IncompatibleCandidates -> - UnifFailure (evd,ConversionFailed (env,mkEvar ev1,t2)) + | IncompatibleCandidates t -> + UnifFailure (evd,IncompatibleInstances (env,ev1,t,t2)) diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 207ffc7b86..1e8441dd8a 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -20,6 +20,7 @@ type unification_error = | NotSameHead | NoCanonicalStructure | ConversionFailed of env * constr * constr (* Non convertible closed terms *) + | IncompatibleInstances of env * existential * constr * constr | MetaOccurInBody of Evar.t | InstanceNotSameType of Evar.t * env * types * types | UnifUnivInconsistency of Univ.univ_inconsistency diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 70f218d617..45997e9a66 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -23,6 +23,7 @@ type unification_error = | NotSameHead | NoCanonicalStructure | ConversionFailed of env * constr * constr + | IncompatibleInstances of env * existential * constr * constr | MetaOccurInBody of Evar.t | InstanceNotSameType of Evar.t * env * types * types | UnifUnivInconsistency of Univ.univ_inconsistency diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index adb9c5299f..fc71254a46 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -11,7 +11,6 @@ (*i*) open Names open Globnames -open Term open Constr open Vars open Evd @@ -42,7 +41,11 @@ let get_solve_one_instance, solve_one_instance_hook = Hook.make () let resolve_one_typeclass ?(unique=get_typeclasses_unique_solutions ()) env evm t = Hook.get get_solve_one_instance env evm t unique -type direction = Forward | Backward +type class_method = { + meth_name : Name.t; + meth_info : hint_info option; + meth_const : Constant.t option; +} (* This module defines type-classes *) type typeclass = { @@ -59,8 +62,7 @@ type typeclass = { cl_props : Constr.rel_context; (* The method implementations as projections. *) - cl_projs : (Name.t * (direction * hint_info) option - * Constant.t option) list; + cl_projs : class_method list; cl_strict : bool; @@ -156,66 +158,6 @@ let load_class cl = (** Build the subinstances hints. *) -let check_instance env sigma c = - try - let (evd, c) = resolve_one_typeclass env sigma - (Retyping.get_type_of env sigma c) in - not (Evd.has_undefined evd) - with e when CErrors.noncritical e -> false - -let build_subclasses ~check env sigma glob { hint_priority = pri } = - let _id = Nametab.basename_of_global glob in - let _next_id = - let i = ref (-1) in - (fun () -> incr i; - Nameops.add_suffix _id ("_subinstance_" ^ string_of_int !i)) - in - let ty, ctx = Typeops.type_of_global_in_context env glob in - let inst, ctx = UnivGen.fresh_instance_from ctx None in - let ty = Vars.subst_instance_constr inst ty in - let ty = EConstr.of_constr ty in - let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in - let rec aux pri c ty path = - match class_of_constr env sigma ty with - | None -> [] - | Some (rels, ((tc,u), args)) -> - let instapp = - Reductionops.whd_beta env sigma (EConstr.of_constr (appvectc c (Context.Rel.to_extended_vect mkRel 0 rels))) - in - let instapp = EConstr.Unsafe.to_constr instapp in - let projargs = Array.of_list (args @ [instapp]) in - let projs = List.map_filter - (fun (n, b, proj) -> - match b with - | None -> None - | Some (Backward, _) -> None - | Some (Forward, info) -> - let proj = Option.get proj in - let rels = List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) rels in - let u = EConstr.EInstance.kind sigma u in - let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in - if check && check_instance env sigma (EConstr.of_constr body) then None - else - let newpri = - match pri, info.hint_priority with - | Some p, Some p' -> Some (p + p') - | Some p, None -> Some (p + 1) - | _, _ -> None - in - Some (GlobRef.ConstRef proj, { info with hint_priority = newpri }, body)) tc.cl_projs - in - let declare_proj hints (cref, info, body) = - let path' = cref :: path in - let ty = Retyping.get_type_of env sigma (EConstr.of_constr body) in - let rest = aux pri body ty path' in - hints @ (path', info, body) :: rest - in List.fold_left declare_proj [] projs - in - let term = Constr.mkRef (glob, inst) in - (*FIXME subclasses should now get substituted for each particular instance of - the polymorphic superclass *) - aux pri term ty [glob] - (* * interface functions *) diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index 9de8083276..3f84d08a7e 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -13,8 +13,6 @@ open Constr open Evd open Environ -type direction = Forward | Backward - (* Core typeclasses hints *) type 'a hint_info_gen = { hint_priority : int option; @@ -22,6 +20,12 @@ type 'a hint_info_gen = type hint_info = (Pattern.patvar list * Pattern.constr_pattern) hint_info_gen +type class_method = { + meth_name : Name.t; + meth_info : hint_info option; + meth_const : Constant.t option; +} + (** This module defines type-classes *) type typeclass = { cl_univs : Univ.AUContext.t; @@ -39,7 +43,7 @@ type typeclass = { cl_props : Constr.rel_context; (** Context of definitions and properties on defs, will not be shared *) - cl_projs : (Name.t * (direction * hint_info) option * Constant.t option) list; + cl_projs : class_method list; (** The methods implementations of the typeclass as projections. Some may be undefinable due to sorting restrictions or simply undefined if no name is provided. The [int option option] indicates subclasses whose hint has @@ -127,11 +131,3 @@ val classes_transparent_state : unit -> TransparentState.t val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t val solve_one_instance_hook : (env -> evar_map -> EConstr.types -> bool -> evar_map * EConstr.constr) Hook.t - -(** Build the subinstances hints for a given typeclass object. - check tells if we should check for existence of the - subinstances and add only the missing ones. *) - -val build_subclasses : check:bool -> env -> evar_map -> GlobRef.t -> - hint_info -> - (GlobRef.t list * hint_info * constr) list diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index ecdbfa5118..1207e0e599 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -99,7 +99,7 @@ let db_pr_goal sigma g = str" " ++ pc) ++ fnl () let pr_gls gls = - hov 0 (pr_evar_map (Some 2) (pf_env gls) (sig_sig gls) ++ fnl () ++ db_pr_goal (project gls) (sig_it gls)) + hov 0 (pr_evar_map (Some 2) (pf_env gls) (project gls) ++ fnl () ++ db_pr_goal (project gls) (sig_it gls)) (* Variants of [Tacmach] functions built with the new proof engine *) module New = struct @@ -183,6 +183,9 @@ module New = struct let pf_unsafe_type_of gl t = pf_apply (unsafe_type_of[@warning "-3"]) gl t + let pr_gls gl = + hov 0 (pr_evar_map (Some 2) (pf_env gl) (project gl) ++ fnl () ++ db_pr_goal (project gl) (Proofview.Goal.goal gl)) + end (* deprecated *) diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index d8f7b7eed8..08f88d46c1 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -126,4 +126,5 @@ module New : sig val pf_nf_evar : Proofview.Goal.t -> constr -> constr + val pr_gls : Proofview.Goal.t -> Pp.t end diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index b4d7e7d7f0..ed92a85a12 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -483,17 +483,7 @@ let make_resolve_hyp env sigma st only_classes pri decl = if keep then let id = GlobRef.VarRef id in let name = PathHints [id] in - let hints = - if is_class then - let hints = build_subclasses ~check:false env sigma id empty_hint_info in - (List.map_append - (fun (path,info,c) -> - let h = IsConstr (EConstr.of_constr c, None) [@ocaml.warning "-3"] in - make_resolves env sigma ~name:(PathHints path) info ~check:true h) - hints) - else [] - in - (hints @ make_resolves env sigma pri ~name ~check:false (IsGlobRef id)) + (make_resolves env sigma pri ~name ~check:false (IsGlobRef id)) else [] let make_hints g (modes,st) only_classes sign = diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index c0fad0026f..24aa178ed2 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -797,6 +797,9 @@ module New = struct end let onLastDecl = onNthDecl 1 + let nLastHypsId gl n = List.map (NamedDecl.get_id) (nLastDecls gl n) + let nLastHyps gl n = List.map mkVar (nLastHypsId gl n) + let ifOnHyp pred tac1 tac2 id = Proofview.Goal.enter begin fun gl -> let typ = Tacmach.New.pf_get_hyp_typ id gl in @@ -808,6 +811,10 @@ module New = struct let onHyps find tac = Proofview.Goal.enter begin fun gl -> tac (find gl) end + let onNLastDecls n tac = onHyps (fun gl -> nLastDecls gl n) tac + let onNLastHypsId n tac = onHyps (fun gl -> nLastHypsId gl n) tac + let onNLastHyps n tac = onHyps (fun gl -> nLastHyps gl n) tac + let afterHyp id tac = Proofview.Goal.enter begin fun gl -> let hyps = Proofview.Goal.hyps gl in @@ -835,6 +842,16 @@ module New = struct tclMAP tac (Locusops.simple_clause_of (fun () -> hyps) cl) end + let fullGoal gl = None :: List.map Option.make (Tacmach.New.pf_ids_of_hyps gl) + let onAllHyps tac = + Proofview.Goal.enter begin fun gl -> + tclMAP tac (Tacmach.New.pf_ids_of_hyps gl) + end + let onAllHypsAndConcl tac = + Proofview.Goal.enter begin fun gl -> + tclMAP tac (fullGoal gl) + end + let elimination_sort_of_goal gl = (* Retyping will expand evars anyway. *) let c = Proofview.Goal.concl gl in @@ -855,4 +872,11 @@ module New = struct let (sigma, c) = Evd.fresh_global env sigma ref in Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT c + let tclTYPEOFTHEN ?refresh c tac = + Proofview.Goal.enter (fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let (sigma, t) = Typing.type_of ?refresh env sigma c in + Proofview.Unsafe.tclEVARS sigma <*> tac sigma t) + end diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index bfead34b3b..e97c5f3c1f 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -224,6 +224,10 @@ module New : sig val onLastHyp : (constr -> unit tactic) -> unit tactic val onLastDecl : (named_declaration -> unit tactic) -> unit tactic + val onNLastHypsId : int -> (Id.t list -> unit tactic) -> unit tactic + val onNLastHyps : int -> (constr list -> unit tactic) -> unit tactic + val onNLastDecls : int -> (named_context -> unit tactic) -> unit tactic + val onHyps : (Proofview.Goal.t -> named_context) -> (named_context -> unit tactic) -> unit tactic val afterHyp : Id.t -> (named_context -> unit tactic) -> unit tactic @@ -232,9 +236,14 @@ module New : sig val tryAllHypsAndConcl : (Id.t option -> unit tactic) -> unit tactic val onClause : (Id.t option -> unit tactic) -> clause -> unit tactic + val onAllHyps : (Id.t -> unit tactic) -> unit tactic + val onAllHypsAndConcl : (Id.t option -> unit tactic) -> unit tactic + val elimination_sort_of_goal : Proofview.Goal.t -> Sorts.family val elimination_sort_of_hyp : Id.t -> Proofview.Goal.t -> Sorts.family val elimination_sort_of_clause : Id.t option -> Proofview.Goal.t -> Sorts.family val pf_constr_of_global : GlobRef.t -> constr Proofview.tactic + + val tclTYPEOFTHEN : ?refresh:bool -> constr -> (evar_map -> types -> unit Proofview.tactic) -> unit Proofview.tactic end diff --git a/test-suite/bugs/closed/bug_13059.v b/test-suite/bugs/closed/bug_13059.v new file mode 100644 index 0000000000..2416e3ad13 --- /dev/null +++ b/test-suite/bugs/closed/bug_13059.v @@ -0,0 +1,31 @@ +Set Uniform Inductive Parameters. +Inductive test (X : Set) : Prop := +with test2 (X : Set) : X -> Prop := + | C (x : X) : test2 x. + +Require Import List. +Import ListNotations. + +Set Suggest Proof Using. +Set Primitive Projections. + + +Section Grammar. +Variable A : Type. + +Record grammar : Type := Grammar { + gm_nonterm :> Type ; + gm_rules :> list (gm_nonterm * list (A + gm_nonterm)) ; +}. + +Set Uniform Inductive Parameters. +Inductive lang (gm : grammar) : gm -> list A -> Prop := +| lang_rule S ps ws : In (S, ps) gm -> lmatch ps ws -> lang S (concat ws) +with lmatch (gm : grammar) : list (A + gm) -> list (list A) -> Prop := +| lmatch_nil : lmatch [] [] +| lmatch_consL ps ws a : lmatch ps ws -> lmatch (inl a :: ps) ([a] :: ws) +| lmatch_consR ps ws S w : + lang S w -> lmatch ps ws -> lmatch (inr S :: ps) (w :: ws) +. + +End Grammar. diff --git a/test-suite/bugs/closed/bug_13109.v b/test-suite/bugs/closed/bug_13109.v new file mode 100644 index 0000000000..76511a44c5 --- /dev/null +++ b/test-suite/bugs/closed/bug_13109.v @@ -0,0 +1,24 @@ +Require Import Coq.Program.Tactics. + +Set Universe Polymorphism. +Obligation Tactic := idtac. + +Program Definition foo : Type := _. +Program Definition bar : Type := _. +Admit Obligations. +(* Error: Anomaly "Uncaught exception AcyclicGraph.Make(Point).AlreadyDeclared." +Please report at http://coq.inria.fr/bugs/. + *) +Print foo. +Print foo_obligation_1. +Print bar. +Print bar_obligation_1. + +Program Definition baz : Type := _. +Admit Obligations of baz. +Print baz. +Print baz_obligation_1. + +Admit Obligations. + +Fail Admit Obligations of nobody. diff --git a/test-suite/bugs/closed/bug_2928.v b/test-suite/bugs/closed/bug_2928.v deleted file mode 100644 index 21e92ae20c..0000000000 --- a/test-suite/bugs/closed/bug_2928.v +++ /dev/null @@ -1,11 +0,0 @@ -Class Equiv A := equiv: A -> A -> Prop. -Infix "=" := equiv : type_scope. - -Class Associative {A} f `{Equiv A} := associativity x y z : f x (f y z) = f (f x y) z. - -Class SemiGroup A op `{Equiv A} := { sg_ass :>> Associative op }. - -Class SemiLattice A op `{Equiv A} := - { semilattice_sg :>> SemiGroup A op - ; redundant : Associative op - }. diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index ce51acac95..a42518822f 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -1,6 +1,6 @@ [< 0 > + < 1 > * < 2 >] : nat -Entry constr:myconstr is +Entry custom:myconstr is [ "6" RIGHTA [ ] | "5" RIGHTA @@ -8,7 +8,7 @@ Entry constr:myconstr is | "4" RIGHTA [ SELF; "*"; NEXT ] | "3" RIGHTA - [ "<"; constr:operconstr LEVEL "10"; ">" ] ] + [ "<"; operconstr LEVEL "10"; ">" ] ] [< b > + < b > * < 2 >] : nat @@ -75,9 +75,9 @@ The command has indeed failed with message: The format is not the same on the right- and left-hand sides of the special token "..". The command has indeed failed with message: The format is not the same on the right- and left-hand sides of the special token "..". -Entry constr:expr is +Entry custom:expr is [ "201" RIGHTA - [ "{"; constr:operconstr LEVEL "200"; "}" ] ] + [ "{"; operconstr LEVEL "200"; "}" ] ] fun x : nat => [ x ] : nat -> nat diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 163ed15606..d8d3f696b7 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -67,9 +67,9 @@ mono The command has indeed failed with message: Universe u already exists. bobmorane = -let tt := Type@{UnivBinders.33} in -let ff := Type@{UnivBinders.35} in tt -> ff - : Type@{max(UnivBinders.32,UnivBinders.34)} +let tt := Type@{UnivBinders.32} in +let ff := Type@{UnivBinders.34} in tt -> ff + : Type@{max(UnivBinders.31,UnivBinders.33)} The command has indeed failed with message: Universe u already bound. foo@{E M N} = diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v index cec1033fdf..547d180d95 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -19,7 +19,7 @@ Require Coq.ssr.ssrsetoid. Definition Setoid_Theory := @Equivalence. Definition Build_Setoid_Theory := @Build_Equivalence. -Register Build_Setoid_Theory as plugins.setoid_ring.Build_Setoid_Theory. +Register Build_Setoid_Theory as plugins.ring.Build_Setoid_Theory. Definition Seq_refl A Aeq (s : Setoid_Theory A Aeq) : forall x:A, Aeq x x. Proof. diff --git a/theories/dune b/theories/dune index de8dcdc5b1..c2d8197ee4 100644 --- a/theories/dune +++ b/theories/dune @@ -23,7 +23,7 @@ coq.plugins.btauto coq.plugins.rtauto - coq.plugins.setoid_ring + coq.plugins.ring coq.plugins.nsatz coq.plugins.omega diff --git a/theories/setoid_ring/Ring_base.v b/theories/setoid_ring/Ring_base.v index 04c7a3a83b..4986661ad1 100644 --- a/theories/setoid_ring/Ring_base.v +++ b/theories/setoid_ring/Ring_base.v @@ -12,7 +12,7 @@ ring tactic. Abstract rings need more theory, depending on ZArith_base. *) -Declare ML Module "newring_plugin". +Declare ML Module "ring_plugin". Require Export Ring_theory. Require Export Ring_tac. Require Import InitialRing. diff --git a/theories/setoid_ring/Ring_polynom.v b/theories/setoid_ring/Ring_polynom.v index e0a3d5a3bf..a13b1fc738 100644 --- a/theories/setoid_ring/Ring_polynom.v +++ b/theories/setoid_ring/Ring_polynom.v @@ -919,14 +919,14 @@ Section MakeRingPol. | PEopp : PExpr -> PExpr | PEpow : PExpr -> N -> PExpr. - Register PExpr as plugins.setoid_ring.pexpr. - Register PEc as plugins.setoid_ring.const. - Register PEX as plugins.setoid_ring.var. - Register PEadd as plugins.setoid_ring.add. - Register PEsub as plugins.setoid_ring.sub. - Register PEmul as plugins.setoid_ring.mul. - Register PEopp as plugins.setoid_ring.opp. - Register PEpow as plugins.setoid_ring.pow. + Register PExpr as plugins.ring.pexpr. + Register PEc as plugins.ring.const. + Register PEX as plugins.ring.var. + Register PEadd as plugins.ring.add. + Register PEsub as plugins.ring.sub. + Register PEmul as plugins.ring.mul. + Register PEopp as plugins.ring.opp. + Register PEpow as plugins.ring.pow. (** evaluation of polynomial expressions towards R *) Definition mk_X j := mkPinj_pred j mkX. diff --git a/theories/setoid_ring/Ring_tac.v b/theories/setoid_ring/Ring_tac.v index df54989169..76e9b1e947 100644 --- a/theories/setoid_ring/Ring_tac.v +++ b/theories/setoid_ring/Ring_tac.v @@ -15,7 +15,7 @@ Require Import Ring_polynom. Require Import BinList. Require Export ListTactics. Require Import InitialRing. -Declare ML Module "newring_plugin". +Declare ML Module "ring_plugin". (* adds a definition t' on the normal form of t and an hypothesis id diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index d42a935104..5ae8f4ae6e 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -72,13 +72,13 @@ let test_ltac1_env = 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 tac2mode = Entry.create "vernac:ltac2_command" +let tac2type = Entry.create "tac2type" +let tac2def_val = Entry.create "tac2def_val" +let tac2def_typ = Entry.create "tac2def_typ" +let tac2def_ext = Entry.create "tac2def_ext" +let tac2def_syn = Entry.create "tac2def_syn" +let tac2def_mut = Entry.create "tac2def_mut" +let tac2mode = Entry.create "ltac2_command" let ltac1_expr = Pltac.tactic_expr let tac2expr_in_env = Tac2entries.Pltac.tac2expr_in_env diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 0a6e976db8..30340cd632 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -24,29 +24,29 @@ open Tac2intern module Pltac = struct -let tac2expr = Pcoq.Entry.create "tactic:tac2expr" -let tac2expr_in_env = Pcoq.Entry.create "tactic:tac2expr_in_env" - -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" +let tac2expr = Pcoq.Entry.create "tac2expr" +let tac2expr_in_env = Pcoq.Entry.create "tac2expr_in_env" + +let q_ident = Pcoq.Entry.create "q_ident" +let q_bindings = Pcoq.Entry.create "q_bindings" +let q_with_bindings = Pcoq.Entry.create "q_with_bindings" +let q_intropattern = Pcoq.Entry.create "q_intropattern" +let q_intropatterns = Pcoq.Entry.create "q_intropatterns" +let q_destruction_arg = Pcoq.Entry.create "q_destruction_arg" +let q_induction_clause = Pcoq.Entry.create "q_induction_clause" +let q_conversion = Pcoq.Entry.create "q_conversion" +let q_rewriting = Pcoq.Entry.create "q_rewriting" +let q_clause = Pcoq.Entry.create "q_clause" +let q_dispatch = Pcoq.Entry.create "q_dispatch" +let q_occurrences = Pcoq.Entry.create "q_occurrences" +let q_reference = Pcoq.Entry.create "q_reference" +let q_strategy_flag = Pcoq.Entry.create "q_strategy_flag" +let q_constr_matching = Pcoq.Entry.create "q_constr_matching" +let q_goal_matching = Pcoq.Entry.create "q_goal_matching" +let q_hintdb = Pcoq.Entry.create "q_hintdb" +let q_move_location = Pcoq.Entry.create "q_move_location" +let q_pose = Pcoq.Entry.create "q_pose" +let q_assert = Pcoq.Entry.create "q_assert" end (** Tactic definition *) diff --git a/vernac/classes.ml b/vernac/classes.ml index b38a249b73..a464eab127 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -58,13 +58,7 @@ let is_local_for_hint i = let add_instance_base inst = let locality = if is_local_for_hint inst then Goptions.OptLocal else Goptions.OptGlobal in add_instance_hint (Hints.IsGlobRef inst.is_impl) [inst.is_impl] ~locality - inst.is_info; - List.iter (fun (path, pri, c) -> - let h = Hints.IsConstr (EConstr.of_constr c, None) [@ocaml.warning "-3"] in - add_instance_hint h path - ~locality pri) - (build_subclasses ~check:(not (isVarRef inst.is_impl)) - (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info) + inst.is_info let mk_instance cl info glob impl = let global = @@ -161,8 +155,17 @@ let subst_class (subst,cl) = let do_subst_context (grs,ctx) = List.Smart.map (Option.Smart.map do_subst_gr) grs, do_subst_ctx ctx in - let do_subst_projs projs = List.Smart.map (fun (x, y, z) -> - (x, y, Option.Smart.map do_subst_con z)) projs in + let do_subst_meth m = + let c = Option.Smart.map do_subst_con m.meth_const in + if c == m.meth_const then m + else + { + meth_name = m.meth_name; + meth_info = m.meth_info; + meth_const = c; + } + in + let do_subst_projs projs = List.Smart.map do_subst_meth projs in { cl_univs = cl.cl_univs; cl_impl = do_subst_gr cl.cl_impl; cl_context = do_subst_context cl.cl_context; @@ -247,10 +250,10 @@ let add_class cl = let add_class env sigma cl = add_class cl; - List.iter (fun (n, inst, body) -> - match inst with - | Some (Backward, info) -> - (match body with + List.iter (fun m -> + match m.meth_info with + | Some info -> + (match m.meth_const with | None -> CErrors.user_err Pp.(str "Non-definable projection can not be declared as a subinstance") | Some b -> declare_instance ~warn:true env sigma (Some info) false (GlobRef.ConstRef b)) | _ -> ()) @@ -430,9 +433,9 @@ let do_instance_type_ctx_instance props k env' ctx' sigma ~program_mode subst = let rest' = List.filter (fun v -> not (is_id v)) rest in let {CAst.loc;v=mid} = get_id loc_mid in - List.iter (fun (n, _, x) -> - if Name.equal n (Name mid) then - Option.iter (fun x -> Dumpglob.add_glob ?loc (GlobRef.ConstRef x)) x) k.cl_projs; + List.iter (fun m -> + if Name.equal m.meth_name (Name mid) then + Option.iter (fun x -> Dumpglob.add_glob ?loc (GlobRef.ConstRef x)) m.meth_const) k.cl_projs; c :: props, rest' with Not_found -> ((CAst.make @@ CHole (None(* Some Evar_kinds.GoalEvar *), Namegen.IntroAnonymous, None)) :: props), rest diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 564d24c1ea..78572c6aa6 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -110,7 +110,7 @@ let interp_fix_context ~program_mode ~cofix env sigma fix = else [], fix.Vernacexpr.binders in let sigma, (impl_env, ((env', ctx), imps)) = interp_context_evars ~program_mode env sigma before in let sigma, (impl_env', ((env'', ctx'), imps')) = - interp_context_evars ~program_mode ~impl_env ~shift:(Context.Rel.nhyps ctx) env' sigma after + interp_context_evars ~program_mode ~impl_env env' sigma after in let annot = Option.map (fun _ -> List.length (Termops.assums_of_rel_context ctx)) fix.Vernacexpr.rec_order in sigma, ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 452de69b1d..bb26ce652e 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -16,7 +16,6 @@ open Context open Environ open Names open Libnames -open Nameops open Constrexpr open Constrexpr_ops open Constrintern @@ -139,7 +138,7 @@ let model_conclusion env sigma ind_rel params n arity_indices = let sigma,model_indices = List.fold_right (fun (_,t) (sigma, subst) -> - let t = EConstr.Vars.substl subst (EConstr.Vars.liftn n (List.length subst + 1) (EConstr.Vars.liftn 1 (List.length params + List.length subst + 1) t)) in + let t = EConstr.Vars.substl subst (EConstr.Vars.liftn n (List.length subst + 1) t) in let sigma, c = Evarutil.new_evar env sigma t in sigma, c::subst) arity_indices (sigma, []) in @@ -443,9 +442,8 @@ let interp_params env udecl uparamsl paramsl = interp_context_evars ~program_mode:false ~impl_env:uimpls env_uparams sigma paramsl in (* Names of parameters as arguments of the inductive type (defs removed) *) - let assums = List.filter is_local_assum ctx_params in sigma, env_params, (ctx_params, env_uparams, ctx_uparams, - List.map (RelDecl.get_name %> Name.get_id) assums, userimpls, useruimpls, impls, udecl) + userimpls, useruimpls, impls, udecl) (* When a hole remains for a param, pretend the param is uniform and do the unification. @@ -482,11 +480,12 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not then user_err (str "Inductives with uniform parameters may not have attached notations."); let indnames = List.map (fun ind -> ind.ind_name) indl in + let ninds = List.length indl in (* In case of template polymorphism, we need to compute more constraints *) let env0 = if poly then env0 else Environ.set_universes_lbound env0 UGraph.Bound.Prop in - let sigma, env_params, (ctx_params, env_uparams, ctx_uparams, params, userimpls, useruimpls, impls, udecl) = + let sigma, env_params, (ctx_params, env_uparams, ctx_uparams, userimpls, useruimpls, impls, udecl) = interp_params env0 udecl uparamsl paramsl in @@ -496,16 +495,17 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let sigma, arities = List.fold_left_map (pretype_ind_arity env_params) sigma arities in let arities, relevances, arityconcl, indimpls = List.split4 arities in - let lift1_ctx ctx = + let lift_ctx n ctx = let t = EConstr.it_mkProd_or_LetIn EConstr.mkProp ctx in - let t = EConstr.Vars.lift 1 t in + let t = EConstr.Vars.lift n t in let ctx, _ = EConstr.decompose_prod_assum sigma t in ctx in - let ctx_params_lifted, fullarities = CList.fold_left_map - (fun ctx_params c -> lift1_ctx ctx_params, EConstr.it_mkProd_or_LetIn c ctx_params) - ctx_params - arities + let ctx_params_lifted, fullarities = + lift_ctx ninds ctx_params, + CList.map_i + (fun i c -> EConstr.Vars.lift i (EConstr.it_mkProd_or_LetIn c ctx_params)) + 0 arities in let env_ar = push_types env_uparams indnames relevances fullarities in let env_ar_params = EConstr.push_rel_context ctx_params_lifted env_ar in @@ -515,14 +515,15 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let impls = compute_internalization_env env_uparams sigma ~impls Inductive indnames fullarities indimpls in let ntn_impls = compute_internalization_env env_uparams sigma Inductive indnames fullarities indimpls in - let ninds = List.length indl in let (sigma, _), constructors = Metasyntax.with_syntax_protection (fun () -> (* Temporary declaration of notations and scopes *) List.iter (Metasyntax.set_notation_for_interpretation env_params ntn_impls) notations; (* Interpret the constructor types *) List.fold_left2_map - (fun (sigma, ind_rel) -> interp_cstrs env_ar_params (sigma, ind_rel) impls ctx_params) + (fun (sigma, ind_rel) ind arity -> + interp_cstrs env_ar_params (sigma, ind_rel) impls ctx_params_lifted + ind (EConstr.Vars.liftn ninds (Rel.length ctx_params + 1) arity)) (sigma, ninds) indl arities) () in @@ -540,7 +541,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let nuparams = Context.Rel.length ctx_uparams in let uargs = Context.Rel.to_extended_vect EConstr.mkRel 0 ctx_uparams in let uparam_subst = - List.init (List.length indl) EConstr.(fun i -> mkApp (mkRel (i + 1 + nuparams), uargs)) + List.init ninds EConstr.(fun i -> mkApp (mkRel (i + 1 + nuparams), uargs)) @ List.init nuparams EConstr.(fun i -> mkRel (i + 1)) in let generalize_constructor c = EConstr.Unsafe.to_constr (EConstr.Vars.substnl uparam_subst nparams c) in let cimpls = List.map pi3 constructors in diff --git a/vernac/declare.ml b/vernac/declare.ml index 099a63cf8f..ae7878b615 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -725,7 +725,6 @@ module Obligation = struct ; obl_tac : unit Proofview.tactic option } let set_type ~typ obl = {obl with obl_type = typ} - let set_body ~body obl = {obl with obl_body = Some body} end type obligations = {obls : Obligation.t array; remaining : int} @@ -2464,32 +2463,25 @@ let add_mutual_definitions l ~pm ~info ?obl_hook ~uctx in pm -let admit_prog ~pm prg = - let {obls; remaining} = Internal.get_obligations prg in - let obls = Array.copy obls in - Array.iteri - (fun i x -> - match x.obl_body with - | None -> - let x = subst_deps_obl obls x in - let uctx = Internal.get_uctx prg in - let univs = UState.univ_entry ~poly:false uctx in - let kn = declare_constant ~name:x.obl_name ~local:Locality.ImportNeedQualified - (ParameterEntry (None, (x.obl_type, univs), None)) ~kind:Decls.(IsAssumption Conjectural) - in - assumption_message x.obl_name; - obls.(i) <- Obligation.set_body ~body:(DefinedObl (kn, Univ.Instance.empty)) x - | Some _ -> ()) - obls; - Obls_.update_obls ~pm prg obls 0 - -(* get_any_prog *) +let rec admit_prog ~pm prg = + let {obls} = Internal.get_obligations prg in + let is_open _ x = Option.is_empty x.obl_body && List.is_empty (deps_remaining obls x.obl_deps) in + let i = match Array.findi is_open obls with + | Some i -> i + | None -> CErrors.anomaly (Pp.str "Could not find a solvable obligation.") + in + let proof = solve_obligation prg i None in + let pm = Proof.save_admitted ~pm ~proof in + match ProgMap.find_opt (Internal.get_name prg) pm with + | Some prg -> admit_prog ~pm (CEphemeron.get prg) + | None -> pm + let rec admit_all_obligations ~pm = let prg = State.first_pending pm in match prg with | None -> pm | Some prg -> - let pm, _prog = admit_prog ~pm prg in + let pm = admit_prog ~pm prg in admit_all_obligations ~pm let admit_obligations ~pm n = @@ -2497,7 +2489,7 @@ let admit_obligations ~pm n = | None -> admit_all_obligations ~pm | Some _ -> let prg = get_unique_prog ~pm n in - let pm, _ = admit_prog ~pm prg in + let pm = admit_prog ~pm prg in pm let next_obligation ~pm n tac = diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index cbd83e88b6..b134f7b82b 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -268,16 +268,16 @@ let custom_entry_locality = Summary.ref ~name:"LOCAL-CUSTOM-ENTRY" String.Set.em let create_custom_entry ~local s = if List.mem s ["constr";"pattern";"ident";"global";"binder";"bigint"] then user_err Pp.(quote (str s) ++ str " is a reserved entry name."); - let sc = "constr:"^s in - let sp = "pattern:"^s in + let sc = "custom:"^s in + let sp = "custom_pattern:"^s in let _ = extend_entry_command constr_custom_entry sc in let _ = extend_entry_command pattern_custom_entry sp in let () = if local then custom_entry_locality := String.Set.add s !custom_entry_locality in () let find_custom_entry s = - let sc = "constr:"^s in - let sp = "pattern:"^s in + let sc = "custom:"^s in + let sp = "custom_pattern:"^s in try (find_custom_entry constr_custom_entry sc, find_custom_entry pattern_custom_entry sp) with Not_found -> user_err Pp.(str "Undeclared custom entry: " ++ str s ++ str ".") diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index e0550fd744..831aeff6a0 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -33,26 +33,26 @@ open Attributes (* Rem: do not join the different GEXTEND into one, it breaks native *) (* compilation on PowerPC and Sun architectures *) -let query_command = Entry.create "vernac:query_command" - -let search_query = Entry.create "vernac:search_query" -let search_queries = Entry.create "vernac:search_queries" - -let subprf = Entry.create "vernac:subprf" - -let quoted_attributes = Entry.create "vernac:quoted_attributes" -let class_rawexpr = Entry.create "vernac:class_rawexpr" -let thm_token = Entry.create "vernac:thm_token" -let def_token = Entry.create "vernac:def_token" -let assumption_token = Entry.create "vernac:assumption_token" -let def_body = Entry.create "vernac:def_body" -let decl_notations = Entry.create "vernac:decl_notations" -let record_field = Entry.create "vernac:record_field" -let of_type_with_opt_coercion = Entry.create "vernac:of_type_with_opt_coercion" -let section_subset_expr = Entry.create "vernac:section_subset_expr" -let scope_delimiter = Entry.create "vernac:scope_delimiter" -let syntax_modifiers = Entry.create "vernac:syntax_modifiers" -let only_parsing = Entry.create "vernac:only_parsing" +let query_command = Entry.create "query_command" + +let search_query = Entry.create "search_query" +let search_queries = Entry.create "search_queries" + +let subprf = Entry.create "subprf" + +let quoted_attributes = Entry.create "quoted_attributes" +let class_rawexpr = Entry.create "class_rawexpr" +let thm_token = Entry.create "thm_token" +let def_token = Entry.create "def_token" +let assumption_token = Entry.create "assumption_token" +let def_body = Entry.create "def_body" +let decl_notations = Entry.create "decl_notations" +let record_field = Entry.create "record_field" +let of_type_with_opt_coercion = Entry.create "of_type_with_opt_coercion" +let section_subset_expr = Entry.create "section_subset_expr" +let scope_delimiter = Entry.create "scope_delimiter" +let syntax_modifiers = Entry.create "syntax_modifiers" +let only_parsing = Entry.create "only_parsing" let make_bullet s = let open Proof_bullet in @@ -469,11 +469,8 @@ GRAMMAR EXTEND Gram [ [ id = identref; c=constructor_type -> { c id } ] ] ; of_type_with_opt_coercion: - [ [ ":>>" -> { Some false } - | ":>"; ">" -> { Some false } - | ":>" -> { Some true } - | ":"; ">"; ">" -> { Some false } - | ":"; ">" -> { Some true } + [ [ ":>" -> { Some () } + | ":"; ">" -> { Some () } | ":" -> { None } ] ] ; END diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 762c95fffe..c16eaac516 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -71,6 +71,9 @@ let rec contract3' env sigma a b c = function | ConversionFailed (env',t1,t2) -> let (env',t1,t2) = contract2 env' sigma t1 t2 in contract3 env sigma a b c, ConversionFailed (env',t1,t2) + | IncompatibleInstances (env',ev,t1,t2) -> + let (env',ev,t1,t2) = contract3 env' sigma (EConstr.mkEvar ev) t1 t2 in + contract3 env sigma a b c, IncompatibleInstances (env',EConstr.destEvar sigma ev,t1,t2) | NotSameArgSize | NotSameHead | NoCanonicalStructure | MetaOccurInBody _ | InstanceNotSameType _ | ProblemBeyondCapabilities | UnifUnivInconsistency _ as x -> contract3 env sigma a b c, x @@ -313,6 +316,13 @@ let explain_unification_error env sigma p1 p2 = function let t1, t2 = pr_explicit env sigma t1 t2 in [str "cannot unify " ++ t1 ++ strbrk " and " ++ t2] else [] + | IncompatibleInstances (env,ev,t1,t2) -> + let env = make_all_name_different env sigma in + let ev = pr_leconstr_env env sigma (EConstr.mkEvar ev) in + let t1 = Reductionops.nf_betaiota env sigma t1 in + let t2 = Reductionops.nf_betaiota env sigma t2 in + let t1, t2 = pr_explicit env sigma t1 t2 in + [ev ++ strbrk " has otherwise to unify with " ++ t1 ++ str " which is incompatible with " ++ t2] | MetaOccurInBody evk -> [str "instance for " ++ quote (pr_existential_key sigma evk) ++ strbrk " refers to a metavariable - please report your example" ++ @@ -689,34 +699,29 @@ let explain_cannot_unify_binding_type env sigma m n = str "which should be unifiable with" ++ brk(1,1) ++ pn ++ str "." let explain_cannot_find_well_typed_abstraction env sigma p l e = - let p = EConstr.to_constr sigma p in str "Abstracting over the " ++ str (String.plural (List.length l) "term") ++ spc () ++ - hov 0 (pr_enum (fun c -> pr_lconstr_env env sigma (EConstr.to_constr sigma c)) l) ++ spc () ++ - str "leads to a term" ++ spc () ++ pr_ltype_env ~goal_concl_style:true env sigma p ++ + hov 0 (pr_enum (fun c -> pr_leconstr_env env sigma c) l) ++ spc () ++ + str "leads to a term" ++ spc () ++ pr_letype_env ~goal_concl_style:true env sigma p ++ spc () ++ str "which is ill-typed." ++ (match e with None -> mt () | Some e -> fnl () ++ str "Reason is: " ++ e) let explain_wrong_abstraction_type env sigma na abs expected result = - let abs = EConstr.to_constr sigma abs in - let expected = EConstr.to_constr sigma expected in - let result = EConstr.to_constr sigma result in let ppname = match na with Name id -> Id.print id ++ spc () | _ -> mt () in str "Cannot instantiate metavariable " ++ ppname ++ strbrk "of type " ++ - pr_lconstr_env env sigma expected ++ strbrk " with abstraction " ++ - pr_lconstr_env env sigma abs ++ strbrk " of incompatible type " ++ - pr_lconstr_env env sigma result ++ str "." + pr_leconstr_env env sigma expected ++ strbrk " with abstraction " ++ + pr_leconstr_env env sigma abs ++ strbrk " of incompatible type " ++ + pr_leconstr_env env sigma result ++ str "." let explain_abstraction_over_meta _ m n = strbrk "Too complex unification problem: cannot find a solution for both " ++ Name.print m ++ spc () ++ str "and " ++ Name.print n ++ str "." let explain_non_linear_unification env sigma m t = - let t = EConstr.to_constr sigma t in strbrk "Cannot unambiguously instantiate " ++ Name.print m ++ str ":" ++ strbrk " which would require to abstract twice on " ++ - pr_lconstr_env env sigma t ++ str "." + pr_leconstr_env env sigma t ++ str "." let explain_unsatisfied_constraints env sigma cst = strbrk "Unsatisfied constraints: " ++ @@ -803,10 +808,10 @@ let explain_cannot_unify_occurrences env sigma nested ((cl2,pos2),t2) ((cl1,pos1 explain_unification_error env sigma c1 c2 (Some e) in str "Found incompatible occurrences of the pattern" ++ str ":" ++ - spc () ++ str "Matched term " ++ pr_lconstr_env env sigma (EConstr.to_constr sigma t2) ++ + spc () ++ str "Matched term " ++ pr_leconstr_env env sigma t2 ++ strbrk " at position " ++ pr_position (cl2,pos2) ++ strbrk " is not compatible with matched term " ++ - pr_lconstr_env env sigma (EConstr.to_constr sigma t1) ++ strbrk " at position " ++ + pr_leconstr_env env sigma t1 ++ strbrk " at position " ++ pr_position (cl1,pos1) ++ ppreason ++ str "." let pr_constraints printenv env sigma evars cstrs = @@ -1287,9 +1292,8 @@ let explain_recursion_scheme_error env = function (* Pattern-matching errors *) let explain_bad_pattern env sigma cstr ty = - let ty = EConstr.to_constr sigma ty in let env = make_all_name_different env sigma in - let pt = pr_lconstr_env env sigma ty in + let pt = pr_leconstr_env env sigma ty in let pc = pr_constructor env cstr in str "Found the constructor " ++ pc ++ brk(1,1) ++ str "while matching a term of type " ++ pt ++ brk(1,1) ++ @@ -1326,12 +1330,11 @@ let explain_non_exhaustive env pats = spc () ++ hov 0 (prlist_with_sep pr_comma pr_cases_pattern pats) let explain_cannot_infer_predicate env sigma typs = - let inj c = EConstr.to_constr sigma c in - let typs = Array.map_to_list (fun (c1, c2) -> (inj c1, inj c2)) typs in + let typs = Array.to_list typs in let env = make_all_name_different env sigma in let pr_branch (cstr,typ) = - let cstr,_ = decompose_app cstr in - str "For " ++ pr_lconstr_env env sigma cstr ++ str ": " ++ pr_lconstr_env env sigma typ + let cstr,_ = EConstr.decompose_app sigma cstr in + str "For " ++ pr_leconstr_env env sigma cstr ++ str ": " ++ pr_leconstr_env env sigma typ in str "Unable to unify the types found in the branches:" ++ spc () ++ hov 0 (prlist_with_sep fnl pr_branch typs) diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index ab1ce44081..898a262266 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -85,7 +85,7 @@ let pr_grammar = function pr_entry Pvernac.Vernac_.gallina_ext | name -> pr_registered_grammar name -let pr_custom_grammar name = pr_registered_grammar ("constr:"^name) +let pr_custom_grammar name = pr_registered_grammar ("custom:"^name) (**********************************************************************) (* Parse a format (every terminal starting with a letter or a single diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index b73e7c7515..8a98a43ba0 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -504,8 +504,7 @@ let pr_intarg n = spc () ++ int n let pr_oc = function | None -> str" :" - | Some true -> str" :>" - | Some false -> str" :>>" + | Some () -> str" :>" let pr_record_field (x, { rf_subclass = oc ; rf_priority = pri ; rf_notation = ntn }) = let prx = match x with diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index f4cb1adfe8..c9f68eed57 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -10,7 +10,9 @@ open Pcoq -let uvernac = create_universe "vernac" +[@@@ocaml.warning "-3"] +let uvernac = create_universe "vernac" [@@deprecated "Deprecated in 8.13"] +[@@@ocaml.warning "+3"] type proof_mode = string @@ -35,20 +37,18 @@ let command_entry_ref = ref None module Vernac_ = struct - let gec_vernac s = Entry.create ("vernac:" ^ s) - (* The different kinds of vernacular commands *) - let gallina = gec_vernac "gallina" - let gallina_ext = gec_vernac "gallina_ext" - let command = gec_vernac "command" - let syntax = gec_vernac "syntax_command" - let vernac_control = gec_vernac "Vernac.vernac_control" - let rec_definition = gec_vernac "Vernac.rec_definition" - let red_expr = new_entry utactic "red_expr" - let hint_info = gec_vernac "hint_info" + let gallina = Entry.create "gallina" + let gallina_ext = Entry.create "gallina_ext" + let command = Entry.create "command" + let syntax = Entry.create "syntax_command" + let vernac_control = Entry.create "Vernac.vernac_control" + let rec_definition = Entry.create "Vernac.rec_definition" + let red_expr = Entry.create "red_expr" + let hint_info = Entry.create "hint_info" (* Main vernac entry *) let main_entry = Entry.create "vernac" - let noedit_mode = gec_vernac "noedit_command" + let noedit_mode = Entry.create "noedit_command" let () = let act_vernac v loc = Some v in diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index 1718024edd..8ab4af7d48 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -12,7 +12,9 @@ open Pcoq open Genredexpr open Vernacexpr -val uvernac : gram_universe +[@@@ocaml.warning "-3"] +val uvernac : gram_universe [@@deprecated "Deprecated in 8.13"] +[@@@ocaml.warning "+3"] type proof_mode diff --git a/vernac/record.ml b/vernac/record.ml index bd5b71cd6b..89acd79dda 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -557,10 +557,15 @@ let declare_class def cumulative ubinders univs id idbuild paramimpls params uni Impargs.declare_manual_implicits false (GlobRef.ConstRef proj_cst) (List.hd fieldimpls); Classes.set_typeclass_transparency (EvalConstRef cst) false false; let sub = match List.hd coers with - | Some b -> Some ((if b then Backward else Forward), List.hd priorities) + | Some () -> Some (List.hd priorities) | None -> None in - [cref, [Name proj_name, sub, Some proj_cst]] + let m = { + meth_name = Name proj_name; + meth_info = sub; + meth_const = Some proj_cst; + } in + [cref, [m]] | _ -> let record_data = [id, idbuild, univ, arity, fieldimpls, fields, false, List.map (fun _ -> { pf_subclass = false ; pf_canonical = true }) fields] in @@ -568,14 +573,17 @@ let declare_class def cumulative ubinders univs id idbuild paramimpls params uni params template ~kind:Decls.Method ~name:[|binder_name|] record_data in let coers = List.map2 (fun coe pri -> - Option.map (fun b -> - if b then Backward, pri else Forward, pri) coe) + Option.map (fun () -> pri) coe) coers priorities in let map ind = - let l = List.map3 (fun decl b y -> RelDecl.get_name decl, b, y) - (List.rev fields) coers (Recordops.lookup_projections ind) - in GlobRef.IndRef ind, l + let map decl b y = { + meth_name = RelDecl.get_name decl; + meth_info = b; + meth_const = y; + } in + let l = List.map3 map (List.rev fields) coers (Recordops.lookup_projections ind) in + GlobRef.IndRef ind, l in List.map map inds in diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index fba6800729..60c6d2ec0b 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -776,7 +776,7 @@ let vernac_inductive ~atts kind indl = | _ -> CErrors.user_err Pp.(str "Definitional classes do not support the \"|\" syntax.") in let (coe, (lid, ce)) = l in - let coe' = if coe then Some true else None in + let coe' = if coe then Some () else None in let f = AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce), { rf_subclass = coe' ; rf_priority = None ; rf_notation = [] ; rf_canonical = true } in vernac_record ~template udecl ~cumulative (Class true) ~poly finite [id, bl, c, None, [f]] diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index d8e17d00e3..721e710e1d 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -106,8 +106,8 @@ type search_restriction = type verbose_flag = bool (* true = Verbose; false = Silent *) type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) -type instance_flag = bool option - (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) +type instance_flag = unit option + (* Some () = Backward instance, None = NoInstance *) type export_flag = bool (* true = Export; false = Import *) diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 496b1a43d1..eacb7fe6cb 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -247,7 +247,7 @@ let vernac_argument_extend ~name arg = let () = Pcoq.register_grammar wit e in e | Arg_rules rules -> - let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in + let e = Pcoq.create_generic_entry2 name (Genarg.rawwit wit) in let () = Pcoq.grammar_extend e {Pcoq.pos=None; data=[(None, None, rules)]} in e in |