diff options
| author |  Enrico Tassi <gareuselesinge@debian.org> | 2015-07-15 13:15:50 +0200 |
|---|---|---|
| committer | Enrico Tassi <gareuselesinge@debian.org> | 2015-07-15 13:15:50 +0200 |
| commit | e347929583f820a2cc0296597b6382309e930989 (patch) | |
| tree | cdc3f18fc5c66a9d3d7cc8404c6a295169e41fcc | |
| parent | c01be74d81a5466c58f8dc6c568db286b0979997 (diff) | |
| parent | 0aa2544d04dbd4b6ee665b551ed165e4fb02d2fa (diff) | |
Merge tag 'upstream/8.5_beta2+dfsg' into test
Upstream version 8.5~beta2+dfsg
552 files changed, 14747 insertions, 4344 deletions
@@ -14,15 +14,18 @@ Logic parameters, i.e. [@p] is definitionally equal to [λ params r. r.(p)]. Records with primitive projections have eta-conversion, the canonical form being [mkR pars (p1 t) ... (pn t)]. - - New universe polymorphism (see reference manual) - New option -type-in-type to collapse the universe hierarchy (this makes the logic inconsistent). -- The guard condition for fixpoints is now a bit stricter. Propagation of -subterm value through pattern matching is restricted according to the return -predicate. Restores compatibility of Coq's logic with the propositional -extensionality axiom. May create incompatibilities in recursive programs heavily -using dependent types. +- The guard condition for fixpoints is now a bit stricter. Propagation + of subterm value through pattern matching is restricted according to + the return predicate. Restores compatibility of Coq's logic with the + propositional extensionality axiom. May create incompatibilities in + recursive programs heavily using dependent types. +- Trivial inductive types are no longer defined in Type but in Prop, which + leads to a non-dependent induction principle being generated in place of + the dependent one. To recover the old behavior, explicitly define your + inductive types in Set. Vernacular commands @@ -44,7 +47,7 @@ Vernacular commands - Command "Search" has been renamed into "SearchHead". The command name "Search" now behaves like former "SearchAbout". The latter name is deprecated. -- "Search" "About" "SearchHead" "SearchRewrite" and "SearchPattern" +- "Search", "About", "SearchHead", "SearchRewrite" and "SearchPattern" now search for hypothesis (of the current goal by default) first. They now also support the goal selector prefix to specify another goal to search: e.g. "n:Search id". This is also true for @@ -59,18 +62,20 @@ Vernacular commands Coq: terms, modules, tactics, etc. The old behavior of the command can be retrieved using the "Locate Term" command. - New "Derive" command to help writing program by derivation. -- "Undo" undoes any command, not just tactics. - New "Refine Instance Mode" option that allows to deactivate the generation of obligations in incomplete typeclass instances, raising an error instead. - "Collection" command to name sets of section hypotheses. Named collections - can be used in the syntax of "Proof using" to assert with section variables + can be used in the syntax of "Proof using" to assert which section variables are used in a proof. - The "Optimize Proof" command can be placed in the middle of a proof to - force the compaction the data structure used to represent the ongoing - proof (evar map). This may result in a lower memory footprint and speed up + force the compaction of the data structure used to represent the ongoing + proof (evar map). This may result in a lower memory footprint and speed up the execution of the following tactics. -- "Optimize Heap" command to tell the OCaml runtime to performa a major +- "Optimize Heap" command to tell the OCaml runtime to perform a major garbage collection step and heap compaction. +- "Instance" no longer treats the {|...|} syntax specially; it handles it + in the same way as other commands, e.g. "Definition". Use the {...} + syntax (no pipe symbols) to recover the old behavior. Specification Language @@ -78,10 +83,13 @@ Specification Language - Added a syntax $(...)$ that allows putting tactics in terms (may break user notations using "$(", fixable by inserting a space or rewriting the notation). -- Constants in pattern-matching branches now respect the same rules regarding - implicit arguments than in applicative position. The old behavior can be - recovered by the command "Set Asymmetric Patterns". (possible source of - incompatibilities) +- Constructors in pattern-matching patterns now respect the same rules + regarding implicit arguments than in applicative position. The old + behavior can be recovered by the command "Set Asymmetric + Patterns". As a side effect, Much more notations can be used in + patterns. Considering that the pattern language is rich enough like + that, definitions are now always forbidden in patterns. (source of + incompatibilities for definitions that delta-reduce to a constructor) - Type inference algorithm now granting opacity of constants. This might also affect behavior of tactics (source of incompatibilities, solvable by re-declaring transparent constants which were set opaque). @@ -98,38 +106,38 @@ Tactics instantiation information of existential variables is always propagated to tactics, removing the need to manually use the "instantiate" tactics to mark propagation points. - * New tactical (a+b) insert a backtracking point. When (a+b);c fails + * New tactical (a+b) inserts a backtracking point. When (a+b);c fails during the execution of c, it can backtrack and try b instead of a. - * New tactical (once a) removes all the backtracking point from a + * New tactical (once a) removes all the backtracking points from a (i.e. it selects the first success of a). * Tactic "constructor" is now fully backtracking, thus deprecating the need of the undocumented "constructor <tac>" syntax which is - now equivalent to "once (constructor; tac)". (potential source of - rare incompatibilities). + now equivalent to "[> once (constructor; tac) ..]". (potential + source of rare incompatibilities). * New "multimatch" variant of "match" tactic which backtracks to new branches in case of a later failure. The "match" tactic is equivalent to "once multimatch". - * New selector all: to qualify a tactic allows applying a tactic to - all the focused goal, instead of just the first one as is the + * New selector "all:" such that "all:tac" applies tactic "tac" to + all the focused goals, instead of just the first one as is the default. * A corresponding new option Set Default Goal Selector "all" makes the tactics in scripts be applied to all the focused goal by default - * New selector par: to qualify a tactic allows applying a (terminating) - tactic to all the focused goal in parallel. The number of worker can - be selected with -async-proofs-tac-j and also limited using the + * New selector "par:" such that "par:tac" applies the (terminating) + tactic "tac" to all the focused goal in parallel. The number of worker + can be selected with -async-proofs-tac-j and also limited using the coqworkmgr utility. * New tactics "revgoals", "cycle" and "swap" to reorder goals. - * The semantics of recursive tactics (introduced with Ltac t := - ... or let rec t := ... in ...) changes slightly as t is now - applied to every goal not each goal independently, in particular - it may be applied when no goal are left. This may cause tactics - such as let rec t := constructor;t to loop indefinitely. The - simple fix is to rewrite the recursive calls as follows: let rec t - := constructor;[t..] which recovers the earlier behavior (source - of rare incompatibilities). - * New tactic language feature "numgoals" to count number of goals. - Accompanied by "guard" tactic which fails if a Boolean test does - not pass. + * The semantics of recursive tactics (introduced with "Ltac t := ..." + or "let rec t := ... in ...") changed slightly as t is now + applied to every goal, not each goal independently. In particular + it may be applied when no goals are left. This may cause tactics + such as "let rec t := constructor;t" to loop indefinitely. The + simple fix is to rewrite the recursive calls as follows: + "let rec t := constructor;[t..]" which recovers the earlier behavior + (source of rare incompatibilities). + * New tactic language feature "numgoals" to count number of goals. It is + accompanied by a "guard" tactic which fails if a Boolean test over + integers does not pass. * New tactical "[> ... ]" to apply tactics to individual goals. * New tactic "gfail" which works like "fail" except it will also fail if every goal has been solved. @@ -143,9 +151,17 @@ Tactics Unshelve command. * A variant shelve_unifiable only removes those goals which appear as existential variables in other goals. To emulate the old - refine, use (refine c;shelve_unifiable). This can still cause + refine, use "refine c;shelve_unifiable". This can still cause incompatibilities in rare occasions. - * New "give_up" tactic to skip over a goal without admitting it. + * New "give_up" tactic to skip over a goal. A proof containing + given up goals cannot be closed with "Qed", but only with "Admitted". +- The implementation of the admit tactic has changed: no axiom is + generated for the admitted sub proof. "admit" is now an alias for + "give_up". Code relying on this specific behavior of "admit" + can be made to work by: + * Adding an "Axiom" for each admitted subproof. + * Adding a single "Axiom proof_admitted : False." and the Ltac definition + "Ltac admit := case proof_admitted.". - Matching using "lazymatch" was fundamentally modified. It now behaves like "match" (immediate execution of the matching branch) but without the backtracking mechanism in case of failure. @@ -164,7 +180,9 @@ Tactics opposite side, new tactic "dtauto" is able to destruct any record-like inductive types, superseding the old version of "tauto". - Similarly, "intuition" has been made more uniform and, where it now - fails, "dintuition" can be used. (possible source of incompatibilities) + fails, "dintuition" can be used (possible source of incompatibilities). +- New option "Unset Intuition Negation Unfolding" for deactivating automatic + unfolding of "not" in intuition. - Tactic notations can now be defined locally to a module (use "Local" prefix). - Tactic "red" now reduces head beta-iota redexes (potential source of rare incompatibilities). @@ -198,6 +216,8 @@ Tactics on the fly if injection is applicable to the hypothesis under consideration (idea borrowed from Georges Gonthier). Introduction pattern [=] applies "discriminate" if a discriminable equality. +- New introduction patterns * and ** to respectively introduce all forthcoming + dependent variables and all variables/hypotheses dependent or not. - Tactic "injection c as ipats" now clears c if c refers to an hypothesis and moves the resulting equations in the hypotheses independently of the number of ipats, which has itself to be less @@ -221,15 +241,15 @@ Tactics the relevant hypotheses). - New construct "uconstr:c" and "type_term c" to build untyped terms. - Binders in terms defined in Ltac (either "constr" or "uconstr") can - now take their names from identifier defined in Ltac. As a - consequence, a name cannot be used in a binder (constr:(fun x => - ...)) if an Ltac variable of that name already exists and does not + now take their names from identifiers defined in Ltac. As a + consequence, a name cannot be used in a binder "constr:(fun x => + ...)" if an Ltac variable of that name already exists and does not contain an identifier. Source of occasional incompatibilities. - The "refine" tactic now accepts untyped terms built with "uconstr" so that terms with holes can be constructed piecewise in Ltac. - New bullets --, ++, **, ---, +++, ***, ... made available. - More informative messages when wrong bullet is used. -- bullet suggestion when a subgoal is solved. +- Bullet suggestion when a subgoal is solved. - New tactic "enough", symmetric to "assert", but with subgoals swapped, as a more friendly replacement of "cut". - In destruct/induction, experimental modifier "!" prefixing the @@ -238,9 +258,9 @@ Tactics - Behavior of introduction patterns -> and <- made more uniform (hypothesis is cleared, rewrite in hypotheses and conclusion and erasing the variable when rewriting a variable). -- Tactics from plugins are now active only when the corresponding - module is imported (source of incompatibilities, solvable by adding - an "Import", like e.g. "Import Omega"). +- Tactics from plugins are now active only when the corresponding module + is imported (source of incompatibilities, solvable by adding an "Import"; + in the particular case of Omega, use "Require Import OmegaTactic"). - Semantics of destruct/induction has been made more regular in some edge cases, possibly leading to incompatibilities: - new goals are now opened when the term does not match a subterm of @@ -253,6 +273,12 @@ Tactics an inductive type with indices is fixed - residual local definitions are now correctly removed. - The rename tactic may now replace variables in parallel. +- A new "Info" command replaces the "info" tactical discontinued in + v8.4. It still gives informative results in many cases. +- The "info_auto" tactic is known to be broken and does not print a + trace anymore. Use "Info 1 auto" instead. The same goes for + "info_trivial". On the other hand "info_eauto" still works fine, + while "Info 1 eauto" prints a trivial trace. Program @@ -270,9 +296,9 @@ Notations (possible source of incompatibilities) - Notations accept term-providing tactics using the $(...)$ syntax. - "Bind Scope" can no longer bind "Funclass" and "Sortclass". -- A notation can be given a (compat "8.x") annotation, making - it behave like a (only parsing), but flags may active warning - or error when this notation is used. +- A notation can be given a (compat "8.x") annotation, making it behave + like a "only parsing" notation, but the annotation may lead to eventually + issue warnings or errors in further versions when this notation is used. - More systematic insertion of spaces as a default for printing notations ("format" still available to override the default). - In notations, a level modifier referring to a non-existent variable is @@ -280,10 +306,9 @@ Notations Tools -- Option -I now only adds directories to the ml path. To add to both - the load path and the ml path, use -I -as. -- Option -Q behaves as -I -as and -R, except that the logical path of - any loaded file has to be fully qualified. +- Option -I now only adds directories to the ml path. +- Option -Q behaves as -R, except that the logical path of any loaded file has + to be fully qualified. - Option -R no longer adds recursively to the ml path; only the root directory is added. (Behavior with respect to the load path is unchanged.) @@ -291,7 +316,7 @@ Tools added to the load path. (Same behavior as with coq/user-contrib.) - coqdep accepts a -dumpgraph option generating a dot file. - Makefiles generated through coq_makefile have three new targets "quick" - "checkproof" and "vio2vo", allowing respectively to asynchronously compile + "checkproofs" and "vio2vo", allowing respectively to asynchronously compile the files without playing the proof scripts, asynchronously checking that the quickly generated proofs are correct and generating the object files from the quickly generated proofs. @@ -305,14 +330,14 @@ Interfaces - CoqIDE supports asynchronous edition of the document, ongoing tasks and errors are reported in the bottom right window. The number of workers taking care of processing proofs can be selected with -async-proofs-j. -- CoqIDE highlight in yellow "unsafe" commands such as axiom - declarations, and tactics like "admit". +- CoqIDE highlights in yellow "unsafe" commands such as axiom + declarations, and tactics like "give_up". - CoqIDE supports Proof General like key bindings; to activate the PG mode go to Edit -> Preferences -> Editor. For the documentation see Help -> Help for PG mode. - CoqIDE automatically retracts the locked area when one edits the locked text. -- CoqIDE search and replace got regular expressions power. See the +- CoqIDE search and replace got regular expressions power. See the documentation of OCaml's Str module for the supported syntax. - Many CoqIDE windows, including the query one, are now detachable to improve usability on multi screen work stations. @@ -334,7 +359,7 @@ Internal Infrastructure initially does a "Require" of Prelude.vo (or nothing when given the options -noinit or -nois). - The format of vo files has slightly changed: cf final comments in - checker/cic.mli + checker/cic.mli. - The build system does not produce anymore programs named coqtop.opt and a symbolic link to coqtop. Instead, coqtop is now directly an executable compiled with the best OCaml compiler available. @@ -525,7 +550,7 @@ Vernacular commands - New command "Add/Remove Search Blacklist <substring> ...": a Search or SearchAbout or similar query will never mention lemmas whose qualified names contain any of the declared substrings. - The default blacklisted substrings are "_admitted" "_subproof" "Private_". + The default blacklisted substrings are "_subproof" "Private_". - When the output file of "Print Universes" ends in ".dot" or ".gv", the universe graph is printed in the DOT language, and can be processed by Graphviz tools. diff --git a/COMPATIBILITY b/COMPATIBILITY index 2ce29346..eaeb2cba 100644 --- a/COMPATIBILITY +++ b/COMPATIBILITY @@ -26,6 +26,20 @@ Universe Polymorphism. (e.g. induction). Extra "Transparent" might have to be added to revert opacity of constants. +Type classes. + +- When writing an Instance foo : Class A := {| proj := t |} (note the + vertical bars), support for typechecking the projections using the + type information and switching to proof mode is no longer available. + Use { } (without the vertical bars) instead. + +Tactic abstract. + +- Auxiliary lemmas generated by the abstract tactic are removed from + the global environment and inlined in the proof term when a proof + is ended with Qed. The behavior of 8.4 can be obtained by ending + proofs with "Qed exporting" or "Qed exporting ident, .., ident". + Potential sources of incompatibilities between Coq V8.3 and V8.4 ---------------------------------------------------------------- @@ -6,19 +6,6 @@ WHAT DO YOU NEED ? ================== - Coq is designed to work on computers equipped with a POSIX (Unix or a - clone) operating system. It also works under Microsoft Windows (see - INSTALL.win); for a MacOS X bundle application, see INSTALL.macosx. - - Coq is known to be actively used under GNU/Linux (i386 and amd64) and - FreeBSD. Automated tests are run under many, many different architectures - under GNU/Linux. - - Naturally, Coq will run faster on an architecture where OCaml can compile - to native code, rather than only bytecode. See - http://caml.inria.fr/ocaml/portability.en.html for details. - - Your OS may already contain Coq under the form of a precompiled package or ready-to-compile port. In this case, and if the supplied version suits you, follow the usual procedure for your OS to @@ -36,34 +23,31 @@ WHAT DO YOU NEED ? urpmi coq - - MacOS: + - MacPorts for MacOS X port install coq - Should you need or prefer to compile Coq V8.5 yourself, you need: - - - Objective Caml version 3.12.1 or later - (available at http://caml.inria.fr/) + To compile Coq V8.5 yourself, you need: - - Camlp5 (version >= 6.06) (Coq compiles with Camlp4 but might be less - well supported) + - Objective Caml version 3.12.1 or later + (available at http://caml.inria.fr/) - - GNU Make version 3.81 or later + - Camlp5 (version >= 6.02) (Coq compiles with Camlp4 but might be less + well supported) - - a C compiler + - GNU Make version 3.81 or later - - for Coqide, the Lablgtk development files, and the GTK libraries - incuding gtksourceview, see INSTALL.ide for more details + - a C compiler - By FTP, Coq comes as a single compressed tar-file. You have - probably already decompressed it if you are reading this document. + - for Coqide, the Lablgtk development files, and the GTK libraries + incuding gtksourceview, see INSTALL.ide for more details QUICK INSTALLATION PROCEDURE. ============================= 1. ./configure -2. make world +2. make 3. make install (you may need superuser rights) 4. make clean @@ -132,17 +116,13 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). Compile Coq to run in its source directory. The installation (step 6) is not necessary in that case. --opt - Use the ocamlc.opt compiler instead of ocamlc (and ocamlopt.opt - compiler instead of ocamlopt). Makes compilation faster (recommended). - -browser <command> Use <command> to open an URL in a browser. %s must appear in <command>, and will be replaced by the URL. 5- Still in the root directory, do - make world + make to compile Coq in Objective Caml bytecode (and native-code if supported). @@ -219,7 +199,7 @@ THE AVAILABLE COMMANDS. command "Require". A detailed description of these commands and of their options is given - in the Reference Manual (which you can get by FTP, in the doc/ + in the Reference Manual (which you can get in the doc/ directory, or read online on http://coq.inria.fr/doc/) and in the corresponding manual pages. @@ -291,7 +271,7 @@ DYNAMICALLY LOADED LIBRARIES FOR BYTECODE EXECUTABLES. during compilation of binary packages); - install dllcoqrun.so in a location listed in the file ld.conf that is in the directory of the standard library of OCaml; - - recompile your bytecode executables after reconfiguring the location of + - recompile your bytecode executables after reconfiguring the location of the shared library: ./configure -vmbyteflags "-dllib,-lcoqrun,-dllpath,<path>" ... where <path> is the directory where the dllcoqrun.so is installed; diff --git a/INSTALL.ide b/INSTALL.ide index 2bbb4a5f..13e741e3 100644 --- a/INSTALL.ide +++ b/INSTALL.ide @@ -1,12 +1,9 @@ - CoqIde Installation procedure. + CoqIde Installation procedure CoqIde is a graphical interface to perform interactive proofs. You should be able to do everything you do in coqtop inside CoqIde excepted dropping to the ML toplevel. -DISCLAIMER: CoqIde is ongoing work. Although it should never let you - loose a proof, you may encounter unexpected bugs. - Do not hesitate to send suggestions/bug reports. DISTRIBUTION PACKAGES @@ -22,92 +19,87 @@ On Gentoo GNU/Linux, do: Else, read the rest of this document to compile your own CoqIde. -REQUIREMENT: - - OCaml >= 3.12.1 with native threads support. - - make world must succeed. - - The graphical toolkit GTK+ 2.x. See http://www.gtk.org. - The official supported version is at least 2.24.x. - You may still compile CoqIde with older versions and - use all features. - Run - "pkg-config --modversion gtk+-2.0" - to check your version. - All recent distributions have precompiled packages. - Do not forget to install the developement headers packages. - On Debian, installing lablgtk2 (see below) will automatically - install GTK+. (But "aptitude install libgtk2.0-dev" will - install GTK+ 2.x should you need to force it for one reason - or another.) +COMPILATION REQUIREMENTS - - The OCaml bindings for GTK+ 2.x, lablgtk2 with support for gtksourceview2. +- OCaml >= 3.12.1 with native threads support. +- make world must succeed. +- The graphical toolkit GTK+ 2.x. See http://www.gtk.org. + The official supported version is at least 2.24.x. + You may still compile CoqIde with older versions and use all features. + Run - You need at least version 2.14.2. + pkg-config --modversion gtk+-2.0 - Your distribution may contain precompiled packages. For - example, for Debian, run - aptitude install liblablgtksourceview2-ocaml-dev - for Mandriva, run - urpmi ocaml-lablgtk-devel + to check your version. + Do not forget to install the development headers packages. - If it does not, see - http://lablgtk.forge.ocamlcore.org/ + On Debian, installing lablgtk2 (see below) will automatically + install GTK+. (But "aptitude install libgtk2.0-dev" will + install GTK+ 2.x, should you need to force it for one reason + or another.) +- The OCaml bindings for GTK+ 2.x, lablgtk2 with support for gtksourceview2. + You need at least version 2.14.2. - One official releases of lablgtk2 is here: - https://forge.ocamlcore.org/frs/download.php/561/lablgtk-2.14.2.tar.gz + Your distribution may contain precompiled packages. For example, for + Debian, run - If you are in a hurry just run : + aptitude install liblablgtksourceview2-ocaml-dev - cd /tmp && \ - wget \ - https://forge.ocamlcore.org/frs/download.php/561/lablgtk-2.14.2.tar.gz && \ - tar zxvf lablgtk-2.14.2.tar.gz && \ - cd lablgtk-2.14.2 && \ - ./configure && \ - make world && \ - make install + for Mandriva, run - You must have write access to the OCaml standard library path. + urpmi ocaml-lablgtk-devel - If this fails, read lablgtk-2.14.2/README. + If it does not, see http://lablgtk.forge.ocamlcore.org/ + + The basic command installing lablgtk2 from the source package is: + + ./configure && make world && make install + + You must have write access to the OCaml standard library path. + If this fails, read lablgtk-2.14.2/README. INSTALLATION - 0) For optimal performance, OCaml must support native threads (aka pthreads). - If this not the case, this means that Coq computations will be slow and - "make ide" will fail. Use "make bin/coqide.byte" instead. To fix this - problem, just recompile OCaml from source and configure OCaml with : + +0) For optimal performance, OCaml must support native threads (aka pthreads). + If this not the case, this means that Coq computations will be slow and + "make ide" will fail. Use "make bin/coqide.byte" instead. To fix this + problem, just recompile OCaml from source and configure OCaml with: + "./configure --with-pthreads". - In case you install over an existing copy of OCaml, you should better - empty the OCaml installation directory. - 1) Go into your Coq source directory and, as usual, configure with: + In case you install over an existing copy of OCaml, you should better + empty the OCaml installation directory. + +1) Go into your Coq source directory and, as usual, configure with: ./configure - This should detect the ability of making CoqIde; check that is - says it has detected this ability and activated the building of - CoqIde. + This should detect the ability of making CoqIde; check in the + report printed by configure that ability to build CoqIde is detected. - Then compile with + Then compile with make world - and install with + and install with make install - In case you are upgrading from an old version you may need to run + In case you are upgrading from an old version you may need to run + make clean-ide -3) You may now run bin/coqide +2) You may now run bin/coqide NOTES -There are three configuration files located in your $(XDG_CONFIG_HOME)/coq dir. - You may need to set HOME to some sensible value under Windows. -- coqiderc is generated by coqide itself. It may be edited by hand or +There are three configuration files located in your $(XDG_CONFIG_HOME)/coq +dir (defaulting to $HOME/.config/coq). + +- coqiderc is generated by coqide itself. It may be edited by hand or by using the Preference menu from coqide. It will be generated the first time you save your the preferences in Coqide. @@ -119,13 +111,13 @@ Read ide/FAQ for more informations. TROUBLESHOOTING - - Problem with automatic templates +- Problem with automatic templates - Some users may experiment problems with unwanted automatic - templates while using Coqide. This is due to a change in the - modifiers keys available through GTK. The straightest way to get - rid of the problem is to edit by hand your coqiderc (either - /home/<user>/.config/coq/coqiderc under Linux, or - C:\Documents and Settings\<user>\.config\coq\coqiderc under Windows) - and replace any occurence of MOD4 by MOD1. + Some users may experiment problems with unwanted automatic + templates while using Coqide. This is due to a change in the + modifiers keys available through GTK. The straightest way to get + rid of the problem is to edit by hand your coqiderc (either + /home/<user>/.config/coq/coqiderc under Linux, or + C:\Documents and Settings\<user>\.config\coq\coqiderc under Windows) + and replace any occurence of MOD4 by MOD1. diff --git a/INSTALL.macosx b/INSTALL.macosx deleted file mode 100644 index cc1317b1..00000000 --- a/INSTALL.macosx +++ /dev/null @@ -1,20 +0,0 @@ -INSTALLATION PROCEDURE FOR THE PRECOMPILED COQ V8.1 SYSTEM UNDER MACOS X ------------------------------------------------------------------------- - -You can also use fink, or the MacOS X package prepared by the Coq -team. To use the MacOS X package,: - -1) Download archive coq-8.1-macosx-ppc.dmg (for PowerPC-base computer) - or coq-8.1-macosx-i386.dmg (for Pentium-based computer). - -2) Double-click on its icon; it mounts a disk volume named "Coq V8.1". - -3) Open volume "Coq 8.1" and double-click on coq-8.1.pkg to launch the - installer (you'll need administrator permissions). - -4) Coq installs in /usr/local/bin, which should be in your PATH, and - can be used from a Terminal window: the interactive toplevel is - named coqtop and the compiler is coqc. - -If you have any trouble with this installation, please contact: -coq-bugs@pauillac.inria.fr. @@ -169,7 +169,7 @@ Makefile Makefile.build Makefile.common config/Makefile : ; # Cleaning ########################################################################### -.PHONY: clean cleankeepvo objclean cruftclean indepclean doclean archclean optclean clean-ide ml4clean ml4depclean depclean cleanconfig distclean voclean devdocclean +.PHONY: clean cleankeepvo objclean cruftclean indepclean docclean archclean optclean clean-ide ml4clean ml4depclean depclean cleanconfig distclean voclean devdocclean clean: objclean cruftclean depclean docclean devdocclean diff --git a/Makefile.build b/Makefile.build index 0d87d98e..018471b6 100644 --- a/Makefile.build +++ b/Makefile.build @@ -59,7 +59,7 @@ CURDEPS:=$(addsuffix .d, $(CURFILES)) VERBOSE= NO_RECOMPILE_ML4= NO_RECALC_DEPS= -READABLE_ML4=true # non-empty means .ml of .ml4 will be ascii instead of binary +READABLE_ML4= # non-empty means .ml of .ml4 will be ascii instead of binary VALIDATE= COQ_XML= # is "-xml" when building XML library VM= # is "-no-vm" to not use the vm" @@ -101,12 +101,12 @@ BYTEFLAGS=-thread $(CAMLDEBUG) $(USERFLAGS) OPTFLAGS=-thread $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) DEPFLAGS= $(LOCALINCLUDES) -I ide -I ide/utils -ifeq ($(ARCH),Darwin) +ifeq ($(shell which codesign > /dev/null && echo $(ARCH)),Darwin) LINKMETADATA=-ccopt "-sectcreate __TEXT __info_plist config/Info-$(notdir $@).plist" -CODESIGN=codesign -s - +CODESIGN:=codesign -s - else LINKMETADATA= -CODESIGN=true +CODESIGN:=true endif define bestocaml @@ -388,7 +388,7 @@ install-ide-info: $(COQIDEAPP)/Contents: rm -rdf $@ $(MKDIR) $@ - sed -e "s/VERSION/$(VERSION)/g" ide/MacOS/Info.plist.template > $@/Info.plist + sed -e "s/VERSION/$(VERSION4MACOS)/g" ide/MacOS/Info.plist.template > $@/Info.plist $(MKDIR) "$@/MacOS" $(COQIDEINAPP): ide/macos_prehook.cmx $(LINKIDEOPT) | $(COQIDEAPP)/Contents diff --git a/Makefile.common b/Makefile.common index d752a5be..07df8bb1 100644 --- a/Makefile.common +++ b/Makefile.common @@ -207,12 +207,21 @@ ifneq ($(HASNATDYNLINK),false) PLUGINS:=$(PLUGINSCMA) PLUGINSOPT:=$(PLUGINSCMA:.cma=.cmxs) else +ifeq ($(BEST),byte) + STATICPLUGINS:= + INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) \ + $(FUNINDCMA) $(NATSYNTAXCMA) + INITPLUGINSOPT:=$(INITPLUGINS:.cma=.cmxs) + PLUGINS:=$(PLUGINSCMA) + PLUGINSOPT:=$(PLUGINSCMA:.cma=.cmxs) +else STATICPLUGINS:=$(PLUGINSCMA) INITPLUGINS:= INITPLUGINSOPT:= PLUGINS:= PLUGINSOPT:= endif +endif LINKCMO:=$(CORECMA) $(STATICPLUGINS) LINKCMX:=$(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cma=.cmxa) @@ -279,6 +288,7 @@ STRINGSVO:=$(call cat_vo_itarget, theories/Strings) SETSVO:=$(call cat_vo_itarget, theories/Sets) FSETSVO:=$(call cat_vo_itarget, theories/FSets) MSETSVO:=$(call cat_vo_itarget, theories/MSets) +MMAPSVO:=$(call cat_vo_itarget, theories/MMaps) RELATIONSVO:=$(call cat_vo_itarget, theories/Relations) WELLFOUNDEDVO:=$(call cat_vo_itarget, theories/Wellfounded) REALSVO:=$(call cat_vo_itarget, theories/Reals) @@ -294,7 +304,7 @@ THEORIESVO:=\ $(RELATIONSVO) $(WELLFOUNDEDVO) $(SETOIDSVO) \ $(LISTSVO) $(STRINGSVO) \ $(PARITHVO) $(NARITHVO) $(ZARITHVO) \ - $(SETSVO) $(FSETSVO) $(MSETSVO) \ + $(SETSVO) $(FSETSVO) $(MSETSVO) $(MMAPSVO) \ $(REALSVO) $(SORTINGVO) $(QARITHVO) \ $(NUMBERSVO) $(STRUCTURESVO) $(VECTORSVO) diff --git a/Makefile.doc b/Makefile.doc index bc6ae020..1f350935 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -53,7 +53,7 @@ ifdef QUICK %.v.tex: %.tex $(COQTEX) $(COQTEXOPTS) $< else -%.v.tex: %.tex $(COQTEX) $(COQTOPEXE) $(PLUGINSVO) $(THEORIESVO) +%.v.tex: %.tex $(COQTEX) $(COQTOPEXE) $(ALLVO) $(COQTEX) $(COQTEXOPTS) $< endif @@ -99,6 +99,8 @@ doc/refman/Reference-Manual.dvi: $(REFMANFILES) doc/refman/Reference-Manual.tex $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ $(MAKEINDEX) -q Reference-Manual.comidx -o Reference-Manual.comind;\ $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ + $(MAKEINDEX) -q Reference-Manual.optidx -o Reference-Manual.optind;\ + $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ $(MAKEINDEX) -q Reference-Manual.erridx -o Reference-Manual.errind;\ $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ $(LATEX) -interaction=batchmode Reference-Manual > /dev/null;\ @@ -202,12 +204,12 @@ doc/faq/html/index.html: doc/faq/FAQ.v.html ifdef QUICK doc/stdlib/html/genindex.html: else -doc/stdlib/html/genindex.html: | $(COQDOC) $(THEORIESVO) +doc/stdlib/html/genindex.html: | $(COQDOC) $(ALLVO) endif - rm -rf doc/stdlib/html $(MKDIR) doc/stdlib/html $(COQDOC) -q -d doc/stdlib/html --with-header doc/common/styles/html/$(HTMLSTYLE)/header.html --with-footer doc/common/styles/html/$(HTMLSTYLE)/footer.html --multi-index --html -g \ - -R theories Coq $(THEORIESVO:.vo=.v) + -R theories Coq -R plugins Coq $(VFILES) mv doc/stdlib/html/index.html doc/stdlib/html/genindex.html doc/stdlib/index-list.html: doc/stdlib/index-list.html.template doc/stdlib/make-library-index @@ -246,12 +248,12 @@ doc/stdlib/FullLibrary.tex: doc/stdlib/Library.tex ifdef QUICK doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ - -R theories Coq $(THEORIESVO:.vo=.v) > $@ + -R theories Coq -R plugins Coq $(VFILES) > $@ sed -i.tmp -e 's///g' $@ && rm $@.tmp else -doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) $(THEORIESVO) +doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) $(ALLVO) $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ - -R theories Coq $(THEORIESVO:.vo=.v) > $@ + -R theories Coq -R plugins Coq $(VFILES) > $@ sed -i.tmp -e 's///g' $@ && rm $@.tmp endif @@ -8,10 +8,10 @@ INSTALLATION. The Coq package for Windows comes with an auto-installer. It will install Coq binaries and libraries under any directory you specify -(C:\Program Files\Coq is the default path). It also creates shortcuts -in the Windows menus. Alternatively, you can launch Coq using coqide.exe -or coqtop.exe in the bin sub-directory of the installation -(C:\Program Files\Coq\bin by default). +(C:\Coq is the default path). It also creates shortcuts +in the Windows menus. Binaries, like coqc.exe, +are in the bin sub-directory of the installation +(C:\Coq\bin by default). COMPILATION. ============ @@ -20,40 +20,25 @@ COMPILATION. distribution. If you really need to recompile under Windows, here are some indications: - 1- Install ocaml for Windows (MinGW port). - See: http://caml.inria.fr + 1- Install cygwin and the wget package + See: http://cygwin.com - 2- Install a shell environment with at least: - - a C compiler (gcc), - - the GNU make utility + 2- Download and unzip in C:\ the SDK for windows + See: https://coq.inria.fr/distrib/current/files/ - The Cygwin environment is well suited for compiling Coq - (official packages are made using Cygwin) See: - http://www.cygwin.com + 3- From the cygwin prompt type - 3- In order to compile Coqide, you will need the LablGTK library - See: http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/lablgtk.html + . /cygdrive/c/CoqSDK-85-1/environ - You also need to install the GTK libraries for Windows (see the - installation instruction for LablGTK) + The first time the script installs the C toolchain. - 4- In a shell window, type successively + 4- Then Coq can be compiled as follows: + + ./configure -local + make - ./configure - make world - make install + 5- To build the installer, type: - 5- Though not nescessary, you can find useful: - - Windows version of (X)Emacs: it is a powerful environment for - developpers with coloured syntax, modes for compilation and debug, - and many more. It is free. See: http://www.gnu.org/software. - - Windows subversion client (very useful if you have access to the Coq - archive). - - Good luck :-) - - Alternatively, it is now possible (and even recommended ...) to build - Windows executables of coq from Linux thanks to a mingw cross-compiler. - If interested, please contact us for more details. + dev/make-installer-win32.sh The Coq Team. @@ -24,8 +24,6 @@ ## tags for camlp4 files -"toplevel/whelp.ml4": use_grammar - "parsing/g_constr.ml4": use_compat5 "parsing/g_ltac.ml4": use_compat5 "parsing/g_prim.ml4": use_compat5 @@ -74,4 +72,4 @@ "tools/coqdoc": include "toplevel": include -<plugins/**>: include
\ No newline at end of file +<plugins/**>: include diff --git a/checker/check.ml b/checker/check.ml index 9a750858..3e22c4b1 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -321,7 +321,7 @@ let intern_from_file (dir, f) = System.marshal_in_segment f ch in (* Verification of the final checksum *) let () = close_in ch in - let ch = open_in f in + let ch = open_in_bin f in if not (String.equal (Digest.channel ch pos) checksum) then errorlabstrm "intern_from_file" (str "Checksum mismatch"); let () = close_in ch in diff --git a/checker/checker.ml b/checker/checker.ml index ffe15531..9a1007ac 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -181,8 +181,7 @@ let print_usage_channel co command = " -I dir -as coqdir map physical dir to logical coqdir\ \n -I dir map directory dir to the empty logical path\ \n -include dir (idem)\ -\n -R dir -as coqdir recursively map physical dir to logical coqdir\ -\n -R dir coqdir (idem)\ +\n -R dir coqdir recursively map physical dir to logical coqdir\ \n\ \n -admit module load module and dependencies without checking\ \n -norec module check module but admit dependencies without checking\ diff --git a/checker/cic.mli b/checker/cic.mli index a793fefa..90a0e9fe 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -333,7 +333,7 @@ type ('ty,'a) functorize = type with_declaration = | WithMod of Id.t list * module_path - | WithDef of Id.t list * constr + | WithDef of Id.t list * (constr * Univ.universe_context) type module_alg_expr = | MEident of module_path diff --git a/checker/declarations.ml b/checker/declarations.ml index c6709a78..8d913475 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -583,7 +583,7 @@ let implem_map fs fa = function let subst_with_body sub = function | WithMod(id,mp) -> WithMod(id,subst_mp sub mp) - | WithDef(id,c) -> WithDef(id,subst_mps sub c) + | WithDef(id,(c,ctx)) -> WithDef(id,(subst_mps sub c,ctx)) let rec subst_expr sub = function | MEident mp -> MEident (subst_mp sub mp) diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 2ce9f038..050c33e6 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -230,7 +230,6 @@ let compute_elim_sorts env_ar params mib arity lc = let infos = Array.map (sorts_of_constr_args env_params) lc in let (small,unit) = small_unit infos in (* We accept recursive unit types... *) - let unit = unit && mib.mind_ntypes = 1 in (* compute the max of the sorts of the products of the constructor type *) let level = max_inductive_sort (Array.concat (Array.to_list (Array.map Array.of_list infos))) in diff --git a/checker/reduction.ml b/checker/reduction.ml index 185c6edf..28fdb130 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -169,7 +169,15 @@ let sort_cmp univ pb s0 s1 = (match pb with | CONV -> Univ.check_eq univ u1 u2 | CUMUL -> Univ.check_leq univ u1 u2) - then raise NotConvertible + then begin + if !Flags.debug then begin + let op = match pb with CONV -> "=" | CUMUL -> "<=" in + Printf.eprintf "cort_cmp: %s\n%!" Pp.(string_of_ppcmds + (str"Error: " ++ Univ.pr_uni u1 ++ str op ++ Univ.pr_uni u2 ++ str ":" ++ cut() + ++ Univ.pr_universes univ)) + end; + raise NotConvertible + end | (_, _) -> raise NotConvertible let rec no_arg_available = function diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index 35f7f14b..810d6e0b 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -83,6 +83,7 @@ let import file clib univs digest = (* When the module is admitted, digests *must* match *) let unsafe_import file clib univs digest = let env = !genv in - check_imports (errorlabstrm"unsafe_import") clib.comp_name env clib.comp_deps; + if !Flags.debug then check_imports msg_warning clib.comp_name env clib.comp_deps + else check_imports (errorlabstrm"unsafe_import") clib.comp_name env clib.comp_deps; check_engagement env clib.comp_enga; full_add_module clib.comp_name clib.comp_mod univs digest diff --git a/checker/univ.ml b/checker/univ.ml index 5fed6dcd..3bcb3bc9 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -174,6 +174,16 @@ struct | _, Level _ -> 1 | Var n, Var m -> Int.compare n m + let hequal x y = + x == y || + match x, y with + | Prop, Prop -> true + | Set, Set -> true + | Level (n,d), Level (n',d') -> + n == n' && d == d' + | Var n, Var n' -> n == n' + | _ -> false + let hcons = function | Prop as x -> x | Set as x -> x @@ -211,27 +221,26 @@ module Level = struct let hash x = x.hash - let hcons x = - let data' = RawLevel.hcons x.data in - if data' == x.data then x - else { x with data = data' } - let data x = x.data (** Hashcons on levels + their hash *) - let make = - let module Self = struct - type _t = t - type t = _t - let equal = equal - let hash = hash - end in - let module WH = Weak.Make(Self) in - let pool = WH.create 4910 in fun x -> - let x = { hash = RawLevel.hash x; data = x } in - try WH.find pool x - with Not_found -> WH.add pool x; x + module Self = struct + type _t = t + type t = _t + type u = unit + let equal x y = x.hash == y.hash && RawLevel.hequal x.data y.data + let hash x = x.hash + let hashcons () x = + let data' = RawLevel.hcons x.data in + if x.data == data' then x else { x with data = data' } + end + + let hcons = + let module H = Hashcons.Make(Self) in + Hashcons.simple_hcons H.generate H.hcons () + + let make l = hcons { hash = RawLevel.hash l; data = l } let set = make Set let prop = make Prop diff --git a/checker/values.ml b/checker/values.ml index 3ca44b7d..cf93466b 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -13,7 +13,7 @@ To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli with a copy we maintain here: -MD5 0fbea8efeae581d87d977faa9eb2f421 checker/cic.mli +MD5 0a174243f8b06535c9eecbbe8d339fe1 checker/cic.mli *) @@ -270,7 +270,7 @@ let v_ind_pack = v_tuple "mutual_inductive_body" let v_with = Sum ("with_declaration_body",0, [|[|List v_id;v_mp|]; - [|List v_id;v_constr|]|]) + [|List v_id;v_tuple "with_def" [|v_constr;v_context|]|]|]) let rec v_mae = Sum ("module_alg_expr",0, @@ -321,6 +321,33 @@ let v_libobj = Tuple ("libobj", [|v_id;v_obj|]) let v_libobjs = List v_libobj let v_libraryobjs = Tuple ("library_objects",[|v_libobjs;v_libobjs|]) +(** STM objects *) + +let v_frozen = Tuple ("frozen", [|List (v_pair Int Dyn); Opt Dyn|]) +let v_states = v_pair Any v_frozen +let v_state = Tuple ("state", [|v_states; Any; v_bool|]) + +let v_vcs = + let data = Opt Any in + let vcs = + Tuple ("vcs", + [|Any; Any; + Tuple ("dag", + [|Any; Any; v_map Any (Tuple ("state_info", + [|Any; Any; Opt v_state; v_pair data Any|])) + |]) + |]) + in + let () = Obj.set_field (Obj.magic data) 0 (Obj.magic vcs) in + vcs + +let v_uuid = Any +let v_request id doc = + Tuple ("request", [|Any; Any; doc; Any; id; String|]) +let v_tasks = List (v_pair (v_request v_uuid v_vcs) v_bool) +let v_counters = Any +let v_stm_seg = v_pair v_tasks v_counters + (** Toplevel structures in a vo (see Cic.mli) *) let v_lib = @@ -332,19 +359,19 @@ let v_univopaques = (** Registering dynamic values *) -module StringOrd = +module IntOrd = struct - type t = string + type t = int let compare (x : t) (y : t) = compare x y end -module StringMap = Map.Make(StringOrd) +module IntMap = Map.Make(IntOrd) -let dyn_table : value StringMap.t ref = ref StringMap.empty +let dyn_table : value IntMap.t ref = ref IntMap.empty let register_dyn name t = - dyn_table := StringMap.add name t !dyn_table + dyn_table := IntMap.add name t !dyn_table let find_dyn name = - try StringMap.find name !dyn_table + try IntMap.find name !dyn_table with Not_found -> Any diff --git a/checker/votour.ml b/checker/votour.ml index 29593cb7..7c954d6f 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -10,11 +10,44 @@ open Values (** {6 Interactive visit of a vo} *) -(** Name of a value *) - -type dyn = { dyn_tag : string; dyn_obj : Obj.t; } +type 'a repr = +| INT of int +| STRING of string +| BLOCK of int * 'a array +| OTHER + +module type S = +sig + type obj + val input : in_channel -> obj + val repr : obj -> obj repr + val size : int list -> int +end + +module Repr : S = +struct + type obj = Obj.t + + let input chan = + let obj = input_value chan in + let () = CObj.register_shared_size obj in + obj + + let repr obj = + if Obj.is_block obj then + let tag = Obj.tag obj in + if tag = Obj.string_tag then STRING (Obj.magic obj) + else if tag < Obj.no_scan_tag then + let data = Obj.dup obj in + let () = Obj.set_tag data 0 in + BLOCK (tag, Obj.magic data) + else OTHER + else INT (Obj.magic obj) + + let size p = CObj.shared_size_of_pos p +end -let to_dyn obj = (Obj.magic obj : dyn) +(** Name of a value *) let rec get_name ?(extra=false) = function |Any -> "?" @@ -32,69 +65,101 @@ let rec get_name ?(extra=false) = function (** For tuples, its quite handy to display the inner 1st string (if any). Cf. [structure_body] for instance *) -let get_string_in_tuple v o = +let get_string_in_tuple o = try - for i = 0 to Array.length v - 1 do - if v.(i) = String then - failwith (" [.."^(Obj.magic (Obj.field o i) : string)^"..]"); + for i = 0 to Array.length o - 1 do + match Repr.repr o.(i) with + | STRING s -> + failwith (Printf.sprintf " [..%s..]" s) + | _ -> () done; "" with Failure s -> s (** Some details : tags, integer value for non-block, etc etc *) -let rec get_details v o = match v with - |String | Any when (Obj.is_block o && Obj.tag o = Obj.string_tag) -> - " [" ^ String.escaped (Obj.magic o : string) ^"]" - |Tuple (_,v) -> get_string_in_tuple v o - |(Sum _|Any) when Obj.is_block o -> - " [tag=" ^ string_of_int (Obj.tag o) ^"]" - |(Sum _|Any) -> - " [imm=" ^ string_of_int (Obj.magic o : int) ^"]" - |Int -> " [" ^ string_of_int (Obj.magic o : int) ^"]" - |Annot (s,v) -> get_details v o +let rec get_details v o = match v, Repr.repr o with + | (String | Any), STRING s -> + Printf.sprintf " [%s]" (String.escaped s) + |Tuple (_,v), BLOCK (_, o) -> get_string_in_tuple o + |(Sum _|Any), BLOCK (tag, _) -> + Printf.sprintf " [tag=%i]" tag + |(Sum _|Any), INT i -> + Printf.sprintf " [imm=%i]" i + |Int, INT i -> Printf.sprintf " [imm=%i]" i + |Annot (s,v), _ -> get_details v o |_ -> "" let node_info (v,o,p) = get_name ~extra:true v ^ get_details v o ^ - " (size "^ string_of_int (CObj.shared_size_of_pos p)^"w)" + " (size "^ string_of_int (Repr.size p)^"w)" (** Children of a block : type, object, position. For lists, we collect all elements of the list at once *) -let access_children vs o pos = - Array.mapi (fun i v -> v, Obj.field o i, i::pos) vs - +let access_children vs os pos = + if Array.length os = Array.length vs then + Array.mapi (fun i v -> v, os.(i), i::pos) vs + else raise Exit + +let access_list v o pos = + let rec loop o pos = match Repr.repr o with + | INT 0 -> [] + | BLOCK (0, [|hd; tl|]) -> + (v, hd, 0 :: pos) :: loop tl (1 :: pos) + | _ -> raise Exit + in + Array.of_list (loop o pos) + +let access_block o = match Repr.repr o with +| BLOCK (tag, os) -> (tag, os) +| _ -> raise Exit +let access_int o = match Repr.repr o with INT i -> i | _ -> raise Exit + +(** raises Exit if the object has not the expected structure *) let rec get_children v o pos = match v with - |Tuple (_,v) -> access_children v o pos - |Sum (_,_,vv) -> - if Obj.is_block o then access_children vv.(Obj.tag o) o pos - else [||] - |Array v -> access_children (Array.make (Obj.size o) v) o pos - |List v -> - let rec loop pos = function - | [] -> [] - | o :: ol -> (v,o,0::pos) :: loop (1::pos) ol - in - Array.of_list (loop pos (Obj.magic o : Obj.t list)) + |Tuple (_, v) -> + let (_, os) = access_block o in + access_children v os pos + |Sum (_, _, vv) -> + begin match Repr.repr o with + | BLOCK (tag, os) -> access_children vv.(tag) os pos + | INT _ -> [||] + | _ -> raise Exit + end + |Array v -> + let (_, os) = access_block o in + access_children (Array.make (Array.length os) v) os pos + |List v -> access_list v o pos |Opt v -> - if Obj.is_block o then [|v,Obj.field o 0,0::pos|] else [||] + begin match Repr.repr o with + | INT 0 -> [||] + | BLOCK (0, [|x|]) -> [|(v, x, 0 :: pos)|] + | _ -> raise Exit + end |String | Int -> [||] |Annot (s,v) -> get_children v o pos - |Any -> - if Obj.is_block o && Obj.tag o < Obj.no_scan_tag then - Array.init (Obj.size o) (fun i -> (Any,Obj.field o i,i::pos)) - else [||] + |Any -> raise Exit |Dyn -> - let t = to_dyn o in - let tpe = find_dyn t.dyn_tag in - [|(String, Obj.repr t.dyn_tag, 0 :: pos); (tpe, t.dyn_obj, 1 :: pos)|] + begin match Repr.repr o with + | BLOCK (0, [|id; o|]) -> + let n = access_int id in + let tpe = find_dyn n in + [|(Int, id, 0 :: pos); (tpe, o, 1 :: pos)|] + | _ -> raise Exit + end |Fail s -> failwith "forbidden" +let get_children v o pos = + try get_children v o pos + with Exit -> match Repr.repr o with + | BLOCK (_, os) -> Array.mapi (fun i o -> Any, o, i :: pos) os + | _ -> [||] + type info = { nam : string; typ : value; - obj : Obj.t; + obj : Repr.obj; pos : int list } @@ -154,7 +219,7 @@ let visit_vo f = {name="library"; pos=0; typ=Values.v_lib}; {name="univ constraints of opaque proofs"; pos=0;typ=Values.v_univopaques}; {name="discharging info"; pos=0; typ=Opt Any}; - {name="STM tasks"; pos=0; typ=Opt Any}; + {name="STM tasks"; pos=0; typ=Opt Values.v_stm_seg}; {name="opaque proofs"; pos=0; typ=Values.v_opaques}; |] in while true do @@ -176,8 +241,7 @@ let visit_vo f = let l = read_line () in let seg = int_of_string l in seek_in ch segments.(seg).pos; - let o = (input_value ch : Obj.t) in - let () = CObj.register_shared_size o in + let o = Repr.input ch in let () = init () in visit segments.(seg).typ o [] done diff --git a/configure.ml b/configure.ml index d68fc505..bbe43520 100644 --- a/configure.ml +++ b/configure.ml @@ -11,13 +11,13 @@ #load "str.cma" open Printf -let coq_version = "8.5beta1" -let coq_macos_version = "8.5.91" (** "[...] should be a string comprised of +let coq_version = "8.5beta2" +let coq_macos_version = "8.4.92" (** "[...] should be a string comprised of three non-negative, period-separed integers [...]" *) let vo_magic = 8591 let state_magic = 58501 let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqmktop";"coqworkmgr"; -"coqdoc";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert"] +"coqdoc";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert";"coqdep"] let verbose = ref false (* for debugging this script *) @@ -27,7 +27,7 @@ let die msg = eprintf "%s\nConfiguration script failed!\n" msg; exit 1 let s2i = int_of_string let i2s = string_of_int -let (/) = Filename.concat +let (/) x y = x ^ "/" ^ y (** Remove the final '\r' that may exists on Win32 *) @@ -77,7 +77,12 @@ let read_lines_and_close fd = type err = StdErr | StdOut | DevNull +let exe = ref "" (* Will be set later on, when the suffix is known *) + let run ?(fatal=true) ?(err=StdErr) prog args = + let prog = (* Ensure prog ends with exe *) + if Str.string_match (Str.regexp ("^.*" ^ !exe ^ "$")) prog 0 + then prog else (prog ^ !exe) in let argv = Array.of_list (prog::args) in try let out_r,out_w = Unix.pipe () in @@ -236,12 +241,11 @@ module Prefs = struct let usecamlp5 = ref true let camlp5dir = ref (None : string option) let arch = ref (None : string option) - let opt = ref false let natdynlink = ref true let coqide = ref (None : ide option) let macintegration = ref true let browser = ref (None : string option) - let withdoc = ref true + let withdoc = ref false let geoproof = ref false let byteonly = ref false let debug = ref false @@ -283,11 +287,11 @@ let args_options = Arg.align [ "-emacs", Arg.String (fun s -> printf "Warning: obsolete -emacs option\n"; Prefs.emacslib := Some s), - "<dir> (Obsolete) same as -emacslib"; + "<dir> Obsolete: same as -emacslib"; "-coqdocdir", arg_string_option Prefs.coqdocdir, "<dir> Where to install Coqdoc style files"; "-camldir", arg_string_option Prefs.camldir, - "<dir> Specifies the path to the OCaml library"; + "<dir> Specifies the path to the OCaml binaries"; "-lablgtkdir", arg_string_option Prefs.lablgtkdir, "<dir> Specifies the path to the Lablgtk library"; "-usecamlp5", Arg.Set Prefs.usecamlp5, @@ -299,8 +303,8 @@ let args_options = Arg.align [ "<dir> Specifies where is the Camlp5 library and tells to use it"; "-arch", arg_string_option Prefs.arch, "<arch> Specifies the architecture"; - "-opt", Arg.Set Prefs.opt, - " Use OCaml *.opt optimized compilers"; + "-opt", Arg.Unit (fun () -> printf "Warning: obsolete -opt option\n"), + " Obsolete: native OCaml executables detected automatically"; "-natdynlink", arg_bool Prefs.natdynlink, "(yes|no) Use dynamic loading of native code or not"; "-coqide", Arg.String (fun s -> Prefs.coqide := Some (get_ide s)), @@ -355,21 +359,25 @@ type camlexec = mutable dep : string; mutable doc : string; mutable lex : string; - mutable yacc : string; - mutable p4 : string } + mutable yacc : string } (* TODO: autodetect .opt binaries ? *) let camlexec = - { byte = if !Prefs.opt then "ocamlc.opt" else "ocamlc"; - opt = if !Prefs.opt then "ocamlopt.opt" else "ocamlopt"; + { byte = "ocamlc"; + opt = "ocamlopt"; top = "ocaml"; mklib = "ocamlmklib"; dep = "ocamldep"; doc = "ocamldoc"; lex = "ocamllex"; - yacc = "ocamlyacc"; - p4 = "camlp4o" } + yacc = "ocamlyacc" } + +let reset_caml_byte c o = c.byte <- o +let reset_caml_opt c o = c.opt <- o +let reset_caml_doc c o = c.doc <- o +let reset_caml_lex c o = c.lex <- o +let reset_caml_dep c o = c.dep <- o let rebase_camlexec dir c = c.byte <- Filename.concat dir c.byte; @@ -379,8 +387,7 @@ let rebase_camlexec dir c = c.dep <- Filename.concat dir c.dep; c.doc <- Filename.concat dir c.doc; c.lex <- Filename.concat dir c.lex; - c.yacc <- Filename.concat dir c.yacc; - c.p4 <- Filename.concat dir c.p4 + c.yacc <- Filename.concat dir c.yacc let coq_debug_flag = if !Prefs.debug then "-g" else "" let coq_profile_flag = if !Prefs.profile then "-p" else "" @@ -426,7 +433,7 @@ let arch = match !Prefs.arch with let arch_win32 = (arch = "win32") -let exe = if arch_win32 then ".exe" else "" +let exe = exe := if arch_win32 then ".exe" else ""; !exe let dll = if os_type_win32 then ".dll" else ".so" (** * VCS @@ -464,7 +471,8 @@ let browser = (** * OCaml programs *) -let camlbin, camlc = match !Prefs.camldir with +let camlbin, caml_version, camllib = + let camlbin, camlc = match !Prefs.camldir with | Some dir -> rebase_camlexec dir camlexec; Filename.dirname camlexec.byte, camlexec.byte @@ -473,13 +481,21 @@ let camlbin, camlc = match !Prefs.camldir with with Not_found -> die (sprintf "Error: cannot find '%s' in your path!\n" camlexec.byte ^ "Please adjust your path or use the -camldir option of ./configure") + in + let camlcopt = camlc ^ ".opt" in + let camlc = + if is_executable camlcopt then begin + reset_caml_byte camlexec (camlexec.byte ^ ".opt"); + camlcopt + end + else if is_executable camlc then + camlc + else + die ("Error: cannot find the executable '"^camlc^"'.") in + let caml_version, _ = run camlc ["-version"] in + let camllib, _ = run camlc ["-where"] in + camlbin, caml_version, camllib -let _ = - if not (is_executable camlc) then - die ("Error: cannot find the executable '"^camlc^"'.") - -let caml_version, _ = run camlc ["-version"] -let camllib, _ = run camlc ["-where"] let camlp4compat = "-loc loc" (** Caml version as a list of string, e.g. ["4";"00";"1"] *) @@ -518,10 +534,15 @@ let camltag = match caml_version_list with (** * CamlpX configuration *) -(** We assume that camlp(4|5) binaries are at the same place as ocaml ones - (this should become configurable some day). *) +(* Convention: we use camldir as a prioritary location for camlpX, if given *) -let camlp4bin = camlbin +let which_camlpX base = + match !Prefs.camldir with + | Some dir -> + let file = Filename.concat dir base in + if is_executable file then file else which base + | None -> + which base (* TODO: camlp5dir should rather be the *binary* location, just as camldir *) (* TODO: remove the late attempts at finding gramlib.cma *) @@ -545,7 +566,7 @@ let check_camlp5 testcma = match !Prefs.camlp5dir with camllib/"site-lib"/"camlp5" else "" in - (* if the two values are different than camlp5 has been relocated + (* if the two values are different then camlp5 has been relocated * and will not be able to find its own files, so we prefer the * path where the files actually do exist *) if dir2 = "" then @@ -557,39 +578,40 @@ let check_camlp5 testcma = match !Prefs.camlp5dir with else dir2 let check_camlp5_version () = - let s = camlexec.p4 in - (* translate 4 into 5 in the binary name *) - for i = 0 to String.length s - 1 do - if s.[i] = '4' then s.[i] <- '5' - done; try - let version_line, _ = run ~err:StdOut camlexec.p4 ["-v"] in + let camlp5o = which_camlpX "camlp5o" in + let version_line, _ = run ~err:StdOut camlp5o ["-v"] in let version = List.nth (string_split ' ' version_line) 2 in match string_split '.' version with | major::minor::_ when s2i major > 5 || (s2i major, s2i minor) >= (5,1) -> - printf "You have Camlp5 %s. Good!\n" version + printf "You have Camlp5 %s. Good!\n" version; camlp5o, version | _ -> failwith "bad version" - with _ -> die "Error: unsupported Camlp5 (version < 5.01 or unrecognized).\n" + with + | Not_found -> die "Error: cannot find Camlp5 binaries in path.\n" + | _ -> die "Error: unsupported Camlp5 (version < 5.01 or unrecognized).\n" let config_camlpX () = try if not !Prefs.usecamlp5 then raise NoCamlp5; - let lib = "gramlib" in - let dir = check_camlp5 (lib^".cma") in - let () = check_camlp5_version () in - "camlp5", dir, lib + let camlp5mod = "gramlib" in + let camlp5libdir = check_camlp5 (camlp5mod^".cma") in + let camlp5o, camlp5_version = check_camlp5_version () in + "camlp5", camlp5o, Filename.dirname camlp5o, camlp5libdir, camlp5mod, camlp5_version with NoCamlp5 -> (* We now try to use Camlp4, either by explicit choice or by lack of proper Camlp5 installation *) - let lib = "camlp4lib" in - let dir = camllib/"camlp4" in - if not (Sys.file_exists (dir/lib^".cma")) then + let camlp4mod = "camlp4lib" in + let camlp4libdir = camllib/"camlp4" in + if not (Sys.file_exists (camlp4libdir/camlp4mod^".cma")) then die "No Camlp4 installation found.\n"; - let () = camlexec.p4 <- camlexec.p4 ^ "rf" in - ignore (run camlexec.p4 []); - "camlp4", dir, lib + try + let camlp4orf = which_camlpX "camlp4orf" in + let version_line, _ = run ~err:StdOut camlp4orf ["-v"] in + let camlp4_version = List.nth (string_split ' ' version_line) 2 in + "camlp4", camlp4orf, Filename.dirname camlp4orf, camlp4libdir, camlp4mod, camlp4_version + with _ -> die "No Camlp4 installation found.\n" -let camlp4, fullcamlp4lib, camlp4mod = config_camlpX () +let camlpX, camlpXo, camlpXbindir, fullcamlpXlibdir, camlpXmod, camlpX_version = config_camlpX () let shorten_camllib s = if starts_with s (camllib^"/") then @@ -597,8 +619,7 @@ let shorten_camllib s = "+" ^ String.sub s l (String.length s - l) else s -let camlp4lib = shorten_camllib fullcamlp4lib - +let camlpXlibdir = shorten_camllib fullcamlpXlibdir (** * Native compiler *) @@ -608,8 +629,8 @@ let msg_byteonly () = let msg_no_ocamlopt () = printf "Cannot find the OCaml native-code compiler.\n"; msg_byteonly () -let msg_no_camlp4_cmxa () = - printf "Cannot find the native-code library of %s.\n" camlp4; msg_byteonly () +let msg_no_camlpX_cmxa () = + printf "Cannot find the native-code library of %s.\n" camlpX; msg_byteonly () let msg_no_dynlink_cmxa () = printf "Cannot find native-code dynlink library.\n"; msg_byteonly (); @@ -619,10 +640,13 @@ let msg_no_dynlink_cmxa () = let check_native () = if !Prefs.byteonly then raise Not_found; - if not (is_executable camlexec.opt || program_in_path camlexec.opt) then + let camloptopt = camlexec.opt ^ ".opt" in + if (is_executable camloptopt || program_in_path camloptopt) then + reset_caml_opt camlexec camloptopt + else if not (is_executable camlexec.opt || program_in_path camlexec.opt) then (msg_no_ocamlopt (); raise Not_found); - if not (Sys.file_exists (fullcamlp4lib/camlp4mod^".cmxa")) then - (msg_no_camlp4_cmxa (); raise Not_found); + if not (Sys.file_exists (fullcamlpXlibdir/camlpXmod^".cmxa")) then + (msg_no_camlpX_cmxa (); raise Not_found); if not (Sys.file_exists (camllib/"dynlink.cmxa")) then (msg_no_dynlink_cmxa (); raise Not_found); let version, _ = run camlexec.opt ["-version"] in @@ -634,6 +658,20 @@ let check_native () = let best_compiler = try check_native (); "opt" with Not_found -> "byte" +let _ = + let camllexopt = camlexec.lex ^ ".opt" in + if is_executable camllexopt || program_in_path camllexopt then + reset_caml_lex camlexec camllexopt + +let _ = + let camldepopt = camlexec.dep ^ ".opt" in + if is_executable camldepopt || program_in_path camldepopt then + reset_caml_dep camlexec camldepopt + +let _ = + let camldocopt = camlexec.doc ^ ".opt" in + if is_executable camldocopt || program_in_path camldocopt then + reset_caml_doc camlexec camldocopt (** * Native dynlink *) @@ -930,10 +968,12 @@ let print_summary () = pr " Coq VM bytecode link flags : %s\n" (String.concat " " vmbyteflags); pr " Other bytecode link flags : %s\n" custom_flag; pr " OS dependent libraries : %s\n" osdeplibs; - pr " OCaml/Camlp4 version : %s\n" caml_version; - pr " OCaml/Camlp4 binaries in : %s\n" camlbin; + pr " OCaml version : %s\n" caml_version; + pr " OCaml binaries in : %s\n" camlbin; pr " OCaml library in : %s\n" camllib; - pr " Camlp4 library in : %s\n" camlp4lib; + pr " %s version : %s\n" (String.capitalize camlpX) camlpX_version; + pr " %s binaries in : %s\n" (String.capitalize camlpX) camlpXbindir; + pr " %s library in : %s\n" (String.capitalize camlpX) camlpXlibdir; if best_compiler = "opt" then pr " Native dynamic link support : %B\n" hasnatdynlink; if coqide <> "no" then @@ -973,7 +1013,7 @@ let write_dbg_wrapper f = pr "# DO NOT EDIT THIS FILE: automatically generated by ../configure #\n\n"; pr "export COQTOP=%S\n" coqtop; pr "OCAMLDEBUG=%S\n" (camlbin^"/ocamldebug"); - pr "CAMLP4LIB=%S\n\n" camlp4lib; + pr "CAMLP4LIB=%S\n\n" camlpXlibdir; pr ". $COQTOP/dev/ocamldebug-coq.run\n"; close_out o; Unix.chmod f 0o555 @@ -1012,10 +1052,10 @@ let write_configml f = pr_s "ocamllex" camlexec.lex; pr_s "camlbin" camlbin; pr_s "camllib" camllib; - pr_s "camlp4" camlp4; - pr_s "camlp4o" camlexec.p4; - pr_s "camlp4bin" camlp4bin; - pr_s "camlp4lib" camlp4lib; + pr_s "camlp4" camlpX; + pr_s "camlp4o" camlpXo; + pr_s "camlp4bin" camlpXbindir; + pr_s "camlp4lib" camlpXlibdir; pr_s "camlp4compat" camlp4compat; pr_s "cflags" cflags; pr_s "best" best_compiler; @@ -1088,7 +1128,8 @@ let write_makefile f = List.iter (fun (v,msg,_,_) -> pr "# %s: path for %s\n" v msg) install_dirs; List.iter (fun (v,_,dir,_) -> pr "%s=%S\n" v dir) install_dirs; pr "\n# Coq version\n"; - pr "VERSION=%s\n\n" coq_version; + pr "VERSION=%s\n" coq_version; + pr "VERSION4MACOS=%s\n\n" coq_macos_version; pr "# Objective-Caml compile command\n"; pr "OCAML=%S\n" camlexec.top; pr "OCAMLC=%S\n" camlexec.byte; @@ -1122,10 +1163,10 @@ let write_makefile f = pr "CAMLTIMEPROF=%s\n\n" coq_profile_flag; pr "# Camlp4 : flavor, binaries, libraries ...\n"; pr "# NB : avoid using CAMLP4LIB (conflict under Windows)\n"; - pr "CAMLP4=%s\n" camlp4; - pr "CAMLP4O=%S\n" camlexec.p4; + pr "CAMLP4=%s\n" camlpX; + pr "CAMLP4O=%S\n" camlpXo; pr "CAMLP4COMPAT=%s\n" camlp4compat; - pr "MYCAMLP4LIB=%S\n\n" camlp4lib; + pr "MYCAMLP4LIB=%S\n\n" camlpXlibdir; pr "# Your architecture\n"; pr "# Can be obtain by UNIX command arch\n"; pr "ARCH=%s\n" arch; diff --git a/dev/TODO b/dev/TODO deleted file mode 100644 index e62ee6e5..00000000 --- a/dev/TODO +++ /dev/null @@ -1,22 +0,0 @@ - - o options de la ligne de commande - - reporter les options de l'ancien script coqtop sur le nouveau coqtop.ml - - o arguments implicites - - les calculer une fois pour toutes à la déclaration (dans Declare) - et stocker cette information dans le in_variable, in_constant, etc. - - o Environnements compilés (type Environ.compiled_env) - - pas de timestamp mais plutôt un checksum avec Digest (mais comment ?) - - o Efficacité - - utiliser DOPL plutôt que DOPN (sauf pour Case) - - batch mode => pas de undo, ni de reset - - conversion : déplier la constante la plus récente - - un cache pour type_of_const, type_of_inductive, type_of_constructor, - lookup_mind_specif - - o Toplevel - - parsing de la ligne de commande : utiliser Arg ??? - - diff --git a/dev/nsis/coq.nsi b/dev/nsis/coq.nsi index 90e3fdaa..5b421e49 100755 --- a/dev/nsis/coq.nsi +++ b/dev/nsis/coq.nsi @@ -196,14 +196,12 @@ SectionEnd Section "Uninstall" -;; We keep the settings -;; Delete "$INSTDIR\config\coqide-gtk2rc" - RMDir /r "$INSTDIR\bin" RMDir /r "$INSTDIR\dev" RMDir /r "$INSTDIR\etc" RMDir /r "$INSTDIR\lib" RMDir /r "$INSTDIR\share" + RMDir /r "$INSTDIR\ide" Delete "$INSTDIR\man\*.1" RMDir "$INSTDIR\man" diff --git a/dev/top_printers.ml b/dev/top_printers.ml index dea70360..f969f013 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -22,7 +22,6 @@ open Evd open Goptions open Genarg open Clenv -open Universes let _ = Detyping.print_evar_arguments := true let _ = Detyping.print_universes := true @@ -503,7 +502,7 @@ open Egramml let _ = try - Vernacinterp.vinterp_add ("PrintConstr", 0) + Vernacinterp.vinterp_add false ("PrintConstr", 0) (function [c] when genarg_tag c = ConstrArgType && true -> let c = out_gen (rawwit wit_constr) c in @@ -520,7 +519,7 @@ let _ = let _ = try - Vernacinterp.vinterp_add ("PrintPureConstr", 0) + Vernacinterp.vinterp_add false ("PrintPureConstr", 0) (function [c] when genarg_tag c = ConstrArgType && true -> let c = out_gen (rawwit wit_constr) c in diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 854c786c..024e1341 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -476,6 +476,13 @@ through the <tt>Require Import</tt> command.</p> theories/MSets/MSetPositive.v theories/MSets/MSetToFiniteSet.v (theories/MSets/MSets.v) + theories/MMaps/MMapAVL.v + theories/MMaps/MMapFacts.v + theories/MMaps/MMapInterface.v + theories/MMaps/MMapList.v + theories/MMaps/MMapPositive.v + theories/MMaps/MMapWeakList.v + (theories/MMaps/MMaps.v) </dd> <dt> <b>FSets</b>: diff --git a/doc/whodidwhat/whodidwhat-8.4update.tex b/doc/whodidwhat/whodidwhat-8.4update.tex index 696fff4f..bb4c5ce4 100644 --- a/doc/whodidwhat/whodidwhat-8.4update.tex +++ b/doc/whodidwhat/whodidwhat-8.4update.tex @@ -3,6 +3,7 @@ \usepackage{fullpage} \usepackage[utf8]{inputenc} \usepackage{t1enc} +\usepackage{hyperref} \begin{document} @@ -32,7 +33,7 @@ \end{itemize} \item The universe hierarchy \begin{itemize} - \item Floating universes: Gérard Huet, with contributions from Bruno Barras + \item Floating universes: Gérard Huet, with contributions from Bruno Barras and Pierre Letouzey \item Algebraic universes: Hugo Herbelin \end{itemize} \item Mutual inductive types and recursive definitions @@ -296,10 +297,15 @@ \section{Maintenance and system engineering} \begin{itemize} -\item General bug support: Gérard Huet, Christine Paulin, Chet Murthy, - Jean-Christophe Filliâtre, Hugo Herbelin, Bruno Barras, Pierre - Letouzey with contributions at some time from Benjamin Werner, - Jean-Marc Notin, Pierre Boutillier, ... +%\item General maintenance in version 8.0: Bruno Barras, Hugo Herbelin +%\item General maintenance in version 8.1: Bruno Barras, Hugo Herbelin, Jean-Marc Notin +%\item General maintenance in version 8.2: Hugo Herbelin, Pierre Letouzey, Jean-Marc Notin, +%\item General maintenance in version 8.3: Hugo Herbelin, Pierre +% Letouzey +\item General maintenance in version 8.4: Pierre Letouzey, Hugo + Herbelin, Pierre Boutillier, Matthieu Sozeau, Stéphane Glondu with + contributions from Guillaume Melquiond, Julien Narboux and + Pierre-Marie Pédrot \item Team coordination: Gérard Huet, Christine Paulin, Hugo Herbelin, with various other contributions \item Packaging tools: Henri Laulhere, David Delahaye, Julien Narboux, @@ -327,8 +333,10 @@ \begin{itemize} \item Searching modulo isomorphism: David Delahaye \item Explanation of proofs in pseudo-natural language: Yann Coscoy +\item Dp: Jean-Christophe Filliâtre, Nicolas Ayache with contributions + from Claude Marché (now integrated to \href{http://why3.lri.fr/}{Why3}) \end{itemize} -For probable oversights or accidental errors, please report to Hugo~\verb=.=~Herbelin~\verb=@=~inria~\verb=.=~fr +For oversights or accidental errors, please report to Hugo~\verb=.=~Herbelin~\verb=@=~inria~\verb=.=~fr \end{document} diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index 7a4d52ab..9db89308 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -17,6 +17,19 @@ open Pcoq open Egramml open Compat +type rule = { + r_head : string option; + (** The first terminal grammar token *) + r_patt : grammar_prod_item list; + (** The remaining tokens of the parsing rule *) + r_class : MLast.expr option; + (** An optional classifier for the STM *) + r_branch : MLast.expr; + (** The action performed by this rule. *) + r_depr : unit option; + (** Whether this entry is deprecated *) +} + let rec make_let e = function | [] -> e | GramNonTerminal(loc,t,_,Some p)::l -> @@ -27,7 +40,7 @@ let rec make_let e = function <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >> | _::l -> make_let e l -let make_clause (_,pt,_,e) = +let make_clause { r_patt = pt; r_branch = e; } = (make_patt pt, vala (Some (make_when (MLast.loc_of_expr e) pt)), make_let e pt) @@ -41,7 +54,7 @@ let mk_ignore c pt = let names = List.fold_left fold <:expr< () >> names in <:expr< do { let _ = $names$ in $c$ } >> -let make_clause_classifier cg s (_,pt,c,_) = +let make_clause_classifier cg s { r_patt = pt; r_class = c; } = match c ,cg with | Some c, _ -> (make_patt pt, @@ -76,8 +89,15 @@ let make_clause_classifier cg s (_,pt,c,_) = <:expr< fun () -> (Vernacexpr.VtUnknown, Vernacexpr.VtNow) >>) let make_fun_clauses loc s l = - let cl = List.map (fun c -> Compat.make_fun loc [make_clause c]) l in - mlexpr_of_list (fun x -> x) cl + let map c = + let depr = match c.r_depr with + | None -> false + | Some () -> true + in + let cl = Compat.make_fun loc [make_clause c] in + <:expr< ($mlexpr_of_bool depr$, $cl$)>> + in + mlexpr_of_list map l let make_fun_classifiers loc s c l = let cl = List.map (fun x -> Compat.make_fun loc [make_clause_classifier c s x]) l in @@ -85,7 +105,7 @@ let make_fun_classifiers loc s c l = let mlexpr_of_clause = mlexpr_of_list - (fun (a,b,_,_) -> mlexpr_of_list make_prod_item + (fun { r_head = a; r_patt = b; } -> mlexpr_of_list make_prod_item (Option.List.cons (Option.map (fun a -> GramTerminal a) a) b)) let declare_command loc s c nt cl = @@ -96,7 +116,7 @@ let declare_command loc s c nt cl = declare_str_items loc [ <:str_item< do { try do { - CList.iteri (fun i f -> Vernacinterp.vinterp_add ($se$, i) f) $funcl$; + CList.iteri (fun i (depr, f) -> Vernacinterp.vinterp_add depr ($se$, i) f) $funcl$; CList.iteri (fun i f -> Vernac_classifier.declare_vernac_classifier ($se$, i) f) $classl$ } with [ e when Errors.noncritical e -> Pp.msg_warning @@ -135,22 +155,28 @@ EXTEND <:expr< fun _ -> Vernac_classifier.classify_as_query >> ] ] ; + deprecation: + [ [ "DEPRECATED" -> () ] ] + ; (* spiwack: comment-by-guessing: it seems that the isolated string (which otherwise could have been another argument) is not passed to the VernacExtend interpreter function to discriminate between the clauses. *) rule: [ [ "["; s = STRING; l = LIST0 args; "]"; - c = OPT [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< fun () -> $c$>> ]; - "->"; "["; e = Pcaml.expr; "]" -> + d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> if String.is_empty s then Errors.user_err_loc (!@loc,"",Pp.str"Command name is empty."); - (Some s,l,c,<:expr< fun () -> $e$ >>) + let b = <:expr< fun () -> $e$ >> in + { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; } | "[" ; "-" ; l = LIST1 args ; "]" ; - c = OPT [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< fun () -> $c$>> ]; - "->"; "["; e = Pcaml.expr; "]" -> - (None,l,c,<:expr< fun () -> $e$ >>) + d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> + let b = <:expr< fun () -> $e$ >> in + { r_head = None; r_patt = l; r_class = c; r_branch = b; r_depr = d; } ] ] ; + classifier: + [ [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< fun () -> $c$>> ] ] + ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> let t, g = interp_entry_name false None e "" in diff --git a/ide/MacOS/Info.plist.template b/ide/MacOS/Info.plist.template index fd80c839..e224e812 100644 --- a/ide/MacOS/Info.plist.template +++ b/ide/MacOS/Info.plist.template @@ -66,7 +66,7 @@ <key>CFBundleGetInfoString</key> <string>Coq_vVERSION</string> <key>NSHumanReadableCopyright</key> - <string>Copyright 1999-2014, The Coq Development Team INRIA - CNRS - LIX - LRI - PPS</string> + <string>Copyright 1999-2015, The Coq Development Team INRIA - CNRS - LIX - LRI - PPS</string> <key>CFBundleHelpBookFolder</key> <string>share/doc/coq/html/</string> <key>CFAppleHelpAnchor</key> diff --git a/ide/MacOS/default_accel_map b/ide/MacOS/default_accel_map index 6f474eb1..47612cdf 100644 --- a/ide/MacOS/default_accel_map +++ b/ide/MacOS/default_accel_map @@ -247,7 +247,6 @@ ; (gtk_accel_path "<Actions>/Tactics/Tactic constructor" "") ; (gtk_accel_path "<Actions>/Tactics/Tactic elim -- with" "") ; (gtk_accel_path "<Actions>/Templates/Template Identity Coercion" "") -; (gtk_accel_path "<Actions>/Queries/Whelp Locate" "") (gtk_accel_path "<Actions>/View/Display all low-level contents" "<Shift><Control>l") ; (gtk_accel_path "<Actions>/Tactics/Tactic right" "") ; (gtk_accel_path "<Actions>/Edit/Find Previous" "<Shift>F3") diff --git a/ide/coq.lang b/ide/coq.lang index 608a4aea..65150d6a 100644 --- a/ide/coq.lang +++ b/ide/coq.lang @@ -22,19 +22,19 @@ </styles> <definitions> - <define-regex id="space">\s</define-regex> + <define-regex id="space">\s+</define-regex> <define-regex id="first_ident_char">[_\p{L}]</define-regex> <define-regex id="ident_char">[_\p{L}'\pN]</define-regex> <define-regex id="ident">\%{first_ident_char}\%{ident_char}*</define-regex> <define-regex id="qualit">(\%{ident}\.)*\%{ident}</define-regex> <define-regex id="undotted_sep">[-+*{}]</define-regex> <define-regex id="dot_sep">\.(\s|\z)</define-regex> - <define-regex id="single_decl">(Definition)|(Let)|(Example)|(SubClass)|(Fixpoint)|(CoFixpoint)|(Scheme)|(Function)|(Hypothesis)|(Axiom)|(Variable)|(Parameter)|(Conjecture)|(Inductive)|(CoInductive)|(Record)|(Structure)|(Ltac)|(Instance)|(Context)|(Class)|(Module(\%{space}+Type)?)|(Existing\%{space}+Instance)|(Canonical\%{space}+Structure)</define-regex> - <define-regex id="mult_decl">(Hypotheses)|(Axioms)|(Variables)|(Parameters)|(Implicit\%{space}+Type(s)?)</define-regex> - <define-regex id="locality">(((Local)|(Global))\%{space}+)?</define-regex> - <define-regex id="begin_proof">(Theorem)|(Lemma)|(Fact)|(Remark)|(Corollary)|(Proposition)|(Property)</define-regex> - <define-regex id="end_proof">(Qed)|(Defined)|(Admitted)|(Abort)</define-regex> - <define-regex id="decl_head">((?'gal'\%{locality}(Program\%{space}+)?(\%{single_decl}|\%{begin_proof}))\%{space}+(?'id'\%{ident}))|((?'gal4list'\%{mult_decl})(?'id_list'(\%{space}+\%{ident})*))|(?'gal2'Goal)</define-regex> + <define-regex id="single_decl">Definition|Let|Example|SubClass|(Co)?Fixpoint|Function|Conjecture|(Co)?Inductive|Record|Structure|Ltac|Instance|Class|Existing\%{space}Instance|Canonical\%{space}Structure|Coercion</define-regex> + <define-regex id="mult_decl">Hypothes[ie]s|Axiom(s)?|Variable(s)?|Parameter(s)?|Context|Implicit\%{space}Type(s)?</define-regex> + <define-regex id="locality">((Local|Global)\%{space})?</define-regex> + <define-regex id="begin_proof">Theorem|Lemma|Fact|Remark|Corollary|Proposition|Property</define-regex> + <define-regex id="end_proof">Qed|Defined|Admitted|Abort|Save</define-regex> + <define-regex id="decl_head">((?'gal'\%{locality}(Program\%{space})?(\%{single_decl}|\%{begin_proof}))\%{space}(?'id'\%{ident}))|((?'gal4list'\%{mult_decl})(?'id_list'(\%{space}\%{ident})*))|(?'gal2'Goal)</define-regex> <context id="escape-seq" style-ref="escape"> <match>""</match> @@ -97,7 +97,6 @@ <keyword>then</keyword> <keyword>else</keyword> <keyword>return</keyword> - <keyword>using</keyword> </context> <context id="constr-sort" style-ref="constr-sort"> <keyword>Prop</keyword> @@ -113,7 +112,7 @@ </include> </context> <context id="proof"> - <start>Proof(\%{dot_sep}|\%{space}+(using)|\%{space}+(with))</start> + <start>Proof(\%{dot_sep}|\%{space}using|\%{space}with)</start> <end>\%{end_proof}\%{dot_sep}</end> <include> <context sub-pattern="0" where="start" style-ref="vernac-keyword"/> @@ -157,17 +156,18 @@ <keyword>Eval</keyword> <keyword>Load</keyword> <keyword>Undo</keyword> + <keyword>(Print|Reset)\%{space}+Extraction\%{space}+(Inline|Blacklist)</keyword> <keyword>Print</keyword> - <keyword>Save</keyword> <keyword>Comments</keyword> - <keyword>Solve\%{space}+Obligation</keyword> - <keyword>((Uns)|(S))et(\%{space}+\%{ident})+</keyword> - <keyword>(\%{locality}|((Reserved)|(Tactic))\%{space}+)?Notation</keyword> + <keyword>Solve\%{space}Obligation</keyword> + <keyword>(Uns|S)et(\%{space}\%{ident})+</keyword> + <keyword>(\%{locality}|(Reserved|Tactic)\%{space})?Notation</keyword> <keyword>\%{locality}Infix</keyword> - <keyword>(Print)|(Reset)\%{space}+Extraction\%{space}+(Inline)|(Blacklist)</keyword> + <keyword>Declare\%{space}ML\%{space}Module</keyword> + <keyword>Extraction\%{space}Language\%{space}(Ocaml|Haskell|Scheme|JSON)</keyword> </context> <context id="hint-command" style-ref="vernac-keyword"> - <prefix>\%{locality}Hint\%{space}+</prefix> + <prefix>\%{locality}Hint\%{space}</prefix> <keyword>Resolve</keyword> <keyword>Immediate</keyword> <keyword>Constructors</keyword> @@ -178,35 +178,40 @@ <keyword>Rewrite</keyword> </context> <context id="scope-command" style-ref="vernac-keyword"> - <suffix>\%{space}+Scope</suffix> + <suffix>\%{space}Scope</suffix> <keyword>\%{locality}Open</keyword> <keyword>\%{locality}Close</keyword> <keyword>Bind</keyword> <keyword>Delimit</keyword> </context> <context id="command-for-qualit"> - <suffix>\%{space}+(?'qua'\%{qualit})</suffix> + <suffix>\%{space}(?'qua'\%{qualit})</suffix> <keyword>Chapter</keyword> - <keyword>Combined\%{space}+Scheme</keyword> + <keyword>Combined\%{space}Scheme</keyword> + <keyword>Scheme\%{space}(Induction|Minimality|Elimination|Case|Equality)\%{space}for</keyword> <keyword>End</keyword> <keyword>Section</keyword> + <keyword>Module(\%{space}Type)?</keyword> + <keyword>Declare\%{space}Module(\%{space}(Import|Export))?</keyword> + <keyword>About</keyword> <keyword>Arguments</keyword> - <keyword>Implicit\%{space}+Arguments</keyword> - <keyword>Import</keyword> + <keyword>Implicit\%{space}Arguments</keyword> <keyword>Include</keyword> - <keyword>Export</keyword> - <keyword>Require(\%{space}+((Import)|(Export)))?</keyword> - <keyword>(Recursive\%{space}+)?Extraction(\%{space}+(Language\%{space}+(Ocaml)|(Haskell)|(Scheme)|(Toplevel))|(Library)|((No)?Inline)|(Blacklist))?</keyword> - <keyword>Extract\%{space}+(Inlined\%{space}+)?(Constant)|(Inductive)</keyword> + <keyword>Extract\%{space}((Inlined\%{space})?Constant|Inductive)</keyword> <include> <context sub-pattern="1" style-ref="vernac-keyword"/> <context sub-pattern="qua" style-ref="identifier"/> </include> </context> - <context id="command-for-qualit-list" style-ref="vernac-keyword"> - <suffix>(?'qua_list'(\%{space}+\%{qualit})+)</suffix> - <keyword>Typeclasses (Transparent)|(Opaque)</keyword> + <context id="command-for-qualit-list"> + <suffix>(?'qua_list'(\%{space}\%{qualit})+)</suffix> + <keyword>Typeclasses (Transparent|Opaque)</keyword> + <keyword>Require(\%{space}(Import|Export))?</keyword> + <keyword>Import</keyword> + <keyword>Export</keyword> + <keyword>((Recursive|Separate)\%{space})?Extraction(\%{space}(Library|(No)?Inline|Blacklist))?</keyword> <include> + <context sub-pattern="1" style-ref="vernac-keyword"/> <context sub-pattern="qua_list" style-ref="identifier"/> </include> </context> diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 52e18456..af728471 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -215,8 +215,24 @@ object(self) document_length <- pred document_length; segment#set_length document_length; in + let on_click id = + let find _ _ s = Int.equal s.index id in + let sentence = Doc.find document find in + let mark = sentence.start in + let iter = script#buffer#get_iter_at_mark mark in + (** Sentence starts tend to be at the end of a line, so we rather choose + the first non-line-ending position. *) + let rec sentence_start iter = + if iter#ends_line then sentence_start iter#forward_line + else iter + in + let iter = sentence_start iter in + script#buffer#place_cursor iter; + ignore (script#scroll_to_iter ~use_align:true ~yalign:0. iter) + in let _ = (Doc.connect document)#pushed on_push in let _ = (Doc.connect document)#popped on_pop in + let _ = segment#connect#clicked on_click in () method private tooltip_callback ~x ~y ~kbd tooltip = @@ -260,21 +276,11 @@ object(self) Doc.focus document ~cond_top:(at start) ~cond_bot:(at stop); self#print_stack; let qed_s = Doc.tip_data document in - buffer#apply_tag Tags.Script.read_only - ~start:((buffer#get_iter_at_mark qed_s.start)#forward_find_char - (fun c -> not(Glib.Unichar.isspace c))) - ~stop:(buffer#get_iter_at_mark qed_s.stop); buffer#move_mark ~where:(buffer#get_iter_at_mark qed_s.stop) (`NAME "stop_of_input") method private exit_focus = Minilib.log "Unfocusing"; - begin try - let { start; stop } = Doc.tip_data document in - buffer#remove_tag Tags.Script.read_only - ~start:(buffer#get_iter_at_mark start) - ~stop:(buffer#get_iter_at_mark stop) - with Doc.Empty -> () end; Doc.unfocus document; self#print_stack; begin try @@ -347,7 +353,7 @@ object(self) else if has_flag sentence `ERROR then [error_bg] else if has_flag sentence `INCOMPLETE then [incomplete] else [processed]) @ - (if [ `UNSAFE ] = sentence.flags then [unjustified] else []) + (if has_flag sentence `UNSAFE then [unjustified] else []) in List.iter (fun t -> buffer#remove_tag t ~start ~stop) all_tags; List.iter (fun t -> buffer#apply_tag t ~start ~stop) tags @@ -499,7 +505,7 @@ object(self) | Some (start, stop) -> if until n start stop then begin () - end else if start#has_tag Tags.Script.processed then begin + end else if stop#backward_char#has_tag Tags.Script.processed then begin Queue.push (`Skip (start, stop)) queue; loop n stop end else begin @@ -547,12 +553,15 @@ object(self) script#recenter_insert; match topstack with | [] -> self#show_goals_aux ?move_insert () - | (_,s) :: _ -> self#backtrack_to_iter (buffer#get_iter_at_mark s.start) in + | (_,s)::_ -> self#backtrack_to_iter (buffer#get_iter_at_mark s.start) in let process_queue queue = let rec loop tip topstack = if Queue.is_empty queue then conclude topstack else match Queue.pop queue, topstack with - | `Skip(start,stop), [] -> assert false + | `Skip(start,stop), [] -> + logger Pp.Error "You muse close the proof with Qed or Admitted"; + self#discard_command_queue queue; + conclude [] | `Skip(start,stop), (_,s) :: topstack -> assert(start#equal (buffer#get_iter_at_mark s.start)); assert(stop#equal (buffer#get_iter_at_mark s.stop)); @@ -646,10 +655,13 @@ object(self) buffer#remove_tag Tags.Script.unjustified ~start ~stop; buffer#remove_tag Tags.Script.tooltip ~start ~stop; buffer#remove_tag Tags.Script.to_process ~start ~stop; + buffer#remove_tag Tags.Script.error ~start ~stop; + buffer#remove_tag Tags.Script.error_bg ~start ~stop; buffer#move_mark ~where:start (`NAME "start_of_input") end; List.iter (fun { start } -> buffer#delete_mark start) seg; - List.iter (fun { stop } -> buffer#delete_mark stop) seg + List.iter (fun { stop } -> buffer#delete_mark stop) seg; + self#print_stack (** Wrapper around the raw undo command *) method private backtrack_to_id ?(move_insert=true) (to_id, unfocus_needed) = diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index 995c45c5..37e38a54 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -228,8 +228,6 @@ let state_preserving = [ "Test Printing Synth"; "Test Printing Wildcard"; - "Whelp Hint"; - "Whelp Locate"; ] diff --git a/ide/coqide.ml b/ide/coqide.ml index fa64defa..0f4cb7b0 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -84,14 +84,15 @@ let pr_exit_status = function | _ -> " failed" let make_coqtop_args = function - |None -> !sup_args + |None -> "", !sup_args |Some the_file -> let get_args f = Project_file.args_from_project f !custom_project_files prefs.project_file_name in match prefs.read_project with - |Ignore_args -> !sup_args - |Append_args -> get_args the_file @ !sup_args + |Ignore_args -> "", !sup_args + |Append_args -> + let fname, args = get_args the_file in fname, args @ !sup_args |Subst_args -> get_args the_file (** Setting drag & drop on widgets *) @@ -120,7 +121,10 @@ let set_drag (w : GObj.drag_ops) = (** Session management *) let create_session f = - let ans = Session.create f (make_coqtop_args f) in + let project_file, args = make_coqtop_args f in + if project_file <> "" then + flash_info (Printf.sprintf "Reading options from %s" project_file); + let ans = Session.create f args in let _ = set_drag ans.script#drag in ans @@ -249,11 +253,14 @@ let newfile _ = !refresh_editor_hook (); notebook#goto_page index -let load _ = - match select_file_for_open ~title:"Load file" () with +let load sn = + let filename = sn.fileops#filename in + match select_file_for_open ~title:"Load file" ?filename () with | None -> () | Some f -> FileAux.load_file f +let load = cb_on_current_term load + let save _ = on_current_term (FileAux.check_save ~saveas:false) let saveas sn = @@ -530,7 +537,7 @@ let update_status sn = | None -> "" | Some n -> ", proving " ^ n in - display ("Ready"^ if current.nanoPG then ", [μPG]" else "" ^ path ^ name); + display ("Ready"^ (if current.nanoPG then ", [μPG]" else "") ^ path ^ name); Coq.return () in Coq.bind (Coq.status ~logger:sn.messages#push false) next @@ -588,13 +595,24 @@ let get_current_word term = | Some p -> p | None -> (** Then look at the current selected word *) - if term.script#buffer#has_selection then - let (start, stop) = term.script#buffer#selection_bounds in + let buf1 = term.script#buffer in + let buf2 = term.proof#buffer in + let buf3 = term.messages#buffer in + if buf1#has_selection then + let (start, stop) = buf1#selection_bounds in + buf1#get_text ~slice:true ~start ~stop () + else if buf2#has_selection then + let (start, stop) = buf2#selection_bounds in + buf2#get_text ~slice:true ~start ~stop () + else if buf3#has_selection then + let (start, stop) = buf3#selection_bounds in + buf3#get_text ~slice:true ~start ~stop () + (** Otherwise try to find the word around the cursor *) + else + let it = term.script#buffer#get_iter_at_mark `INSERT in + let start = find_word_start it in + let stop = find_word_end start in term.script#buffer#get_text ~slice:true ~start ~stop () - (** Otherwise try to recover the clipboard *) - else match Ideutils.cb#text with - | Some t -> t - | None -> "" let print_branch c l = Format.fprintf c " | @[<hov 1>%a@]=> _@\n" @@ -838,10 +856,16 @@ let refresh_editor_prefs () = sn.command#refresh_font (); (* Colors *) + Tags.set_processing_color (Tags.color_of_string current.processing_color); + Tags.set_processed_color (Tags.color_of_string current.processed_color); + Tags.set_error_color (Tags.color_of_string current.error_color); + Tags.set_error_fg_color (Tags.color_of_string current.error_fg_color); sn.script#misc#modify_base [`NORMAL, `COLOR clr]; sn.proof#misc#modify_base [`NORMAL, `COLOR clr]; - sn.messages#misc#modify_base [`NORMAL, `COLOR clr]; - sn.command#refresh_color () + sn.messages#refresh_color (); + sn.command#refresh_color (); + sn.errpage#refresh_color (); + sn.jobpage#refresh_color (); in List.iter iter_session notebook#pages @@ -1135,14 +1159,14 @@ let build_ui () = menu templates_menu [ item "Templates" ~label:"Te_mplates"; - template_item ("Lemma new_lemma : .\nProof.\n\nSave.\n", 6,9, "L"); + template_item ("Lemma new_lemma : .\nProof.\n\nSave.\n", 6,9, "J"); template_item ("Theorem new_theorem : .\nProof.\n\nSave.\n", 8,11, "T"); template_item ("Definition ident := .\n", 11,5, "E"); template_item ("Inductive ident : :=\n | : .\n", 10,5, "I"); template_item ("Fixpoint ident (_ : _) {struct _} : _ :=\n.\n", 9,5, "F"); template_item ("Scheme new_scheme := Induction for _ Sort _\n" ^ "with _ := Induction for _ Sort _.\n", 7,10, "S"); - item "match" ~label:"match ..." ~accel:(prefs.modifier_for_templates^"C") + item "match" ~label:"match ..." ~accel:(prefs.modifier_for_templates^"M") ~callback:match_callback ]; alpha_items templates_menu "Template" Coq_commands.commands; @@ -1150,13 +1174,12 @@ let build_ui () = let qitem s accel = item s ~label:("_"^s) ?accel ~callback:(Query.query s) in menu queries_menu [ item "Queries" ~label:"_Queries"; - qitem "Search" (Some "F2"); - qitem "Check" (Some "F3"); - qitem "Print" (Some "F4"); - qitem "About" (Some "F5"); - qitem "Locate" None; - qitem "Print Assumptions" None; - qitem "Whelp Locate" None; + qitem "Search" (Some "<Ctrl><Shift>K"); + qitem "Check" (Some "<Ctrl><Shift>C"); + qitem "Print" (Some "<Ctrl><Shift>P"); + qitem "About" (Some "<Ctrl><Shift>A"); + qitem "Locate" (Some "<Ctrl><Shift>L"); + qitem "Print Assumptions" (Some "<Ctrl><Shift>N"); ]; menu tools_menu [ @@ -1314,8 +1337,6 @@ let build_ui () = refresh_tabs_hook := refresh_notebook_pos; (* Color configuration *) - Tags.set_processing_color (Tags.color_of_string prefs.processing_color); - Tags.set_processed_color (Tags.color_of_string prefs.processed_color); Tags.Script.incomplete#set_property (`BACKGROUND_STIPPLE (Gdk.Bitmap.create_from_data ~width:2 ~height:2 "\x01\x02")); diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index af71b1e7..edfe28b2 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -119,7 +119,6 @@ let init () = <menuitem action='About' /> <menuitem action='Locate' /> <menuitem action='Print Assumptions' /> - <menuitem action='Whelp Locate' /> </menu> <menu name='Tools' action='Tools'> <menuitem action='Comment' /> diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml index abbd7e6d..79ccf61a 100644 --- a/ide/gtk_parsing.ml +++ b/ide/gtk_parsing.ml @@ -166,3 +166,16 @@ let find_nearest_backward (cursor:GText.iter) targets = | None -> raise Not_found | Some nearest -> nearest +(** On double-click on a view, select the whole word. This is a workaround for + a deficient word handling in TextView. *) +let fix_double_click self = + let callback ev = match GdkEvent.get_type ev with + | `TWO_BUTTON_PRESS -> + let iter = self#buffer#get_iter `INSERT in + let start, stop = get_word_around iter in + let () = self#buffer#move_mark `INSERT ~where:start in + let () = self#buffer#move_mark `SEL_BOUND ~where:stop in + true + | _ -> false + in + ignore (self#event#connect#button_press ~callback) diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index ac38f1ea..dc52ea9a 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -123,7 +123,7 @@ let annotate phrase = let pa = Pcoq.Gram.parsable (Stream.of_string phrase) in Vernac.parse_sentence (pa,None) in - let (_, _, xml) = + let (_, xml) = Richprinter.richpp_vernac ast in xml @@ -327,14 +327,14 @@ let handle_exn (e, info) = let loc_of e = match Loc.get_loc e with | Some loc when not (Loc.is_ghost loc) -> Some (Loc.unloc loc) | _ -> None in - let mk_msg e = read_stdout ()^"\n"^string_of_ppcmds (Errors.print e) in + let mk_msg () = read_stdout ()^"\n"^string_of_ppcmds (Errors.print ~info e) in match e with | Errors.Drop -> dummy, None, "Drop is not allowed by coqide!" | Errors.Quit -> dummy, None, "Quit is not allowed by coqide!" | e -> match Stateid.get info with - | Some (valid, _) -> valid, loc_of info, mk_msg e - | None -> dummy, loc_of info, mk_msg e + | Some (valid, _) -> valid, loc_of info, mk_msg () + | None -> dummy, loc_of info, mk_msg () let init = let initialized = ref false in diff --git a/ide/ideutils.ml b/ide/ideutils.ml index d2305b58..67e4bdb0 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -132,8 +132,6 @@ let mktimer () = with Glib.GError _ -> ()); timer := None) } -let last_dir = ref "" - let filter_all_files () = GFile.filter ~name:"All" ~patterns:["*"] () @@ -142,8 +140,11 @@ let filter_coq_files () = GFile.filter ~name:"Coq source code" ~patterns:[ "*.v"] () -let select_file_for_open ~title () = - let file = ref None in +let current_dir () = match current.project_path with +| None -> "" +| Some dir -> dir + +let select_file_for_open ~title ?filename () = let file_chooser = GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title () in @@ -152,19 +153,22 @@ let select_file_for_open ~title () = file_chooser#add_filter (filter_coq_files ()); file_chooser#add_filter (filter_all_files ()); file_chooser#set_default_response `OPEN; - ignore (file_chooser#set_current_folder !last_dir); - begin match file_chooser#run () with + let dir = match filename with + | None -> current_dir () + | Some f -> Filename.dirname f in + ignore (file_chooser#set_current_folder dir); + let file = + match file_chooser#run () with | `OPEN -> begin - file := file_chooser#filename; - match !file with - | None -> () - | Some s -> last_dir := Filename.dirname s; + match file_chooser#filename with + | None -> None + | Some _ as f -> + current.project_path <- file_chooser#current_folder; f end - | `DELETE_EVENT | `CANCEL -> () - end ; + | `DELETE_EVENT | `CANCEL -> None in file_chooser#destroy (); - !file + file let select_file_for_save ~title ?filename () = let file = ref None in @@ -175,13 +179,10 @@ let select_file_for_save ~title ?filename () = file_chooser#add_select_button_stock `SAVE `SAVE ; file_chooser#add_filter (filter_coq_files ()); file_chooser#add_filter (filter_all_files ()); - (* this line will be used when a lablgtk >= 2.10.0 is the default - on most distributions: - file_chooser#set_do_overwrite_confirmation true; - *) + file_chooser#set_do_overwrite_confirmation true; file_chooser#set_default_response `SAVE; let dir,filename = match filename with - |None -> !last_dir, "" + |None -> current_dir (), "" |Some f -> Filename.dirname f, Filename.basename f in ignore (file_chooser#set_current_folder dir); @@ -192,7 +193,7 @@ let select_file_for_save ~title ?filename () = file := file_chooser#filename; match !file with None -> () - | Some s -> last_dir := Filename.dirname s; + | Some s -> current.project_path <- file_chooser#current_folder end | `DELETE_EVENT | `CANCEL -> () end ; @@ -246,7 +247,14 @@ let coqtop_path () = let i = Str.search_backward (Str.regexp_string "coqide") prog pos in String.blit "coqtop" 0 prog i 6; - if Sys.file_exists prog then prog else "coqtop" + if Sys.file_exists prog then prog + else + let in_macos_bundle = + Filename.concat + (Filename.dirname prog) + (Filename.concat "../Resources/bin" (Filename.basename prog)) + in if Sys.file_exists in_macos_bundle then in_macos_bundle + else "coqtop" with Not_found -> "coqtop" in file @@ -279,7 +287,7 @@ let default_logger level message = (** {6 File operations} *) -(** A customized [stat] function. Exceptions are catched. *) +(** A customized [stat] function. Exceptions are caught. *) type stats = MTime of float | NoSuchFile | OtherError diff --git a/ide/ideutils.mli b/ide/ideutils.mli index 8269582d..1fb30e4d 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -29,7 +29,7 @@ val find_tag_limits : GText.tag -> GText.iter -> GText.iter * GText.iter val find_tag_start : GText.tag -> GText.iter -> GText.iter val find_tag_stop : GText.tag -> GText.iter -> GText.iter -val select_file_for_open : title:string -> unit -> string option +val select_file_for_open : title:string -> ?filename:string -> unit -> string option val select_file_for_save : title:string -> ?filename:string -> unit -> string option val try_convert : string -> string @@ -71,7 +71,7 @@ val default_logger : Pp.message_level -> string -> unit (** {6 I/O operations} *) -(** A customized [stat] function. Exceptions are catched. *) +(** A customized [stat] function. Exceptions are caught. *) type stats = MTime of float | NoSuchFile | OtherError val stat : string -> stats diff --git a/ide/preferences.ml b/ide/preferences.ml index c8506132..c59642d3 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -105,6 +105,7 @@ type pref = mutable read_project : project_behavior; mutable project_file_name : string; + mutable project_path : string option; mutable encoding : inputenc; @@ -144,6 +145,7 @@ type pref = mutable processing_color : string; mutable processed_color : string; mutable error_color : string; + mutable error_fg_color : string; mutable dynamic_word_wrap : bool; mutable show_line_number : bool; @@ -179,8 +181,9 @@ let current = { source_language = "coq"; source_style = "coq_style"; - read_project = Ignore_args; + read_project = Append_args; project_file_name = "_CoqProject"; + project_path = None; encoding = if Sys.os_type = "Win32" then Eutf8 else Elocale; @@ -220,10 +223,11 @@ let current = { vertical_tabs = false; opposite_tabs = false; - background_color = "cornsilk"; - processed_color = "light green"; - processing_color = "light blue"; - error_color = "#FFCCCC"; + background_color = Tags.default_color; + processed_color = Tags.default_processed_color; + processing_color = Tags.default_processing_color; + error_color = Tags.default_error_color; + error_fg_color = Tags.default_error_fg_color; dynamic_word_wrap = false; show_line_number = false; @@ -263,6 +267,7 @@ let save_pref () = add "project_options" [string_of_project_behavior p.read_project] ++ add "project_file_name" [p.project_file_name] ++ + add "project_path" (match p.project_path with None -> [] | Some s -> [s]) ++ add "encoding" [string_of_inputenc p.encoding] ++ @@ -296,6 +301,7 @@ let save_pref () = add "processing_color" [p.processing_color] ++ add "processed_color" [p.processed_color] ++ add "error_color" [p.error_color] ++ + add "error_fg_color" [p.error_fg_color] ++ add "dynamic_word_wrap" [string_of_bool p.dynamic_word_wrap] ++ add "show_line_number" [string_of_bool p.show_line_number] ++ add "auto_indent" [string_of_bool p.auto_indent] ++ @@ -339,6 +345,7 @@ let load_pref () = set_hd "project_options" (fun v -> np.read_project <- (project_behavior_of_string v)); set_hd "project_file_name" (fun v -> np.project_file_name <- v); + set_option "project_path" (fun v -> np.project_path <- v); set "automatic_tactics" (fun v -> np.automatic_tactics <- v); set_hd "cmd_print" (fun v -> np.cmd_print <- v); @@ -382,6 +389,7 @@ let load_pref () = set_hd "processing_color" (fun v -> np.processing_color <- v); set_hd "processed_color" (fun v -> np.processed_color <- v); set_hd "error_color" (fun v -> np.error_color <- v); + set_hd "error_fg_color" (fun v -> np.error_fg_color <- v); set_bool "dynamic_word_wrap" (fun v -> np.dynamic_word_wrap <- v); set_bool "show_line_number" (fun v -> np.show_line_number <- v); set_bool "auto_indent" (fun v -> np.auto_indent <- v); @@ -466,10 +474,15 @@ let configure ?(apply=(fun () -> ())) () = ~text:"Background color of errors" ~packing:(table#attach ~expand:`X ~left:0 ~top:3) () in + let error_fg_label = GMisc.label + ~text:"Foreground color of errors" + ~packing:(table#attach ~expand:`X ~left:0 ~top:4) () + in let () = background_label#set_xalign 0. in let () = processed_label#set_xalign 0. in let () = processing_label#set_xalign 0. in let () = error_label#set_xalign 0. in + let () = error_fg_label#set_xalign 0. in let background_button = GButton.color_button ~color:(Tags.color_of_string (current.background_color)) ~packing:(table#attach ~left:1 ~top:0) () @@ -486,15 +499,19 @@ let configure ?(apply=(fun () -> ())) () = ~color:(Tags.get_error_color ()) ~packing:(table#attach ~left:1 ~top:3) () in + let error_fg_button = GButton.color_button + ~color:(Tags.get_error_fg_color ()) + ~packing:(table#attach ~left:1 ~top:4) () + in let reset_button = GButton.button ~label:"Reset" ~packing:box#pack () in let reset_cb () = - background_button#set_color (Tags.color_of_string "cornsilk"); - processing_button#set_color (Tags.color_of_string "light blue"); - processed_button#set_color (Tags.color_of_string "light green"); - error_button#set_color (Tags.color_of_string "#FFCCCC"); + background_button#set_color Tags.(color_of_string default_color); + processing_button#set_color Tags.(color_of_string default_processing_color); + processed_button#set_color Tags.(color_of_string default_processed_color); + error_button#set_color Tags.(color_of_string default_error_color); in let _ = reset_button#connect#clicked ~callback:reset_cb in let label = "Color configuration" in @@ -503,10 +520,12 @@ let configure ?(apply=(fun () -> ())) () = current.processing_color <- Tags.string_of_color processing_button#color; current.processed_color <- Tags.string_of_color processed_button#color; current.error_color <- Tags.string_of_color error_button#color; + current.error_fg_color <- Tags.string_of_color error_fg_button#color; !refresh_editor_hook (); Tags.set_processing_color processing_button#color; Tags.set_processed_color processed_button#color; - Tags.set_error_color error_button#color + Tags.set_error_color error_button#color; + Tags.set_error_fg_color error_fg_button#color in custom ~label box callback true in diff --git a/ide/preferences.mli b/ide/preferences.mli index 1b52d20a..1e4f152c 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -32,6 +32,7 @@ type pref = mutable read_project : project_behavior; mutable project_file_name : string; + mutable project_path : string option; mutable encoding : inputenc; @@ -71,6 +72,7 @@ type pref = mutable processing_color : string; mutable processed_color : string; mutable error_color : string; + mutable error_fg_color : string; mutable dynamic_word_wrap : bool; mutable show_line_number : bool; diff --git a/ide/project_file.ml4 b/ide/project_file.ml4 index 41dc1bef..f7279f9c 100644 --- a/ide/project_file.ml4 +++ b/ide/project_file.ml4 @@ -182,29 +182,21 @@ let read_project_file f = (snd (process_cmd_line (Filename.dirname f) (Some f, None, NoInstall, true) [] (parse f))) let args_from_project file project_files default_name = - let is_f = CUnix.same_file file in - let contains_file dir = - List.exists (fun x -> is_f (CUnix.correct_path x dir)) - in let build_cmd_line ml_inc i_inc r_inc args = List.fold_right (fun (_,i) o -> "-I" :: i :: o) ml_inc (List.fold_right (fun (_,l,i) o -> "-Q" :: i :: l :: o) i_inc (List.fold_right (fun (_,l,p) o -> "-R" :: p :: l :: o) r_inc (List.fold_right (fun a o -> parse_args (Stream.of_string a) @ o) args []))) in try - let (_,(_,(ml_inc,i_inc,r_inc),(args,_))) = - List.find (fun (dir,((v_files,_,_,_),_,_)) -> - contains_file dir v_files) project_files in - build_cmd_line ml_inc i_inc r_inc args - with Not_found -> + let (fname,(_,(ml_inc,i_inc,r_inc),(args,_))) = List.hd project_files in + fname, build_cmd_line ml_inc i_inc r_inc args + with Failure _ -> let rec find_project_file dir = try + let fname = Filename.concat dir default_name in let ((v_files,_,_,_),(ml_inc,i_inc,r_inc),(args,_)) = - read_project_file (Filename.concat dir default_name) in - if contains_file dir v_files - then build_cmd_line ml_inc i_inc r_inc args - else let newdir = Filename.dirname dir in - if dir = newdir then [] else find_project_file newdir + read_project_file fname in + fname, build_cmd_line ml_inc i_inc r_inc args with Sys_error s -> let newdir = Filename.dirname dir in - if dir = newdir then [] else find_project_file newdir + if dir = newdir then "",[] else find_project_file newdir in find_project_file (Filename.dirname file) diff --git a/ide/session.ml b/ide/session.ml index 29363211..12b77966 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -18,6 +18,7 @@ class type ['a] page = inherit GObj.widget method update : 'a -> unit method on_update : callback:('a -> unit) -> unit + method refresh_color : unit -> unit end class type control = @@ -133,6 +134,11 @@ let set_buffer_handlers try ignore(buffer#get_mark (`NAME "stop_of_input")) with GText.No_such_mark _ -> assert false in let get_insert () = buffer#get_iter_at_mark `INSERT in + let update_prev it = + let prev = buffer#get_iter_at_mark (`NAME "prev_insert") in + if it#offset < prev#offset then + buffer#move_mark (`NAME "prev_insert") ~where:it + in let debug_edit_zone () = if false (*!Minilib.debug*) then begin buffer#remove_tag Tags.Script.edit_zone ~start:buffer#start_iter ~stop:buffer#end_iter; @@ -147,10 +153,9 @@ let set_buffer_handlers let insert_cb it s = if String.length s = 0 then () else begin Minilib.log ("insert_cb " ^ string_of_int it#offset); let text_mark = add_mark it in + let () = update_prev it in if it#has_tag Tags.Script.to_process then cancel_signal "Altering the script being processed in not implemented" - else if it#has_tag Tags.Script.read_only then - cancel_signal "Altering read_only text not allowed" else if it#has_tag Tags.Script.processed then call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark)) else if it#has_tag Tags.Script.error_bg then begin @@ -160,16 +165,14 @@ let set_buffer_handlers end end in let delete_cb ~start ~stop = Minilib.log (Printf.sprintf "delete_cb %d %d" start#offset stop#offset); - cur_action := new_action_id (); let min_iter, max_iter = if start#compare stop < 0 then start, stop else stop, start in + let () = update_prev min_iter in let text_mark = add_mark min_iter in let rec aux min_iter = if min_iter#equal max_iter then () else if min_iter#has_tag Tags.Script.to_process then cancel_signal "Altering the script being processed in not implemented" - else if min_iter#has_tag Tags.Script.read_only then - cancel_signal "Altering read_only text not allowed" else if min_iter#has_tag Tags.Script.processed then call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark)) else if min_iter#has_tag Tags.Script.error_bg then @@ -250,6 +253,10 @@ let make_table_widget cd cb = ~rules_hint:true ~headers_visible:false ~model:store ~packing:frame#add () in let () = data#set_headers_visible true in + let refresh () = + let clr = Tags.color_of_string current.background_color in + data#misc#modify_base [`NORMAL, `COLOR clr] + in let mk_rend c = GTree.cell_renderer_text [], ["text",c] in let cols = List.map2 (fun (_,c) (_,n,v) -> @@ -265,10 +272,10 @@ let make_table_widget cd cb = ignore( data#connect#row_activated ~callback:(fun tp vc -> cb columns store tp vc) ); - frame, (fun f -> f columns store) + frame, (fun f -> f columns store), refresh let create_errpage (script : Wg_ScriptView.script_view) : errpage = - let table, access = + let table, access, refresh = make_table_widget [`Int,"Line",true; `String,"Error message",true] (fun columns store tp vc -> @@ -299,10 +306,11 @@ let create_errpage (script : Wg_ScriptView.script_view) : errpage = errs end method on_update ~callback:cb = callback := cb + method refresh_color () = refresh () end let create_jobpage coqtop coqops : jobpage = - let table, access = + let table, access, refresh = make_table_widget [`String,"Worker",true; `String,"Job name",true] (fun columns store tp vc -> @@ -338,6 +346,7 @@ let create_jobpage coqtop coqops : jobpage = jobs end method on_update ~callback:cb = callback := cb + method refresh_color () = refresh () end let create_proof () = @@ -465,7 +474,7 @@ let build_layout (sn:session) = message_frame#misc#show (); detachable#show); detachable#button#misc#hide (); - lbl in + detachable, lbl in let session_tab = GPack.hbox ~homogeneous:false () in let img = GMisc.image ~icon_size:`SMALL_TOOLBAR ~packing:session_tab#pack () in @@ -496,9 +505,17 @@ let build_layout (sn:session) = sn.command#pack_in (session_paned#pack2 ~shrink:false ~resize:false); script_scroll#add sn.script#coerce; proof_scroll#add sn.proof#coerce; - ignore(add_msg_page 0 sn.tab_label#text "Messages" sn.messages#coerce); - let label = add_msg_page 1 sn.tab_label#text "Errors" sn.errpage#coerce in - ignore(add_msg_page 2 sn.tab_label#text "Jobs" sn.jobpage#coerce); + let detach, _ = add_msg_page 0 sn.tab_label#text "Messages" sn.messages#coerce in + let _, label = add_msg_page 1 sn.tab_label#text "Errors" sn.errpage#coerce in + let _, _ = add_msg_page 2 sn.tab_label#text "Jobs" sn.jobpage#coerce in + (** When a message is received, focus on the message pane *) + let _ = + sn.messages#connect#pushed ~callback:(fun _ _ -> + let num = message_frame#page_num detach#coerce in + if 0 <= num then message_frame#goto_page num + ) + in + (** When an error occurs, paint the error label in red *) let txt = label#text in let red s = "<span foreground=\"#FF0000\">" ^ s ^ "</span>" in sn.errpage#on_update ~callback:(fun l -> diff --git a/ide/session.mli b/ide/session.mli index 3a6b4585..52e55721 100644 --- a/ide/session.mli +++ b/ide/session.mli @@ -14,6 +14,7 @@ class type ['a] page = inherit GObj.widget method update : 'a -> unit method on_update : callback:('a -> unit) -> unit + method refresh_color : unit -> unit end class type control = diff --git a/ide/tags.ml b/ide/tags.ml index 04ad9a51..c9b57af4 100644 --- a/ide/tags.ml +++ b/ide/tags.ml @@ -13,15 +13,23 @@ let make_tag (tt:GText.tag_table) ~name prop = tt#add new_tag#as_tag; new_tag -let processed_color = ref "light green" -let processing_color = ref "light blue" -let error_color = ref "#FFCCCC" +(* These work fine for colorblind people too *) +let default_processed_color = "light green" +let default_processing_color = "light blue" +let default_error_color = "#FFCCCC" +let default_error_fg_color = "red" +let default_color = "cornsilk" + +let processed_color = ref default_processed_color +let processing_color = ref default_processing_color +let error_color = ref default_error_color +let error_fg_color = ref default_error_fg_color module Script = struct let table = GText.tag_table () let comment = make_tag table ~name:"comment" [] - let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE ; `FOREGROUND "red"] + let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE ; `FOREGROUND !error_fg_color] let error_bg = make_tag table ~name:"error_bg" [`BACKGROUND !error_color] let to_process = make_tag table ~name:"to_process" [`BACKGROUND !processing_color] let processed = make_tag table ~name:"processed" [`BACKGROUND !processed_color] @@ -44,8 +52,6 @@ struct t let all = edit_zone :: all - let read_only = make_tag table ~name:"read_only" [`EDITABLE false ] - end module Proof = struct @@ -94,3 +100,11 @@ let set_error_color clr = let s = string_of_color clr in error_color := s; Script.error_bg#set_property (`BACKGROUND s) + +let get_error_fg_color () = color_of_string !error_fg_color + +let set_error_fg_color clr = + let s = string_of_color clr in + error_fg_color := s; + Script.error#set_property (`FOREGROUND s) + diff --git a/ide/tags.mli b/ide/tags.mli index 9c3261d6..14cfd0db 100644 --- a/ide/tags.mli +++ b/ide/tags.mli @@ -21,9 +21,6 @@ sig val tooltip : GText.tag val edit_zone : GText.tag (* for debugging *) val all : GText.tag list - - (* Not part of the all list. Special tags! *) - val read_only : GText.tag end module Proof : @@ -53,3 +50,13 @@ val set_processing_color : Gdk.color -> unit val get_error_color : unit -> Gdk.color val set_error_color : Gdk.color -> unit + +val get_error_fg_color : unit -> Gdk.color +val set_error_fg_color : Gdk.color -> unit + +val default_processed_color : string +val default_processing_color : string +val default_error_color : string +val default_error_fg_color : string +val default_color : string + diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml index b6f63a3b..a0949ca0 100644 --- a/ide/wg_Find.ml +++ b/ide/wg_Find.ml @@ -8,6 +8,8 @@ type mode = [ `FIND | `REPLACE ] +let b2c = Ideutils.byte_offset_to_char_offset + class finder name (view : GText.view) = let widget = Wg_Detachable.detachable @@ -61,8 +63,10 @@ class finder name (view : GText.view) = method replace () = if self#may_replace () then let txt = self#get_selected_word () in + let () = view#buffer#begin_user_action () in let _ = view#buffer#delete_selection () in let _ = view#buffer#insert_interactive (self#replacement txt) in + let () = view#buffer#end_user_action () in self#find_forward () else self#find_forward () @@ -85,8 +89,8 @@ class finder name (view : GText.view) = try let i = Str.search_backward regexp text (String.length text - 1) in let j = Str.match_end () in - Some(view#buffer#start_iter#forward_chars i, - view#buffer#start_iter#forward_chars j) + Some(view#buffer#start_iter#forward_chars (b2c text i), + view#buffer#start_iter#forward_chars (b2c text j)) with Not_found -> None method private forward_search starti = @@ -95,7 +99,7 @@ class finder name (view : GText.view) = try let i = Str.search_forward regexp text 0 in let j = Str.match_end () in - Some(starti#forward_chars i, starti#forward_chars j) + Some(starti#forward_chars (b2c text i), starti#forward_chars (b2c text j)) with Not_found -> None method replace_all () = @@ -115,7 +119,9 @@ class finder name (view : GText.view) = let () = view#buffer#delete_mark (`MARK stop_mark) in replace_at next in - replace_at view#buffer#start_iter + let () = view#buffer#begin_user_action () in + let () = replace_at view#buffer#start_iter in + view#buffer#end_user_action () method private set_not_found () = find_entry#misc#modify_base [`NORMAL, `NAME "#F7E6E6"]; diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 9acda53f..211db537 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -6,9 +6,25 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +class type message_view_signals = +object + inherit GObj.misc_signals + inherit GUtil.add_ml_signals + method pushed : callback:(Pp.message_level -> string -> unit) -> GtkSignal.id +end + +class message_view_signals_impl obj (pushed : 'a GUtil.signal) : message_view_signals = +object + val after = false + inherit GObj.misc_signals obj + inherit GUtil.add_ml_signals obj [pushed#disconnect] + method pushed ~callback = pushed#connect ~after ~callback:(fun (lvl, s) -> callback lvl s) +end + class type message_view = object inherit GObj.widget + method connect : message_view_signals method clear : unit method add : string -> unit method set : string -> unit @@ -17,6 +33,7 @@ class type message_view = method buffer : GText.buffer (** for more advanced text edition *) method modify_font : Pango.font_description -> unit + method refresh_color : unit -> unit end let message_view () : message_view = @@ -32,12 +49,18 @@ let message_view () : message_view = ~source_buffer:buffer ~packing:scroll#add ~editable:false ~cursor_visible:false ~wrap_mode:`WORD () in + let () = Gtk_parsing.fix_double_click view in let default_clipboard = GData.clipboard Gdk.Atom.primary in let _ = buffer#add_selection_clipboard default_clipboard in let () = view#set_left_margin 2 in object (self) inherit GObj.widget box#as_widget + val push = new GUtil.signal () + + method connect = + new message_view_signals_impl box#as_widget push + method clear = buffer#set_text "" @@ -49,7 +72,8 @@ let message_view () : message_view = in if msg <> "" then begin buffer#insert ~tags msg; - buffer#insert ~tags "\n" + buffer#insert ~tags "\n"; + push#call (level, msg) end method add msg = self#push Pp.Notice msg @@ -60,4 +84,9 @@ let message_view () : message_view = method modify_font fd = view#misc#modify_font fd + method refresh_color () = + let open Preferences in + let clr = Tags.color_of_string current.background_color in + view#misc#modify_base [`NORMAL, `COLOR clr] + end diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli index cd3f00c9..23c94f40 100644 --- a/ide/wg_MessageView.mli +++ b/ide/wg_MessageView.mli @@ -6,9 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +class type message_view_signals = +object + inherit GObj.misc_signals + inherit GUtil.add_ml_signals + method pushed : callback:(Pp.message_level -> string -> unit) -> GtkSignal.id +end + class type message_view = object inherit GObj.widget + method connect : message_view_signals method clear : unit method add : string -> unit method set : string -> unit @@ -17,6 +25,7 @@ class type message_view = method buffer : GText.buffer (** for more advanced text edition *) method modify_font : Pango.font_description -> unit + method refresh_color : unit -> unit end val message_view : unit -> message_view diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 7e7a311e..b12d29d6 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -9,6 +9,7 @@ class type proof_view = object inherit GObj.widget + method buffer : GText.buffer method refresh : unit -> unit method clear : unit -> unit method set_goals : Interface.goals option -> unit @@ -176,9 +177,11 @@ let proof_view () = ~highlight_matching_brackets:true ~tag_table:Tags.Proof.table () in + let text_buffer = new GText.buffer buffer#as_buffer in let view = GSourceView2.source_view ~source_buffer:buffer ~editable:false ~wrap_mode:`WORD () in + let () = Gtk_parsing.fix_double_click view in let default_clipboard = GData.clipboard Gdk.Atom.primary in let _ = buffer#add_selection_clipboard default_clipboard in object @@ -186,6 +189,8 @@ let proof_view () = val mutable goals = None val mutable evars = None + method buffer = text_buffer + method clear () = buffer#set_text "" method set_goals gls = goals <- gls diff --git a/ide/wg_ProofView.mli b/ide/wg_ProofView.mli index 1fbf9900..c5e042ea 100644 --- a/ide/wg_ProofView.mli +++ b/ide/wg_ProofView.mli @@ -9,6 +9,7 @@ class type proof_view = object inherit GObj.widget + method buffer : GText.buffer method refresh : unit -> unit method clear : unit -> unit method set_goals : Interface.goals option -> unit diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index 1f399070..8298d995 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -186,11 +186,19 @@ object(self) method undo () = Minilib.log "UNDO"; - self#with_lock_undo self#perform_undo (); + self#with_lock_undo begin fun () -> + buffer#begin_user_action (); + self#perform_undo (); + buffer#end_user_action () + end () method redo () = Minilib.log "REDO"; - self#with_lock_undo self#perform_redo (); + self#with_lock_undo begin fun () -> + buffer#begin_user_action (); + self#perform_redo (); + buffer#end_user_action () + end () method process_begin_user_action () = (* Push a new level of event on history stack *) @@ -410,6 +418,7 @@ object (self) self#buffer#end_user_action () initializer + let () = Gtk_parsing.fix_double_click self in let supersed cb _ = let _ = cb () in GtkSignal.stop_emit() diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml index 8520727a..25a031d6 100644 --- a/ide/wg_Segment.ml +++ b/ide/wg_Segment.ml @@ -70,9 +70,25 @@ let color_eq (c1 : GDraw.color) (c2 : GDraw.color) = match c1, c2 with | `WHITE, `WHITE -> true | _ -> false +class type segment_signals = +object + inherit GObj.misc_signals + inherit GUtil.add_ml_signals + method clicked : callback:(int -> unit) -> GtkSignal.id +end + +class segment_signals_impl obj (clicked : 'a GUtil.signal) : segment_signals = +object + val after = false + inherit GObj.misc_signals obj + inherit GUtil.add_ml_signals obj [clicked#disconnect] + method clicked = clicked#connect ~after +end + class segment () = let box = GBin.frame () in -let draw = GMisc.image ~packing:box#add () in +let eventbox = GBin.event_box ~packing:box#add () in +let draw = GMisc.image ~packing:eventbox#add () in object (self) inherit GObj.widget box#as_widget @@ -82,6 +98,7 @@ object (self) val mutable data = Segment.empty val mutable default : color = `WHITE val mutable pixmap : GDraw.pixmap = GDraw.pixmap ~width:1 ~height:1 () + val clicked = new GUtil.signal () initializer box#misc#set_size_request ~height (); @@ -96,6 +113,15 @@ object (self) end in let _ = box#misc#connect#size_allocate cb in + let clicked_cb ev = + let x = GdkEvent.Button.x ev in + let (width, _) = pixmap#size in + let len = Segment.length data in + let idx = f2i ((x *. i2f len) /. i2f width) in + let () = clicked#call idx in + true + in + let _ = eventbox#event#connect#button_press clicked_cb in (** Initial pixmap *) draw#set_pixmap pixmap @@ -140,4 +166,7 @@ object (self) Segment.fold color_eq fold data (); draw#set_mask None; + method connect = + new segment_signals_impl box#as_widget clicked + end diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli index ecb45147..0263856a 100644 --- a/ide/wg_Segment.mli +++ b/ide/wg_Segment.mli @@ -8,10 +8,18 @@ type color = GDraw.color +class type segment_signals = +object + inherit GObj.misc_signals + inherit GUtil.add_ml_signals + method clicked : callback:(int -> unit) -> GtkSignal.id +end + class segment : unit -> object inherit GObj.widget val obj : Gtk.widget Gtk.obj + method connect : segment_signals method length : int method set_length : int -> unit method default_color : color diff --git a/interp/constrarg.ml b/interp/constrarg.ml index 3f232c36..a7241399 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -55,6 +55,9 @@ let wit_constr_with_bindings = unsafe_of_type ConstrWithBindingsArgType let wit_bindings = unsafe_of_type BindingsArgType +let wit_hyp_location_flag : 'a Genarg.uniform_genarg_type = + Genarg.make0 None "hyp_location_flag" + let wit_red_expr = unsafe_of_type RedExprArgType let wit_clause_dft_concl = diff --git a/interp/constrarg.mli b/interp/constrarg.mli index 74c6bd31..fdeddd66 100644 --- a/interp/constrarg.mli +++ b/interp/constrarg.mli @@ -64,6 +64,8 @@ val wit_bindings : glob_constr_and_expr bindings, constr bindings Evd.sigma) genarg_type +val wit_hyp_location_flag : Locus.hyp_location_flag uniform_genarg_type + val wit_red_expr : ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 58e1eb1d..f57772ec 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -977,7 +977,7 @@ let rec glob_of_pat env sigma = function | PRef ref -> GRef (loc,ref,None) | PVar id -> GVar (loc,id) | PEvar (evk,l) -> - let test id = function PVar id' -> Id.equal id id' | _ -> false in + let test (id,_,_) = function PVar id' -> Id.equal id id' | _ -> false in let l = Evd.evar_instance_array test (Evd.find sigma evk) l in let id = Evd.evar_ident evk sigma in GEvar (loc,id,List.map (on_snd (glob_of_pat env sigma)) l) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 68f0050d..5151d2a1 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1567,7 +1567,6 @@ let internalize globalenv env allow_patvar lvar c = let lvars = Id.Set.union lvars env.ids in let ist = { Genintern.ltacvars = lvars; - ltacrecvars = Id.Map.empty; genv = globalenv; } in let (_, glb) = Genintern.generic_intern ist gen in diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 792e6f63..0d33d433 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -174,6 +174,7 @@ val interp_context_evars : (** Locating references of constructions, possibly via a syntactic definition (these functions do not modify the glob file) *) +val locate_reference : Libnames.qualid -> Globnames.global_reference val is_global : Id.t -> bool val construct_reference : named_context -> Id.t -> constr val global_reference : Id.t -> constr diff --git a/interp/coqlib.ml b/interp/coqlib.ml index e722615a..02504c92 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -349,7 +349,6 @@ let build_coq_inversion_eq_true_data () = (* The False proposition *) let coq_False = lazy_init_constant ["Logic"] "False" -let coq_proof_admitted = lazy_init_constant ["Logic"] "proof_admitted" (* The True proposition and its unique proof *) let coq_True = lazy_init_constant ["Logic"] "True" @@ -371,7 +370,6 @@ let build_coq_True () = Lazy.force coq_True let build_coq_I () = Lazy.force coq_I let build_coq_False () = Lazy.force coq_False -let build_coq_proof_admitted () = Lazy.force coq_proof_admitted let build_coq_not () = Lazy.force coq_not let build_coq_and () = Lazy.force coq_and let build_coq_conj () = Lazy.force coq_conj diff --git a/interp/coqlib.mli b/interp/coqlib.mli index 986a4385..41204a71 100644 --- a/interp/coqlib.mli +++ b/interp/coqlib.mli @@ -160,7 +160,6 @@ val build_coq_sumbool : constr delayed (** Connectives The False proposition *) val build_coq_False : constr delayed -val build_coq_proof_admitted : constr delayed (** The True proposition and its unique proof *) val build_coq_True : constr delayed diff --git a/interp/genintern.ml b/interp/genintern.ml index c78b13a8..7795946d 100644 --- a/interp/genintern.ml +++ b/interp/genintern.ml @@ -12,7 +12,6 @@ open Genarg type glob_sign = { ltacvars : Id.Set.t; - ltacrecvars : Nametab.ltac_constant Id.Map.t; genv : Environ.env } type ('raw, 'glb) intern_fun = glob_sign -> 'raw -> glob_sign * 'glb diff --git a/interp/genintern.mli b/interp/genintern.mli index 6e63f71c..28f4f530 100644 --- a/interp/genintern.mli +++ b/interp/genintern.mli @@ -12,7 +12,6 @@ open Genarg type glob_sign = { ltacvars : Id.Set.t; - ltacrecvars : Nametab.ltac_constant Id.Map.t; genv : Environ.env } (** {5 Internalization functions} *) diff --git a/interp/modintern.ml b/interp/modintern.ml index fdc6e609..bf0b2f98 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -61,7 +61,9 @@ let transl_with_decl env = function | CWith_Module ((_,fqid),qid) -> WithMod (fqid,lookup_module qid) | CWith_Definition ((_,fqid),c) -> - WithDef (fqid,fst (interp_constr env Evd.empty c)) (*FIXME*) + let c, ectx = interp_constr env (Evd.from_env env) c in + let ctx = Univ.ContextSet.to_context (Evd.evar_universe_context_set ectx) in + WithDef (fqid,(c,ctx)) let loc_of_module = function | CMident (loc,_) | CMapply (loc,_,_) | CMwith (loc,_,_) -> loc diff --git a/interp/notation.ml b/interp/notation.ml index aeec4b61..80db2cb3 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -136,10 +136,6 @@ let scope_is_open sc = scope_is_open_in_scopes sc (!scope_stack) (* Exportation of scopes *) let open_scope i (_,(local,op,sc)) = if Int.equal i 1 then - let sc = match sc with - | Scope sc -> Scope (normalize_scope sc) - | _ -> sc - in scope_stack := if op then sc :: !scope_stack else List.except scope_eq sc !scope_stack @@ -166,7 +162,7 @@ let inScope : bool * bool * scope_elem -> obj = classify_function = classify_scope } let open_close_scope (local,opening,sc) = - Lib.add_anonymous_leaf (inScope (local,opening,Scope sc)) + Lib.add_anonymous_leaf (inScope (local,opening,Scope (normalize_scope sc))) let empty_scope_stack = [] @@ -516,6 +512,32 @@ let availability_of_prim_token n printer_scope local_scopes = (* Miscellaneous *) +let pair_eq f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 + +let ntpe_eq t1 t2 = match t1, t2 with +| NtnTypeConstr, NtnTypeConstr -> true +| NtnTypeConstrList, NtnTypeConstrList -> true +| NtnTypeBinderList, NtnTypeBinderList -> true +| (NtnTypeConstr | NtnTypeConstrList | NtnTypeBinderList), _ -> false + + +let vars_eq (id1, (sc1, tp1)) (id2, (sc2, tp2)) = + Id.equal id1 id2 && + pair_eq (Option.equal String.equal) (List.equal String.equal) sc1 sc2 && + ntpe_eq tp1 tp2 + +let interpretation_eq (vars1, t1) (vars2, t2) = + List.equal vars_eq vars1 vars2 && + Notation_ops.eq_notation_constr t1 t2 + +let exists_notation_in_scope scopt ntn r = + let scope = match scopt with Some s -> s | None -> default_scope in + try + let sc = String.Map.find scope !scope_map in + let (r',_) = String.Map.find ntn sc.notations in + interpretation_eq r' r + with Not_found -> false + let isNVar_or_NHole = function NVar _ | NHole _ -> true | _ -> false (**********************************************************************) diff --git a/interp/notation.mli b/interp/notation.mli index c66115cb..854c52b2 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -140,6 +140,10 @@ val level_of_notation : notation -> level (** raise [Not_found] if no level *) val interp_notation_as_global_reference : Loc.t -> (global_reference -> bool) -> notation -> delimiters option -> global_reference +(** Checks for already existing notations *) +val exists_notation_in_scope : scope_name option -> notation -> + interpretation -> bool + (** Declares and looks for scopes associated to arguments of a global ref *) val declare_arguments_scope : bool (** true=local *) -> global_reference -> scope_name option list -> unit diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index c91c7815..2762dc0b 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -170,6 +170,69 @@ let compare_glob_constr f add t1 t2 = match t1,t2 with let rec eq_glob_constr t1 t2 = compare_glob_constr eq_glob_constr (fun _ -> ()) t1 t2 +let rec eq_notation_constr t1 t2 = match t1, t2 with +| NRef gr1, NRef gr2 -> eq_gr gr1 gr2 +| NVar id1, NVar id2 -> Id.equal id1 id2 +| NApp (t1, a1), NApp (t2, a2) -> + eq_notation_constr t1 t2 && List.equal eq_notation_constr a1 a2 +| NHole (_, _, _), NHole (_, _, _) -> true (** FIXME? *) +| NList (i1, j1, t1, u1, b1), NList (i2, j2, t2, u2, b2) -> + Id.equal i1 i2 && Id.equal j1 j2 && eq_notation_constr t1 t2 && + eq_notation_constr u1 u2 && b1 == b2 +| NLambda (na1, t1, u1), NLambda (na2, t2, u2) -> + Name.equal na1 na2 && eq_notation_constr t1 t2 && eq_notation_constr u1 u2 +| NProd (na1, t1, u1), NProd (na2, t2, u2) -> + Name.equal na1 na2 && eq_notation_constr t1 t2 && eq_notation_constr u1 u2 +| NBinderList (i1, j1, t1, u1), NBinderList (i2, j2, t2, u2) -> + Id.equal i1 i2 && Id.equal j1 j2 && eq_notation_constr t1 t2 && + eq_notation_constr u1 u2 +| NLetIn (na1, t1, u1), NLetIn (na2, t2, u2) -> + Name.equal na1 na2 && eq_notation_constr t1 t2 && eq_notation_constr u1 u2 +| NCases (_, o1, r1, p1), NCases (_, o2, r2, p2) -> (** FIXME? *) + let eqpat (p1, t1) (p2, t2) = + List.equal cases_pattern_eq p1 p2 && + eq_notation_constr t1 t2 + in + let eqf (t1, (na1, o1)) (t2, (na2, o2)) = + let eq (i1, n1) (i2, n2) = eq_ind i1 i2 && List.equal Name.equal n1 n2 in + eq_notation_constr t1 t2 && Name.equal na1 na2 && Option.equal eq o1 o2 + in + Option.equal eq_notation_constr o1 o2 && + List.equal eqf r1 r2 && + List.equal eqpat p1 p2 +| NLetTuple (nas1, (na1, o1), t1, u1), NLetTuple (nas2, (na2, o2), t2, u2) -> + List.equal Name.equal nas1 nas2 && + Name.equal na1 na2 && + Option.equal eq_notation_constr o1 o2 && + eq_notation_constr t1 t2 && + eq_notation_constr u1 u2 +| NIf (t1, (na1, o1), u1, r1), NIf (t2, (na2, o2), u2, r2) -> + eq_notation_constr t1 t2 && + Name.equal na1 na2 && + Option.equal eq_notation_constr o1 o2 && + eq_notation_constr u1 u2 && + eq_notation_constr r1 r2 +| NRec (_, ids1, ts1, us1, rs1), NRec (_, ids2, ts2, us2, rs2) -> (** FIXME? *) + let eq (na1, o1, t1) (na2, o2, t2) = + Name.equal na1 na2 && + Option.equal eq_notation_constr o1 o2 && + eq_notation_constr t1 t2 + in + Array.equal Id.equal ids1 ids2 && + Array.equal (List.equal eq) ts1 ts2 && + Array.equal eq_notation_constr us1 us2 && + Array.equal eq_notation_constr rs1 rs2 +| NSort s1, NSort s2 -> + Miscops.glob_sort_eq s1 s2 +| NPatVar p1, NPatVar p2 -> + Id.equal p1 p2 +| NCast (t1, c1), NCast (t2, c2) -> + eq_notation_constr t1 t2 && cast_type_eq eq_notation_constr c1 c2 +| (NRef _ | NVar _ | NApp _ | NHole _ | NList _ | NLambda _ | NProd _ + | NBinderList _ | NLetIn _ | NCases _ | NLetTuple _ | NIf _ + | NRec _ | NSort _ | NPatVar _ | NCast _), _ -> false + + let subtract_loc loc1 loc2 = Loc.make_loc (fst (Loc.unloc loc1),fst (Loc.unloc loc2)-1) let check_is_hole id = function GHole _ -> () | t -> diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index 7283ed6f..c6770dee 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -25,6 +25,8 @@ val ldots_var : Id.t (** FIXME: nothing to do here *) val eq_glob_constr : glob_constr -> glob_constr -> bool +val eq_notation_constr : notation_constr -> notation_constr -> bool + (** Re-interpret a notation as a [glob_constr], taking care of binders *) val glob_constr_of_notation_constr_with_binders : Loc.t -> diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 7b9ad313..ff090ca8 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -10,12 +10,10 @@ open Loc open Names open Constrexpr open Libnames -open Globnames open Nametab open Genredexpr open Genarg open Pattern -open Decl_kinds open Misctypes open Locus diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 3f2d002c..450b1af0 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -135,7 +135,7 @@ type search_restriction = type rec_flag = bool (* true = Rec; false = NoRec *) type verbose_flag = bool (* true = Verbose; false = Silent *) -type opacity_flag = bool (* true = Opaque; false = Transparent *) +type opacity_flag = Opaque of lident list option | Transparent type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) type instance_flag = bool option (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) @@ -316,7 +316,7 @@ type vernac_expr = | VernacBeginSection of lident | VernacEndSegment of lident | VernacRequire of - export_flag option * lreference list + lreference option * export_flag option * lreference list | VernacImport of export_flag * lreference list | VernacCanonical of reference or_by_notation | VernacCoercion of obsolete_locality * reference or_by_notation * diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index 3fded663..1be3e651 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -13,6 +13,7 @@ #include <stdio.h> #include <stdlib.h> +#include <stdint.h> #include <caml/config.h> #include <caml/misc.h> #include <caml/mlvalues.h> @@ -146,21 +147,21 @@ value coq_tcode_of_code (value code, value size) { }; *q++ = VALINSTR(instr); if (instr == SWITCH) { - uint32 i, sizes, const_size, block_size; + uint32_t i, sizes, const_size, block_size; COPY32(q,p); p++; sizes=*q++; - const_size = sizes & 0xFFFF; - block_size = sizes >> 16; + const_size = sizes & 0xFFFFFF; + block_size = sizes >> 24; sizes = const_size + block_size; for(i=0; i<sizes; i++) { COPY32(q,p); p++; q++; }; } else if (instr == CLOSUREREC || instr==CLOSURECOFIX) { - uint32 i, n; + uint32_t i, n; COPY32(q,p); p++; /* ndefs */ n = 3 + 2*(*q); /* ndefs, nvars, start, typlbls,lbls*/ q++; for(i=1; i<n; i++) { COPY32(q,p); p++; q++; }; } else { - uint32 i, ar; + uint32_t i, ar; ar = arity[instr]; for(i=0; i<ar; i++) { COPY32(q,p); p++; q++; }; } diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index f9e0dc7f..0ab9f89f 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -15,6 +15,7 @@ #include <stdio.h> #include <signal.h> +#include <stdint.h> #include "coq_gc.h" #include "coq_instruct.h" #include "coq_fix_code.h" @@ -30,9 +31,9 @@ #endif /* spiwack: I append here a few macros for value/number manipulation */ -#define uint32_of_value(val) (((uint32)val >> 1)) -#define value_of_uint32(i) ((value)(((uint32)(i) << 1) | 1)) -#define UI64_of_uint32(lo) ((uint64)(I64_literal(0,(uint32)(lo)))) +#define uint32_of_value(val) (((uint32_t)val >> 1)) +#define value_of_uint32(i) ((value)(((uint32_t)(i) << 1) | 1)) +#define UI64_of_uint32(lo) ((uint64_t)(I64_literal(0,(uint32_t)(lo)))) #define UI64_of_value(val) (UI64_of_uint32(uint32_of_value(val))) /* /spiwack */ @@ -788,14 +789,14 @@ value coq_interprete /* Access to components of blocks */ Instruct(SWITCH) { - uint32 sizes = *pc++; + uint32_t sizes = *pc++; print_instr("SWITCH"); - print_int(sizes & 0xFFFF); + print_int(sizes & 0xFFFFFF); if (Is_block(accu)) { long index = Tag_val(accu); print_instr("block"); print_int(index); - pc += pc[(sizes & 0xFFFF) + index]; + pc += pc[(sizes & 0xFFFFFF) + index]; } else { long index = Long_val(accu); print_instr("constant"); @@ -1054,7 +1055,7 @@ value coq_interprete the one ontop of the stack (which is poped)*/ print_instr("ADDINT31"); accu = - (value)((uint32) accu + (uint32) *sp++ - 1); + (value)((uint32_t) accu + (uint32_t) *sp++ - 1); /* nota,unlike CaML we don't want to have a different behavior depending on the architecture. Thus we cast the operand to uint32 */ @@ -1064,9 +1065,9 @@ value coq_interprete Instruct (ADDCINT31) { print_instr("ADDCINT31"); /* returns the sum with a carry */ - uint32 s; - s = (uint32)accu + (uint32)*sp++ - 1; - if( (uint32)s < (uint32)accu ) { + uint32_t s; + s = (uint32_t)accu + (uint32_t)*sp++ - 1; + if( (uint32_t)s < (uint32_t)accu ) { /* carry */ Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ } @@ -1081,10 +1082,10 @@ value coq_interprete Instruct (ADDCARRYCINT31) { print_instr("ADDCARRYCINT31"); /* returns the sum plus one with a carry */ - uint32 s; - s = (uint32)accu + (uint32)*sp++ + 1; + uint32_t s; + s = (uint32_t)accu + (uint32_t)*sp++ + 1; value block; - if( (uint32)s <= (uint32)accu ) { + if( (uint32_t)s <= (uint32_t)accu ) { /* carry */ Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ } @@ -1100,18 +1101,18 @@ value coq_interprete print_instr("SUBINT31"); /* returns the subtraction */ accu = - (value)((uint32) accu - (uint32) *sp++ + 1); + (value)((uint32_t) accu - (uint32_t) *sp++ + 1); Next; } Instruct (SUBCINT31) { print_instr("SUBCINT31"); /* returns the subtraction with a carry */ - uint32 b; - uint32 s; - b = (uint32)*sp++; - s = (uint32)accu - b + 1; - if( (uint32)accu < b ) { + uint32_t b; + uint32_t s; + b = (uint32_t)*sp++; + s = (uint32_t)accu - b + 1; + if( (uint32_t)accu < b ) { /* carry */ Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ } @@ -1126,11 +1127,11 @@ value coq_interprete Instruct (SUBCARRYCINT31) { print_instr("SUBCARRYCINT31"); /* returns the subtraction minus one with a carry */ - uint32 b; - uint32 s; - b = (uint32)*sp++; - s = (value)((uint32)accu - b - 1); - if( (uint32)accu <= b ) { + uint32_t b; + uint32_t s; + b = (uint32_t)*sp++; + s = (value)((uint32_t)accu - b - 1); + if( (uint32_t)accu <= b ) { /* carry */ Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ } @@ -1154,7 +1155,7 @@ value coq_interprete /*returns the multiplication on a double size word (special case for 0) */ print_instr("MULCINT31"); - uint64 p; + uint64_t p; /*accu = 2v+1, *sp=2w+1 ==> p = 2v*w */ p = I64_mul (UI64_of_value (accu), UI64_of_uint32 ((*sp++)^1)); if ( I64_is_zero(p) ) { @@ -1177,10 +1178,10 @@ value coq_interprete /* spiwack: takes three int31 (the two first ones represent an int62) and performs the euclidian division of the int62 by the int31 */ - uint64 bigint; + uint64_t bigint; bigint = UI64_of_value(accu); bigint = I64_or(I64_lsl(bigint, 31),UI64_of_value(*sp++)); - uint64 divisor; + uint64_t divisor; divisor = UI64_of_value(*sp++); Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ if (I64_is_zero (divisor)) { @@ -1188,7 +1189,7 @@ value coq_interprete Field(accu, 1) = 1; /* 2*0+1 */ } else { - uint64 quo, mod; + uint64_t quo, mod; I64_udivmod(bigint, divisor, &quo, &mod); Field(accu, 0) = value_of_uint32(I64_to_int32(quo)); Field(accu, 1) = value_of_uint32(I64_to_int32(mod)); @@ -1201,7 +1202,7 @@ value coq_interprete /* spiwack: a priori no need of the NON_STANDARD_DIV_MOD flag since it probably only concerns negative number. needs to be checked at this point */ - uint32 divisor; + uint32_t divisor; divisor = uint32_of_value(*sp++); if (divisor == 0) { Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ @@ -1209,7 +1210,7 @@ value coq_interprete Field(accu, 1) = 1; /* 2*0+1 */ } else { - uint32 modulus; + uint32_t modulus; modulus = uint32_of_value(accu); Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ Field(accu, 0) = value_of_uint32(modulus/divisor); @@ -1221,7 +1222,7 @@ value coq_interprete Instruct (ADDMULDIVINT31) { print_instr("ADDMULDIVINT31"); /* higher level shift (does shifts and cycles and such) */ - uint32 shiftby; + uint32_t shiftby; shiftby = uint32_of_value(accu); if (shiftby > 31) { if (shiftby < 62) { @@ -1236,7 +1237,7 @@ value coq_interprete /* *sp = 2*x+1 --> accu = 2^(shiftby+1)*x */ accu = (value)(((*sp++)^1) << shiftby); /* accu = 2^(shiftby+1)*x --> 2^(shifby+1)*x+2*y/2^(31-shiftby)+1 */ - accu = (value)((accu | (((uint32)(*sp++)) >> (31-shiftby)))|1); + accu = (value)((accu | (((uint32_t)(*sp++)) >> (31-shiftby)))|1); } Next; } @@ -1245,11 +1246,11 @@ value coq_interprete /* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */ /* assumes Inudctive _ : _ := Eq | Lt | Gt */ print_instr("COMPAREINT31"); - if ((uint32)accu == (uint32)*sp) { + if ((uint32_t)accu == (uint32_t)*sp) { accu = 1; /* 2*0+1 */ sp++; } - else{if ((uint32)accu < (uint32)(*sp++)) { + else{if ((uint32_t)accu < (uint32_t)(*sp++)) { accu = 3; /* 2*1+1 */ } else{ @@ -1260,9 +1261,9 @@ value coq_interprete Instruct (HEAD0INT31) { int r = 0; - uint32 x; + uint32_t x; print_instr("HEAD0INT31"); - x = (uint32) accu; + x = (uint32_t) accu; if (!(x & 0xFFFF0000)) { x <<= 16; r += 16; } if (!(x & 0xFF000000)) { x <<= 8; r += 8; } if (!(x & 0xF0000000)) { x <<= 4; r += 4; } @@ -1275,9 +1276,9 @@ value coq_interprete Instruct (TAIL0INT31) { int r = 0; - uint32 x; + uint32_t x; print_instr("TAIL0INT31"); - x = (((uint32) accu >> 1) | 0x80000000); + x = (((uint32_t) accu >> 1) | 0x80000000); if (!(x & 0xFFFF)) { x >>= 16; r += 16; } if (!(x & 0x00FF)) { x >>= 8; r += 8; } if (!(x & 0x000F)) { x >>= 4; r += 4; } @@ -1327,7 +1328,7 @@ value coq_interprete /*accu=accu or accu = (value)((unsigned long)1-accu) if bool is used for the bits */ for(i=0; i < 30; i++) { - accu = (value) ((((uint32)accu-1) << 1) | *sp++); + accu = (value) ((((uint32_t)accu-1) << 1) | *sp++); /* -1 removes the tag bit, << 1 multiplies the value by 2, | *sp++ pops the last value and add it (no carry involved) not that it reintroduces a tag bit */ @@ -1347,7 +1348,7 @@ value coq_interprete for(i = 30; i >= 0; i--) { Field(block, i) = (value)(accu & 3); /* two last bits of the accumulator */ //Field(block, i) = 3; - accu = (value) ((uint32)accu >> 1) | 1; /* last bit must be a one */ + accu = (value) ((uint32_t)accu >> 1) | 1; /* last bit must be a one */ }; accu = block; Next; diff --git a/kernel/byterun/int64_native.h b/kernel/byterun/int64_native.h index 8a6a2664..657d0a07 100644 --- a/kernel/byterun/int64_native.h +++ b/kernel/byterun/int64_native.h @@ -18,9 +18,9 @@ #ifndef CAML_INT64_NATIVE_H #define CAML_INT64_NATIVE_H -#define I64_literal(hi,lo) ((int64)(hi) << 32 | (lo)) +#define I64_literal(hi,lo) ((int64_t)(hi) << 32 | (lo)) #define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) -#define I64_ult(x,y) ((uint64)(x) < (uint64)(y)) +#define I64_ult(x,y) ((uint64_t)(x) < (uint64_t)(y)) #define I64_neg(x) (-(x)) #define I64_add(x,y) ((x) + (y)) #define I64_sub(x,y) ((x) - (y)) @@ -30,19 +30,19 @@ #define I64_div(x,y) ((x) / (y)) #define I64_mod(x,y) ((x) % (y)) #define I64_udivmod(x,y,quo,rem) \ - (*(rem) = (uint64)(x) % (uint64)(y), \ - *(quo) = (uint64)(x) / (uint64)(y)) + (*(rem) = (uint64_t)(x) % (uint64_t)(y), \ + *(quo) = (uint64_t)(x) / (uint64_t)(y)) #define I64_and(x,y) ((x) & (y)) #define I64_or(x,y) ((x) | (y)) #define I64_xor(x,y) ((x) ^ (y)) #define I64_lsl(x,y) ((x) << (y)) #define I64_asr(x,y) ((x) >> (y)) -#define I64_lsr(x,y) ((uint64)(x) >> (y)) +#define I64_lsr(x,y) ((uint64_t)(x) >> (y)) #define I64_to_intnat(x) ((intnat) (x)) #define I64_of_intnat(x) ((intnat) (x)) -#define I64_to_int32(x) ((int32) (x)) -#define I64_of_int32(x) ((int64) (x)) +#define I64_to_int32(x) ((int32_t) (x)) +#define I64_of_int32(x) ((int64_t) (x)) #define I64_to_double(x) ((double)(x)) -#define I64_of_double(x) ((int64)(x)) +#define I64_of_double(x) ((int64_t)(x)) #endif /* CAML_INT64_NATIVE_H */ diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index ae679027..700de502 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -24,6 +24,9 @@ let fix_tag = 3 let switch_tag = 4 let cofix_tag = 5 let cofix_evaluated_tag = 6 +(* It could be greate if OCaml export this value, + So fixme if this occur in a new version of OCaml *) +let last_variant_tag = 245 type structured_constant = | Const_sorts of sorts diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index b65268f7..fbb40ffd 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -20,6 +20,7 @@ val fix_tag : tag val switch_tag : tag val cofix_tag : tag val cofix_evaluated_tag : tag +val last_variant_tag : tag type structured_constant = | Const_sorts of sorts diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index d6c160c3..07fab06a 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -38,7 +38,7 @@ open Pre_env (* In the function body [arg1] is represented by de Bruijn [n], and *) (* [argn] by de Bruijn [1] *) -(* Representation of environements of mutual fixpoints : *) +(* Representation of environments of mutual fixpoints : *) (* [t1|C1| ... |tc|Cc| ... |t(nbr)|C(nbr)| fv1 | fv2 | .... | fvn | type] *) (* ^<----------offset---------> *) (* type = [Ct1 | .... | Ctn] *) @@ -329,13 +329,50 @@ let init_fun_code () = fun_code := [] (* Compilation of constructors and inductive types *) + +(* Limitation due to OCaml's representation of non-constant + constructors: limited to 245 + 1 (0 tag) cases. *) + +exception TooLargeInductive of Id.t + +let max_nb_const = 0x1000000 +let max_nb_block = 0x1000000 + last_variant_tag - 1 + +let str_max_constructors = + Format.sprintf + " which has more than %i constant constructors or more than %i non-constant constructors" max_nb_const max_nb_block + +let check_compilable ib = + + if not (ib.mind_nb_args <= max_nb_block && ib.mind_nb_constant <= max_nb_const) then + raise (TooLargeInductive ib.mind_typename) + +(* Inv: arity > 0 *) + +let const_bn tag args = + if tag < last_variant_tag then Const_bn(tag, args) + else + Const_bn(last_variant_tag, Array.append [|Const_b0 (tag - last_variant_tag) |] args) + + +let code_makeblock arity tag cont = + if tag < last_variant_tag then + Kmakeblock(arity, tag) :: cont + else + Kpush :: Kconst (Const_b0 (tag - last_variant_tag)) :: + Kmakeblock(arity+1, last_variant_tag) :: cont + (* Inv : nparam + arity > 0 *) let code_construct tag nparams arity cont = let f_cont = add_pop nparams (if Int.equal arity 0 then [Kconst (Const_b0 tag); Kreturn 0] - else [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0]) + else if tag < last_variant_tag then + [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0] + else + [Kconst (Const_b0 (tag - last_variant_tag)); + Kmakeblock(arity+1, last_variant_tag); Kreturn 0]) in let lbl = Label.create() in fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)]; @@ -345,7 +382,6 @@ let get_strcst = function | Bstrconst sc -> sc | _ -> raise Not_found - let rec str_const c = match kind_of_term c with | Sort s -> Bstrconst (Const_sorts s) @@ -357,7 +393,8 @@ let rec str_const c = begin let oib = lookup_mind kn !global_env in let oip = oib.mind_packets.(j) in - let num,arity = oip.mind_reloc_tbl.(i-1) in + let () = check_compilable oip in + let tag,arity = oip.mind_reloc_tbl.(i-1) in let nparams = oib.mind_nparams in if Int.equal (nparams + arity) (Array.length args) then (* spiwack: *) @@ -399,15 +436,15 @@ let rec str_const c = with Not_found -> (* 3/ if no special behavior is available, then the compiler falls back to the normal behavior *) - if Int.equal arity 0 then Bstrconst(Const_b0 num) + if Int.equal arity 0 then Bstrconst(Const_b0 tag) else let rargs = Array.sub args nparams arity in let b_args = Array.map str_const rargs in try let sc_args = Array.map get_strcst b_args in - Bstrconst(Const_bn(num, sc_args)) + Bstrconst(const_bn tag sc_args) with Not_found -> - Bmakeblock(num,b_args) + Bmakeblock(tag,b_args) else let b_args = Array.map str_const args in (* spiwack: tries first to apply the run-time compilation @@ -418,7 +455,7 @@ let rec str_const c = f), b_args) with Not_found -> - Bconstruct_app(num, nparams, arity, b_args) + Bconstruct_app(tag, nparams, arity, b_args) end | _ -> Bconstr c end @@ -435,6 +472,7 @@ let rec str_const c = with Not_found -> let oib = lookup_mind kn !global_env in let oip = oib.mind_packets.(j) in + let () = check_compilable oip in let num,arity = oip.mind_reloc_tbl.(i-1) in let nparams = oib.mind_nparams in if Int.equal (nparams + arity) 0 then Bstrconst(Const_b0 num) @@ -489,9 +527,12 @@ let rec compile_fv reloc l sz cont = let rec get_allias env (kn,u as p) = let cb = lookup_constant kn env in let tps = cb.const_body_code in - (match Cemitcodes.force tps with - | BCallias (kn',u') -> get_allias env (kn', Univ.subst_instance_instance u u') - | _ -> p) + match tps with + | None -> p + | Some tps -> + (match Cemitcodes.force tps with + | BCallias (kn',u') -> get_allias env (kn', Univ.subst_instance_instance u u') + | _ -> p) (* Compiling expressions *) @@ -607,9 +648,14 @@ let rec compile_constr reloc c sz cont = let ind = ci.ci_ind in let mib = lookup_mind (fst ind) !global_env in let oib = mib.mind_packets.(snd ind) in + let () = check_compilable oib in let tbl = oib.mind_reloc_tbl in let lbl_consts = Array.make oib.mind_nb_constant Label.no in - let lbl_blocks = Array.make (oib.mind_nb_args+1) Label.no in + let nallblock = oib.mind_nb_args + 1 in (* +1 : accumulate *) + let nblock = min nallblock (last_variant_tag + 1) in + let lbl_blocks = Array.make nblock Label.no in + let neblock = max 0 (nallblock - last_variant_tag) in + let lbl_eblocks = Array.make neblock Label.no in let branch1,cont = make_branch cont in (* Compiling return type *) let lbl_typ,fcode = @@ -629,6 +675,15 @@ let rec compile_constr reloc c sz cont = in lbl_blocks.(0) <- lbl_accu; let c = ref code_accu in + (* perform the extra match if needed (to many block constructors) *) + if neblock <> 0 then begin + let lbl_b, code_b = + label_code ( + Kpush :: Kfield 0 :: Kswitch(lbl_eblocks, [||]) :: !c) in + lbl_blocks.(last_variant_tag) <- lbl_b; + c := code_b + end; + (* Compiling regular constructor branches *) for i = 0 to Array.length tbl - 1 do let tag, arity = tbl.(i) in @@ -640,22 +695,24 @@ let rec compile_constr reloc c sz cont = else let args, body = decompose_lam branchs.(i) in let nargs = List.length args in - let lbl_b,code_b = - label_code( - if Int.equal nargs arity then - Kpushfields arity :: + + let code_b = + if Int.equal nargs arity then compile_constr (push_param arity sz_b reloc) body (sz_b+arity) (add_pop arity (branch :: !c)) else let sz_appterm = if is_tailcall then sz_b + arity else arity in - Kpushfields arity :: compile_constr reloc branchs.(i) (sz_b+arity) - (Kappterm(arity,sz_appterm) :: !c)) - in - lbl_blocks.(tag) <- lbl_b; + (Kappterm(arity,sz_appterm) :: !c) in + let code_b = + if tag < last_variant_tag then Kpushfields arity :: code_b + else Kacc 0::Kpop 1::Kpushfields(arity+1)::Kpop 1::code_b in + let lbl_b,code_b = label_code code_b in + if tag < last_variant_tag then lbl_blocks.(tag) <- lbl_b + else lbl_eblocks.(tag - last_variant_tag) <- lbl_b; c := code_b done; - c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c; + c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c; let code_sw = match branch1 with (* spiwack : branch1 can't be a lbl anymore it's a Branch instead @@ -677,9 +734,10 @@ and compile_str_cst reloc sc sz cont = | Bstrconst sc -> Kconst sc :: cont | Bmakeblock(tag,args) -> let nargs = Array.length args in - comp_args compile_str_cst reloc args sz (Kmakeblock(nargs,tag) :: cont) + comp_args compile_str_cst reloc args sz (code_makeblock nargs tag cont) | Bconstruct_app(tag,nparams,arity,args) -> - if Int.equal (Array.length args) 0 then code_construct tag nparams arity cont + if Int.equal (Array.length args) 0 then + code_construct tag nparams arity cont else comp_app (fun _ _ _ cont -> code_construct tag nparams arity cont) @@ -706,13 +764,14 @@ and compile_const = Kgetglobal (get_allias !global_env (kn,u)) :: cont) compile_constr reloc () args sz cont -let compile env c = +let compile fail_on_error env c = set_global_env env; init_fun_code (); Label.reset_label_counter (); let reloc = empty_comp_env () in - let init_code = compile_constr reloc c 0 [Kstop] in - let fv = List.rev (!(reloc.in_env).fv_rev) in + try + let init_code = compile_constr reloc c 0 [Kstop] in + let fv = List.rev (!(reloc.in_env).fv_rev) in (* draw_instr init_code; draw_instr !fun_code; Format.print_string "fv = "; @@ -722,21 +781,26 @@ let compile env c = | FVrel i -> Format.print_string ((string_of_int i)^"; ")) fv; Format .print_string "\n"; Format.print_flush(); *) - init_code,!fun_code, Array.of_list fv - -let compile_constant_body env = function - | Undef _ | OpaqueDef _ -> BCconstant + Some (init_code,!fun_code, Array.of_list fv) + with TooLargeInductive tname -> + let fn = if fail_on_error then Errors.errorlabstrm "compile" else Pp.msg_warning in + (Pp.(fn + (str "Cannot compile code for virtual machine as it uses inductive " ++ + Id.print tname ++ str str_max_constructors)); + None) + +let compile_constant_body fail_on_error env = function + | Undef _ | OpaqueDef _ -> Some BCconstant | Def sb -> let body = Mod_subst.force_constr sb in match kind_of_term body with | Const (kn',u) -> (* we use the canonical name of the constant*) let con= constant_of_kn (canonical_con kn') in - BCallias (get_allias env (con,u)) + Some (BCallias (get_allias env (con,u))) | _ -> - let res = compile env body in - let to_patch = to_memory res in - BCdefined to_patch + let res = compile fail_on_error env body in + Option.map (fun x -> BCdefined (to_memory x)) res (* Shortcut of the previous function used during module strengthening *) diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index eab36d8b..1128f0d0 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -1,4 +1,3 @@ -open Names open Cbytecodes open Cemitcodes open Term @@ -6,10 +5,12 @@ open Declarations open Pre_env -val compile : env -> constr -> bytecodes * bytecodes * fv - (** init, fun, fv *) +val compile : bool -> (* Fail on error with a nice user message, otherwise simply a warning *) + env -> constr -> (bytecodes * bytecodes * fv) option +(** init, fun, fv *) -val compile_constant_body : env -> constant_def -> body_code +val compile_constant_body : bool -> + env -> constant_def -> body_code option (** Shortcut of the previous function used during module strengthening *) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 3c9692a5..2535a64d 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -10,7 +10,6 @@ machine, Oct 2004 *) (* Extension: Arnaud Spiwack (support for native arithmetic), May 2005 *) -open Names open Term open Cbytecodes open Copcodes @@ -24,34 +23,22 @@ type reloc_info = type patch = reloc_info * int +let patch_char4 buff pos c1 c2 c3 c4 = + String.unsafe_set buff pos c1; + String.unsafe_set buff (pos + 1) c2; + String.unsafe_set buff (pos + 2) c3; + String.unsafe_set buff (pos + 3) c4 + let patch_int buff pos n = - String.unsafe_set buff pos (Char.unsafe_chr n); - String.unsafe_set buff (pos + 1) (Char.unsafe_chr (n asr 8)); - String.unsafe_set buff (pos + 2) (Char.unsafe_chr (n asr 16)); - String.unsafe_set buff (pos + 3) (Char.unsafe_chr (n asr 24)) - + patch_char4 buff pos + (Char.unsafe_chr n) (Char.unsafe_chr (n asr 8)) (Char.unsafe_chr (n asr 16)) + (Char.unsafe_chr (n asr 24)) (* Buffering of bytecode *) let out_buffer = ref(String.create 1024) and out_position = ref 0 -(* -let out_word b1 b2 b3 b4 = - let p = !out_position in - if p >= String.length !out_buffer then begin - let len = String.length !out_buffer in - let new_buffer = String.create (2 * len) in - String.blit !out_buffer 0 new_buffer 0 len; - out_buffer := new_buffer - end; - String.unsafe_set !out_buffer p (Char.unsafe_chr b1); - String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2); - String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3); - String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4); - out_position := p + 4 -*) - let out_word b1 b2 b3 b4 = let p = !out_position in if p >= String.length !out_buffer then begin @@ -67,13 +54,10 @@ let out_word b1 b2 b3 b4 = String.blit !out_buffer 0 new_buffer 0 len; out_buffer := new_buffer end; - String.unsafe_set !out_buffer p (Char.unsafe_chr b1); - String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2); - String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3); - String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4); + patch_char4 !out_buffer p (Char.unsafe_chr b1) + (Char.unsafe_chr b2) (Char.unsafe_chr b3) (Char.unsafe_chr b4); out_position := p + 4 - let out opcode = out_word opcode 0 0 0 @@ -102,7 +86,7 @@ let extend_label_table needed = let backpatch (pos, orig) = let displ = (!out_position - orig) asr 2 in - !out_buffer.[pos] <- Char.unsafe_chr displ; + !out_buffer.[pos] <- Char.unsafe_chr displ; !out_buffer.[pos+1] <- Char.unsafe_chr (displ asr 8); !out_buffer.[pos+2] <- Char.unsafe_chr (displ asr 16); !out_buffer.[pos+3] <- Char.unsafe_chr (displ asr 24) @@ -223,8 +207,12 @@ let emit_instr = function out_label typlbl; out_label swlbl; slot_for_annot annot;out_int sz | Kswitch (tbl_const, tbl_block) -> + let lenb = Array.length tbl_block in + let lenc = Array.length tbl_const in + assert (lenb < 0x100 && lenc < 0x1000000); out opSWITCH; - out_int (Array.length tbl_const + (Array.length tbl_block lsl 16)); + out_word lenc (lenc asr 8) (lenc asr 16) (lenb); +(* out_int (Array.length tbl_const + (Array.length tbl_block lsl 23)); *) let org = !out_position in Array.iter (out_label_with_orig org) tbl_const; Array.iter (out_label_with_orig org) tbl_block @@ -334,25 +322,41 @@ let subst_patch s (ri,pos) = let subst_to_patch s (code,pl,fv) = code,List.rev_map (subst_patch s) pl,fv +let subst_pconstant s (kn, u) = (fst (subst_con_kn s kn), u) + type body_code = | BCdefined of to_patch | BCallias of pconstant | BCconstant -let subst_body_code s = function - | BCdefined tp -> BCdefined (subst_to_patch s tp) - | BCallias (kn,u) -> BCallias (fst (subst_con_kn s kn), u) - | BCconstant -> BCconstant - -type to_patch_substituted = body_code substituted - -let from_val = from_val - -let force = force subst_body_code - -let subst_to_patch_subst = subst_substituted - -let repr_body_code = repr_substituted +type to_patch_substituted = +| PBCdefined of to_patch substituted +| PBCallias of pconstant substituted +| PBCconstant + +let from_val = function +| BCdefined tp -> PBCdefined (from_val tp) +| BCallias cu -> PBCallias (from_val cu) +| BCconstant -> PBCconstant + +let force = function +| PBCdefined tp -> BCdefined (force subst_to_patch tp) +| PBCallias cu -> BCallias (force subst_pconstant cu) +| PBCconstant -> BCconstant + +let subst_to_patch_subst s = function +| PBCdefined tp -> PBCdefined (subst_substituted s tp) +| PBCallias cu -> PBCallias (subst_substituted s cu) +| PBCconstant -> PBCconstant + +let repr_body_code = function +| PBCdefined tp -> + let (s, tp) = repr_substituted tp in + (s, BCdefined tp) +| PBCallias cu -> + let (s, cu) = repr_substituted cu in + (s, BCallias cu) +| PBCconstant -> (None, BCconstant) let to_memory (init_code, fun_code, fv) = init(); diff --git a/kernel/closure.ml b/kernel/closure.ml index f06b13d8..ea9b2755 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -771,24 +771,6 @@ let drop_parameters depth n argstk = (* we know that n < stack_args_size(argstk) (if well-typed term) *) anomaly (Pp.str "ill-typed term: found a match on a partially applied constructor") - -let rec get_parameters depth n argstk = - match argstk with - Zapp args::s -> - let q = Array.length args in - if n > q then Array.append args (get_parameters depth (n-q) s) - else if Int.equal n q then [||] - else Array.sub args 0 n - | Zshift(k)::s -> - get_parameters (depth-k) n s - | [] -> (* we know that n < stack_args_size(argstk) (if well-typed term) *) - if Int.equal n 0 then [||] - else raise Not_found (* Trying to eta-expand a partial application..., should do - eta expansion first? *) - | _ -> assert false - (* strip_update_shift_app only produces Zapp and Zshift items *) - - (** [eta_expand_ind_stack env ind c s t] computes stacks correspoding to the conversion of the eta expansion of t, considered as an inhabitant of ind, and the Constructor c of this inductive type applied to arguments @@ -942,7 +924,7 @@ let rec knr info m stk = | (_,args,s) -> (m,args@s)) | FCoFix _ when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with - (_, args, (((Zcase _|ZcaseT _)::_) as stk')) -> + (_, args, (((Zcase _|ZcaseT _|Zproj _)::_) as stk')) -> let (fxe,fxbd) = contract_fix_vect m.term in knit info fxe fxbd (args@stk') | (_,args,s) -> (m,args@s)) diff --git a/kernel/constr.ml b/kernel/constr.ml index 49f74841..e823c01b 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -464,55 +464,22 @@ let map_with_binders g f l c0 = match kind c0 with let bl' = CArray.Fun1.smartmap f l' bl in mkCoFix (ln,(lna,tl',bl')) -(* [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to compare - the immediate subterms of [c1] of [c2] if needed, [u] to compare universe - instances and [s] to compare sorts; Cast's, +(* [compare_head_gen_evar k1 k2 u s e eq leq c1 c2] compare [c1] and + [c2] (using [k1] to expose the structure of [c1] and [k2] to expose + the structure [c2]) using [eq] to compare the immediate subterms of + [c1] of [c2] for conversion if needed, [leq] for cumulativity, [u] + to compare universe instances, and [s] to compare sorts; Cast's, application associativity, binders name and Cases annotations are - not taken into account *) + not taken into account. Note that as [kind1] and [kind2] are + potentially different, we cannot use, in recursive case, the + optimisation that physically equal arrays are equals (hence the + calls to {!Array.equal_norefl}). *) -let compare_head_gen eq_universes eq_sorts f t1 t2 = - match kind t1, kind t2 with +let compare_head_gen_with kind1 kind2 eq_universes leq_sorts eq leq t1 t2 = + match kind1 t1, kind2 t2 with | Rel n1, Rel n2 -> Int.equal n1 n2 | Meta m1, Meta m2 -> Int.equal m1 m2 | Var id1, Var id2 -> Id.equal id1 id2 - | Sort s1, Sort s2 -> eq_sorts s1 s2 - | Cast (c1,_,_), _ -> f c1 t2 - | _, Cast (c2,_,_) -> f t1 c2 - | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 && f c1 c2 - | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 && f c1 c2 - | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 && f t1 t2 && f c1 c2 - | App (Cast(c1, _, _),l1), _ -> f (mkApp (c1,l1)) t2 - | _, App (Cast (c2, _, _),l2) -> f t1 (mkApp (c2,l2)) - | App (c1,l1), App (c2,l2) -> - Int.equal (Array.length l1) (Array.length l2) && - f c1 c2 && Array.equal f l1 l2 - | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal f l1 l2 - | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && f c1 c2 - | Const (c1,u1), Const (c2,u2) -> eq_constant c1 c2 && eq_universes true u1 u2 - | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && eq_universes false u1 u2 - | Construct (c1,u1), Construct (c2,u2) -> eq_constructor c1 c2 && eq_universes false u1 u2 - | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> - f p1 p2 && f c1 c2 && Array.equal f bl1 bl2 - | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> - Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 - && Array.equal f tl1 tl2 && Array.equal f bl1 bl2 - | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> - Int.equal ln1 ln2 && Array.equal f tl1 tl2 && Array.equal f bl1 bl2 - | _ -> false - -let compare_head = compare_head_gen (fun _ -> Univ.Instance.equal) Sorts.equal - -(* [compare_head_gen_leq u s sl eq leq c1 c2] compare [c1] and [c2] using [eq] to compare - the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, - [u] to compare universe instances and [s] to compare sorts; Cast's, - application associativity, binders name and Cases annotations are - not taken into account *) - -let compare_head_gen_leq eq_universes eq_sorts leq_sorts eq leq t1 t2 = - match kind t1, kind t2 with - | Rel n1, Rel n2 -> Int.equal n1 n2 - | Meta m1, Meta m2 -> Int.equal m1 m2 - | Var id1, Var id2 -> Int.equal (id_ord id1 id2) 0 | Sort s1, Sort s2 -> leq_sorts s1 s2 | Cast (c1,_,_), _ -> leq c1 t2 | _, Cast (c2,_,_) -> leq t1 c2 @@ -522,8 +489,8 @@ let compare_head_gen_leq eq_universes eq_sorts leq_sorts eq leq t1 t2 = | App (Cast(c1, _, _),l1), _ -> leq (mkApp (c1,l1)) t2 | _, App (Cast (c2, _, _),l2) -> leq t1 (mkApp (c2,l2)) | App (c1,l1), App (c2,l2) -> - Int.equal (Array.length l1) (Array.length l2) && - eq c1 c2 && Array.equal eq l1 l2 + Int.equal (Array.length l1) (Array.length l2) && + eq c1 c2 && Array.equal_norefl eq l1 l2 | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && eq c1 c2 | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal eq l1 l2 | Const (c1,u1), Const (c2,u2) -> eq_constant c1 c2 && eq_universes true u1 u2 @@ -533,11 +500,31 @@ let compare_head_gen_leq eq_universes eq_sorts leq_sorts eq leq t1 t2 = eq p1 p2 && eq c1 c2 && Array.equal eq bl1 bl2 | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 - && Array.equal eq tl1 tl2 && Array.equal eq bl1 bl2 + && Array.equal_norefl eq tl1 tl2 && Array.equal_norefl eq bl1 bl2 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> - Int.equal ln1 ln2 && Array.equal eq tl1 tl2 && Array.equal eq bl1 bl2 + Int.equal ln1 ln2 && Array.equal_norefl eq tl1 tl2 && Array.equal_norefl eq bl1 bl2 | _ -> false +(* [compare_head_gen_leq u s eq leq c1 c2] compare [c1] and [c2] using [eq] to compare + the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, + [u] to compare universe instances and [s] to compare sorts; Cast's, + application associativity, binders name and Cases annotations are + not taken into account *) + +let compare_head_gen_leq eq_universes leq_sorts eq leq t1 t2 = + compare_head_gen_with kind kind eq_universes leq_sorts eq leq t1 t2 + +(* [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to compare + the immediate subterms of [c1] of [c2] if needed, [u] to compare universe + instances and [s] to compare sorts; Cast's, + application associativity, binders name and Cases annotations are + not taken into account *) + +let compare_head_gen eq_universes eq_sorts eq t1 t2 = + compare_head_gen_leq eq_universes eq_sorts eq eq t1 t2 + +let compare_head = compare_head_gen (fun _ -> Univ.Instance.equal) Sorts.equal + (*******************************) (* alpha conversion functions *) (*******************************) @@ -549,6 +536,14 @@ let rec eq_constr m n = let equal m n = eq_constr m n (* to avoid tracing a recursive fun *) +let rec equal_with kind1 kind2 m n = + (* note that pointer equality is not sufficient to ensure equality + up to [eq_evars], because we may evaluates evars of [m] and [n] + in different evar contexts. *) + let req_constr m n = equal_with kind1 kind2 m n in + compare_head_gen_with kind1 kind2 + (fun _ -> Instance.equal) Sorts.equal req_constr req_constr m n + let eq_constr_univs univs m n = if m == n then true else @@ -570,7 +565,7 @@ let leq_constr_univs univs m n = m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n in let rec compare_leq m n = - compare_head_gen_leq eq_universes eq_sorts leq_sorts eq_constr' leq_constr' m n + compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n and leq_constr' m n = m == n || compare_leq m n in compare_leq m n @@ -620,7 +615,7 @@ let leq_constr_univs_infer univs m n = m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n in let rec compare_leq m n = - compare_head_gen_leq eq_universes eq_sorts leq_sorts eq_constr' leq_constr' m n + compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n and leq_constr' m n = m == n || compare_leq m n in let res = compare_leq m n in res, !cstrs diff --git a/kernel/constr.mli b/kernel/constr.mli index 5d11511b..67d1aded 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -203,6 +203,14 @@ val kind : constr -> (constr, types) kind_of_term and application grouping *) val equal : constr -> constr -> bool +(** [equal_with_evars k1 k2 a b] is true when [a] equals [b] modulo + alpha, casts, application grouping, and using [k1] to expose the + head of [a] and [k2] to expose the head of [b]. *) +val equal_with : + (constr -> (constr,types) kind_of_term) -> + (constr -> (constr,types) kind_of_term) -> + constr -> constr -> bool + (** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts, application grouping and the universe equalities in [u]. *) val eq_constr_univs : constr Univ.check_function @@ -285,16 +293,15 @@ val compare_head_gen : (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) -> (constr -> constr -> bool) -> constr -> constr -> bool -(** [compare_head_gen_leq u s sle f fle c1 c2] compare [c1] and [c2] - using [f] to compare the immediate subterms of [c1] of [c2] for +(** [compare_head_gen_leq u s f fle c1 c2] compare [c1] and [c2] using + [f] to compare the immediate subterms of [c1] of [c2] for conversion, [fle] for cumulativity, [u] to compare universe instances (the first boolean tells if they belong to a constant), - [s] to compare sorts for equality and [sle] for subtyping; Cast's, - binders name and Cases annotations are not taken into account *) + [s] to compare sorts for for subtyping; Cast's, binders name and + Cases annotations are not taken into account *) val compare_head_gen_leq : (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) -> (Sorts.t -> Sorts.t -> bool) -> - (Sorts.t -> Sorts.t -> bool) -> (constr -> constr -> bool) -> (constr -> constr -> bool) -> constr -> constr -> bool diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index ed8b0a6d..b29f06c6 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -148,14 +148,17 @@ let rec slot_for_getglobal env (kn,u) = with NotEvaluated -> (* Pp.msgnl(str"not yet evaluated");*) let pos = - match Cemitcodes.force cb.const_body_code with - | BCdefined(code,pl,fv) -> - if Univ.Instance.is_empty u then - let v = eval_to_patch env (code,pl,fv) in - set_global v - else set_global (val_of_constant (kn,u)) - | BCallias kn' -> slot_for_getglobal env kn' - | BCconstant -> set_global (val_of_constant (kn,u)) in + match cb.const_body_code with + | None -> set_global (val_of_constant (kn,u)) + | Some code -> + match Cemitcodes.force code with + | BCdefined(code,pl,fv) -> + if Univ.Instance.is_empty u then + let v = eval_to_patch env (code,pl,fv) in + set_global v + else set_global (val_of_constant (kn,u)) + | BCallias kn' -> slot_for_getglobal env kn' + | BCconstant -> set_global (val_of_constant (kn,u)) in (*Pp.msgnl(str"value stored at: "++int pos);*) rk := Some (Ephemeron.create pos); pos @@ -210,7 +213,9 @@ and eval_to_patch env (buff,pl,fv) = and val_of_constr env c = let (_,fun_code,_ as ccfv) = - try compile env c + try match compile true env c with + | Some v -> v + | None -> assert false with reraise -> let reraise = Errors.push reraise in let () = print_string "can not compile \n" in diff --git a/kernel/declarations.mli b/kernel/declarations.mli index bec52122..27c1c3f3 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -70,7 +70,7 @@ type constant_body = { const_hyps : Context.section_context; (** New: younger hyp at top *) const_body : constant_def; const_type : constant_type; - const_body_code : Cemitcodes.to_patch_substituted; + const_body_code : Cemitcodes.to_patch_substituted option; const_polymorphic : bool; (** Is it polymorphic or not *) const_universes : constant_universes; const_proj : projection_body option; @@ -139,7 +139,7 @@ type one_inductive_body = { mind_kelim : sorts_family list; (** List of allowed elimination sorts *) - mind_nf_lc : types array; (** Head normalized constructor types so that their conclusion is atomic *) + mind_nf_lc : types array; (** Head normalized constructor types so that their conclusion exposes the inductive type *) mind_consnrealargs : int array; (** Number of expected proper arguments of the constructors (w/o params) @@ -172,7 +172,7 @@ type mutual_inductive_body = { mind_hyps : Context.section_context; (** Section hypotheses on which the block depends *) - mind_nparams : int; (** Number of expected parameters *) + mind_nparams : int; (** Number of expected parameters including non-uniform ones (i.e. length of mind_params_ctxt w/o let-in) *) mind_nparams_rec : int; (** Number of recursively uniform (i.e. ordinary) parameters *) @@ -202,7 +202,7 @@ type ('ty,'a) functorize = type with_declaration = | WithMod of Id.t list * module_path - | WithDef of Id.t list * constr + | WithDef of Id.t list * constr Univ.in_universe_context type module_alg_expr = | MEident of module_path diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 48a6098e..a7051d5c 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -129,7 +129,7 @@ let subst_const_body sub cb = const_type = type'; const_proj = proj'; const_body_code = - Cemitcodes.subst_to_patch_subst sub cb.const_body_code; + Option.map (Cemitcodes.subst_to_patch_subst sub) cb.const_body_code; const_polymorphic = cb.const_polymorphic; const_universes = cb.const_universes; const_inline_code = cb.const_inline_code } diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 47a82cc6..ce65af97 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -9,7 +9,6 @@ open Declarations open Mod_subst open Univ -open Context (** Operations concerning types in [Declarations] : [constant_body], [mutual_inductive_body], [module_body] ... *) diff --git a/kernel/environ.ml b/kernel/environ.ml index 0ebff440..a79abbb7 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -473,7 +473,7 @@ type unsafe_type_judgment = { (*s Compilation of global declaration *) -let compile_constant_body = Cbytegen.compile_constant_body +let compile_constant_body = Cbytegen.compile_constant_body false exception Hyp_not_found diff --git a/kernel/environ.mli b/kernel/environ.mli index de960ecc..ede356e6 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -253,7 +253,7 @@ type unsafe_type_judgment = { (** {6 Compilation of global declaration } *) -val compile_constant_body : env -> constant_def -> Cemitcodes.body_code +val compile_constant_body : env -> constant_def -> Cemitcodes.body_code option exception Hyp_not_found diff --git a/kernel/fast_typeops.mli b/kernel/fast_typeops.mli index 4c2c92cc..90d9c55f 100644 --- a/kernel/fast_typeops.mli +++ b/kernel/fast_typeops.mli @@ -6,13 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Names -open Univ open Term -open Context open Environ -open Entries -open Declarations (** {6 Typing functions (not yet tagged as safe) } diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 99d9f52c..6b909824 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -164,10 +164,12 @@ let infer_constructor_packet env_ar_par ctx params lc = (* If indices matter *) let cumulate_arity_large_levels env sign = fst (List.fold_right - (fun (_,_,t as d) (lev,env) -> - let tj = infer_type env t in - let u = univ_of_sort tj.utj_type in - (Universe.sup u lev, push_rel d env)) + (fun (_,b,t as d) (lev,env) -> + if Option.is_empty b then + let tj = infer_type env t in + let u = univ_of_sort tj.utj_type in + (Universe.sup u lev, push_rel d env) + else lev, push_rel d env) sign (Universe.type0m,env)) let is_impredicative env u = @@ -344,7 +346,7 @@ let typecheck_inductive env mie = in (id,cn,lc,(sign,arity))) inds - in (env_arities, params, inds) + in (env_arities, env_ar_par, params, inds) (************************************************************************) (************************************************************************) @@ -364,9 +366,8 @@ exception IllFormedInd of ill_formed_ind let mind_extract_params = decompose_prod_n_assum -let explain_ind_err id ntyp env0 nbpar c nargs err = +let explain_ind_err id ntyp env nbpar c nargs err = let (lpar,c') = mind_extract_params nbpar c in - let env = push_rel_context lpar env0 in match err with | LocalNonPos kt -> raise (InductiveError (NonPos (env,c',mkRel (kt+nbpar)))) @@ -484,6 +485,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d) | Rel k -> (try let (ra,rarg) = List.nth ra_env (k-1) in + let largs = List.map (whd_betadeltaiota env) largs in let nmr1 = (match ra with Mrec _ -> compute_rec_par ienv hyps nmr largs @@ -654,7 +656,6 @@ let used_section_variables env inds = keep_hyps env ids let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) -let rel_appvect n m = rel_vect n (List.length m) exception UndefinableExpansion @@ -821,9 +822,9 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re let check_inductive env kn mie = (* First type-check the inductive definition *) - let (env_ar, params, inds) = typecheck_inductive env mie in + let (env_ar, env_ar_par, params, inds) = typecheck_inductive env mie in (* Then check positivity conditions *) - let (nmr,recargs) = check_positivity kn env_ar params inds in + let (nmr,recargs) = check_positivity kn env_ar_par params inds in (* Build the inductive packets *) build_inductive env mie.mind_entry_polymorphic mie.mind_entry_private mie.mind_entry_universes diff --git a/kernel/inductive.ml b/kernel/inductive.ml index bb57ad25..ca814f49 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -364,7 +364,7 @@ let build_branches_type (ind,u) (_,mip as specif) params p = let cstr = ith_constructor_of_inductive ind (i+1) in let dep_cstr = applist (mkConstructU (cstr,u),lparams@(local_rels args)) in vargs @ [dep_cstr] in - let base = beta_appvect (lift nargs p) (Array.of_list cargs) in + let base = betazeta_appvect mip.mind_nrealdecls (lift nargs p) (Array.of_list cargs) in it_mkProd_or_LetIn base args in Array.mapi build_one_branch mip.mind_nf_lc @@ -447,13 +447,6 @@ type subterm_spec = let eq_wf_paths = Rtree.equal Declareops.eq_recarg -let pp_recarg = function - | Norec -> Pp.str "Norec" - | Mrec i -> Pp.str ("Mrec "^MutInd.to_string (fst i)) - | Imbr i -> Pp.str ("Imbr "^MutInd.to_string (fst i)) - -let pp_wf_paths = Rtree.pp_tree pp_recarg - let inter_recarg r1 r2 = match r1, r2 with | Norec, Norec -> Some r1 | Mrec i1, Mrec i2 diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 97c1d1fd..26dd45f5 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -54,7 +54,7 @@ let rec rebuild_mp mp l = let (+++) = Univ.Constraint.union -let rec check_with_def env struc (idl,c) mp equiv = +let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let lab,idl = match idl with | [] -> assert false | id::idl -> Label.of_id id, idl @@ -74,30 +74,33 @@ let rec check_with_def env struc (idl,c) mp equiv = as long as they have the right type *) let ccst = Declareops.constraints_of_constant (opaque_tables env) cb in let env' = Environ.add_constraints ccst env' in + let newus, cst = Univ.UContext.dest ctx in + let env' = Environ.add_constraints cst env' in let c',cst = match cb.const_body with | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in let typ = Typeops.type_of_constant_type env' cb.const_type in - let cst = Reduction.infer_conv_leq env' (Environ.universes env') + let cst' = Reduction.infer_conv_leq env' (Environ.universes env') j.uj_type typ in - j.uj_val,cst + j.uj_val,cst' +++ cst | Def cs -> - let cst = Reduction.infer_conv env' (Environ.universes env') c + let cst' = Reduction.infer_conv env' (Environ.universes env') c (Mod_subst.force_constr cs) in let cst = (*FIXME MS: what to check here? subtyping of polymorphic constants... *) - if cb.const_polymorphic then cst - else ccst +++ cst + if cb.const_polymorphic then cst' +++ cst + else cst' +++ cst in c, cst in let def = Def (Mod_subst.from_val c') in + let ctx' = Univ.UContext.make (newus, cst) in let cb' = { cb with const_body = def; - const_body_code = Cemitcodes.from_val (compile_constant_body env' def) } - (* const_universes = Future.from_val cst } *) + const_body_code = Option.map Cemitcodes.from_val (compile_constant_body env' def); + const_universes = ctx' } in - before@(lab,SFBconst(cb'))::after, c', cst + before@(lab,SFBconst(cb'))::after, c', ctx' else (* Definition inside a sub-module *) let mb = match spec with @@ -108,7 +111,7 @@ let rec check_with_def env struc (idl,c) mp equiv = | Abstract -> let struc = Modops.destr_nofunctor mb.mod_type in let struc',c',cst = - check_with_def env' struc (idl,c) (MPdot(mp,lab)) mb.mod_delta + check_with_def env' struc (idl,(c,ctx)) (MPdot(mp,lab)) mb.mod_delta in let mb' = { mb with mod_type = NoFunctor struc'; @@ -204,8 +207,8 @@ let check_with env mp (sign,alg,reso,cst) = function |WithDef(idl,c) -> let struc = destr_nofunctor sign in let struc',c',cst' = check_with_def env struc (idl,c) mp reso in - let alg' = mk_alg_with alg (WithDef (idl,c')) in - (NoFunctor struc'),alg',reso, cst+++cst' + let alg' = mk_alg_with alg (WithDef (idl,(c',cst'))) in + (NoFunctor struc'),alg',reso, cst+++(Univ.UContext.constraints cst') |WithMod(idl,mp1) as wd -> let struc = destr_nofunctor sign in let struc',reso',cst' = check_with_mod env struc (idl,mp1) mp reso in diff --git a/kernel/modops.ml b/kernel/modops.ml index 392e667b..d52fe611 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -177,9 +177,9 @@ let subst_with_body sub = function |WithMod(id,mp) as orig -> let mp' = subst_mp sub mp in if mp==mp' then orig else WithMod(id,mp') - |WithDef(id,c) as orig -> + |WithDef(id,(c,ctx)) as orig -> let c' = subst_mps sub c in - if c==c' then orig else WithDef(id,c') + if c==c' then orig else WithDef(id,(c',ctx)) let rec subst_structure sub do_delta sign = let subst_body ((l,body) as orig) = match body with @@ -337,7 +337,7 @@ let strengthen_const mp_from l cb resolver = in { cb with const_body = Def (Mod_subst.from_val (mkConstU (con,u))); - const_body_code = Cemitcodes.from_val (Cbytegen.compile_alias (con,u)) } + const_body_code = Some (Cemitcodes.from_val (Cbytegen.compile_alias (con,u))) } let rec strengthen_mod mp_from mp_to mb = if mp_in_delta mb.mod_mp mb.mod_delta then mb @@ -428,16 +428,20 @@ let rec strengthen_and_subst_mod mb subst mp_from mp_to = and strengthen_and_subst_struct str subst mp_from mp_to alias incl reso = match str with | [] -> empty_delta_resolver,[] - | (l,SFBconst cb) :: rest -> + | (l,SFBconst cb) as item :: rest -> let cb' = subst_const_body subst cb in - let cb'' = + let cb' = if alias then cb' else strengthen_const mp_from l cb' reso in - let item' = l, SFBconst cb'' in + let item' = if cb' == cb then item else (l, SFBconst cb') in let reso',rest' = strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in + let str' = + if rest' == rest && item' == item then str + else item' :: rest' + in if incl then (* If we are performing an inclusion we need to add the fact that the constant mp_to.l is \Delta-equivalent @@ -445,26 +449,31 @@ and strengthen_and_subst_struct str subst mp_from mp_to alias incl reso = let kn_from = KerName.make2 mp_from l in let kn_to = KerName.make2 mp_to l in let old_name = kn_of_delta reso kn_from in - add_kn_delta_resolver kn_to old_name reso', item'::rest' + add_kn_delta_resolver kn_to old_name reso', str' else (* In this case the fact that the constant mp_to.l is \Delta-equivalent to resolver(mp_from.l) is already known because reso' contains mp_to maps to reso(mp_from) *) - reso', item'::rest' - | (l,SFBmind mib) :: rest -> - let item' = l,SFBmind (subst_mind_body subst mib) in + reso', str' + | (l,SFBmind mib) as item :: rest -> + let mib' = subst_mind_body subst mib in + let item' = if mib' == mib then item else (l, SFBmind mib') in let reso',rest' = strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in + let str' = + if rest' == rest && item' == item then str + else item' :: rest' + in (* Same as constant *) if incl then let kn_from = KerName.make2 mp_from l in let kn_to = KerName.make2 mp_to l in let old_name = kn_of_delta reso kn_from in - add_kn_delta_resolver kn_to old_name reso', item'::rest' + add_kn_delta_resolver kn_to old_name reso', str' else - reso', item'::rest' - | (l,SFBmodule mb) :: rest -> + reso', str' + | (l,SFBmodule mb) as item :: rest -> let mp_from' = MPdot (mp_from,l) in let mp_to' = MPdot (mp_to,l) in let mb' = if alias then @@ -472,31 +481,39 @@ and strengthen_and_subst_struct str subst mp_from mp_to alias incl reso = else strengthen_and_subst_mod mb subst mp_from' mp_to' in - let item' = l,SFBmodule mb' in + let item' = if mb' == mb then item else (l, SFBmodule mb') in let reso',rest' = strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in + let str' = + if rest' == rest && item' == item then str + else item' :: rest' + in (* if mb is a functor we should not derive new equivalences on names, hence we add the fact that the functor can only be equivalent to itself. If we adopt an applicative semantic for functor this should be changed.*) if is_functor mb'.mod_type then - add_mp_delta_resolver mp_to' mp_to' reso', item':: rest' + add_mp_delta_resolver mp_to' mp_to' reso', str' else - add_delta_resolver reso' mb'.mod_delta, item':: rest' - | (l,SFBmodtype mty) :: rest -> + add_delta_resolver reso' mb'.mod_delta, str' + | (l,SFBmodtype mty) as item :: rest -> let mp_from' = MPdot (mp_from,l) in let mp_to' = MPdot(mp_to,l) in let subst' = add_mp mp_from' mp_to' empty_delta_resolver subst in - let mty = subst_modtype subst' + let mty' = subst_modtype subst' (fun resolver _ -> subst_dom_codom_delta_resolver subst' resolver) mty in - let item' = l,SFBmodtype mty in + let item' = if mty' == mty then item else (l, SFBmodtype mty') in let reso',rest' = strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in - add_mp_delta_resolver mp_to' mp_to' reso', item'::rest' + let str' = + if rest' == rest && item' == item then str + else item' :: rest' + in + add_mp_delta_resolver mp_to' mp_to' reso', str' (** Let P be a module path when we write: diff --git a/kernel/names.ml b/kernel/names.ml index b349ccb0..480b37e8 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -33,9 +33,9 @@ struct let hash = String.hash - let check_soft x = + let check_soft ?(warn = true) x = let iter (fatal, x) = - if fatal then Errors.error x else Pp.msg_warning (str x) + if fatal then Errors.error x else if warn then Pp.msg_warning (str x) in Option.iter iter (Unicode.ident_refutation x) @@ -48,6 +48,11 @@ struct let s = String.copy s in String.hcons s + let of_string_soft s = + let () = check_soft ~warn:false s in + let s = String.copy s in + String.hcons s + let to_string id = String.copy id let print id = str id @@ -571,7 +576,6 @@ let constr_modpath (ind,_) = ind_modpath ind let ith_mutual_inductive (mind, _) i = (mind, i) let ith_constructor_of_inductive ind i = (ind, i) -let ith_constructor_of_pinductive (ind,u) i = ((ind,i),u) let inductive_of_constructor (ind, i) = ind let index_of_constructor (ind, i) = i diff --git a/kernel/names.mli b/kernel/names.mli index d82043da..92ee58f2 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -29,7 +29,11 @@ sig val of_string : string -> t (** Converts a string into an identifier. May raise [UserError _] if the - string is not valid. *) + string is not valid, or echo a warning if it contains invalid identifier + characters. *) + + val of_string_soft : string -> t + (** Same as {!of_string} except that no warning is ever issued. *) val to_string : t -> string (** Converts a identifier into an string. *) diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 1a4a4b54..ada7ae73 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -12,7 +12,6 @@ open Context open Declarations open Util open Nativevalues -open Primitives open Nativeinstr open Nativelambda open Pre_env diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 543397df..383f8102 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -375,9 +375,12 @@ let makeblock env cn u tag args = let rec get_allias env (kn, u as p) = let tps = (lookup_constant kn env).const_body_code in - match Cemitcodes.force tps with - | Cemitcodes.BCallias kn' -> get_allias env kn' - | _ -> p + match tps with + | None -> p + | Some tps -> + match Cemitcodes.force tps with + | Cemitcodes.BCallias kn' -> get_allias env kn' + | _ -> p (*i Global environment *) diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index 6a97edc4..ccf2888b 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -8,7 +8,6 @@ open Names open Term open Pre_env -open Nativevalues open Nativeinstr (** This file defines the lambda code generation phase of the native compiler *) diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index dd47bc06..605c1225 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -77,7 +77,10 @@ let call_compiler ml_filename = ::include_dirs @ ["-impl"; ml_filename] in if !Flags.debug then Pp.msg_debug (Pp.str (compiler_name ^ " " ^ (String.concat " " args))); - CUnix.sys_command compiler_name args = Unix.WEXITED 0, link_filename + try CUnix.sys_command compiler_name args = Unix.WEXITED 0, link_filename + with Unix.Unix_error (e,_,_) -> + Pp.(msg_warning (str (Unix.error_message e))); + false, link_filename let compile fn code = write_ml_code fn code; diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml index 914f577e..0b8662ff 100644 --- a/kernel/nativelibrary.ml +++ b/kernel/nativelibrary.ml @@ -12,7 +12,6 @@ open Environ open Mod_subst open Modops open Nativecode -open Nativelib (** This file implements separate compilation for libraries in the native compiler *) diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index d7a21950..e4a77999 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -370,6 +370,11 @@ type coq_pair = | Paccu of t | PPair of t * t +type coq_zn2z = + | Zaccu of t + | ZW0 + | ZWW of t * t + let mkCarry b i = if b then (Obj.magic (C1(of_uint i)):t) else (Obj.magic (C0(of_uint i)):t) @@ -413,8 +418,13 @@ let subcarryc accu x y = let of_pair (x, y) = (Obj.magic (PPair(of_uint x, of_uint y)):t) +let zn2z_of_pair (x,y) = + if Uint31.equal x (Uint31.of_uint 0) && + Uint31.equal y (Uint31.of_uint 0) then Obj.magic ZW0 + else (Obj.magic (ZWW(of_uint x, of_uint y)) : t) + let no_check_mulc x y = - of_pair(Uint31.mulc (to_uint x) (to_uint y)) + zn2z_of_pair(Uint31.mulc (to_uint x) (to_uint y)) let mulc accu x y = if is_int x && is_int y then no_check_mulc x y diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 87cebd62..0609c851 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -9,7 +9,6 @@ open Names open Term open Mod_subst -open Int (** This module implements the handling of opaque proof terms. Opauqe proof terms are special since: diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 4153b323..b09367dd 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -28,14 +28,6 @@ open Esubst let left2right = ref false -let conv_key k = - match k with - VarKey id -> - VarKey id - | ConstKey (cst,_) -> - ConstKey cst - | RelKey n -> RelKey n - let rec is_empty_stack = function [] -> true | Zupdate _::s -> is_empty_stack s diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 20cecc84..d762a246 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -379,7 +379,9 @@ let globalize_constant_universes env cb = | None -> [] | Some fc -> match Future.peek_val fc with - | None -> [Later (Future.chain ~pure:true fc Univ.ContextSet.constraints)] + | None -> [Later (Future.chain + ~greedy:(not (Future.is_exn fc)) + ~pure:true fc Univ.ContextSet.constraints)] | Some c -> [Now (Univ.ContextSet.constraints c)]) let globalize_mind_universes mb = @@ -821,7 +823,7 @@ let retroknowledge f senv = let register field value by_clause senv = (* todo : value closed, by_clause safe, by_clause of the proper type*) (* spiwack : updates the safe_env with the information that the register - action has to be performed (again) when the environement is imported *) + action has to be performed (again) when the environment is imported *) { senv with env = Environ.register senv.env field value; local_retroknowledge = diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index a3441aa3..a316b449 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -15,7 +15,6 @@ open Errors open Util open Names -open Univ open Term open Context open Declarations @@ -101,10 +100,6 @@ let hcons_j j = let feedback_completion_typecheck = Option.iter (fun state_id -> Pp.feedback ~state_id Feedback.Complete) - -let subst_instance_j s j = - { uj_val = Vars.subst_univs_level_constr s j.uj_val; - uj_type = Vars.subst_univs_level_constr s j.uj_type } let infer_declaration env kn dcl = match dcl with @@ -250,12 +245,14 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) let tps = (* FIXME: incompleteness of the bytecode vm: we compile polymorphic constants like opaque definitions. *) - if poly then Cemitcodes.from_val Cemitcodes.BCconstant + if poly then Some (Cemitcodes.from_val Cemitcodes.BCconstant) else - match proj with - | None -> Cemitcodes.from_val (compile_constant_body env def) - | Some pb -> - Cemitcodes.from_val (compile_constant_body env (Def (Mod_subst.from_val pb.proj_body))) + let res = + match proj with + | None -> compile_constant_body env def + | Some pb -> + compile_constant_body env (Def (Mod_subst.from_val pb.proj_body)) + in Option.map Cemitcodes.from_val res in { const_hyps = hyps; const_body = def; diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 696fc3d2..1b54b1ea 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -8,7 +8,6 @@ open Names open Term -open Univ open Environ open Declarations open Entries diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 2642b186..48dbacf1 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -153,13 +153,13 @@ let type_of_constant_type_knowing_parameters env t paramtyps = let type_of_constant_knowing_parameters env cst paramtyps = let cb = lookup_constant (fst cst) env in - let _ = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in + let () = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in let ty, cu = constant_type env cst in type_of_constant_type_knowing_parameters env ty paramtyps, cu let type_of_constant_knowing_parameters_in env cst paramtyps = let cb = lookup_constant (fst cst) env in - let _ = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in + let () = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in let ty = constant_type_in env cst in type_of_constant_type_knowing_parameters env ty paramtyps @@ -171,14 +171,14 @@ let type_of_constant env cst = let type_of_constant_in env cst = let cb = lookup_constant (fst cst) env in - let _ = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in + let () = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in let ar = constant_type_in env cst in type_of_constant_type_knowing_parameters env ar [||] let judge_of_constant_knowing_parameters env (kn,u as cst) args = let c = mkConstU cst in let ty, cu = type_of_constant_knowing_parameters env cst args in - let _ = Environ.check_constraints cu env in + let () = check_constraints cu env in make_judge c ty let judge_of_constant env cst = @@ -372,7 +372,7 @@ let judge_of_case env ci pj cj lfj = let (pind, _ as indspec) = try find_rectype env cj.uj_type with Not_found -> error_case_not_inductive env cj in - let _ = check_case_info env pind ci in + let () = check_case_info env pind ci in let (bty,rslty) = type_case_branches env indspec pj cj.uj_val in let () = check_branch_types env pind cj (lfj,bty) in diff --git a/kernel/uint31.ml b/kernel/uint31.ml index 3a0da2f6..d9c723c2 100644 --- a/kernel/uint31.ml +++ b/kernel/uint31.ml @@ -1,7 +1,7 @@ (* Invariant: For arch64 all extra bytes are set to 0 *) type t = int - (* to be used only on 32 bits achitectures *) + (* to be used only on 32 bits architectures *) let maxuint31 = Int32.of_string "0x7FFFFFFF" let uint_32 i = Int32.logand (Int32.of_int i) maxuint31 @@ -16,7 +16,7 @@ let of_int_64 i = i land 0x7FFFFFFF let of_int = select of_int_32 of_int_64 let of_uint i = i - (* convertion of an uint31 to a string *) + (* conversion of an uint31 to a string *) let to_string_32 i = Int32.to_string (uint_32 i) let to_string_64 = string_of_int diff --git a/kernel/uint31.mli b/kernel/uint31.mli index e8b98080..d1f933cc 100644 --- a/kernel/uint31.mli +++ b/kernel/uint31.mli @@ -5,7 +5,7 @@ val to_int : t -> int val of_int : int -> t val of_uint : int -> t - (* convertion to a string *) + (* conversion to a string *) val to_string : t -> string val of_string : string -> t diff --git a/kernel/univ.ml b/kernel/univ.ml index 08e9fee0..763c0822 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -194,7 +194,17 @@ struct | Level _, _ -> -1 | _, Level _ -> 1 | Var n, Var m -> Int.compare n m - + + let hequal x y = + x == y || + match x, y with + | Prop, Prop -> true + | Set, Set -> true + | Level (n,d), Level (n',d') -> + n == n' && d == d' + | Var n, Var n' -> n == n' + | _ -> false + let hcons = function | Prop as x -> x | Set as x -> x @@ -233,27 +243,26 @@ module Level = struct let hash x = x.hash - let hcons x = - let data' = RawLevel.hcons x.data in - if data' == x.data then x - else { x with data = data' } - let data x = x.data (** Hashcons on levels + their hash *) - let make = - let module Self = struct - type _t = t - type t = _t - let equal = equal - let hash = hash - end in - let module WH = Weak.Make(Self) in - let pool = WH.create 4910 in fun x -> - let x = { hash = RawLevel.hash x; data = x } in - try WH.find pool x - with Not_found -> WH.add pool x; x + module Self = struct + type _t = t + type t = _t + type u = unit + let equal x y = x.hash == y.hash && RawLevel.hequal x.data y.data + let hash x = x.hash + let hashcons () x = + let data' = RawLevel.hcons x.data in + if x.data == data' then x else { x with data = data' } + end + + let hcons = + let module H = Hashcons.Make(Self) in + Hashcons.simple_hcons H.generate H.hcons () + + let make l = hcons { hash = RawLevel.hash l; data = l } let set = make Set let prop = make Prop @@ -2064,7 +2073,7 @@ let explain_universe_inconsistency prl (o,u,v,p) = (spc() ++ str "= " ++ pr_uni u)) in str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++ - pr_rel o ++ spc() ++ pr_uni v ++ reason ++ str")" + pr_rel o ++ spc() ++ pr_uni v ++ reason let compare_levels = Level.compare let eq_levels = Level.equal diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 80b15f8b..1c31cc04 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -42,8 +42,6 @@ let conv_vect fconv vect1 vect2 cu = let infos = ref (create_clos_infos betaiotazeta Environ.empty_env) -let eq_table_key = Names.eq_table_key eq_constant - let rec conv_val env pb k v1 v2 cu = if v1 == v2 then cu else conv_whd env pb k (whd_val v1) (whd_val v2) cu @@ -66,8 +64,9 @@ and conv_whd env pb k whd1 whd2 cu = | Vconstr_const i1, Vconstr_const i2 -> if Int.equal i1 i2 then cu else raise NotConvertible | Vconstr_block b1, Vconstr_block b2 -> + let tag1 = btag b1 and tag2 = btag b2 in let sz = bsize b1 in - if Int.equal (btag b1) (btag b2) && Int.equal sz (bsize b2) then + if Int.equal tag1 tag2 && Int.equal sz (bsize b2) then let rcu = ref cu in for i = 0 to sz - 1 do rcu := conv_val env CONV k (bfield b1 i) (bfield b2 i) !rcu diff --git a/kernel/vm.ml b/kernel/vm.ml index 2cc1efe4..d4bf461b 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -79,7 +79,7 @@ type vprod type vfun type vfix type vcofix -type vblock +type vblock type arguments type vm_env @@ -224,10 +224,9 @@ let whd_val : values -> whd = | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o)) | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) | _ -> Errors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work")) - else Vconstr_block(Obj.obj o) - - - + else + Vconstr_block(Obj.obj o) + (************************************************) (* Abstrct machine ******************************) (************************************************) @@ -518,8 +517,13 @@ let type_of_switch sw = let branch_arg k (tag,arity) = if Int.equal arity 0 then ((Obj.magic tag):values) else - let b = Obj.new_block tag arity in - for i = 0 to arity - 1 do + let b, ofs = + if tag < last_variant_tag then Obj.new_block tag arity, 0 + else + let b = Obj.new_block last_variant_tag (arity+1) in + Obj.set_field b 0 (Obj.repr (tag-last_variant_tag)); + b,1 in + for i = ofs to ofs + arity - 1 do Obj.set_field b i (Obj.repr (val_of_rel (k+i))) done; val_of_obj b diff --git a/kernel/vm.mli b/kernel/vm.mli index 295ea83c..51903568 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -94,7 +94,7 @@ val reduce_cofix : int -> vcofix -> values array * values array (** Block *) -val btag : vblock -> int +val btag : vblock -> int val bsize : vblock -> int val bfield : vblock -> int -> values diff --git a/lib/cArray.ml b/lib/cArray.ml index 16034543..bb1e3354 100644 --- a/lib/cArray.ml +++ b/lib/cArray.ml @@ -13,6 +13,7 @@ sig include S val compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int val equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool + val equal_norefl : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool val is_empty : 'a array -> bool val exists : ('a -> bool) -> 'a array -> bool val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool @@ -85,19 +86,22 @@ let compare cmp v1 v2 = in loop (len - 1) +let equal_norefl cmp t1 t2 = + let len = Array.length t1 in + if not (Int.equal len (Array.length t2)) then false + else + let rec aux i = + if i < 0 then true + else + let x = uget t1 i in + let y = uget t2 i in + cmp x y && aux (pred i) + in + aux (len - 1) + let equal cmp t1 t2 = - if t1 == t2 then true else - let len = Array.length t1 in - if not (Int.equal len (Array.length t2)) then false - else - let rec aux i = - if i < 0 then true - else - let x = uget t1 i in - let y = uget t2 i in - cmp x y && aux (pred i) - in - aux (len - 1) + if t1 == t2 then true else equal_norefl cmp t1 t2 + let is_empty array = Int.equal (Array.length array) 0 diff --git a/lib/cArray.mli b/lib/cArray.mli index 39c35e2d..7e5c93b5 100644 --- a/lib/cArray.mli +++ b/lib/cArray.mli @@ -17,6 +17,11 @@ sig val equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool (** Lift equality to array type. *) + val equal_norefl : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool + (** Like {!equal} but does not assume that equality is reflexive: no + optimisation is performed if both arrays are physically the + same. *) + val is_empty : 'a array -> bool (** True whenever the array is empty. *) diff --git a/lib/cString.ml b/lib/cString.ml index 250b7cee..e9006860 100644 --- a/lib/cString.ml +++ b/lib/cString.ml @@ -135,7 +135,14 @@ let plural n s = if n<>1 then s^"s" else s let conjugate_verb_to_be n = if n<>1 then "are" else "is" let ordinal n = - let s = match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th" in + let s = + if (n / 10) mod 10 = 1 then "th" + else match n mod 10 with + | 1 -> "st" + | 2 -> "nd" + | 3 -> "rd" + | _ -> "th" + in string_of_int n ^ s (* string parsing *) diff --git a/lib/cThread.ml b/lib/cThread.ml index 55bb6fd6..2d1f10bf 100644 --- a/lib/cThread.ml +++ b/lib/cThread.ml @@ -22,7 +22,7 @@ let thread_friendly_read_fd fd s ~off ~len = let rec loop () = try Unix.read fd s off len with Unix.Unix_error((Unix.EWOULDBLOCK|Unix.EAGAIN|Unix.EINTR),_,_) -> - while not (safe_wait_timed_read fd 1.0) do Thread.yield () done; + while not (safe_wait_timed_read fd 0.05) do Thread.yield () done; loop () in loop () @@ -43,6 +43,18 @@ let really_read_fd fd s off len = i := !i + r done +let really_read_fd_2_oc fd oc len = + let i = ref 0 in + let size = 4096 in + let s = String.create size in + while !i < len do + let len = len - !i in + let r = thread_friendly_read_fd fd s ~off:0 ~len:(min len size) in + if r = 0 then raise End_of_file; + i := !i + r; + output oc s 0 r; + done + let thread_friendly_really_read ic s ~off ~len = try let fd = Unix.descr_of_in_channel ic in @@ -68,9 +80,26 @@ let thread_friendly_input_value ic = let header = String.create Marshal.header_size in really_read_fd fd header 0 Marshal.header_size; let body_size = Marshal.data_size header 0 in - let msg = String.create (body_size + Marshal.header_size) in - String.blit header 0 msg 0 Marshal.header_size; - really_read_fd fd msg Marshal.header_size body_size; - Marshal.from_string msg 0 - with Unix.Unix_error _ -> raise End_of_file + let desired_size = body_size + Marshal.header_size in + if desired_size <= Sys.max_string_length then begin + let msg = String.create desired_size in + String.blit header 0 msg 0 Marshal.header_size; + really_read_fd fd msg Marshal.header_size body_size; + Marshal.from_string msg 0 + end else begin + (* Workaround for 32 bit systems and data > 16M *) + let name, oc = + Filename.open_temp_file ~mode:[Open_binary] "coq" "marshal" in + try + output oc header 0 Marshal.header_size; + really_read_fd_2_oc fd oc body_size; + close_out oc; + let ic = open_in_bin name in + let data = Marshal.from_channel ic in + close_in ic; + Sys.remove name; + data + with e -> Sys.remove name; raise e + end + with Unix.Unix_error _ | Sys_error _ -> raise End_of_file @@ -47,3 +47,5 @@ let tag (s,_) = anomaly msg let pointer_equal (t1,o1) (t2,o2) = t1 = t2 && o1 == o2 + +let dump () = Int.Map.bindings !dyntab diff --git a/lib/dyn.mli b/lib/dyn.mli index 4a713472..cac912ac 100644 --- a/lib/dyn.mli +++ b/lib/dyn.mli @@ -14,3 +14,4 @@ val create : string -> ('a -> t) * (t -> 'a) val tag : t -> string val has_tag : t -> string -> bool val pointer_equal : t -> t -> bool +val dump : unit -> (int * string) list diff --git a/lib/errors.ml b/lib/errors.ml index ab331d6a..a4ec357e 100644 --- a/lib/errors.ml +++ b/lib/errors.ml @@ -108,7 +108,7 @@ let _ = register_handler begin function | _ -> raise Unhandled end -(** Critical exceptions shouldn't be catched and ignored by mistake +(** Critical exceptions should not be caught and ignored by mistake by inner functions during a [vernacinterp]. They should be handled only at the very end of interp, to be displayed to the user. *) diff --git a/lib/errors.mli b/lib/errors.mli index e4096a7e..03caa6a9 100644 --- a/lib/errors.mli +++ b/lib/errors.mli @@ -81,7 +81,7 @@ val iprint : Exninfo.iexn -> Pp.std_ppcmds isn't printed (used in Ltac debugging). *) val print_no_report : exn -> Pp.std_ppcmds -(** Critical exceptions shouldn't be catched and ignored by mistake +(** Critical exceptions should not be caught and ignored by mistake by inner functions during a [vernacinterp]. They should be handled only in [Toplevel.do_vernac] (or Ideslave), to be displayed to the user. Typical example: [Sys.Break], [Assert_failure], [Anomaly] ... diff --git a/lib/future.ml b/lib/future.ml index 2f1ce5e4..02d3702d 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -11,19 +11,21 @@ let freeze = ref (fun () -> assert false : unit -> Dyn.t) let unfreeze = ref (fun _ -> () : Dyn.t -> unit) let set_freeze f g = freeze := f; unfreeze := g -exception NotReady -exception NotHere +exception NotReady of string +exception NotHere of string let _ = Errors.register_handler (function - | NotReady -> - Pp.strbrk("The value you are asking for is not ready yet. " ^ + | NotReady name -> + Pp.strbrk("The value you are asking for ("^name^") is not ready yet. "^ "Please wait or pass "^ "the \"-async-proofs off\" option to CoqIDE to disable "^ - "asynchronous script processing.") - | NotHere -> - Pp.strbrk("The value you are asking for is not available "^ + "asynchronous script processing and don't pass \"-quick\" to "^ + "coqc.") + | NotHere name -> + Pp.strbrk("The value you are asking for ("^name^") is not available "^ "in this process. If you really need this, pass "^ "the \"-async-proofs off\" option to CoqIDE to disable "^ - "asynchronous script processing.") + "asynchronous script processing and don't pass \"-quick\" to "^ + "coqc.") | _ -> raise Errors.Unhandled) type fix_exn = Exninfo.iexn -> Exninfo.iexn @@ -54,67 +56,69 @@ and 'a comp = | Exn of Exninfo.iexn (* Invariant: this exception is always "fixed" as in fix_exn *) and 'a comput = - | Ongoing of (UUID.t * fix_exn * 'a comp ref) Ephemeron.key + | Ongoing of string * (UUID.t * fix_exn * 'a comp ref) Ephemeron.key | Finished of 'a and 'a computation = 'a comput ref -let create ?(uuid=UUID.fresh ()) f x = - ref (Ongoing (Ephemeron.create (uuid, f, Pervasives.ref x))) +let unnamed = "unnamed" + +let create ?(name=unnamed) ?(uuid=UUID.fresh ()) f x = + ref (Ongoing (name, Ephemeron.create (uuid, f, Pervasives.ref x))) let get x = match !x with - | Finished v -> UUID.invalid, id, ref (Val (v,None)) - | Ongoing x -> - try Ephemeron.get x + | Finished v -> unnamed, UUID.invalid, id, ref (Val (v,None)) + | Ongoing (name, x) -> + try let uuid, fix, c = Ephemeron.get x in name, uuid, fix, c with Ephemeron.InvalidKey -> - UUID.invalid, id, ref (Exn (NotHere, Exninfo.null)) + name, UUID.invalid, id, ref (Exn (NotHere name, Exninfo.null)) type 'a value = [ `Val of 'a | `Exn of Exninfo.iexn ] -let is_over kx = let _, _, x = get kx in match !x with +let is_over kx = let _, _, _, x = get kx in match !x with | Val _ | Exn _ -> true | Closure _ | Delegated _ -> false -let is_val kx = let _, _, x = get kx in match !x with +let is_val kx = let _, _, _, x = get kx in match !x with | Val _ -> true | Exn _ | Closure _ | Delegated _ -> false -let is_exn kx = let _, _, x = get kx in match !x with +let is_exn kx = let _, _, _, x = get kx in match !x with | Exn _ -> true | Val _ | Closure _ | Delegated _ -> false -let peek_val kx = let _, _, x = get kx in match !x with +let peek_val kx = let _, _, _, x = get kx in match !x with | Val (v, _) -> Some v | Exn _ | Closure _ | Delegated _ -> None -let uuid kx = let id, _, _ = get kx in id +let uuid kx = let _, id, _, _ = get kx in id let from_val ?(fix_exn=id) v = create fix_exn (Val (v, None)) let from_here ?(fix_exn=id) v = create fix_exn (Val (v, Some (!freeze ()))) -let fix_exn_of ck = let _, fix_exn, _ = get ck in fix_exn +let fix_exn_of ck = let _, _, fix_exn, _ = get ck in fix_exn -let create_delegate ?(blocking=true) fix_exn = +let create_delegate ?(blocking=true) ~name fix_exn = let assignement signal ck = fun v -> - let _, fix_exn, c = get ck in + let _, _, fix_exn, c = get ck in assert (match !c with Delegated _ -> true | _ -> false); begin match v with | `Val v -> c := Val (v, None) | `Exn e -> c := Exn (fix_exn e) - | `Comp f -> let _, _, comp = get f in c := !comp end; + | `Comp f -> let _, _, _, comp = get f in c := !comp end; signal () in let wait, signal = - if not blocking then (fun () -> raise NotReady), ignore else + if not blocking then (fun () -> raise (NotReady name)), ignore else let lock = Mutex.create () in let cond = Condition.create () in (fun () -> Mutex.lock lock; Condition.wait cond lock; Mutex.unlock lock), (fun () -> Mutex.lock lock; Condition.broadcast cond; Mutex.unlock lock) in - let ck = create fix_exn (Delegated wait) in + let ck = create ~name fix_exn (Delegated wait) in ck, assignement signal ck (* TODO: get rid of try/catch to be stackless *) let rec compute ~pure ck : 'a value = - let _, fix_exn, c = get ck in + let _, _, fix_exn, c = get ck in match !c with | Val (x, _) -> `Val x | Exn (e, info) -> `Exn (e, info) @@ -128,7 +132,7 @@ let rec compute ~pure ck : 'a value = let e = Errors.push e in let e = fix_exn e in match e with - | (NotReady, _) -> `Exn e + | (NotReady _, _) -> `Exn e | _ -> c := Exn e; `Exn e let force ~pure x = match compute ~pure x with @@ -136,8 +140,8 @@ let force ~pure x = match compute ~pure x with | `Exn e -> Exninfo.iraise e let chain ~pure ck f = - let uuid, fix_exn, c = get ck in - create ~uuid fix_exn (match !c with + let name, uuid, fix_exn, c = get ck in + create ~uuid ~name fix_exn (match !c with | Closure _ | Delegated _ -> Closure (fun () -> f (force ~pure ck)) | Exn _ as x -> x | Val (v, None) when pure -> Closure (fun () -> f v) @@ -156,7 +160,7 @@ let chain ~pure ck f = let create fix_exn f = create fix_exn (Closure f) let replace kx y = - let _, _, x = get kx in + let _, _, _, x = get kx in match !x with | Exn _ -> x := Closure (fun () -> force ~pure:false y) | _ -> Errors.anomaly @@ -207,10 +211,10 @@ let map2 ?greedy f x l = let print f kx = let open Pp in - let (uid, _, x) = get kx in + let name, uid, _, x = get kx in let uid = - if UUID.equal uid UUID.invalid then str "[#]" - else str "[" ++ int uid ++ str "]" + if UUID.equal uid UUID.invalid then str "[#:" ++ str name ++ str "]" + else str "[" ++ int uid ++ str":" ++ str name ++ str "]" in match !x with | Delegated _ -> str "Delegated" ++ uid diff --git a/lib/future.mli b/lib/future.mli index 8a4fa0bd..324d5f7d 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -63,7 +63,7 @@ end module UUIDMap : Map.S with type key = UUID.t module UUIDSet : Set.S with type elt = UUID.t -exception NotReady +exception NotReady of string type 'a computation type 'a value = [ `Val of 'a | `Exn of Exninfo.iexn ] @@ -100,7 +100,8 @@ val fix_exn_of : 'a computation -> fix_exn delage assigns it. *) type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation] val create_delegate : - ?blocking:bool -> fix_exn -> 'a computation * ('a assignement -> unit) + ?blocking:bool -> name:string -> + fix_exn -> 'a computation * ('a assignement -> unit) (* Given a computation that is_exn, replace it by another one *) val replace : 'a computation -> 'a computation -> unit diff --git a/lib/hashcons.ml b/lib/hashcons.ml index 752e2634..46ba0b62 100644 --- a/lib/hashcons.ml +++ b/lib/hashcons.ml @@ -43,6 +43,7 @@ module type S = type table val generate : u -> table val hcons : table -> t -> t + val stats : table -> Hashset.statistics end module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) = @@ -67,6 +68,8 @@ module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) = let y = X.hashcons u x in Htbl.repr (X.hash y) y tab + let stats (tab, _) = Htbl.stats tab + end (* A few usefull wrappers: diff --git a/lib/hashcons.mli b/lib/hashcons.mli index 60a9ee01..8d0adc3f 100644 --- a/lib/hashcons.mli +++ b/lib/hashcons.mli @@ -56,6 +56,8 @@ module type S = (** This create a hashtable of the hashconsed objects. *) val hcons : table -> t -> t (** Perform the hashconsing of the given object within the table. *) + val stats : table -> Hashset.statistics + (** Recover statistics of the hashconsing table. *) end module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) diff --git a/lib/hashset.ml b/lib/hashset.ml index 6bec81c7..1ca6cc64 100644 --- a/lib/hashset.ml +++ b/lib/hashset.ml @@ -19,12 +19,20 @@ module type EqType = sig val equal : t -> t -> bool end +type statistics = { + num_bindings: int; + num_buckets: int; + max_bucket_length: int; + bucket_histogram: int array +} + module type S = sig type elt type t val create : int -> t val clear : t -> unit val repr : int -> elt -> t -> elt + val stats : t -> statistics end module Make (E : EqType) = @@ -185,6 +193,24 @@ module Make (E : EqType) = let ifnotfound index = add_aux t Weak.set (Some d) h index; d in find_or h t d ifnotfound + let stats t = + let fold accu bucket = max (count_bucket 0 bucket 0) accu in + let max_length = Array.fold_left fold 0 t.table in + let histogram = Array.make (max_length + 1) 0 in + let iter bucket = + let len = count_bucket 0 bucket 0 in + histogram.(len) <- succ histogram.(len) + in + let () = Array.iter iter t.table in + let fold (num, len, i) k = (num + k * i, len + k, succ i) in + let (num, len, _) = Array.fold_left fold (0, 0, 0) histogram in + { + num_bindings = num; + num_buckets = len; + max_bucket_length = Array.length histogram; + bucket_histogram = histogram; + } + end module Combine = struct diff --git a/lib/hashset.mli b/lib/hashset.mli index 537f3418..a455eec6 100644 --- a/lib/hashset.mli +++ b/lib/hashset.mli @@ -19,6 +19,13 @@ module type EqType = sig val equal : t -> t -> bool end +type statistics = { + num_bindings: int; + num_buckets: int; + max_bucket_length: int; + bucket_histogram: int array +} + module type S = sig type elt (** Type of hashsets elements. *) @@ -34,6 +41,8 @@ module type S = sig specific representation that is stored in [set]. Otherwise, [constr] is stored in [set] and will be used as the canonical representation of this value in the future. *) + val stats : t -> statistics + (** Recover statistics on the table. *) end module Make (E : EqType) : S with type elt = E.t diff --git a/lib/monad.ml b/lib/monad.ml index 4a52684d..a1714a41 100644 --- a/lib/monad.ml +++ b/lib/monad.ml @@ -111,7 +111,7 @@ module Make (M:Def) : S with type +'a t = 'a M.t = struct | [a] -> M.map (fun a' -> [a']) (f a) | a::b::l -> - map f l >>= fun l' -> + map_right f l >>= fun l' -> f b >>= fun b' -> M.map (fun a' -> a'::b'::l') (f a) @@ -387,8 +387,6 @@ let pp_with ?pp_tag ft strm = let ppnl_with ft strm = pp_dirs ft (Glue.atom (Ppdir_ppcmds (strm ++ fnl ()))) -let pp_flush_with ft = Format.pp_print_flush ft - (* pretty printing functions WITH FLUSH *) let msg_with ft strm = pp_dirs ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush)) @@ -519,8 +517,17 @@ let pr_arg pr x = spc () ++ pr x let pr_opt pr = function None -> mt () | Some x -> pr_arg pr x let pr_opt_no_spc pr = function None -> mt () | Some x -> pr x +(** TODO: merge with CString.ordinal *) let pr_nth n = - int n ++ str (match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th") + let s = + if (n / 10) mod 10 = 1 then "th" + else match n mod 10 with + | 1 -> "st" + | 2 -> "nd" + | 3 -> "rd" + | _ -> "th" + in + int n ++ str s (* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *) diff --git a/lib/richpp.ml b/lib/richpp.ml index 745b7d2a..c4a9c39d 100644 --- a/lib/richpp.ml +++ b/lib/richpp.ml @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Util open Xml_datatype type 'annotation located = { @@ -14,129 +15,117 @@ type 'annotation located = { endpos : int } +type 'a stack = +| Leaf +| Node of string * 'a located gxml list * int * 'a stack + +type 'a context = { + mutable stack : 'a stack; + (** Pending opened nodes *) + mutable offset : int; + (** Quantity of characters printed so far *) + mutable annotations : 'a option Int.Map.t; + (** Map associating annotations to indexes *) + mutable index : int; + (** Current index of annotations *) +} + +(** We use Format to introduce tags inside the pretty-printed document. + Each inserted tag is a fresh index that we keep in sync with the contents + of annotations. + + We build an XML tree on the fly, by plugging ourselves in Format tag + marking functions. As those functions are called when actually writing to + the device, the resulting tree is correct. +*) let rich_pp annotate ppcmds = - (** First, we use Format to introduce tags inside - the pretty-printed document. - - Each inserted tag is a fresh index that we keep in sync with the contents - of annotations. - *) - let annotations = ref [] in - let index = ref (-1) in + + let context = { + stack = Leaf; + offset = 0; + annotations = Int.Map.empty; + index = (-1); + } in + let pp_tag obj = - let () = incr index in - let () = annotations := obj :: !annotations in - string_of_int !index + let index = context.index + 1 in + let () = context.index <- index in + let obj = annotate obj in + let () = context.annotations <- Int.Map.add index obj context.annotations in + string_of_int index + in + + let pp_buffer = Buffer.create 13 in + + let push_pcdata () = + (** Push the optional PCData on the above node *) + let len = Buffer.length pp_buffer in + if len = 0 then () + else match context.stack with + | Leaf -> assert false + | Node (node, child, pos, ctx) -> + let data = Buffer.contents pp_buffer in + let () = Buffer.clear pp_buffer in + let () = context.stack <- Node (node, PCData data :: child, pos, ctx) in + context.offset <- context.offset + len in - let tagged_pp = Format.( - - (** Warning: The following instructions are valid only if - [str_formatter] is not used for another purpose in - Pp.pp_with. *) - - let ft = str_formatter in - - (** We reuse {!Format} standard way of producing tags - inside pretty-printing. *) - pp_set_tags ft true; - - (** The whole output must be a valid document. To that - end, we nest the document inside a tag named <pp>. *) - pp_open_tag ft "pp"; - - (** XML ignores spaces. The problem is that our pretty-printings - are based on spaces to indent. To solve that problem, we - systematically output non-breakable spaces, which are properly - honored by XML. - - To do so, we reconfigure the [str_formatter] temporarily by - hijacking the function that output spaces. *) - let out, flush, newline, std_spaces = - pp_get_all_formatter_output_functions ft () - in - let set = pp_set_all_formatter_output_functions ft ~out ~flush ~newline in - set ~spaces:(fun k -> - for i = 0 to k - 1 do - Buffer.add_string stdbuf " " - done - ); - - (** Some characters must be escaped in XML. This is done by the - following rewriting of the strings held by pretty-printing - commands. *) - Pp.(pp_with ~pp_tag ft (rewrite Xml_printer.pcdata_to_string ppcmds)); - - (** Insert </pp>. *) - pp_close_tag ft (); - - (** Get the final string. *) - let output = flush_str_formatter () in - - (** Finalize by restoring the state of the [str_formatter] and the - default behavior of Format. By the way, there may be a bug here: - there is no {!Format.pp_get_tags} and therefore if the tags flags - was already set to true before executing this piece of code, the - state of Format is not restored. *) - set ~spaces:std_spaces; - pp_set_tags ft false; - output - ) + let open_xml_tag tag = + let () = push_pcdata () in + context.stack <- Node (tag, [], context.offset, context.stack) in - (** Second, we retrieve the final function that relates - each tag to an annotation. *) - let objs = CArray.rev_of_list !annotations in - let get index = annotate objs.(index) in - - (** Third, we parse the resulting string. It is a valid XML - document (in the sense of Xml_parser). As blanks are - meaningful we deactivate canonicalization in the XML - parser. *) - let xml_pp = - try - Xml_parser.(parse ~do_not_canonicalize:true (make (SString tagged_pp))) - with Xml_parser.Error e -> - Printf.eprintf - "Broken invariant (RichPp): \n\ - The output semi-structured pretty-printing is ill-formed.\n\ - Please report.\n\ - %s" - (Xml_parser.error e); - exit 1 + + let close_xml_tag tag = + let () = push_pcdata () in + match context.stack with + | Leaf -> assert false + | Node (node, child, pos, ctx) -> + let () = assert (String.equal tag node) in + let annotation = + try Int.Map.find (int_of_string node) context.annotations + with _ -> None + in + let annotation = { + annotation = annotation; + startpos = pos; + endpos = context.offset; + } in + let xml = Element (node, annotation, List.rev child) in + match ctx with + | Leaf -> + (** Final node: we keep the result in a dummy context *) + context.stack <- Node ("", [xml], 0, Leaf) + | Node (node, child, pos, ctx) -> + context.stack <- Node (node, xml :: child, pos, ctx) in - (** Fourth, the low-level XML is turned into a high-level - semi-structured document that contains a located annotation in - every node. During the traversal of the low-level XML document, - we build a raw string representation of the pretty-print. *) - let rec node buffer = function - | Element (index, [], cs) -> - let startpos, endpos, cs = children buffer cs in - let annotation = try get (int_of_string index) with _ -> None in - (Element (index, { annotation; startpos; endpos }, cs), endpos) + let open Format in - | PCData s -> - Buffer.add_string buffer s; - (PCData s, Buffer.length buffer) + let ft = formatter_of_buffer pp_buffer in - | _ -> - assert false (* Because of the form of XML produced by Format. *) - - and children buffer cs = - let startpos = Buffer.length buffer in - let cs, endpos = - List.fold_left (fun (cs, endpos) c -> - let c, endpos = node buffer c in - (c :: cs, endpos) - ) ([], startpos) cs - in - (startpos, endpos, List.rev cs) - in - let pp_buffer = Buffer.create 13 in - let xml, _ = node pp_buffer xml_pp in + let tag_functions = { + mark_open_tag = (fun tag -> let () = open_xml_tag tag in ""); + mark_close_tag = (fun tag -> let () = close_xml_tag tag in ""); + print_open_tag = ignore; + print_close_tag = ignore; + } in + + pp_set_formatter_tag_functions ft tag_functions; + pp_set_mark_tags ft true; + + (** The whole output must be a valid document. To that + end, we nest the document inside <pp> tags. *) + pp_open_tag ft "pp"; + Pp.(pp_with ~pp_tag ft ppcmds); + pp_close_tag ft (); + + (** Get the resulting XML tree. *) + let () = pp_print_flush ft () in + let () = assert (Buffer.length pp_buffer = 0) in + match context.stack with + | Node ("", [xml], 0, Leaf) -> xml + | _ -> assert false - (** We return the raw pretty-printing and its annotations tree. *) - (Buffer.contents pp_buffer, xml) let annotations_positions xml = let rec node accu = function diff --git a/lib/richpp.mli b/lib/richpp.mli index 446ee1a0..bf80c8dc 100644 --- a/lib/richpp.mli +++ b/lib/richpp.mli @@ -17,13 +17,13 @@ type 'annotation located = { } (** [rich_pp get_annotations ppcmds] returns the interpretation - of [ppcmds] as a string as well as a semi-structured document + of [ppcmds] as a semi-structured document that represents (located) annotations of this string. The [get_annotations] function is used to convert tags into the desired annotation. If this function returns [None], then no annotation is put. *) val rich_pp : (Pp.Tag.t -> 'annotation option) -> Pp.std_ppcmds -> - string * 'annotation located Xml_datatype.gxml + 'annotation located Xml_datatype.gxml (** [annotations_positions ssdoc] returns a list associating each annotations with its position in the string from which [ssdoc] is diff --git a/lib/terminal.ml b/lib/terminal.ml index 1e6c2557..0f6b23af 100644 --- a/lib/terminal.ml +++ b/lib/terminal.ml @@ -167,7 +167,8 @@ let reset_style = { negative = Some false; } -let has_style t = Unix.isatty t +let has_style t = + Unix.isatty t && Sys.os_type = "Unix" let split c s = let len = String.length s in diff --git a/library/assumptions.ml b/library/assumptions.ml index 04ee14fb..62645b23 100644 --- a/library/assumptions.ml +++ b/library/assumptions.ml @@ -21,6 +21,7 @@ open Names open Term open Declarations open Mod_subst +open Globnames type context_object = | Variable of Id.t (* A section variable or a Let definition *) @@ -158,93 +159,67 @@ let lookup_constant cst = else lookup_constant_in_impl cst (Some cb) with Not_found -> lookup_constant_in_impl cst None -let assumptions ?(add_opaque=false) ?(add_transparent=false) st (* t *) = - modcache := MPmap.empty; - let (idts,knst) = st in - (* Infix definition for chaining function that accumulate - on a and a ContextObjectSet, ContextObjectMap. *) - let ( ** ) f1 f2 s m = let (s',m') = f1 s m in f2 s' m' in - (* This function eases memoization, by checking if an object is already - stored before trying and applying a function. - If the object is there, the function is not fired (we are in a - particular case where memoized object don't need a treatment at all). - If the object isn't there, it is stored and the function is fired*) - let try_and_go o f s m = - if ContextObjectSet.mem o s then - (s,m) - else - f (ContextObjectSet.add o s) m - in - let identity2 s m = (s,m) +(** Graph traversal of an object, collecting on the way the dependencies of + traversed objects *) +let rec traverse accu t = match kind_of_term t with +| Var id -> + let body () = match Global.lookup_named id with (_, body, _) -> body in + traverse_object accu body (VarRef id) +| Const (kn, _) -> + let body () = Global.body_of_constant_body (lookup_constant kn) in + traverse_object accu body (ConstRef kn) +| Ind (ind, _) -> + traverse_object accu (fun () -> None) (IndRef ind) +| Construct (cst, _) -> + traverse_object accu (fun () -> None) (ConstructRef cst) +| Meta _ | Evar _ -> assert false +| _ -> Constr.fold traverse accu t + +and traverse_object (curr, data) body obj = + let data = + if Refmap.mem obj data then data + else match body () with + | None -> Refmap.add obj Refset.empty data + | Some body -> + let (contents, data) = traverse (Refset.empty, data) body in + Refmap.add obj contents data in - (* Goes recursively into the term to see if it depends on assumptions. - The 3 important cases are : - - Const _ where we need to first unfold the constant and return - the needed assumptions of its body in the environment, - - Rel _ which means the term is a variable which has been bound - earlier by a Lambda or a Prod (returns [] ), - - Var _ which means that the term refers to a section variable or - a "Let" definition, in the former it is an assumption of [t], - in the latter is must be unfolded like a Const. - The other cases are straightforward recursion. - Calls to the environment are memoized, thus avoiding exploration of - the DAG of the environment as if it was a tree (can cause - exponential behavior and prevent the algorithm from terminating - in reasonable time). [s] is a set of [context_object], representing - the object already visited.*) - let rec do_constr t s acc = - let rec iter t = - match kind_of_term t with - | Var id -> do_memoize_id id - | Meta _ | Evar _ -> assert false - | Cast (e1,_,e2) | Prod (_,e1,e2) | Lambda (_,e1,e2) -> - (iter e1)**(iter e2) - | LetIn (_,e1,e2,e3) -> (iter e1)**(iter e2)**(iter e3) - | App (e1, e_array) -> (iter e1)**(iter_array e_array) - | Case (_,e1,e2,e_array) -> (iter e1)**(iter e2)**(iter_array e_array) - | Fix (_,(_, e1_array, e2_array)) | CoFix (_,(_,e1_array, e2_array)) -> - (iter_array e1_array) ** (iter_array e2_array) - | Const (kn,_) -> do_memoize_kn kn - | _ -> identity2 (* closed atomic types + rel *) - and iter_array a = Array.fold_right (fun e f -> (iter e)**f) a identity2 - in iter t s acc - - and add_id id s acc = - (* a Var can be either a variable, or a "Let" definition.*) - match Global.lookup_named id with - | (_,None,t) -> - (s,ContextObjectMap.add (Variable id) t acc) - | (_,Some bdy,_) -> do_constr bdy s acc - - and do_memoize_id id = - try_and_go (Variable id) (add_id id) - - and add_kn kn s acc = + (Refset.add obj curr, data) + +let traverse t = + let () = modcache := MPmap.empty in + traverse (Refset.empty, Refmap.empty) t + +(** Hopefully bullet-proof function to recover the type of a constant. It just + ignores all the universe stuff. There are many issues that can arise when + considering terms out of any valid environment, so use with caution. *) +let type_of_constant cb = match cb.Declarations.const_type with +| Declarations.RegularArity ty -> ty +| Declarations.TemplateArity (ctx, arity) -> + Term.mkArity (ctx, Sorts.sort_of_univ arity.Declarations.template_level) + +let assumptions ?(add_opaque=false) ?(add_transparent=false) st t = + let (idts, knst) = st in + (** Only keep the transitive dependencies *) + let (_, graph) = traverse t in + let fold obj _ accu = match obj with + | VarRef id -> + let (_, body, t) = Global.lookup_named id in + if Option.is_empty body then ContextObjectMap.add (Variable id) t accu + else accu + | ConstRef kn -> let cb = lookup_constant kn in - let do_type cst = - let ctype = Global.type_of_global_unsafe (Globnames.ConstRef kn) in - (s,ContextObjectMap.add cst ctype acc) - in - let (s,acc) = - if Declareops.constant_has_body cb then - if Declareops.is_opaque cb || not (Cpred.mem kn knst) then - (** it is opaque *) - if add_opaque then do_type (Opaque kn) - else (s, acc) - else - if add_transparent then do_type (Transparent kn) - else (s, acc) - else (s, acc) - in - match Global.body_of_constant_body cb with - | None -> do_type (Axiom kn) - | Some body -> do_constr body s acc - - and do_memoize_kn kn = - try_and_go (Axiom kn) (add_kn kn) - - in - fun t -> - snd (do_constr t - (ContextObjectSet.empty) - (ContextObjectMap.empty)) + if not (Declareops.constant_has_body cb) then + let t = type_of_constant cb in + ContextObjectMap.add (Axiom kn) t accu + else if add_opaque && (Declareops.is_opaque cb || not (Cpred.mem kn knst)) then + let t = type_of_constant cb in + ContextObjectMap.add (Opaque kn) t accu + else if add_transparent then + let t = type_of_constant cb in + ContextObjectMap.add (Transparent kn) t accu + else + accu + | IndRef _ | ConstructRef _ -> accu + in + Refmap.fold fold graph ContextObjectMap.empty diff --git a/library/assumptions.mli b/library/assumptions.mli index 0a2c62f5..bb36a972 100644 --- a/library/assumptions.mli +++ b/library/assumptions.mli @@ -9,6 +9,7 @@ open Util open Names open Term +open Globnames (** A few declarations for the "Print Assumption" command @author spiwack *) @@ -23,8 +24,18 @@ module ContextObjectSet : Set.S with type elt = context_object module ContextObjectMap : Map.ExtS with type key = context_object and module Set := ContextObjectSet -(** collects all the assumptions (optionally including opaque definitions) - on which a term relies (together with their type) *) +(** Collects all the objects on which a term directly relies, bypassing kernel + opacity, together with the recursive dependence DAG of objects. + + WARNING: some terms may not make sense in the environment, because they are + sealed inside opaque modules. Do not try to do anything fancy with those + terms apart from printing them, otherwise demons may fly out of your nose. +*) +val traverse : constr -> (Refset.t * Refset.t Refmap.t) + +(** Collects all the assumptions (optionally including opaque definitions) + on which a term relies (together with their type). The above warning of + {!traverse} also applies. *) val assumptions : ?add_opaque:bool -> ?add_transparent:bool -> transparent_state -> constr -> Term.types ContextObjectMap.t diff --git a/library/declare.ml b/library/declare.ml index 7f42a747..c3181e4c 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -253,24 +253,25 @@ let declare_sideff env fix_exn se = if Constant.equal c c' then Some (x,kn) else None) inds_consts) knl)) -let declare_constant ?(internal = UserVerbose) ?(local = false) id (cd, kind) = - let cd = (* We deal with side effects of non-opaque constants *) +let declare_constant ?(internal = UserVerbose) ?(local = false) id ?(export_seff=false) (cd, kind) = + let cd = (* We deal with side effects *) match cd with - | Entries.DefinitionEntry ({ - const_entry_opaque = false; const_entry_body = bo } as de) - | Entries.DefinitionEntry ({ - const_entry_polymorphic = true; const_entry_body = bo } as de) - -> - let _, seff = Future.force bo in - if Declareops.side_effects_is_empty seff then cd - else begin - let seff = Declareops.uniquize_side_effects seff in - Declareops.iter_side_effects - (declare_sideff (Global.env ()) (Future.fix_exn_of bo)) seff; - Entries.DefinitionEntry { de with - const_entry_body = Future.chain ~pure:true bo (fun (pt, _) -> - pt, Declareops.no_seff) } + | Entries.DefinitionEntry de -> + if export_seff || + not de.const_entry_opaque || + de.const_entry_polymorphic then + let bo = de.const_entry_body in + let _, seff = Future.force bo in + if Declareops.side_effects_is_empty seff then cd + else begin + let seff = Declareops.uniquize_side_effects seff in + Declareops.iter_side_effects + (declare_sideff (Global.env ()) (Future.fix_exn_of bo)) seff; + Entries.DefinitionEntry { de with + const_entry_body = Future.chain ~pure:true bo (fun (pt, _) -> + pt, Declareops.no_seff) } end + else cd | _ -> cd in let cst = { diff --git a/library/declare.mli b/library/declare.mli index 03b66271..d8a00db0 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -53,7 +53,7 @@ val definition_entry : ?opaque:bool -> ?inline:bool -> ?types:types -> constr -> definition_entry val declare_constant : - ?internal:internal_flag -> ?local:bool -> Id.t -> constant_declaration -> constant + ?internal:internal_flag -> ?local:bool -> Id.t -> ?export_seff:bool -> constant_declaration -> constant val declare_definition : ?internal:internal_flag -> ?opaque:bool -> ?kind:definition_object_kind -> diff --git a/library/global.mli b/library/global.mli index af23d9b7..62d7ea32 100644 --- a/library/global.mli +++ b/library/global.mli @@ -118,9 +118,23 @@ val is_template_polymorphic : Globnames.global_reference -> bool val type_of_global_in_context : Environ.env -> Globnames.global_reference -> Constr.types Univ.in_universe_context -val type_of_global_unsafe : Globnames.global_reference -> Constr.types +(** Returns the type of the constant in its global or local universe + context. The type should not be used without pushing it's universe + context in the environmnent of usage. For non-universe-polymorphic + constants, it does not matter. *) -(** Returns the universe context of the global reference (whatever it's polymorphic status is). *) +val type_of_global_unsafe : Globnames.global_reference -> Constr.types +(** Returns the type of the constant, forgetting its universe context if + it is polymorphic, use with care: for polymorphic constants, the + type cannot be used to produce a term used by the kernel. For safe + handling of polymorphic global references, one should look at a + particular instantiation of the reference, in some particular + universe context (part of an [env] or [evar_map]), see + e.g. [type_of_constant_in]. If you want to create a fresh instance + of the reference and get its type look at [Evd.fresh_global] or + [Evarutil.new_global] and [Retyping.get_type_of]. *) + +(** Returns the universe context of the global reference (whatever its polymorphic status is). *) val universes_of_global : Globnames.global_reference -> Univ.universe_context (** {6 Retroknowledge } *) diff --git a/library/globnames.ml b/library/globnames.ml index 5eb091af..3befaa9a 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Util open Errors open Names open Term diff --git a/library/goptions.ml b/library/goptions.ml index 4aea3368..ef25fa59 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -268,10 +268,14 @@ let declare_option cast uncast begin fun v -> add_anonymous_leaf (gdecl_obj v) end else write,write,write in + let warn () = + if depr then + msg_warning (str "Option " ++ str (nickname key) ++ str " is deprecated") + in let cread () = cast (read ()) in - let cwrite v = write (uncast v) in - let clwrite v = lwrite (uncast v) in - let cgwrite v = gwrite (uncast v) in + let cwrite v = warn (); write (uncast v) in + let clwrite v = warn (); lwrite (uncast v) in + let cgwrite v = warn (); gwrite (uncast v) in value_tab := OptionMap.add key (name, depr, (sync,cread,cwrite,clwrite,cgwrite)) !value_tab; write diff --git a/library/libnames.ml b/library/libnames.ml index f2a9d041..cdaec6a3 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -32,6 +32,11 @@ let is_dirpath_prefix_of d1 d2 = List.prefix_of Id.equal (List.rev (DirPath.repr d1)) (List.rev (DirPath.repr d2)) +let is_dirpath_suffix_of dir1 dir2 = + let dir1 = DirPath.repr dir1 in + let dir2 = DirPath.repr dir2 in + List.prefix_of Id.equal dir1 dir2 + let chop_dirpath n d = let d1,d2 = List.chop n (List.rev (DirPath.repr d)) in DirPath.make (List.rev d1), DirPath.make (List.rev d2) diff --git a/library/libnames.mli b/library/libnames.mli index 3b5feb94..b95c0887 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -37,6 +37,8 @@ val append_dirpath : DirPath.t -> DirPath.t -> DirPath.t val drop_dirpath_prefix : DirPath.t -> DirPath.t -> DirPath.t val is_dirpath_prefix_of : DirPath.t -> DirPath.t -> bool +val is_dirpath_suffix_of : DirPath.t -> DirPath.t -> bool + module Dirset : Set.S with type elt = DirPath.t module Dirmap : Map.ExtS with type key = DirPath.t and module Set := Dirset diff --git a/library/library.ml b/library/library.ml index b078e2c4..b4261309 100644 --- a/library/library.ml +++ b/library/library.ml @@ -17,6 +17,59 @@ open Libobject open Lib (************************************************************************) +(*s Low-level interning/externing of libraries to files *) + +(*s Loading from disk to cache (preparation phase) *) + +let (raw_extern_library, raw_intern_library) = + System.raw_extern_intern Coq_config.vo_magic_number + +(************************************************************************) +(** Serialized objects loaded on-the-fly *) + +exception Faulty of string + +module Delayed : +sig + +type 'a delayed +val in_delayed : string -> in_channel -> 'a delayed +val fetch_delayed : 'a delayed -> 'a + +end = +struct + +type 'a delayed = { + del_file : string; + del_off : int; + del_digest : Digest.t; +} + +let in_delayed f ch = + let pos = pos_in ch in + let _, digest = System.skip_in_segment f ch in + { del_file = f; del_digest = digest; del_off = pos; } + +(** Fetching a table of opaque terms at position [pos] in file [f], + expecting to find first a copy of [digest]. *) + +let fetch_delayed del = + let { del_digest = digest; del_file = f; del_off = pos; } = del in + try + let ch = System.with_magic_number_check raw_intern_library f in + let () = seek_in ch pos in + let obj, _, digest' = System.marshal_in_segment f ch in + let () = close_in ch in + if not (String.equal digest digest') then raise (Faulty f); + obj + with e when Errors.noncritical e -> raise (Faulty f) + +end + +open Delayed + + +(************************************************************************) (*s Modules on disk contain the following informations (after the magic number, and before the digest). *) @@ -42,12 +95,19 @@ type library_t = { library_extra_univs : Univ.universe_context_set; } +type library_summary = { + libsum_name : compilation_unit_name; + libsum_digests : Safe_typing.vodigest; + libsum_imports : compilation_unit_name array; +} + module LibraryOrdered = DirPath module LibraryMap = Map.Make(LibraryOrdered) module LibraryFilenameMap = Map.Make(LibraryOrdered) (* This is a map from names to loaded libraries *) -let libraries_table = Summary.ref LibraryMap.empty ~name:"LIBRARY" +let libraries_table : library_summary LibraryMap.t ref = + Summary.ref LibraryMap.empty ~name:"LIBRARY" (* This is the map of loaded libraries filename *) (* (not synchronized so as not to be caught in the states on disk) *) @@ -89,32 +149,31 @@ let library_is_loaded dir = with Not_found -> false let library_is_opened dir = - List.exists (fun m -> DirPath.equal m.library_name dir) !libraries_imports_list + List.exists (fun name -> DirPath.equal name dir) !libraries_imports_list -let loaded_libraries () = - List.map (fun m -> m.library_name) !libraries_loaded_list +let loaded_libraries () = !libraries_loaded_list -let opened_libraries () = - List.map (fun m -> m.library_name) !libraries_imports_list +let opened_libraries () = !libraries_imports_list (* If a library is loaded several time, then the first occurrence must be performed first, thus the libraries_loaded_list ... *) let register_loaded_library m = + let libname = m.libsum_name in let link m = - let dirname = Filename.dirname (library_full_filename m.library_name) in - let prefix = Nativecode.mod_uid_of_dirpath m.library_name ^ "." in + let dirname = Filename.dirname (library_full_filename libname) in + let prefix = Nativecode.mod_uid_of_dirpath libname ^ "." in let f = prefix ^ "cmo" in let f = Dynlink.adapt_filename f in if not !Flags.no_native_compiler then Nativelib.link_library ~prefix ~dirname ~basename:f in let rec aux = function - | [] -> link m; [m] - | m'::_ as l when DirPath.equal m'.library_name m.library_name -> l + | [] -> link m; [libname] + | m'::_ as l when DirPath.equal m' libname -> l | m'::l' -> m' :: aux l' in libraries_loaded_list := aux !libraries_loaded_list; - libraries_table := LibraryMap.add m.library_name m !libraries_table + libraries_table := LibraryMap.add libname m !libraries_table (* ... while if a library is imported/exported several time, then only the last occurrence is really needed - though the imported @@ -125,7 +184,7 @@ let register_loaded_library m = let rec remember_last_of_each l m = match l with | [] -> [m] - | m'::l' when DirPath.equal m'.library_name m.library_name -> remember_last_of_each l' m + | m'::l' when DirPath.equal m' m -> remember_last_of_each l' m | m'::l' -> m' :: remember_last_of_each l' m let register_open_library export m = @@ -139,17 +198,15 @@ let register_open_library export m = (* [open_library export explicit m] opens library [m] if not already opened _or_ if explicitly asked to be (re)opened *) -let eq_lib_name m1 m2 = DirPath.equal m1.library_name m2.library_name - let open_library export explicit_libs m = if (* Only libraries indirectly to open are not reopen *) (* Libraries explicitly mentionned by the user are always reopen *) - List.exists (eq_lib_name m) explicit_libs - || not (library_is_opened m.library_name) + List.exists (fun m' -> DirPath.equal m m') explicit_libs + || not (library_is_opened m) then begin register_open_library export m; - Declaremods.really_import_module (MPfile m.library_name) + Declaremods.really_import_module (MPfile m) end else if export then @@ -164,47 +221,44 @@ let open_libraries export modl = (fun l m -> let subimport = Array.fold_left - (fun l m -> remember_last_of_each l (try_find_library m)) - l m.library_imports - in remember_last_of_each subimport m) + (fun l m -> remember_last_of_each l m) + l m.libsum_imports + in remember_last_of_each subimport m.libsum_name) [] modl in - List.iter (open_library export modl) to_open_list + let explicit = List.map (fun m -> m.libsum_name) modl in + List.iter (open_library export explicit) to_open_list (**********************************************************************) -(* import and export - synchronous operations*) +(* import and export of libraries - synchronous operations *) +(* at the end similar to import and export of modules except that it *) +(* is optimized: when importing several libraries at the same time *) +(* which themselves indirectly imports the very same modules, these *) +(* ones are imported only ones *) -let open_import i (_,(dir,export)) = +let open_import_library i (_,(modl,export)) = if Int.equal i 1 then (* even if the library is already imported, we re-import it *) (* if not (library_is_opened dir) then *) - open_libraries export [try_find_library dir] + open_libraries export (List.map try_find_library modl) -let cache_import obj = - open_import 1 obj +let cache_import_library obj = + open_import_library 1 obj -let subst_import (_,o) = o +let subst_import_library (_,o) = o -let classify_import (_,export as obj) = +let classify_import_library (_,export as obj) = if export then Substitute obj else Dispose -let in_import : DirPath.t * bool -> obj = +let in_import_library : DirPath.t list * bool -> obj = declare_object {(default_object "IMPORT LIBRARY") with - cache_function = cache_import; - open_function = open_import; - subst_function = subst_import; - classify_function = classify_import } + cache_function = cache_import_library; + open_function = open_import_library; + subst_function = subst_import_library; + classify_function = classify_import_library } (************************************************************************) -(*s Low-level interning/externing of libraries to files *) - -(*s Loading from disk to cache (preparation phase) *) - -let (raw_extern_library, raw_intern_library) = - System.raw_extern_intern Coq_config.vo_magic_number - -(************************************************************************) (*s Locate absolute or partially qualified library names in the path *) exception LibUnmappedDir @@ -214,8 +268,9 @@ type library_location = LibLoaded | LibInPath let locate_absolute_library dir = (* Search in loadpath *) let pref, base = split_dirpath dir in - let loadpath = Loadpath.expand_root_path pref in + let loadpath = Loadpath.filter_path (fun dir -> DirPath.equal dir pref) in let () = match loadpath with [] -> raise LibUnmappedDir | _ -> () in + let loadpath = List.map fst loadpath in let find ext = try let name = Id.to_string base ^ ext in @@ -232,10 +287,20 @@ let locate_absolute_library dir = | [vo;vi] -> dir, vo | _ -> assert false -let locate_qualified_library warn qid = +let locate_qualified_library ?root ?(warn = true) qid = (* Search library in loadpath *) let dir, base = repr_qualid qid in - let loadpath = Loadpath.expand_path dir in + let loadpath = match root with + | None -> Loadpath.expand_path dir + | Some root -> + let filter path = + if is_dirpath_prefix_of root path then + let path = drop_dirpath_prefix root path in + is_dirpath_suffix_of dir path + else false + in + Loadpath.filter_path filter + in let () = match loadpath with [] -> raise LibUnmappedDir | _ -> () in let find ext = try @@ -279,14 +344,6 @@ let try_locate_absolute_library dir = | LibUnmappedDir -> error_unmapped_dir (qualid_of_dirpath dir) | LibNotFound -> error_lib_not_found (qualid_of_dirpath dir) -let try_locate_qualified_library (loc,qid) = - try - let (_,dir,f) = locate_qualified_library (Flags.is_verbose()) qid in - dir,f - with - | LibUnmappedDir -> error_unmapped_dir qid - | LibNotFound -> error_lib_not_found qid - (************************************************************************) (** {6 Tables of opaque proof terms} *) @@ -296,34 +353,10 @@ let try_locate_qualified_library (loc,qid) = terms, and access them only when a specific command (e.g. Print or Print Assumptions) needs it. *) -exception Faulty - -(** Fetching a table of opaque terms at position [pos] in file [f], - expecting to find first a copy of [digest]. *) - -let fetch_table what dp (f,pos,digest) = - let dir_path = Names.DirPath.to_string dp in - try - msg_info (str"Fetching " ++ str what++str" from disk for " ++ str dir_path); - let ch = System.with_magic_number_check raw_intern_library f in - let () = seek_in ch pos in - if not (String.equal (System.digest_in f ch) digest) then raise Faulty; - let table, pos', digest' = System.marshal_in_segment f ch in - let () = close_in ch in - let ch' = open_in f in - if not (String.equal (Digest.channel ch' pos') digest') then raise Faulty; - let () = close_in ch' in - table - with e when Errors.noncritical e -> - error - ("The file "^f^" (bound to " ^ dir_path ^ - ") is inaccessible or corrupted,\n" ^ - "cannot load some "^what^" in it.\n") - (** Delayed / available tables of opaque terms *) type 'a table_status = - | ToFetch of string * int * Digest.t + | ToFetch of 'a Future.computation array delayed | Fetched of 'a Future.computation array let opaque_tables = @@ -336,25 +369,33 @@ let add_opaque_table dp st = let add_univ_table dp st = univ_tables := LibraryMap.add dp st !univ_tables -let access_table fetch_table add_table tables dp i = - let t = match LibraryMap.find dp tables with +let access_table what tables dp i = + let t = match LibraryMap.find dp !tables with | Fetched t -> t - | ToFetch (f,pos,digest) -> - let t = fetch_table dp (f,pos,digest) in - add_table dp (Fetched t); + | ToFetch f -> + let dir_path = Names.DirPath.to_string dp in + msg_info (str"Fetching " ++ str what++str" from disk for " ++ str dir_path); + let t = + try fetch_delayed f + with Faulty f -> + error + ("The file "^f^" (bound to " ^ dir_path ^ + ") is inaccessible or corrupted,\n" ^ + "cannot load some "^what^" in it.\n") + in + tables := LibraryMap.add dp (Fetched t) !tables; t in assert (i < Array.length t); t.(i) let access_opaque_table dp i = - access_table - (fetch_table "opaque proofs") - add_opaque_table !opaque_tables dp i + let what = "opaque proofs" in + access_table what opaque_tables dp i + let access_univ_table dp i = try - Some (access_table - (fetch_table "universe contexts of opaque proofs") - add_univ_table !univ_tables dp i) + let what = "universe contexts of opaque proofs" in + Some (access_table what univ_tables dp i) with Not_found -> None let () = @@ -381,15 +422,22 @@ let mk_library md digests univs = library_extra_univs = univs; } +let mk_summary m = { + libsum_name = m.library_name; + libsum_imports = m.library_imports; + libsum_digests = m.library_digests; +} + let intern_from_file f = let ch = System.with_magic_number_check raw_intern_library f in let (lmd : seg_lib), pos, digest_lmd = System.marshal_in_segment f ch in let (univs : seg_univ option), _, digest_u = System.marshal_in_segment f ch in let _ = System.skip_in_segment f ch in - let pos, digest = System.skip_in_segment f ch in + let _ = System.skip_in_segment f ch in + let (del_opaque : seg_proofs delayed) = in_delayed f ch in close_in ch; register_library_filename lmd.md_name f; - add_opaque_table lmd.md_name (ToFetch (f,pos,digest)); + add_opaque_table lmd.md_name (ToFetch del_opaque); let open Safe_typing in match univs with | None -> mk_library lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty @@ -402,16 +450,13 @@ let intern_from_file f = module DPMap = Map.Make(DirPath) -let deps_to_string deps = - Array.fold_left (fun s (n, _) -> s^"\n - "^(DirPath.to_string n)) "" deps - let rec intern_library (needed, contents) (dir, f) from = Pp.feedback(Feedback.FileDependency (from, f)); (* Look if in the current logical environment *) - try find_library dir, (needed, contents) + try (find_library dir).libsum_digests, (needed, contents) with Not_found -> (* Look if already listed and consequently its dependencies too *) - try DPMap.find dir contents, (needed, contents) + try (DPMap.find dir contents).library_digests, (needed, contents) with Not_found -> (* [dir] is an absolute name which matches [f] which must be in loadpath *) let m = intern_from_file f in @@ -421,15 +466,15 @@ let rec intern_library (needed, contents) (dir, f) from = pr_dirpath m.library_name ++ spc () ++ str "and not library" ++ spc() ++ pr_dirpath dir); Pp.feedback(Feedback.FileLoaded(DirPath.to_string dir, f)); - m, intern_library_deps (needed, contents) dir m (Some f) + m.library_digests, intern_library_deps (needed, contents) dir m (Some f) and intern_library_deps libs dir m from = let needed, contents = Array.fold_left (intern_mandatory_library dir from) libs m.library_deps in (dir :: needed, DPMap.add dir m contents ) and intern_mandatory_library caller from libs (dir,d) = - let m, libs = intern_library libs (try_locate_absolute_library dir) from in - if not (Safe_typing.digest_match ~actual:m.library_digests ~required:d) then + let digest, libs = intern_library libs (try_locate_absolute_library dir) from in + if not (Safe_typing.digest_match ~actual:digest ~required:d) then errorlabstrm "" (strbrk ("Compiled library "^ DirPath.to_string caller ^ ".vo makes inconsistent assumptions over library " ^ DirPath.to_string dir)); @@ -500,7 +545,7 @@ let register_library m = m.library_objects m.library_digests m.library_extra_univs; - register_loaded_library m + register_loaded_library (mk_summary m) (* Follow the semantics of Anticipate object: - called at module or module type closing when a Require occurs in @@ -543,23 +588,19 @@ let require_library_from_dirpath modrefl export = begin add_anonymous_leaf (in_require (needed,modrefl,None)); Option.iter (fun exp -> - List.iter (fun dir -> add_anonymous_leaf (in_import(dir,exp))) modrefl) + add_anonymous_leaf (in_import_library (modrefl,exp))) export end else add_anonymous_leaf (in_require (needed,modrefl,export)); add_frozen_state () -let require_library qidl export = - let modrefl = List.map try_locate_qualified_library qidl in - require_library_from_dirpath modrefl export - let require_library_from_file idopt file export = let modref,needed = rec_intern_library_from_file idopt file in let needed = List.rev_map snd needed in if Lib.is_module_or_modtype () then begin add_anonymous_leaf (in_require (needed,[modref],None)); - Option.iter (fun exp -> add_anonymous_leaf (in_import (modref,exp))) + Option.iter (fun exp -> add_anonymous_leaf (in_import_library ([modref],exp))) export end else @@ -568,21 +609,38 @@ let require_library_from_file idopt file export = (* the function called by Vernacentries.vernac_import *) -let import_module export (loc,qid) = - try - match Nametab.locate_module qid with - | MPfile dir -> - if Lib.is_module_or_modtype () || not export then - add_anonymous_leaf (in_import (dir, export)) - else - add_anonymous_leaf (in_import (dir, export)) - | mp -> - Declaremods.import_module export mp - with - Not_found -> - user_err_loc - (loc,"import_library", - str ((string_of_qualid qid)^" is not a module")) +let safe_locate_module (loc,qid) = + try Nametab.locate_module qid + with Not_found -> + user_err_loc + (loc,"import_library", str (string_of_qualid qid ^ " is not a module")) + +let import_module export modl = + (* Optimization: libraries in a raw in the list are imported + "globally". If there is non-library in the list; it breaks the + optimization For instance: "Import Arith MyModule Zarith" will + not be optimized (possibly resulting in redefinitions, but + "Import MyModule Arith Zarith" and "Import Arith Zarith MyModule" + will have the submodules imported by both Arith and ZArith + imported only once *) + let flush = function + | [] -> () + | modl -> add_anonymous_leaf (in_import_library (List.rev modl, export)) in + let rec aux acc = function + | (loc,dir as m) :: l -> + let m,acc = + try Nametab.locate_module dir, acc + with Not_found-> flush acc; safe_locate_module m, [] in + (match m with + | MPfile dir -> aux (dir::acc) l + | mp -> + flush acc; + try Declaremods.import_module export mp; aux [] l + with Not_found -> + user_err_loc (loc,"import_library", + str ((string_of_qualid dir)^" is not a module"))) + | [] -> flush acc + in aux [] modl (************************************************************************) (*s Initializing the compilation of a library. *) @@ -654,10 +712,13 @@ let load_library_todo f = (*s [save_library dir] ends library [dir] and save it to the disk. *) let current_deps () = - List.map (fun m -> m.library_name, m.library_digests) !libraries_loaded_list + let map name = + let m = try_find_library name in + (name, m.libsum_digests) + in + List.map map !libraries_loaded_list -let current_reexports () = - List.map (fun m -> m.library_name) !libraries_exports_list +let current_reexports () = !libraries_exports_list let error_recursively_dependent_library dir = errorlabstrm "" @@ -683,7 +744,7 @@ let save_library_to ?todo dir f otab = f ^ "o", Future.UUIDSet.empty | Some (l,_) -> f ^ "io", - List.fold_left (fun e r -> Future.UUIDSet.add r.Stateid.uuid e) + List.fold_left (fun e (r,_) -> Future.UUIDSet.add r.Stateid.uuid e) Future.UUIDSet.empty l in let cenv, seg, ast = Declaremods.end_library ~except dir in let opaque_table, univ_table, disch_table, f2t_map = Opaqueproof.dump otab in @@ -692,14 +753,17 @@ let save_library_to ?todo dir f otab = | None -> None, None, None | Some (tasks, rcbackup) -> let tasks = - List.map Stateid.(fun r -> - { r with uuid = Future.UUIDMap.find r.uuid f2t_map }) tasks in + List.map Stateid.(fun (r,b) -> + try { r with uuid = Future.UUIDMap.find r.uuid f2t_map }, b + with Not_found -> assert b; { r with uuid = -1 }, b) + tasks in Some (tasks,rcbackup), Some (univ_table,Univ.ContextSet.empty,false), Some disch_table in let except = Future.UUIDSet.fold (fun uuid acc -> - Int.Set.add (Future.UUIDMap.find uuid f2t_map) acc) + try Int.Set.add (Future.UUIDMap.find uuid f2t_map) acc + with Not_found -> acc) except Int.Set.empty in let is_done_or_todo i x = Future.is_val x || Int.Set.mem i except in Array.iteri (fun i x -> @@ -750,11 +814,7 @@ let save_library_raw f lib univs proofs = open Printf -let mem s = - let m = try_find_library s in - h 0 (str (sprintf "%dk (cenv = %dk / seg = %dk)" - (CObj.size_kb m) (CObj.size_kb m.library_compiled) - (CObj.size_kb m.library_objects))) +let mem s = Pp.mt () module StringOrd = struct type t = string let compare = String.compare end module StringSet = Set.Make(StringOrd) @@ -762,7 +822,7 @@ module StringSet = Set.Make(StringOrd) let get_used_load_paths () = StringSet.elements (List.fold_left (fun acc m -> StringSet.add - (Filename.dirname (library_full_filename m.library_name)) acc) + (Filename.dirname (library_full_filename m)) acc) StringSet.empty !libraries_loaded_list) let _ = Nativelib.get_load_paths := get_used_load_paths diff --git a/library/library.mli b/library/library.mli index 13d83a5c..35067068 100644 --- a/library/library.mli +++ b/library/library.mli @@ -21,7 +21,6 @@ open Libnames (** {6 ... } *) (** Require = load in the environment + open (if the optional boolean is not [None]); mark also for export if the boolean is [Some true] *) -val require_library : qualid located list -> bool option -> unit val require_library_from_dirpath : (DirPath.t * string) list -> bool option -> unit val require_library_from_file : Id.t option -> CUnix.physical_path -> bool option -> unit @@ -37,14 +36,14 @@ type seg_proofs = Term.constr Future.computation array (** Open a module (or a library); if the boolean is true then it's also an export otherwise just a simple import *) -val import_module : bool -> qualid located -> unit +val import_module : bool -> qualid located list -> unit (** {6 Start the compilation of a library } *) val start_library : string -> DirPath.t * string (** {6 End the compilation of a library and save it to a ".vo" file } *) val save_library_to : - ?todo:((Future.UUID.t,'document) Stateid.request list * 'counters) -> + ?todo:(((Future.UUID.t,'document) Stateid.request * bool) list * 'counters) -> DirPath.t -> string -> Opaqueproof.opaquetab -> unit val load_library_todo : @@ -73,8 +72,14 @@ exception LibNotFound type library_location = LibLoaded | LibInPath val locate_qualified_library : - bool -> qualid -> library_location * DirPath.t * CUnix.physical_path -val try_locate_qualified_library : qualid located -> DirPath.t * string + ?root:DirPath.t -> ?warn:bool -> qualid -> + library_location * DirPath.t * CUnix.physical_path +(** Locates a library by implicit name. + + @raise LibUnmappedDir if the library is not in the path + @raise LibNotFound if there is no corresponding file in the path + +*) (** {6 Statistics: display the memory use of a library. } *) val mem : DirPath.t -> Pp.std_ppcmds diff --git a/library/loadpath.ml b/library/loadpath.ml index 5876eedd..26af809e 100644 --- a/library/loadpath.ml +++ b/library/loadpath.ml @@ -12,14 +12,12 @@ open Errors open Names open Libnames -type path_type = ImplicitPath | ImplicitRootPath | RootPath - (** Load paths. Mapping from physical to logical paths. *) type t = { path_physical : CUnix.physical_path; path_logical : DirPath.t; - path_type : path_type; + path_implicit : bool; } let load_paths = Summary.ref ([] : t list) ~name:"LOADPATHS" @@ -54,32 +52,35 @@ let remove_load_path dir = let filter p = not (String.equal p.path_physical dir) in load_paths := List.filter filter !load_paths -let add_load_path phys_path path_type coq_path = +let add_load_path phys_path coq_path ~implicit = let phys_path = CUnix.canonical_path_name phys_path in let filter p = String.equal p.path_physical phys_path in let binding = { path_logical = coq_path; path_physical = phys_path; - path_type = path_type; + path_implicit = implicit; } in match List.filter filter !load_paths with | [] -> load_paths := binding :: !load_paths - | [p] -> - let dir = p.path_logical in - if not (DirPath.equal coq_path dir) - (* If this is not the default -I . to coqtop *) - && not - (String.equal phys_path (CUnix.canonical_path_name Filename.current_dir_name) - && DirPath.equal coq_path (Nameops.default_root_prefix)) - then + | [{ path_logical = old_path; path_implicit = old_implicit }] -> + let replace = + if DirPath.equal coq_path old_path then + implicit <> old_implicit + else if DirPath.equal coq_path (Nameops.default_root_prefix) + && String.equal phys_path (CUnix.canonical_path_name Filename.current_dir_name) then + false (* This is the default "-I ." path, don't override the old path *) + else + let () = + (* Do not warn when overriding the default "-I ." path *) + if not (DirPath.equal old_path Nameops.default_root_prefix) then + msg_warning + (str phys_path ++ strbrk " was previously bound to " ++ + pr_dirpath old_path ++ strbrk "; it is remapped to " ++ + pr_dirpath coq_path) in + true in + if replace then begin - (* Assume the user is concerned by library naming *) - if not (DirPath.equal dir Nameops.default_root_prefix) then - msg_warning - (str phys_path ++ strbrk " was previously bound to " ++ - pr_dirpath dir ++ strbrk "; it is remapped to " ++ - pr_dirpath coq_path); remove_load_path phys_path; load_paths := binding :: !load_paths; end @@ -89,47 +90,25 @@ let extend_path_with_dirpath p dir = List.fold_left Filename.concat p (List.rev_map Id.to_string (DirPath.repr dir)) -let expand_root_path dir = +let filter_path f = let rec aux = function | [] -> [] | p :: l -> - if p.path_type <> ImplicitPath && is_dirpath_prefix_of p.path_logical dir then - let suffix = drop_dirpath_prefix p.path_logical dir in - extend_path_with_dirpath p.path_physical suffix :: aux l + if f p.path_logical then (p.path_physical, p.path_logical) :: aux l else aux l in aux !load_paths -(* Root p is bound to A.B.C.D and we require file C.D.E.F *) -(* We may mean A.B.C.D.E.F, or A.B.C.D.C.D.E.F *) - -(* Root p is bound to A.B.C.C and we require file C.C.E.F *) -(* We may mean A.B.C.C.E.F, or A.B.C.C.C.E.F, or A.B.C.C.C.C.E.F *) - -let intersections d1 d2 = - let rec aux d1 = - if DirPath.is_empty d1 then [d2] else - let rest = aux (snd (chop_dirpath 1 d1)) in - if is_dirpath_prefix_of d1 d2 then drop_dirpath_prefix d1 d2 :: rest - else rest in - aux d1 - -let expand p dir = - let ph = extend_path_with_dirpath p.path_physical dir in - let log = append_dirpath p.path_logical dir in - (ph, log) - let expand_path dir = let rec aux = function | [] -> [] - | p :: l -> - match p.path_type with - | ImplicitPath -> expand p dir :: aux l - | ImplicitRootPath -> - let inters = intersections p.path_logical dir in - List.map (expand p) inters @ aux l - | RootPath -> - if is_dirpath_prefix_of p.path_logical dir then - expand p (drop_dirpath_prefix p.path_logical dir) :: aux l - else aux l in + | { path_physical = ph; path_logical = lg; path_implicit = implicit } :: l -> + match implicit with + | true -> + (** The path is implicit, so that we only want match the logical suffix *) + if is_dirpath_suffix_of dir lg then (ph, lg) :: aux l else aux l + | false -> + (** Otherwise we must match exactly *) + if DirPath.equal dir lg then (ph, lg) :: aux l else aux l + in aux !load_paths diff --git a/library/loadpath.mli b/library/loadpath.mli index 62dc5d59..3251b8c6 100644 --- a/library/loadpath.mli +++ b/library/loadpath.mli @@ -15,11 +15,6 @@ open Names *) -type path_type = - | ImplicitPath (** Can be implicitly appended to a logical path. *) - | ImplicitRootPath (** Can be implicitly appended to the suffix of a logical path. *) - | RootPath (** Can only be a prefix of a logical path. *) - type t (** Type of loadpath bindings. *) @@ -35,8 +30,8 @@ val get_load_paths : unit -> t list val get_paths : unit -> CUnix.physical_path list (** Same as [get_load_paths] but only get the physical part. *) -val add_load_path : CUnix.physical_path -> path_type -> DirPath.t -> unit -(** [add_load_path phys type log] adds the binding [phys := log] to the current +val add_load_path : CUnix.physical_path -> DirPath.t -> implicit:bool -> unit +(** [add_load_path phys log type] adds the binding [phys := log] to the current loadpaths. *) val remove_load_path : CUnix.physical_path -> unit @@ -52,7 +47,8 @@ val is_in_load_paths : CUnix.physical_path -> bool val expand_path : DirPath.t -> (CUnix.physical_path * DirPath.t) list (** Given a relative logical path, associate the list of absolute physical and - logical paths which are possible expansions of it. *) + logical paths which are possible matches of it. *) -val expand_root_path : DirPath.t -> CUnix.physical_path list -(** As [expand_path] but restricts to root loadpaths. *) +val filter_path : (DirPath.t -> bool) -> (CUnix.physical_path * DirPath.t) list +(** As {!expand_path} but uses a filter function instead, and ignores the + implicit status of loadpaths. *) diff --git a/library/states.ml b/library/states.ml index a1c2a095..96a487b1 100644 --- a/library/states.ml +++ b/library/states.ml @@ -12,6 +12,7 @@ open System type state = Lib.frozen * Summary.frozen let summary_of_state = snd +let replace_summary (lib,_) s = lib, s let freeze ~marshallable = (Lib.freeze ~marshallable, Summary.freeze_summaries ~marshallable) diff --git a/library/states.mli b/library/states.mli index 66de1490..4d5d63e0 100644 --- a/library/states.mli +++ b/library/states.mli @@ -21,6 +21,7 @@ val freeze : marshallable:Summary.marshallable -> state val unfreeze : state -> unit val summary_of_state : state -> Summary.frozen +val replace_summary : state -> Summary.frozen -> state (** {6 Rollback } *) diff --git a/library/summary.ml b/library/summary.ml index 7e7628a1..8e2abbf1 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -66,6 +66,7 @@ let freeze_summaries ~marshallable : frozen = let fold id (_, decl) accu = (* to debug missing Lazy.force if marshallable <> `No then begin + let id, _ = Int.Map.find id !summaries in prerr_endline ("begin marshalling " ^ id); ignore(Marshal.to_string (decl.freeze_function marshallable) []); prerr_endline ("end marshalling " ^ id); diff --git a/library/universes.ml b/library/universes.ml index 79070763..9fddc706 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -165,7 +165,7 @@ let leq_constr_univs_infer univs m n = m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in let rec compare_leq m n = - Constr.compare_head_gen_leq eq_universes eq_sorts leq_sorts + Constr.compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n and leq_constr' m n = m == n || compare_leq m n in let res = compare_leq m n in @@ -213,7 +213,7 @@ let leq_constr_universes m n = m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in let rec compare_leq m n = - Constr.compare_head_gen_leq eq_universes eq_sorts leq_sorts eq_constr' leq_constr' m n + Constr.compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n and leq_constr' m n = m == n || compare_leq m n in let res = compare_leq m n in res, !cstrs @@ -772,7 +772,7 @@ let minimize_univ_variables ctx us algs left right cstrs = else try let lev = Option.get (Universe.level inst) in Constraint.add (lev, d, r) cstrs - with Option.IsNone -> assert false) + with Option.IsNone -> failwith "") cstrs dangling in (ctx', us, algs, insts, cstrs'), b @@ -784,7 +784,8 @@ let minimize_univ_variables ctx us algs left right cstrs = | None -> (* Nothing to do *) acc' (acc, (true, false, Universe.make u)) | Some lbound -> - acc' (instantiate_lbound lbound) + try acc' (instantiate_lbound lbound) + with Failure _ -> acc' (acc, (true, false, Universe.make u)) and aux (ctx', us, algs, seen, cstrs as acc) u = try acc, LMap.find u seen with Not_found -> instance acc u diff --git a/library/universes.mli b/library/universes.mli index f2f68d32..252648d7 100644 --- a/library/universes.mli +++ b/library/universes.mli @@ -7,12 +7,9 @@ (************************************************************************) open Util -open Pp open Names open Term -open Context open Environ -open Locus open Univ (** Universes *) diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 8246df28..3bb029a8 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -157,7 +157,7 @@ GEXTEND Gram ] ] ; universe: - [ [ "max("; ids = LIST1 ident SEP ","; ")" -> ids + [ [ IDENT "max"; "("; ids = LIST1 ident SEP ","; ")" -> ids | id = ident -> [id] ] ] ; diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index b4d96e5c..a4dba506 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -33,7 +33,7 @@ let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat GEXTEND Gram GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg - constr_may_eval; + constr_may_eval constr_eval; tactic_then_last: [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> @@ -153,8 +153,12 @@ GEXTEND Gram | IDENT "type_term"; c=uconstr -> TacPretype c | IDENT "numgoals" -> TacNumgoals ] ] ; + (* If a qualid is given, use its short name. TODO: have the shortest + non ambiguous name where dots are replaced by "_"? Probably too + verbose most of the time. *) fresh_id: - [ [ s = STRING -> ArgArg s | id = ident -> ArgVar (!@loc,id) ] ] + [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*) + | qid = qualid -> let (_pth,id) = Libnames.repr_qualid (snd qid) in ArgVar (!@loc,id) ] ] ; constr_eval: [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 27f14c79..1e254c16 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -52,15 +52,17 @@ GEXTEND Gram | IDENT "Existential"; n = natural; c = constr_body -> VernacSolveExistential (n,c) | IDENT "Admitted" -> VernacEndProof Admitted - | IDENT "Qed" -> VernacEndProof (Proved (true,None)) - | IDENT "Save" -> VernacEndProof (Proved (true,None)) + | IDENT "Qed" -> VernacEndProof (Proved (Opaque None,None)) + | IDENT "Qed"; IDENT "exporting"; l = LIST0 identref SEP "," -> + VernacEndProof (Proved (Opaque (Some l),None)) + | IDENT "Save" -> VernacEndProof (Proved (Opaque None,None)) | IDENT "Save"; tok = thm_token; id = identref -> - VernacEndProof (Proved (true,Some (id,Some tok))) + VernacEndProof (Proved (Opaque None,Some (id,Some tok))) | IDENT "Save"; id = identref -> - VernacEndProof (Proved (true,Some (id,None))) - | IDENT "Defined" -> VernacEndProof (Proved (false,None)) + VernacEndProof (Proved (Opaque None,Some (id,None))) + | IDENT "Defined" -> VernacEndProof (Proved (Transparent,None)) | IDENT "Defined"; id=identref -> - VernacEndProof (Proved (false,Some (id,None))) + VernacEndProof (Proved (Transparent,Some (id,None))) | IDENT "Restart" -> VernacRestart | IDENT "Undo" -> VernacUndo 1 | IDENT "Undo"; n = natural -> VernacUndo n diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index b42b2c6d..69593f99 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -202,7 +202,7 @@ let merge_occurrences loc cl = function GEXTEND Gram GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis bindings red_expr int_or_var open_constr uconstr - simple_intropattern clause_dft_concl; + simple_intropattern clause_dft_concl hypident; int_or_var: [ [ n = integer -> ArgArg n diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 70a8ec55..cf7f6af2 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -465,11 +465,10 @@ GEXTEND Gram (* Requiring an already compiled module *) | IDENT "Require"; export = export_token; qidl = LIST1 global -> - VernacRequire (export, qidl) + VernacRequire (None, export, qidl) | IDENT "From" ; ns = global ; IDENT "Require"; export = export_token ; qidl = LIST1 global -> - let qidl = List.map (Libnames.join_reference ns) qidl in - VernacRequire (export, qidl) + VernacRequire (Some ns, export, qidl) | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl) | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) | IDENT "Include"; e = module_type_inl; l = LIST0 ext_module_expr -> diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index cf6435fe..54edbb2c 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -375,7 +375,9 @@ module Tactic = make_gen_entry utactic (rawwit wit_constr_with_bindings) "constr_with_bindings" let bindings = make_gen_entry utactic (rawwit wit_bindings) "bindings" + let hypident = Gram.entry_create "hypident" let constr_may_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" + let constr_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval" let uconstr = make_gen_entry utactic (rawwit wit_uconstr) "uconstr" let quantified_hypothesis = diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index dbd2aadf..2146ad96 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -215,7 +215,9 @@ module Tactic : val open_constr : open_constr_expr Gram.entry val constr_with_bindings : constr_expr with_bindings Gram.entry val bindings : constr_expr bindings Gram.entry + val hypident : (Id.t located * Locus.hyp_location_flag) Gram.entry val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry + val constr_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry val uconstr : constr_expr Gram.entry val quantified_hypothesis : quantified_hypothesis Gram.entry val int_or_var : int or_var Gram.entry diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli index 0e0eb6d2..2ff2bd38 100644 --- a/plugins/cc/ccproof.mli +++ b/plugins/cc/ccproof.mli @@ -7,7 +7,6 @@ (************************************************************************) open Ccalgo -open Names open Term type rule= diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 7110e5b2..8884aef1 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -23,7 +23,7 @@ open Pp open Errors open Util -let reference dir s = Coqlib.gen_reference "CC" dir s +let reference dir s = lazy (Coqlib.gen_reference "CC" dir s) let _f_equal = reference ["Init";"Logic"] "f_equal" let _eq_rect = reference ["Init";"Logic"] "eq_rect" @@ -91,7 +91,7 @@ let atom_of_constr env sigma term = let kot = kind_of_term wh in match kot with App (f,args)-> - if is_global _eq f && Int.equal (Array.length args) 3 + if is_global (Lazy.force _eq) f && Int.equal (Array.length args) 3 then `Eq (args.(0), decompose_term env sigma args.(1), decompose_term env sigma args.(2)) @@ -126,7 +126,7 @@ let non_trivial = function let patterns_of_constr env sigma nrels term= let f,args= try destApp (whd_delta env term) with DestKO -> raise Not_found in - if is_global _eq f && Int.equal (Array.length args) 3 + if is_global (Lazy.force _eq) f && Int.equal (Array.length args) 3 then let patt1,rels1 = pattern_of_constr env sigma args.(1) and patt2,rels2 = pattern_of_constr env sigma args.(2) in @@ -147,7 +147,7 @@ let patterns_of_constr env sigma nrels term= let rec quantified_atom_of_constr env sigma nrels term = match kind_of_term (whd_delta env term) with Prod (id,atom,ff) -> - if is_global _False ff then + if is_global (Lazy.force _False) ff then let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else @@ -159,7 +159,7 @@ let rec quantified_atom_of_constr env sigma nrels term = let litteral_of_constr env sigma term= match kind_of_term (whd_delta env term) with | Prod (id,atom,ff) -> - if is_global _False ff then + if is_global (Lazy.force _False) ff then match (atom_of_constr env sigma atom) with `Eq(t,a,b) -> `Neq(t,a,b) | `Other(p) -> `Nother(p) @@ -246,10 +246,10 @@ let build_projection intype outtype (cstr:pconstructor) special default gls= let _M =mkMeta let app_global f args k = - Tacticals.pf_constr_of_global f (fun fc -> k (mkApp (fc, args))) + Tacticals.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args))) let new_app_global f args k = - Tacticals.New.pf_constr_of_global f (fun fc -> k (mkApp (fc, args))) + Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args))) let new_refine c = Proofview.V82.tactic (refine c) @@ -375,9 +375,9 @@ let discriminate_tac (cstr,u as cstru) p = let xid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in (* let tid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "t")) gl in *) (* let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in *) - let identity = Universes.constr_of_global _I in + let identity = Universes.constr_of_global (Lazy.force _I) in (* let trivial=pf_type_of gls identity in *) - let trivial = Universes.constr_of_global _True in + let trivial = Universes.constr_of_global (Lazy.force _True) in let evm, outtype = Evd.new_sort_variable Evd.univ_flexible (Proofview.Goal.sigma gl) in let outtype = mkSort outtype in let pred=mkLambda(Name xid,outtype,mkRel 1) in @@ -493,7 +493,7 @@ let f_equal = in Proofview.tclORELSE begin match kind_of_term concl with - | App (r,[|_;t;t'|]) when Globnames.is_global _eq r -> + | App (r,[|_;t;t'|]) when Globnames.is_global (Lazy.force _eq) r -> begin match kind_of_term t, kind_of_term t' with | App (f,v), App (f',v') when Int.equal (Array.length v) (Array.length v') -> let rec cuts i = diff --git a/plugins/decl_mode/decl_expr.mli b/plugins/decl_mode/decl_expr.mli index 7467604a..3c4cacbc 100644 --- a/plugins/decl_mode/decl_expr.mli +++ b/plugins/decl_mode/decl_expr.mli @@ -46,23 +46,23 @@ type ('constr,'tac) casee = Real of 'constr | Virtual of ('constr statement,'constr,'tac) cut -type ('hyp,'constr,'pat,'tac) bare_proof_instr = - | Pthen of ('hyp,'constr,'pat,'tac) bare_proof_instr - | Pthus of ('hyp,'constr,'pat,'tac) bare_proof_instr - | Phence of ('hyp,'constr,'pat,'tac) bare_proof_instr +type ('var,'constr,'pat,'tac) bare_proof_instr = + | Pthen of ('var,'constr,'pat,'tac) bare_proof_instr + | Pthus of ('var,'constr,'pat,'tac) bare_proof_instr + | Phence of ('var,'constr,'pat,'tac) bare_proof_instr | Pcut of ('constr or_thesis statement,'constr,'tac) cut | Prew of side * ('constr statement,'constr,'tac) cut - | Psuffices of ((('hyp,'constr) hyp list * 'constr or_thesis),'constr,'tac) cut - | Passume of ('hyp,'constr) hyp list - | Plet of ('hyp,'constr) hyp list - | Pgiven of ('hyp,'constr) hyp list - | Pconsider of 'constr*('hyp,'constr) hyp list + | Psuffices of ((('var,'constr) hyp list * 'constr or_thesis),'constr,'tac) cut + | Passume of ('var,'constr) hyp list + | Plet of ('var,'constr) hyp list + | Pgiven of ('var,'constr) hyp list + | Pconsider of 'constr*('var,'constr) hyp list | Pclaim of 'constr statement | Pfocus of 'constr statement - | Pdefine of Id.t * 'hyp list * 'constr + | Pdefine of Id.t * 'var list * 'constr | Pcast of Id.t or_thesis * 'constr - | Psuppose of ('hyp,'constr) hyp list - | Pcase of 'hyp list*'pat*(('hyp,'constr or_thesis) hyp list) + | Psuppose of ('var,'constr) hyp list + | Pcase of 'var list*'pat*(('var,'constr or_thesis) hyp list) | Ptake of 'constr list | Pper of elim_type * ('constr,'tac) casee | Pend of block_type @@ -70,19 +70,19 @@ type ('hyp,'constr,'pat,'tac) bare_proof_instr = type emphasis = int -type ('hyp,'constr,'pat,'tac) gen_proof_instr= +type ('var,'constr,'pat,'tac) gen_proof_instr= {emph: emphasis; - instr: ('hyp,'constr,'pat,'tac) bare_proof_instr } + instr: ('var,'constr,'pat,'tac) bare_proof_instr } type raw_proof_instr = - ((Id.t*(Constrexpr.constr_expr option)) Loc.located, + ((Id.t * (Constrexpr.constr_expr option)) Loc.located, Constrexpr.constr_expr, Constrexpr.cases_pattern_expr, raw_tactic_expr) gen_proof_instr type glob_proof_instr = - ((Id.t*(Tacexpr.glob_constr_and_expr option)) Loc.located, + ((Id.t * (Tacexpr.glob_constr_and_expr option)) Loc.located, Tacexpr.glob_constr_and_expr, Constrexpr.cases_pattern_expr, Tacexpr.glob_tactic_expr) gen_proof_instr diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml index d169dc13..774c20c9 100644 --- a/plugins/decl_mode/decl_mode.ml +++ b/plugins/decl_mode/decl_mode.ml @@ -89,25 +89,22 @@ let get_info sigma gl= let try_get_info sigma gl = Store.get (Goal.V82.extra sigma gl) info -let get_stack pts = +let get_goal_stack pts = let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in let info = get_info sigma (List.hd goals) in info.pm_stack let proof_focus = Proof.new_focus_kind () -let proof_cond = Proof.no_cond proof_focus +let proof_cond = Proof.done_cond proof_focus let focus p = - let inf = get_stack p in + let inf = get_goal_stack p in Proof_global.simple_with_current_proof (fun _ -> Proof.focus proof_cond inf 1) let unfocus () = Proof_global.simple_with_current_proof (fun _ p -> Proof.unfocus proof_focus p ()) -let maximal_unfocus () = - Proof_global.simple_with_current_proof (fun _ -> Proof.maximal_unfocus proof_focus) - let get_top_stack pts = try Proof.get_at_focus proof_focus pts @@ -116,7 +113,24 @@ let get_top_stack pts = let info = get_info sigma gl in info.pm_stack +let get_stack pts = Proof.get_at_focus proof_focus pts + let get_last env = match Environ.named_context env with | (id,_,_)::_ -> id | [] -> error "no previous statement to use" + +let get_end_command pts = + match get_top_stack pts with + | [] -> "\"end proof\"" + | Claim::_ -> "\"end claim\"" + | Focus_claim::_-> "\"end focus\"" + | Suppose_case :: Per (et,_,_,_) :: _ | Per (et,_,_,_) :: _ -> + begin + match et with + Decl_expr.ET_Case_analysis -> + "\"end cases\" or start a new case" + | Decl_expr.ET_Induction -> + "\"end induction\" or start a new case" + end + | _ -> anomaly (Pp.str"lonely suppose") diff --git a/plugins/decl_mode/decl_mode.mli b/plugins/decl_mode/decl_mode.mli index 2864ba18..fd7e15c1 100644 --- a/plugins/decl_mode/decl_mode.mli +++ b/plugins/decl_mode/decl_mode.mli @@ -72,8 +72,8 @@ val get_last: Environ.env -> Id.t (** [get_last] raises a [UserError] when it cannot find a previous statement in the environment. *) +val get_end_command : Proof.proof -> string + val focus : Proof.proof -> unit val unfocus : unit -> unit - -val maximal_unfocus : unit -> unit diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 9d25681d..9d0b7f34 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -131,12 +131,13 @@ let daimon_tac gls = (* post-instruction focus management *) -(* spiwack: This used to fail if there was no focusing command - above, but I don't think it ever happened. I hope it doesn't mess - things up*) let goto_current_focus () = - Decl_mode.maximal_unfocus () + Decl_mode.unfocus () +(* spiwack: used to catch errors indicating lack of "focusing command" + in the proof tree. In the current implementation, however, entering + the declarative mode puts a focus first, there should, therefore, + never be exception raised here. *) let goto_current_focus_or_top () = goto_current_focus () @@ -1444,27 +1445,35 @@ let rec postprocess pts instr = Type_errors.IllFormedRecBody(_,_,_,_,_)) -> anomaly (Pp.str "\"end induction\" generated an ill-formed fixpoint") end - | Pend _ -> - goto_current_focus_or_top () + | Pend (B_elim ET_Case_analysis) -> goto_current_focus () + | Pend B_proof -> Proof_global.set_proof_mode "Classic" + | Pend _ -> () let do_instr raw_instr pts = let has_tactic = preprocess pts raw_instr.instr in - begin + (* spiwack: hack! [preprocess] assumes that the [pts] is indeed the + current proof (and, actually so does [do_instr] later one, so + it's ok to do the same here. Ideally the proof should be properly + threaded through the commands here, but since the are interleaved + with actions on the proof mode, which is attached to the global + proof environment, it is not possible without heavy lifting. *) + let pts = Proof_global.give_me_the_proof () in + let pts = if has_tactic then let { it=gls ; sigma=sigma; } = Proof.V82.subgoals pts in let gl = { it=List.hd gls ; sigma=sigma; } in let env= pf_env gl in - let ist = {ltacvars = Id.Set.empty; ltacrecvars = Id.Map.empty; genv = env} in + let ist = {ltacvars = Id.Set.empty; genv = env} in let glob_instr = intern_proof_instr ist raw_instr in let instr = interp_proof_instr (get_its_info gl) env sigma glob_instr in - ignore (Pfedit.by (Proofview.V82.tactic (tclTHEN (eval_instr instr) clean_tmp))) - else () end; - postprocess pts raw_instr.instr; - (* spiwack: this should restore a compatible semantics with - v8.3 where we never stayed focused on 0 goal. *) - Proof_global.set_proof_mode "Declarative" ; - Decl_mode.maximal_unfocus () + let (pts',_) = Proof.run_tactic (Global.env()) + (Proofview.V82.tactic (tclTHEN (eval_instr instr) clean_tmp)) pts in + pts' + else pts + in + Proof_global.simple_with_current_proof (fun _ _ -> pts); + postprocess pts raw_instr.instr let proof_instr raw_instr = let p = Proof_global.give_me_the_proof () in diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 03929b3b..d598e7c3 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -19,6 +19,7 @@ open Tok (* necessary for camlp4 *) open Pcoq.Constr open Pcoq.Tactic +open Ppdecl_proof let pr_goal gs = let (g,sigma) = Goal.V82.nf_evar (Tacmach.project gs) (Evd.sig_it gs) in @@ -35,22 +36,20 @@ let pr_goal gs = str "============================" ++ fnl () ++ thesis ++ str " " ++ pc) ++ fnl () -(* arnaud: rebrancher ça ? -let pr_open_subgoals () = - let p = Proof_global.give_me_the_proof () in - let { Evd.it = goals ; sigma = sigma } = Proof.V82.subgoals p in - let close_cmd = Decl_mode.get_end_command p in - pr_subgoals close_cmd sigma goals -*) - -let pr_raw_proof_instr _ _ _ instr = - Errors.anomaly (Pp.str "Cannot print a proof_instr") - (* arnaud: Il nous faut quelque chose de type extr_genarg_printer si on veut aller - dans cette direction - Ppdecl_proof.pr_proof_instr (Global.env()) instr - *) -let pr_proof_instr _ _ _ instr = Empty.abort instr -let pr_glob_proof_instr _ _ _ instr = Empty.abort instr +let pr_subgoals ?(pr_first=true) _ sigma _ _ _ gll = + match gll with + | [goal] when pr_first -> + pr_goal { Evd.it = goal ; sigma = sigma } + | _ -> + (* spiwack: it's not very nice to have to call proof global + here, a more robust solution would be to add a hook for + [Printer.pr_open_subgoals] in proof modes, in order to + compute the end command. Yet a more robust solution would be + to have focuses give explanations of their unfocusing + behaviour. *) + let p = Proof_global.give_me_the_proof () in + let close_cmd = Decl_mode.get_end_command p in + str "Subproof completed, now type " ++ str close_cmd ++ str "." let interp_proof_instr _ { Evd.it = gl ; sigma = sigma }= Decl_interp.interp_proof_instr @@ -65,23 +64,18 @@ let vernac_decl_proof () = else begin Decl_proof_instr.go_to_proof_mode () ; - Proof_global.set_proof_mode "Declarative" ; - Vernacentries.print_subgoals () + Proof_global.set_proof_mode "Declarative" end (* spiwack: some bureaucracy is not performed here *) let vernac_return () = begin Decl_proof_instr.return_from_tactic_mode () ; - Proof_global.set_proof_mode "Declarative" ; - Vernacentries.print_subgoals () + Proof_global.set_proof_mode "Declarative" end let vernac_proof_instr instr = - begin - Decl_proof_instr.proof_instr instr; - Vernacentries.print_subgoals () - end + Decl_proof_instr.proof_instr instr (* Before we can write an new toplevel command (see below) which takes a [proof_instr] as argument, we need to declare @@ -92,7 +86,7 @@ let vernac_proof_instr instr = (* spiwack: proposal: doing that directly from argextend.ml4, maybe ? *) (* Only declared at raw level, because only used in vernac commands. *) -let wit_proof_instr : (raw_proof_instr, Empty.t, Empty.t) Genarg.genarg_type = +let wit_proof_instr : (raw_proof_instr, glob_proof_instr, proof_instr) Genarg.genarg_type = Genarg.make0 None "proof_instr" (* We create a new parser entry [proof_mode]. The Declarative proof mode @@ -106,14 +100,16 @@ let proof_instr : raw_proof_instr Gram.entry = let _ = Pptactic.declare_extra_genarg_pprule wit_proof_instr pr_raw_proof_instr pr_glob_proof_instr pr_proof_instr -let classify_proof_instr _ = VtProofStep false, VtLater +let classify_proof_instr = function + | { instr = Pescape |Pend B_proof } -> VtProofMode "Classic", VtNow + | _ -> VtProofStep false, VtLater (* We use the VERNAC EXTEND facility with a custom non-terminal to populate [proof_mode] with a new toplevel interpreter. The "-" indicates that the rule does not start with a distinguished string. *) -VERNAC proof_mode EXTEND ProofInstr CLASSIFIED BY classify_proof_instr - [ - proof_instr(instr) ] -> [ vernac_proof_instr instr ] +VERNAC proof_mode EXTEND ProofInstr + [ - proof_instr(instr) ] => [classify_proof_instr instr] -> [ vernac_proof_instr instr ] END (* It is useful to use GEXTEND directly to call grammar entries that have been @@ -143,7 +139,8 @@ let _ = (* We substitute the goal printer, by the one we built for the proof mode. *) Printer.set_printer_pr { Printer.default_printer_pr with - Printer.pr_goal = pr_goal } + Printer.pr_goal = pr_goal; + pr_subgoals = pr_subgoals; } end ; (* function [reset] goes back to No Proof Mode from Declarative Proof Mode *) @@ -160,7 +157,7 @@ VERNAC COMMAND EXTEND DeclProof [ "proof" ] => [ VtProofMode "Declarative", VtNow ] -> [ vernac_decl_proof () ] END VERNAC COMMAND EXTEND DeclReturn -[ "return" ] => [ VtProofMode "Classic", VtNow ] -> [ vernac_return () ] +[ "return" ] => [ VtProofMode "Declarative", VtNow ] -> [ vernac_return () ] END let none_is_empty = function diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml index 27308666..b3198dbf 100644 --- a/plugins/decl_mode/ppdecl_proof.ml +++ b/plugins/decl_mode/ppdecl_proof.ml @@ -12,41 +12,35 @@ open Decl_expr open Names open Nameops -let pr_constr = Printer.pr_constr_env -let pr_tac = Pptactic.pr_glob_tactic -let pr_pat mpat = Ppconstr.pr_cases_pattern_expr mpat.pat_expr - let pr_label = function Anonymous -> mt () | Name id -> pr_id id ++ spc () ++ str ":" ++ spc () -let pr_constr env c = pr_constr env Evd.empty c - -let pr_justification_items env = function +let pr_justification_items pr_constr = function Some [] -> mt () | Some (_::_ as l) -> spc () ++ str "by" ++ spc () ++ - prlist_with_sep (fun () -> str ",") (pr_constr env) l + prlist_with_sep (fun () -> str ",") pr_constr l | None -> spc () ++ str "by *" -let pr_justification_method env = function +let pr_justification_method pr_tac = function None -> mt () | Some tac -> - spc () ++ str "using" ++ spc () ++ pr_tac env tac + spc () ++ str "using" ++ spc () ++ pr_tac tac -let pr_statement pr_it env st = - pr_label st.st_label ++ pr_it env st.st_it +let pr_statement pr_constr st = + pr_label st.st_label ++ pr_constr st.st_it -let pr_or_thesis pr_this env = function +let pr_or_thesis pr_this = function Thesis Plain -> str "thesis" | Thesis (For id) -> str "thesis" ++ spc() ++ str "for" ++ spc () ++ pr_id id - | This c -> pr_this env c + | This c -> pr_this c -let pr_cut pr_it env c = - hov 1 (pr_it env c.cut_stat) ++ - pr_justification_items env c.cut_by ++ - pr_justification_method env c.cut_using +let pr_cut pr_constr pr_tac pr_it c = + hov 1 (pr_it c.cut_stat) ++ + pr_justification_items pr_constr c.cut_by ++ + pr_justification_method pr_tac c.cut_using let type_or_thesis = function Thesis _ -> Term.mkProp @@ -54,128 +48,127 @@ let type_or_thesis = function let _I x = x -let rec print_hyps pconstr gtyp env sep _be _have hyps = +let rec pr_hyps pr_var pr_constr gtyp sep _be _have hyps = let pr_sep = if sep then str "and" ++ spc () else mt () in match hyps with (Hvar _ ::_) as rest -> spc () ++ pr_sep ++ str _have ++ - print_vars pconstr gtyp env false _be _have rest + pr_vars pr_var pr_constr gtyp false _be _have rest | Hprop st :: rest -> begin - let nenv = - match st.st_label with - Anonymous -> env - | Name id -> Environ.push_named (id,None,gtyp st.st_it) env in - spc() ++ pr_sep ++ pr_statement pconstr env st ++ - print_hyps pconstr gtyp nenv true _be _have rest + (* let npr_constr env = pr_constr (Environ.push_named (id,None,gtyp st.st_it) env)*) + spc() ++ pr_sep ++ pr_statement pr_constr st ++ + pr_hyps pr_var pr_constr gtyp true _be _have rest end | [] -> mt () -and print_vars pconstr gtyp env sep _be _have vars = +and pr_vars pr_var pr_constr gtyp sep _be _have vars = match vars with Hvar st :: rest -> begin - let nenv = - match st.st_label with - Anonymous -> anomaly (Pp.str "anonymous variable") - | Name id -> Environ.push_named (id,None,st.st_it) env in + (* let npr_constr env = pr_constr (Environ.push_named (id,None,gtyp st.st_it) env)*) let pr_sep = if sep then pr_comma () else mt () in spc() ++ pr_sep ++ - pr_statement pr_constr env st ++ - print_vars pconstr gtyp nenv true _be _have rest + pr_var st ++ + pr_vars pr_var pr_constr gtyp true _be _have rest end | (Hprop _ :: _) as rest -> let _st = if _be then str "be such that" else str "such that" in - spc() ++ _st ++ print_hyps pconstr gtyp env false _be _have rest + spc() ++ _st ++ pr_hyps pr_var pr_constr gtyp false _be _have rest | [] -> mt () -let pr_suffices_clause env (hyps,c) = - print_hyps pr_constr _I env false false "to have" hyps ++ spc () ++ - str "to show" ++ spc () ++ pr_or_thesis pr_constr env c +let pr_suffices_clause pr_var pr_constr (hyps,c) = + pr_hyps pr_var pr_constr _I false false "to have" hyps ++ spc () ++ + str "to show" ++ spc () ++ pr_or_thesis pr_constr c let pr_elim_type = function ET_Case_analysis -> str "cases" | ET_Induction -> str "induction" -let pr_casee env =function - Real c -> str "on" ++ spc () ++ pr_constr env c - | Virtual cut -> str "of" ++ spc () ++ pr_cut (pr_statement pr_constr) env cut +let pr_block_type = function + B_elim et -> pr_elim_type et + | B_proof -> str "proof" + | B_claim -> str "claim" + | B_focus -> str "focus" + +let pr_casee pr_constr pr_tac =function + Real c -> str "on" ++ spc () ++ pr_constr c + | Virtual cut -> str "of" ++ spc () ++ pr_cut pr_constr pr_tac (pr_statement pr_constr) cut let pr_side = function Lhs -> str "=~" | Rhs -> str "~=" -let rec pr_bare_proof_instr _then _thus env = function +let rec pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac _then _thus = function | Pescape -> str "escape" - | Pthen i -> pr_bare_proof_instr true _thus env i - | Pthus i -> pr_bare_proof_instr _then true env i - | Phence i -> pr_bare_proof_instr true true env i + | Pthen i -> pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac true _thus i + | Pthus i -> pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac _then true i + | Phence i -> pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac true true i | Pcut c -> begin match _then,_thus with false,false -> str "have" ++ spc () ++ - pr_cut (pr_statement (pr_or_thesis pr_constr)) env c + pr_cut pr_constr pr_tac (pr_statement (pr_or_thesis pr_constr)) c | false,true -> str "thus" ++ spc () ++ - pr_cut (pr_statement (pr_or_thesis pr_constr)) env c + pr_cut pr_constr pr_tac (pr_statement (pr_or_thesis pr_constr)) c | true,false -> str "then" ++ spc () ++ - pr_cut (pr_statement (pr_or_thesis pr_constr)) env c + pr_cut pr_constr pr_tac (pr_statement (pr_or_thesis pr_constr)) c | true,true -> str "hence" ++ spc () ++ - pr_cut (pr_statement (pr_or_thesis pr_constr)) env c + pr_cut pr_constr pr_tac (pr_statement (pr_or_thesis pr_constr)) c end | Psuffices c -> - str "suffices" ++ pr_cut pr_suffices_clause env c + str "suffices" ++ pr_cut pr_constr pr_tac (pr_suffices_clause pr_var pr_constr) c | Prew (sid,c) -> (if _thus then str "thus" else str " ") ++ spc () ++ - pr_side sid ++ spc () ++ pr_cut (pr_statement pr_constr) env c + pr_side sid ++ spc () ++ pr_cut pr_constr pr_tac (pr_statement pr_constr) c | Passume hyps -> - str "assume" ++ print_hyps pr_constr _I env false false "we have" hyps + str "assume" ++ pr_hyps pr_var pr_constr _I false false "we have" hyps | Plet hyps -> - str "let" ++ print_vars pr_constr _I env false true "let" hyps + str "let" ++ pr_vars pr_var pr_constr _I false true "let" hyps | Pclaim st -> - str "claim" ++ spc () ++ pr_statement pr_constr env st + str "claim" ++ spc () ++ pr_statement pr_constr st | Pfocus st -> - str "focus on" ++ spc () ++ pr_statement pr_constr env st + str "focus on" ++ spc () ++ pr_statement pr_constr st | Pconsider (id,hyps) -> - str "consider" ++ print_vars pr_constr _I env false false "consider" hyps - ++ spc () ++ str "from " ++ pr_constr env id + str "consider" ++ pr_vars pr_var pr_constr _I false false "consider" hyps + ++ spc () ++ str "from " ++ pr_constr id | Pgiven hyps -> - str "given" ++ print_vars pr_constr _I env false false "given" hyps + str "given" ++ pr_vars pr_var pr_constr _I false false "given" hyps | Ptake witl -> str "take" ++ spc () ++ - prlist_with_sep pr_comma (pr_constr env) witl + prlist_with_sep pr_comma pr_constr witl | Pdefine (id,args,body) -> str "define" ++ spc () ++ pr_id id ++ spc () ++ prlist_with_sep spc (fun st -> str "(" ++ - pr_statement pr_constr env st ++ str ")") args ++ spc () ++ - str "as" ++ (pr_constr env body) + pr_var st ++ str ")") args ++ spc () ++ + str "as" ++ (pr_constr body) | Pcast (id,typ) -> str "reconsider" ++ spc () ++ - pr_or_thesis (fun _ -> pr_id) env id ++ spc () ++ - str "as" ++ spc () ++ (pr_constr env typ) + pr_or_thesis pr_id id ++ spc () ++ + str "as" ++ spc () ++ (pr_constr typ) | Psuppose hyps -> str "suppose" ++ - print_hyps pr_constr _I env false false "we have" hyps + pr_hyps pr_var pr_constr _I false false "we have" hyps | Pcase (params,pat,hyps) -> str "suppose it is" ++ spc () ++ pr_pat pat ++ (if params = [] then mt () else (spc () ++ str "with" ++ spc () ++ prlist_with_sep spc (fun st -> str "(" ++ - pr_statement pr_constr env st ++ str ")") params ++ spc ())) + pr_var st ++ str ")") params ++ spc ())) ++ (if hyps = [] then mt () else (spc () ++ str "and" ++ - print_hyps (pr_or_thesis pr_constr) type_or_thesis - env false false "we have" hyps)) - | Pper (et,c) -> + pr_hyps pr_var (pr_or_thesis pr_constr) type_or_thesis + false false "we have" hyps)) + | Pper (et,c) -> str "per" ++ spc () ++ pr_elim_type et ++ spc () ++ - pr_casee env c - | Pend (B_elim et) -> str "end" ++ spc () ++ pr_elim_type et - | _ -> anomaly (Pp.str "unprintable instruction") + pr_casee pr_constr pr_tac c + | Pend blk -> str "end" ++ spc () ++ pr_block_type blk let pr_emph = function 0 -> str " " @@ -184,7 +177,39 @@ let pr_emph = function | 3 -> str "*** " | _ -> anomaly (Pp.str "unknown emphasis") -let pr_proof_instr env instr = +let pr_gen_proof_instr pr_var pr_constr pr_pat pr_tac instr = pr_emph instr.emph ++ spc () ++ - pr_bare_proof_instr false false env instr.instr + pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac false false instr.instr + + +let pr_raw_proof_instr pconstr1 pconstr2 ptac (instr : raw_proof_instr) = + pr_gen_proof_instr + (fun (_,(id,otyp)) -> + match otyp with + None -> pr_id id + | Some typ -> str "(" ++ pr_id id ++ str ":" ++ pconstr1 typ ++str ")" + ) + pconstr2 + Ppconstr.pr_cases_pattern_expr + (ptac Pptactic.ltop) + instr + +let pr_glob_proof_instr pconstr1 pconstr2 ptac (instr : glob_proof_instr) = + pr_gen_proof_instr + (fun (_,(id,otyp)) -> + match otyp with + None -> pr_id id + | Some typ -> str "(" ++ pr_id id ++ str ":" ++ pconstr1 typ ++str ")") + pconstr2 + Ppconstr.pr_cases_pattern_expr + (ptac Pptactic.ltop) + instr + +let pr_proof_instr pconstr1 pconstr2 ptac (instr : proof_instr) = + pr_gen_proof_instr + (fun st -> pr_statement pconstr1 st) + pconstr2 + (fun mpat -> Ppconstr.pr_cases_pattern_expr mpat.pat_expr) + (ptac Pptactic.ltop) + instr diff --git a/plugins/decl_mode/ppdecl_proof.mli b/plugins/decl_mode/ppdecl_proof.mli index fd6fb663..678fc076 100644 --- a/plugins/decl_mode/ppdecl_proof.mli +++ b/plugins/decl_mode/ppdecl_proof.mli @@ -1,2 +1,14 @@ -val pr_proof_instr : Environ.env -> Decl_expr.proof_instr -> Pp.std_ppcmds +open Decl_expr +open Pptactic + +val pr_gen_proof_instr : + ('var -> Pp.std_ppcmds) -> + ('constr -> Pp.std_ppcmds) -> + ('pat -> Pp.std_ppcmds) -> + ('tac -> Pp.std_ppcmds) -> + ('var,'constr,'pat,'tac) gen_proof_instr -> Pp.std_ppcmds + +val pr_raw_proof_instr : raw_proof_instr raw_extra_genarg_printer +val pr_glob_proof_instr : glob_proof_instr glob_extra_genarg_printer +val pr_proof_instr : proof_instr extra_genarg_printer diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 439b1a5c..c232ae31 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -49,13 +49,13 @@ let start_deriving f suchthat lemma = [suchthat], respectively. *) let (opaque,f_def,lemma_def) = match com with - | Admitted -> Errors.error"Admitted isn't supported in Derive." + | Admitted _ -> Errors.error"Admitted isn't supported in Derive." | Proved (_,Some _,_) -> Errors.error"Cannot save a proof of Derive with an explicit name." | Proved (opaque, None, obj) -> match Proof_global.(obj.entries) with | [_;f_def;lemma_def] -> - opaque , f_def , lemma_def + opaque <> Vernacexpr.Transparent , f_def , lemma_def | _ -> assert false in (** The opacity of [f_def] is adjusted to be [false], as it diff --git a/plugins/extraction/ExtrHaskellBasic.v b/plugins/extraction/ExtrHaskellBasic.v new file mode 100644 index 00000000..294d6102 --- /dev/null +++ b/plugins/extraction/ExtrHaskellBasic.v @@ -0,0 +1,15 @@ +(** Extraction to Haskell : use of basic Haskell types *) + +Extract Inductive bool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ]. +Extract Inductive option => "Prelude.Maybe" [ "Prelude.Just" "Prelude.Nothing" ]. +Extract Inductive unit => "()" [ "()" ]. +Extract Inductive list => "([])" [ "([])" "(:)" ]. +Extract Inductive prod => "(,)" [ "(,)" ]. + +Extract Inductive sumbool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ]. +Extract Inductive sumor => "Prelude.Maybe" [ "Prelude.Just" "Prelude.Nothing" ]. +Extract Inductive sum => "Prelude.Either" [ "Prelude.Left" "Prelude.Right" ]. + +Extract Inlined Constant andb => "(Prelude.&&)". +Extract Inlined Constant orb => "(Prelude.||)". +Extract Inlined Constant negb => "Prelude.not". diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v index 5f653ee1..a0930f15 100644 --- a/plugins/extraction/ExtrOcamlNatInt.v +++ b/plugins/extraction/ExtrOcamlNatInt.v @@ -59,6 +59,7 @@ Extract Constant Compare_dec.nat_compare => "fun n m -> if n=m then Eq else if n<m then Lt else Gt". Extract Inlined Constant Compare_dec.leb => "(<=)". Extract Inlined Constant Compare_dec.le_lt_dec => "(<=)". +Extract Inlined Constant Compare_dec.lt_dec => "(<)". Extract Constant Compare_dec.lt_eq_lt_dec => "fun n m -> if n>m then None else Some (n<m)". diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 21819aa8..97f85694 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -600,6 +600,7 @@ let pp_global k r = let rls = List.rev ls in (* for what come next it's easier this way *) match lang () with | Scheme -> unquote s (* no modular Scheme extraction... *) + | JSON -> dottify (List.map unquote rls) | Haskell -> if modular () then pp_haskell_gen k mp rls else s | Ocaml -> pp_ocaml_gen k mp rls (Some l) @@ -628,7 +629,7 @@ let check_extract_ascii () = try let char_type = match lang () with | Ocaml -> "char" - | Haskell -> "Char" + | Haskell -> "Prelude.Char" | _ -> raise Not_found in String.equal (find_custom (IndRef (ind_ascii, 0))) (char_type) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 42e69d34..0f846013 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -235,7 +235,7 @@ let rec extract_structure_spec env mp = function and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with | MEident mp -> Visit.add_mp_all mp; MTident mp - | MEwith(me',WithDef(idl,c))-> + | MEwith(me',WithDef(idl,(c,ctx)))-> let env' = env_for_mtb_with_def env (mp_of_mexpr me') me_struct idl in let mt = extract_mexpr_spec env mp1 (me_struct,me') in (match extract_with_type env' c with (* cb may contain some kn *) @@ -410,6 +410,7 @@ let descr () = match lang () with | Ocaml -> Ocaml.ocaml_descr | Haskell -> Haskell.haskell_descr | Scheme -> Scheme.scheme_descr + | JSON -> Json.json_descr (* From a filename string "foo.ml" or "foo", builds "foo.ml" and "foo.mli" Works similarly for the other languages. *) @@ -440,7 +441,8 @@ let mono_filename f = let module_filename mp = let f = file_of_modfile mp in let d = descr () in - Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, Id.of_string f + let p = d.file_naming mp ^ d.file_suffix in + Some p, Option.map ((^) f) d.sig_suffix, Id.of_string f (*s Extraction of one decl to stdout. *) diff --git a/plugins/extraction/extraction_plugin.mllib b/plugins/extraction/extraction_plugin.mllib index b7f45861..ad321243 100644 --- a/plugins/extraction/extraction_plugin.mllib +++ b/plugins/extraction/extraction_plugin.mllib @@ -6,6 +6,7 @@ Common Ocaml Haskell Scheme +Json Extract_env G_extraction Extraction_plugin_mod diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index 3caa558f..3fe5a8c0 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -41,12 +41,14 @@ let pr_language = function | Ocaml -> str "Ocaml" | Haskell -> str "Haskell" | Scheme -> str "Scheme" + | JSON -> str "JSON" VERNAC ARGUMENT EXTEND language PRINTED BY pr_language | [ "Ocaml" ] -> [ Ocaml ] | [ "Haskell" ] -> [ Haskell ] | [ "Scheme" ] -> [ Scheme ] +| [ "JSON" ] -> [ JSON ] END (* Extraction commands *) diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 5e08fef5..37b41420 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -26,7 +26,7 @@ let pr_upper_id id = str (String.capitalize (Id.to_string id)) let keywords = List.fold_right (fun s -> Id.Set.add (Id.of_string s)) - [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else"; + [ "Any"; "case"; "class"; "data"; "default"; "deriving"; "do"; "else"; "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance"; "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__"; "as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ] @@ -38,7 +38,7 @@ let pp_bracket_comment s = str"{- " ++ hov 0 s ++ str" -}" let preamble mod_name comment used_modules usf = let pp_import mp = str ("import qualified "^ string_of_modfile mp ^"\n") in - (if not usf.magic then mt () + (if not (usf.magic || usf.tunknown) then mt () else str "{-# OPTIONS_GHC -cpp -XMagicHash #-}" ++ fnl () ++ str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}") @@ -52,19 +52,36 @@ let preamble mod_name comment used_modules usf = str "import qualified Prelude" ++ fnl () ++ prlist pp_import used_modules ++ fnl () ++ (if List.is_empty used_modules then mt () else fnl ()) ++ - (if not usf.magic then mt () + (if not (usf.magic || usf.tunknown) then mt () else str "\ \n#ifdef __GLASGOW_HASKELL__\ \nimport qualified GHC.Base\ +\nimport qualified GHC.Prim\ +\n#else\ +\n-- HUGS\ +\nimport qualified IOExts\ +\n#endif" ++ fnl2 ()) + ++ + (if not usf.magic then mt () + else str "\ +\n#ifdef __GLASGOW_HASKELL__\ \nunsafeCoerce :: a -> b\ \nunsafeCoerce = GHC.Base.unsafeCoerce#\ \n#else\ \n-- HUGS\ -\nimport qualified IOExts\ \nunsafeCoerce :: a -> b\ \nunsafeCoerce = IOExts.unsafeCoerce\ \n#endif" ++ fnl2 ()) ++ + (if not usf.tunknown then mt () + else str "\ +\n#ifdef __GLASGOW_HASKELL__\ +\ntype Any = GHC.Prim.Any\ +\n#else\ +\n-- HUGS\ +\ntype Any = ()\ +\n#endif" ++ fnl2 ()) + ++ (if not usf.mldummy then mt () else str "__ :: any" ++ fnl () ++ str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ()) @@ -102,7 +119,7 @@ let rec pp_type par vl t = pp_par par (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) | Tdummy _ -> str "()" - | Tunknown -> str "()" + | Tunknown -> str "Any" | Taxiom -> str "() -- AXIOM TO BE REALIZED\n" in hov 0 (pp_rec par t) @@ -243,12 +260,12 @@ let pp_logical_ind packet = prvect_with_sep spc pr_id packet.ip_consnames) let pp_singleton kn packet = + let name = pp_global Type (IndRef (kn,0)) in let l = rename_tvars keywords packet.ip_vars in - let l' = List.rev l in - hov 2 (str "type " ++ pp_global Type (IndRef (kn,0)) ++ spc () ++ + hov 2 (str "type " ++ name ++ spc () ++ prlist_with_sep spc pr_id l ++ (if not (List.is_empty l) then str " " else mt ()) ++ str "=" ++ spc () ++ - pp_type false l' (List.hd packet.ip_types.(0)) ++ fnl () ++ + pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ pp_comment (str "singleton inductive, whose constructor was " ++ pr_id packet.ip_consnames.(0))) @@ -346,7 +363,7 @@ and pp_module_expr = function | MEfunctor _ -> mt () (* for the moment we simply discard unapplied functors *) | MEident _ | MEapply _ -> assert false - (* should be expansed in extract_env *) + (* should be expanded in extract_env *) let pp_struct = let pp_sel (mp,sel) = @@ -360,6 +377,7 @@ let pp_struct = let haskell_descr = { keywords = keywords; file_suffix = ".hs"; + file_naming = string_of_modfile; preamble = preamble; pp_struct = pp_struct; sig_suffix = None; diff --git a/plugins/extraction/json.ml b/plugins/extraction/json.ml new file mode 100644 index 00000000..125dc86b --- /dev/null +++ b/plugins/extraction/json.ml @@ -0,0 +1,278 @@ +open Pp +open Errors +open Util +open Names +open Nameops +open Globnames +open Table +open Miniml +open Mlutil +open Common + +let json_str s = + qs s + +let json_int i = + int i + +let json_bool b = + if b then str "true" else str "false" + +let json_null = + str "null" + +let json_global typ ref = + json_str (Common.pp_global typ ref) + +let json_id id = + json_str (Id.to_string id) + +let json_dict_one (k, v) = + json_str k ++ str (": ") ++ v + +let json_dict_open l = + str ("{") ++ fnl () ++ + str (" ") ++ hov 0 (prlist_with_sep pr_comma json_dict_one l) + +let json_dict l = + json_dict_open l ++ fnl () ++ + str ("}") + +let json_list l = + str ("[") ++ fnl () ++ + str (" ") ++ hov 0 (prlist_with_sep pr_comma (fun x -> x) l) ++ fnl () ++ + str ("]") + +let json_listarr a = + str ("[") ++ fnl () ++ + str (" ") ++ hov 0 (prvect_with_sep pr_comma (fun x -> x) a) ++ fnl () ++ + str ("]") + + +let preamble mod_name comment used_modules usf = + (match comment with + | None -> mt () + | Some s -> str "/* " ++ hov 0 s ++ str " */" ++ fnl ()) ++ + json_dict_open [ + ("what", json_str "module"); + ("name", json_id mod_name); + ("need_magic", json_bool (usf.magic)); + ("need_dummy", json_bool (usf.mldummy)); + ("used_modules", json_list + (List.map (fun mf -> json_str (file_of_modfile mf)) used_modules)) + ] + + +(*s Pretty-printing of types. *) + +let rec json_type vl = function + | Tmeta _ | Tvar' _ -> assert false + | Tvar i -> (try + let varid = List.nth vl (pred i) in json_dict [ + ("what", json_str "type:var"); + ("name", json_id varid) + ] + with Failure _ -> json_dict [ + ("what", json_str "type:varidx"); + ("name", json_int i) + ]) + | Tglob (r, l) -> json_dict [ + ("what", json_str "type:glob"); + ("name", json_global Type r); + ("args", json_list (List.map (json_type vl) l)) + ] + | Tarr (t1,t2) -> json_dict [ + ("what", json_str "type:arrow"); + ("left", json_type vl t1); + ("right", json_type vl t2) + ] + | Tdummy _ -> json_dict [("what", json_str "type:dummy")] + | Tunknown -> json_dict [("what", json_str "type:unknown")] + | Taxiom -> json_dict [("what", json_str "type:axiom")] + + +(*s Pretty-printing of expressions. *) + +let rec json_expr env = function + | MLrel n -> json_dict [ + ("what", json_str "expr:rel"); + ("name", json_id (get_db_name n env)) + ] + | MLapp (f, args) -> json_dict [ + ("what", json_str "expr:apply"); + ("func", json_expr env f); + ("args", json_list (List.map (json_expr env) args)) + ] + | MLlam _ as a -> + let fl, a' = collect_lams a in + let fl, env' = push_vars (List.map id_of_mlid fl) env in + json_dict [ + ("what", json_str "expr:lambda"); + ("argnames", json_list (List.map json_id (List.rev fl))); + ("body", json_expr env' a') + ] + | MLletin (id, a1, a2) -> + let i, env' = push_vars [id_of_mlid id] env in + json_dict [ + ("what", json_str "expr:let"); + ("name", json_id (List.hd i)); + ("nameval", json_expr env a1); + ("body", json_expr env' a2) + ] + | MLglob r -> json_dict [ + ("what", json_str "expr:global"); + ("name", json_global Term r) + ] + | MLcons (_, r, a) -> json_dict [ + ("what", json_str "expr:constructor"); + ("name", json_global Cons r); + ("args", json_list (List.map (json_expr env) a)) + ] + | MLtuple l -> json_dict [ + ("what", json_str "expr:tuple"); + ("items", json_list (List.map (json_expr env) l)) + ] + | MLcase (typ, t, pv) -> json_dict [ + ("what", json_str "expr:case"); + ("expr", json_expr env t); + ("cases", json_listarr (Array.map (fun x -> json_one_pat env x) pv)) + ] + | MLfix (i, ids, defs) -> + let ids', env' = push_vars (List.rev (Array.to_list ids)) env in + let ids' = Array.of_list (List.rev ids') in + json_dict [ + ("what", json_str "expr:fix"); + ("funcs", json_listarr (Array.map (fun (fi, ti) -> + json_dict [ + ("what", json_str "fix:item"); + ("name", json_id fi); + ("body", json_function env' ti) + ]) (Array.map2 (fun a b -> a,b) ids' defs))) + ] + | MLexn s -> json_dict [ + ("what", json_str "expr:exception"); + ("msg", json_str s) + ] + | MLdummy -> json_dict [("what", json_str "expr:dummy")] + | MLmagic a -> json_dict [ + ("what", json_str "expr:coerce"); + ("value", json_expr env a) + ] + | MLaxiom -> json_dict [("what", json_str "expr:axiom")] + +and json_one_pat env (ids,p,t) = + let ids', env' = push_vars (List.rev_map id_of_mlid ids) env in json_dict [ + ("what", json_str "case"); + ("pat", json_gen_pat (List.rev ids') env' p); + ("body", json_expr env' t) + ] + +and json_gen_pat ids env = function + | Pcons (r, l) -> json_cons_pat r (List.map (json_gen_pat ids env) l) + | Pusual r -> json_cons_pat r (List.map json_id ids) + | Ptuple l -> json_dict [ + ("what", json_str "pat:tuple"); + ("items", json_list (List.map (json_gen_pat ids env) l)) + ] + | Pwild -> json_dict [("what", json_str "pat:wild")] + | Prel n -> json_dict [ + ("what", json_str "pat:rel"); + ("name", json_id (get_db_name n env)) + ] + +and json_cons_pat r ppl = json_dict [ + ("what", json_str "pat:constructor"); + ("name", json_global Cons r); + ("argnames", json_list ppl) + ] + +and json_function env t = + let bl, t' = collect_lams t in + let bl, env' = push_vars (List.map id_of_mlid bl) env in + json_dict [ + ("what", json_str "expr:lambda"); + ("argnames", json_list (List.map json_id (List.rev bl))); + ("body", json_expr env' t') + ] + + +(*s Pretty-printing of inductive types declaration. *) + +let json_ind ip pl cv = json_dict [ + ("what", json_str "decl:ind"); + ("name", json_global Type (IndRef ip)); + ("argnames", json_list (List.map json_id pl)); + ("constructors", json_listarr (Array.mapi (fun idx c -> json_dict [ + ("name", json_global Cons (ConstructRef (ip, idx+1))); + ("argtypes", json_list (List.map (json_type pl) c)) + ]) cv)) + ] + + +(*s Pretty-printing of a declaration. *) + +let pp_decl = function + | Dind (kn, defs) -> prvecti_with_sep pr_comma + (fun i p -> if p.ip_logical then str "" + else json_ind (kn, i) p.ip_vars p.ip_types) defs.ind_packets + | Dtype (r, l, t) -> json_dict [ + ("what", json_str "decl:type"); + ("name", json_global Type r); + ("argnames", json_list (List.map json_id l)); + ("value", json_type l t) + ] + | Dfix (rv, defs, typs) -> json_dict [ + ("what", json_str "decl:fixgroup"); + ("fixlist", json_listarr (Array.mapi (fun i r -> + json_dict [ + ("what", json_str "fixgroup:item"); + ("name", json_global Term rv.(i)); + ("type", json_type [] typs.(i)); + ("value", json_function (empty_env ()) defs.(i)) + ]) rv)) + ] + | Dterm (r, a, t) -> json_dict [ + ("what", json_str "decl:term"); + ("name", json_global Term r); + ("type", json_type [] t); + ("value", json_function (empty_env ()) a) + ] + +let rec pp_structure_elem = function + | (l,SEdecl d) -> [ pp_decl d ] + | (l,SEmodule m) -> pp_module_expr m.ml_mod_expr + | (l,SEmodtype m) -> [] + (* for the moment we simply discard module type *) + +and pp_module_expr = function + | MEstruct (mp,sel) -> List.concat (List.map pp_structure_elem sel) + | MEfunctor _ -> [] + (* for the moment we simply discard unapplied functors *) + | MEident _ | MEapply _ -> assert false + (* should be expansed in extract_env *) + +let pp_struct mls = + let pp_sel (mp,sel) = + push_visible mp []; + let p = prlist_with_sep pr_comma identity + (List.concat (List.map pp_structure_elem sel)) in + pop_visible (); p + in + str "," ++ fnl () ++ + str " " ++ qs "declarations" ++ str ": [" ++ fnl () ++ + str " " ++ hov 0 (prlist_with_sep pr_comma pp_sel mls) ++ fnl () ++ + str " ]" ++ fnl () ++ + str "}" ++ fnl () + + +let json_descr = { + keywords = Id.Set.empty; + file_suffix = ".json"; + file_naming = file_of_modfile; + preamble = preamble; + pp_struct = pp_struct; + sig_suffix = None; + sig_preamble = (fun _ _ _ _ -> mt ()); + pp_sig = (fun _ -> mt ()); + pp_decl = pp_decl; +} diff --git a/plugins/extraction/json.mli b/plugins/extraction/json.mli new file mode 100644 index 00000000..3ba240a1 --- /dev/null +++ b/plugins/extraction/json.mli @@ -0,0 +1 @@ +val json_descr : Miniml.language_descr diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index 1e491d36..b7dee6cb 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -197,6 +197,7 @@ type language_descr = { (* Concerning the source file *) file_suffix : string; + file_naming : module_path -> string; (* the second argument is a comment to add to the preamble *) preamble : Id.t -> std_ppcmds option -> module_path list -> unsafe_needs -> diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 30ac3d3f..8c482b4b 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -634,7 +634,12 @@ and pp_module_type params = function str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def | MTsig (mp, sign) -> push_visible mp params; - let l = List.map pp_specif sign in + let try_pp_specif l x = + try pp_specif x :: l with Failure "empty phrase" -> l + in + (* We cannot use fold_right here due to side effects in pp_specif *) + let l = List.fold_left try_pp_specif [] sign in + let l = List.rev l in pop_visible (); str "sig " ++ fnl () ++ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ @@ -707,7 +712,12 @@ and pp_module_expr params = function str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def | MEstruct (mp, sel) -> push_visible mp params; - let l = List.map pp_structure_elem sel in + let try_pp_structure_elem l x = + try pp_structure_elem x :: l with Failure "empty phrase" -> l + in + (* We cannot use fold_right here due to side effects in pp_structure_elem *) + let l = List.fold_left try_pp_structure_elem [] sel in + let l = List.rev l in pop_visible (); str "struct " ++ fnl () ++ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ @@ -736,6 +746,7 @@ let pp_decl d = try pp_decl d with Failure "empty phrase" -> mt () let ocaml_descr = { keywords = keywords; file_suffix = ".ml"; + file_naming = file_of_modfile; preamble = preamble; pp_struct = pp_struct; sig_suffix = Some ".mli"; diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index 69dea25a..cc8b6d8e 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -212,7 +212,7 @@ and pp_module_expr = function | MEfunctor _ -> mt () (* for the moment we simply discard unapplied functors *) | MEident _ | MEapply _ -> assert false - (* should be expansed in extract_env *) + (* should be expanded in extract_env *) let pp_struct = let pp_sel (mp,sel) = @@ -225,6 +225,7 @@ let pp_struct = let scheme_descr = { keywords = keywords; file_suffix = ".scm"; + file_naming = file_of_modfile; preamble = preamble; pp_struct = pp_struct; sig_suffix = None; diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 44d760cc..a57c39ee 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -554,7 +554,7 @@ let _ = declare_string_option (*s Extraction Lang *) -type lang = Ocaml | Haskell | Scheme +type lang = Ocaml | Haskell | Scheme | JSON let lang_ref = Summary.ref Ocaml ~name:"ExtrLang" diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 1acbe355..648f2321 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -142,7 +142,7 @@ val file_comment : unit -> string (*s Target language. *) -type lang = Ocaml | Haskell | Scheme +type lang = Ocaml | Haskell | Scheme | JSON val lang : unit -> lang (*s Extraction modes: modular or monolithic, library or minimal ? diff --git a/plugins/extraction/vo.itarget b/plugins/extraction/vo.itarget index 1fe09f6f..f0489048 100644 --- a/plugins/extraction/vo.itarget +++ b/plugins/extraction/vo.itarget @@ -1,3 +1,4 @@ +ExtrHaskellBasic.vo ExtrOcamlBasic.vo ExtrOcamlIntConv.vo ExtrOcamlBigIntConv.vo diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 29ea1e77..6c7b0938 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Names open Term open Context open Globnames diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index a88778c7..5912f0a0 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -113,24 +113,14 @@ let mk_open_instance id idc gl m t= Name id -> id | Anonymous -> dummy_bvid in let revt=substl (List.init m (fun i->mkRel (m-i))) t in - let rec aux n avoid= - if Int.equal n 0 then [] else + let rec aux n avoid env evmap decls = + if Int.equal n 0 then evmap, decls else let nid=(fresh_id avoid var_id gl) in - (Name nid,None,dummy_constr)::(aux (n-1) (nid::avoid)) in - let nt=it_mkLambda_or_LetIn revt (aux m []) in - let rawt=Detyping.detype false [] env evmap nt in - let rec raux n t= - if Int.equal n 0 then t else - match t with - GLambda(loc,name,k,_,t0)-> - let t1=raux (n-1) t0 in - GLambda(loc,name,k,GHole (Loc.ghost,Evar_kinds.BinderType name,Misctypes.IntroAnonymous,None),t1) - | _-> anomaly (Pp.str "can't happen") in - let ntt=try - fst (Pretyping.understand env evmap (raux m rawt))(*FIXME*) - with e when Errors.noncritical e -> - error "Untypable instance, maybe higher-order non-prenex quantification" in - decompose_lam_n_assum m ntt + let evmap, (c, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in + let decl = (Name nid,None,c) in + aux (n-1) (nid::avoid) (Environ.push_rel decl env) evmap (decl::decls) in + let evmap, decls = aux m [] env evmap [] in + evmap, decls, revt (* tactics *) @@ -159,11 +149,15 @@ let left_instance_tac (inst,id) continue seq= if m>0 then pf_constr_of_global id (fun idc -> fun gl-> - let (rc,ot) = mk_open_instance id idc gl m t in + let evmap,rc,ot = mk_open_instance id idc gl m t in let gt= it_mkLambda_or_LetIn (mkApp(idc,[|ot|])) rc in - generalize [gt] gl) + let evmap, _ = + try Typing.e_type_of (pf_env gl) evmap gt + with e when Errors.noncritical e -> + error "Untypable instance, maybe higher-order non-prenex quantification" in + tclTHEN (Refiner.tclEVARS evmap) (generalize [gt]) gl) else pf_constr_of_global id (fun idc -> generalize [mkApp(idc,[|t|])]) diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 2f7f21e4..7d034db5 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -209,7 +209,7 @@ open Hints let extend_with_auto_hints l seq gl= let seqref=ref seq in let f p_a_t = - match p_a_t.code with + match repr_auto_tactic p_a_t.code with Res_pf (c,_) | Give_exact (c,_) | Res_pf_THEN_trivial_fail (c,_) -> (try diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index 8006a3e1..7a56cd66 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -16,7 +16,6 @@ open Term open Tactics open Names open Globnames -open Tacticals open Tacmach open Fourier open Contradiction diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index c8214ada..4a832435 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -7,7 +7,6 @@ open Context open Namegen open Names open Declarations -open Declareops open Pp open Tacmach open Proof_type @@ -16,7 +15,6 @@ open Tactics open Indfun_common open Libnames open Globnames -open Misctypes (* let msgnl = Pp.msgnl *) @@ -46,18 +44,20 @@ let observe_tac s tac g = observe_tac_stream (str s) tac g let debug_queue = Stack.create () -let rec print_debug_queue b e = +let rec print_debug_queue e = if not (Stack.is_empty debug_queue) then begin let lmsg,goal = Stack.pop debug_queue in - if b then - Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal) - else - begin - Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal); - end; - print_debug_queue false e; + let _ = + match e with + | Some e -> + Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal) + | None -> + begin + Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal); + end in + print_debug_queue None ; end let observe strm = @@ -70,13 +70,13 @@ let do_observe_tac s tac g = let lmsg = (str "observation : ") ++ s in Stack.push (lmsg,goal) debug_queue; try - let v = tac g in + let v = tac g in ignore(Stack.pop debug_queue); v with reraise -> let reraise = Errors.push reraise in if not (Stack.is_empty debug_queue) - then print_debug_queue true (fst (Cerrors.process_vernac_interp_error reraise)); + then print_debug_queue (Some (fst (Cerrors.process_vernac_interp_error reraise))); iraise reraise let observe_tac_stream s tac g = @@ -943,13 +943,13 @@ let revert idl = (generalize (List.map mkVar idl)) (thin idl) -let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = +let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num = (* 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) )); *) let f_def = Global.lookup_constant (fst (destConst f)) in let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in - let f_body = Option.get (Global.body_of_constant_body f_def)in + let f_body = Option.get (Global.body_of_constant_body f_def) in let params,f_body_with_params = decompose_lam_n nb_params f_body in let (_,num),(_,_,bodies) = destFix f_body_with_params in let fnames_with_params = @@ -962,41 +962,48 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = let f_body_with_params_and_other_fun = substl fnames_with_params bodies.(num) in (* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in -(* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) - let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args) - (Typeops.type_of_constant_type (Global.env ()) (*FIXME*)f_def.const_type) in + (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) + let (type_ctxt,type_of_f),evd = + let evd,t = Typing.e_type_of ~refresh:true (Global.env ()) evd f + in + decompose_prod_n_assum + (nb_params + nb_args) t,evd + in let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in + (* Pp.msgnl (str "lemma type " ++ Printer.pr_lconstr lemma_type ++ fnl () ++ str "f_body " ++ Printer.pr_lconstr f_body); *) let f_id = Label.to_id (con_label (fst (destConst f))) in let prove_replacement = tclTHENSEQ [ tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro); - (* observe_tac "" *) (fun g -> + observe_tac "" (fun g -> let rec_id = pf_nth_hyp_id g 1 in tclTHENSEQ - [(* 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))); + [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 ) ] in + (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) Lemmas.start_proof (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious i*) (mk_equation_id f_id) - (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem)) - Evd.empty + (Decl_kinds.Global, Flags.is_universe_polymorphism (), (Decl_kinds.Proof Decl_kinds.Theorem)) + evd lemma_type (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); - Lemmas.save_proof (Vernacexpr.Proved(false,None)) + Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None))); + evd -let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = +let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = let equation_lemma = try let finfos = find_Function_infos (fst (destConst f)) (*FIXME*) in @@ -1007,7 +1014,7 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = Ensures by: obvious i*) let equation_lemma_id = (mk_equation_id f_id) in - generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; + 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 -> @@ -1020,9 +1027,16 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = ) } | _ -> () - in - Constrintern.construct_reference (pf_hyps g) equation_lemma_id + (* 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 + let evd',_ = Typing.e_type_of ~refresh:true (Global.env ()) evd' res in + evd:=evd'; + res in let nb_intro_to_do = nb_prod (pf_concl g) in tclTHEN @@ -1031,13 +1045,17 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = fun g' -> let just_introduced = nLastDecls nb_intro_to_do g' in let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in - tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) (revert just_introduced_id) g' + tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) + (revert just_introduced_id) g' ) g -let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tactic = +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 + 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 princ_type in let fresh_id = let avoid = ref (pf_ids_of_hyps g) in @@ -1101,17 +1119,17 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : f_body ) in -(* observe (str "full_params := " ++ *) -(* prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *) -(* full_params *) -(* ); *) -(* observe (str "princ_params := " ++ *) -(* prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *) -(* princ_params *) -(* ); *) -(* observe (str "fbody_with_full_params := " ++ *) -(* pr_lconstr fbody_with_full_params *) -(* ); *) + observe (str "full_params := " ++ + prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) + full_params + ); + observe (str "princ_params := " ++ + prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) + princ_params + ); + observe (str "fbody_with_full_params := " ++ + pr_lconstr 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 @@ -1191,7 +1209,8 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : (List.rev princ_info.predicates) in pte_to_fix,List.rev rev_info - | _ -> Id.Map.empty,[] + | _ -> + Id.Map.empty,[] in let mk_fixes : tactic = let pre_info,infos = list_chop fun_num infos in @@ -1205,7 +1224,10 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : in if List.is_empty other_fix_infos then - (* observe_tac ("h_fix") *) (fix (Some this_fix_info.name) (this_fix_info.idx +1)) + 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 + observe_tac_stream (str "h_fix " ++ int (this_fix_info.idx +1) ) (fix (Some 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 @@ -1213,10 +1235,10 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : in let first_tac : tactic = (* every operations until fix creations *) tclTHENSEQ - [ (* observe_tac "introducing params" *) Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.params)); - (* observe_tac "introducing predictes" *) Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.predicates)); - (* observe_tac "introducing branches" *) Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.branches)); - (* observe_tac "building fixes" *) mk_fixes; + [ observe_tac "introducing params" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.params))); + observe_tac "introducing predictes" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.predicates))); + observe_tac "introducing branches" (Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.branches))); + observe_tac "building fixes" mk_fixes; ] in let intros_after_fixes : tactic = @@ -1250,8 +1272,8 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : in tclTHENSEQ [ -(* observe_tac "do_replace" *) - (do_replace + observe_tac "do_replace" + (do_replace evd full_params (fix_info.idx + List.length princ_params) (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params)) @@ -1259,9 +1281,6 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : fix_info.num_in_block all_funs ); -(* observe_tac "do_replace" *) -(* (do_replace princ_info.params fix_info.idx args_id *) -(* (List.hd (List.rev pte_args)) fix_body); *) let do_prove = build_proof interactive_proof diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index ff98f2b9..61fce267 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -2,6 +2,7 @@ open Names open Term val prove_princ_for_struct : + Evd.evar_map ref -> bool -> int -> constant array -> constr array -> int -> Tacmach.tactic diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 545f8931..45e5aaf5 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -6,7 +6,6 @@ open Vars open Context open Namegen open Names -open Declareops open Pp open Entries open Tactics @@ -106,7 +105,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let dummy_var = mkVar (Id.of_string "________") in let mk_replacement c i args = let res = mkApp(rel_to_fun.(i), Array.map Termops.pop (array_get_start args)) in -(* observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); *) + observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); res in let rec compute_new_princ_type remove env pre_princ : types*(constr list) = @@ -116,7 +115,8 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = begin try match Environ.lookup_rel n env with | _,_,t when is_dom t -> raise Toberemoved - | _ -> pre_princ,[] with Not_found -> assert false + | _ -> pre_princ,[] + with Not_found -> assert false end | Prod(x,t,b) -> compute_new_princ_type_for_binder remove mkProd env x t b @@ -234,7 +234,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = -let change_property_sort toSort princ princName = +let change_property_sort evd toSort princ princName = let princ_info = compute_elim_sig princ in let change_sort_in_predicate (x,v,t) = (x,None, @@ -244,46 +244,48 @@ let change_property_sort toSort princ princName = compose_prod args (mkSort toSort) ) in - let princName_as_constr = Constrintern.global_reference princName in + let evd,princName_as_constr = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in let init = let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in mkApp(princName_as_constr, Array.init nargs (fun i -> mkRel (nargs - i ))) in - it_mkLambda_or_LetIn + evd, it_mkLambda_or_LetIn (it_mkLambda_or_LetIn init (List.map change_sort_in_predicate princ_info.predicates) ) princ_info.params -let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook = +let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook = (* First we get the type of the old graph principle *) let mutr_nparams = (compute_elim_sig old_princ_type).nparams in (* let time1 = System.get_time () in *) let new_principle_type = compute_new_princ_type_from_rel - (Array.map mkConst funs) + (Array.map mkConstU funs) sorts old_princ_type in (* let time2 = System.get_time () in *) (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) - observe (str "new_principle_type : " ++ pr_lconstr new_principle_type); let new_princ_name = next_ident_away_in_goal (Id.of_string "___________princ_________") [] in + let _ = evd := fst(Typing.e_type_of ~refresh:true (Global.env ()) !evd new_principle_type ) in let hook = Lemmas.mk_hook (hook new_principle_type) in begin Lemmas.start_proof new_princ_name - (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem)) - (*FIXME*) Evd.empty - new_principle_type + (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) + !evd + new_principle_type hook - ; + ; (* let _tim1 = System.get_time () in *) - ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map mkConst funs) mutr_nparams))); + ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map mkConstU funs) mutr_nparams))); (* let _tim2 = System.get_time () in *) (* begin *) (* let dur1 = System.time_difference tim1 tim2 in *) @@ -294,7 +296,7 @@ let build_functional_principle interactive_proof old_princ_type sorts funs i pro -let generate_functional_principle +let generate_functional_principle (evd: Evd.evar_map ref) interactive_proof old_princ_type sorts new_princ_name funs i proof_tac = @@ -311,20 +313,23 @@ let generate_functional_principle match new_princ_name with | Some (id) -> id,id | None -> - let id_of_f = Label.to_id (con_label f) in + let id_of_f = Label.to_id (con_label (fst f)) in id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort) in let names = ref [new_princ_name] in - let hook new_principle_type _ _ = + let evd' = !evd in + let hook = + fun new_principle_type _ _ -> if Option.is_empty sorts then (* let id_of_f = Label.to_id (con_label f) in *) let register_with_sort fam_sort = let s = Universes.new_sort_in_family fam_sort in let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in - let value = change_property_sort s new_principle_type new_princ_name in - (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let ce = Declare.definition_entry value in (*FIXME, no poly, nothing *) + let evd',value = change_property_sort evd' s new_principle_type new_princ_name in + let evd' = fst (Typing.e_type_of ~refresh:true (Global.env ()) evd' value) in + (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) + let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs:(Evd.universe_context evd') value in ignore( Declare.declare_constant name @@ -338,7 +343,7 @@ let generate_functional_principle register_with_sort InSet in let ((id,(entry,g_kind)),hook) = - build_functional_principle interactive_proof old_princ_type new_sorts funs i + build_functional_principle evd interactive_proof old_princ_type new_sorts funs i proof_tac hook in (* Pr 1278 : @@ -441,39 +446,37 @@ let get_funs_constant mp dp = exception No_graph_found exception Found_type of int -let make_scheme (fas : (constant*glob_sort) list) : Entries.definition_entry list = - let env = Global.env () - and sigma = Evd.empty in +let make_scheme evd (fas : (pconstant*glob_sort) list) : Entries.definition_entry list = + let env = Global.env () in let funs = List.map fst fas in let first_fun = List.hd funs in - - - let funs_mp,funs_dp,_ = Names.repr_con first_fun in + let funs_mp,funs_dp,_ = KerName.repr (Constant.canonical (fst first_fun)) in let first_fun_kn = try - fst (find_Function_infos first_fun).graph_ind + fst (find_Function_infos (fst first_fun)).graph_ind with Not_found -> raise No_graph_found in - let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in - let this_block_funs = Array.map fst this_block_funs_indexes in + let this_block_funs_indexes = get_funs_constant funs_mp funs_dp (fst first_fun) in + let this_block_funs = Array.map (fun (c,_) -> (c,snd first_fun)) this_block_funs_indexes in let prop_sort = InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.map - (function cst -> List.assoc_f Constant.equal cst this_block_funs_indexes) + (function cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) funs in let ind_list = List.map (fun (idx) -> let ind = first_fun_kn,idx in - (ind,Univ.Instance.empty)(*FIXME*),true,prop_sort + (ind,snd first_fun),true,prop_sort ) funs_indexes in let sigma, schemes = - Indrec.build_mutual_induction_scheme env sigma ind_list + Indrec.build_mutual_induction_scheme env !evd ind_list in + let _ = evd := sigma in let l_schemes = List.map (Typing.type_of env sigma) schemes in @@ -484,6 +487,7 @@ let make_scheme (fas : (constant*glob_sort) list) : Entries.definition_entry lis ) fas in + evd:=sigma; (* We create the first priciple by tactic *) let first_type,other_princ_types = match l_schemes with @@ -492,34 +496,34 @@ let make_scheme (fas : (constant*glob_sort) list) : Entries.definition_entry lis in let ((_,(const,_)),_) = try - build_functional_principle false + build_functional_principle evd false first_type (Array.of_list sorts) this_block_funs 0 - (prove_princ_for_struct false 0 (Array.of_list funs)) + (prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) (fun _ _ _ -> ()) - with e when Errors.noncritical e -> - begin - begin - try - let id = Pfedit.get_current_proof_name () in - let s = Id.to_string id in - let n = String.length "___________princ_________" in - if String.length s >= n - then if String.equal (String.sub s 0 n) "___________princ_________" - then Pfedit.delete_current_proof () - else () - else () - with e when Errors.noncritical e -> () - end; - raise (Defining_principle e) - end + with e when Errors.noncritical e -> + begin + begin + try + let id = Pfedit.get_current_proof_name () in + let s = Id.to_string id in + let n = String.length "___________princ_________" in + if String.length s >= n + then if String.equal (String.sub s 0 n) "___________princ_________" + then Pfedit.delete_current_proof () + else () + else () + with e when Errors.noncritical e -> () + end; + raise (Defining_principle e) + end in incr i; let opacity = - let finfos = find_Function_infos this_block_funs.(0) in + let finfos = find_Function_infos (fst first_fun) in try let equation = Option.get finfos.equation_lemma in Declareops.is_opaque (Global.lookup_constant equation) @@ -533,7 +537,7 @@ let make_scheme (fas : (constant*glob_sort) list) : Entries.definition_entry lis [const] else let other_fun_princ_types = - let funs = Array.map mkConst this_block_funs in + let funs = Array.map mkConstU this_block_funs in let sorts = Array.of_list sorts in List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types in @@ -566,12 +570,13 @@ let make_scheme (fas : (constant*glob_sort) list) : Entries.definition_entry lis *) let ((_,(const,_)),_) = build_functional_principle + evd false (List.nth other_princ_types (!i - 1)) (Array.of_list sorts) this_block_funs !i - (prove_princ_for_struct false !i (Array.of_list funs)) + (prove_princ_for_struct evd false !i (Array.of_list (List.map fst funs))) (fun _ _ _ -> ()) in const @@ -589,24 +594,27 @@ let make_scheme (fas : (constant*glob_sort) list) : Entries.definition_entry lis in const::other_result + let build_scheme fas = Dumpglob.pause (); - let bodies_types = - make_scheme - (List.map + let evd = (ref Evd.empty) in + let pconstants = (List.map (fun (_,f,sort) -> let f_as_constant = try - match Smartlocate.global_with_alias f with - | Globnames.ConstRef c -> c - | _ -> Errors.error "Functional Scheme can only be used with functions" + Smartlocate.global_with_alias f with Not_found -> Errors.error ("Cannot find "^ Libnames.string_of_reference f) in - (f_as_constant,sort) + let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in + let evd',_ = Typing.e_type_of ~refresh:true (Global.env ()) evd' f in + let _ = evd := evd' in + (destConst f,sort) ) fas - ) + ) in + let bodies_types = + make_scheme evd pconstants in List.iter2 (fun (princ_id,_,_) def_entry -> @@ -633,14 +641,10 @@ let build_case_scheme fa = with Not_found -> Errors.error ("Cannot find "^ Libnames.string_of_reference f)) fa in let first_fun,u = destConst funs in - let funs_mp,funs_dp,_ = Names.repr_con first_fun in let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in - - - let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in - let this_block_funs = Array.map fst this_block_funs_indexes in + let this_block_funs = Array.map (fun (c,_) -> (c,u)) this_block_funs_indexes in let prop_sort = InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in @@ -666,12 +670,15 @@ let build_case_scheme fa = ); *) generate_functional_principle + (ref Evd.empty) false scheme_type (Some ([|sorts|])) (Some princ_name) this_block_funs 0 - (prove_princ_for_struct false 0 [|fst (destConst funs)|]) + (prove_princ_for_struct (ref Evd.empty) false 0 [|fst (destConst funs)|]) in () + + diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index a16b834f..f6e5578d 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -3,6 +3,7 @@ open Term open Misctypes val generate_functional_principle : + Evd.evar_map ref -> (* do we accept interactive proving *) bool -> (* induction principle on rel *) @@ -12,7 +13,7 @@ val generate_functional_principle : (* Name of the new principle *) (Id.t) option -> (* the compute functions to use *) - constant array -> + pconstant array -> (* We prove the nth- principle *) int -> (* The tactic to use to make the proof w.r @@ -27,7 +28,8 @@ val compute_new_princ_type_from_rel : constr array -> sorts array -> exception No_graph_found -val make_scheme : (constant*glob_sort) list -> Entries.definition_entry list +val make_scheme : Evd.evar_map ref -> + (pconstant*glob_sort) list -> Entries.definition_entry list val build_scheme : (Id.t*Libnames.reference*glob_sort) list -> unit val build_case_scheme : (Id.t*Libnames.reference*glob_sort) -> unit diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index fd48ab59..043d4328 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -217,7 +217,7 @@ VERNAC COMMAND EXTEND NewFunctionalScheme begin make_graph (Smartlocate.global_with_alias fun_name) end - ; + ; try Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> Errors.error ("Cannot generate induction principle(s)") @@ -386,7 +386,9 @@ let finduction (oid:Id.t option) (heuristic: fapp_info list -> fapp_info list) (nexttac:Proof_type.tactic) g = let test = match oid with | Some id -> - let idconstr = mkConst (const_of_id id) in + let idref = const_of_id id in + (* JF : FIXME : we probably need to keep trace of evd in presence of universe polymorphism *) + let idconstr = snd (Evd.fresh_global (Global.env ()) Evd.empty idref) in (fun u -> constr_head_match u idconstr) (* select only id *) | None -> (fun u -> isApp u) in (* select calls to any function *) let info_list = find_fapp test g in diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index a2577e2b..9e3f3986 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -252,7 +252,7 @@ let coq_False_ref = (* [make_discr_match_el \[e1,...en\]] builds match e1,...,en with - (the list of expresions on which we will do the matching) + (the list of expressions on which we will do the matching) *) let make_discr_match_el = List.map (fun e -> (e,(Anonymous,None))) @@ -674,7 +674,7 @@ and build_entry_lc_from_case env funname make_discr match el with brl end we first compute the list of lists corresponding to [el] and combine them . - Then for each elemeent of the combinations, + Then for each element of the combinations, we compute the result we compute one list per branch in [brl] and finally we just concatenate those list *) @@ -720,9 +720,9 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve match brl with | [] -> (* computed_branches *) {result = [];to_avoid = avoid} | br::brl' -> - (* alpha convertion to prevent name clashes *) + (* alpha conversion to prevent name clashes *) let _,idl,patl,return = alpha_br avoid br in - let new_avoid = idl@avoid in (* for now we can no more use idl as an indentifier *) + let new_avoid = idl@avoid in (* for now we can no more use idl as an identifier *) (* building a list of precondition stating that we are not in this branch (will be used in the following recursive calls) *) @@ -1149,7 +1149,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | _ -> mkGApp(mkGVar relname,args@[rt]),Id.Set.empty -(* debuging wrapper *) +(* debugging wrapper *) let rebuild_cons env nb_args relname args crossed_types rt = (* observennl (str "rebuild_cons : rt := "++ pr_glob_constr rt ++ *) (* str "nb_args := " ++ str (string_of_int nb_args)); *) @@ -1163,7 +1163,7 @@ let rebuild_cons env nb_args relname args crossed_types rt = (* naive implementation of parameter detection. A parameter is an argument which is only preceded by parameters and whose - calls are all syntaxically equal. + calls are all syntactically equal. TODO: Find a valid way to deal with implicit arguments here! *) @@ -1178,7 +1178,7 @@ let rec compute_cst_params relnames params = function compute_cst_params relnames t_params b | GCases _ -> params (* If there is still cases at this point they can only be - discriminitation ones *) + discrimination ones *) | GSort _ -> params | GHole _ -> params | GIf _ | GRec _ | GCast _ -> @@ -1233,11 +1233,11 @@ let rec rebuild_return_type rt = let do_build_inductive - mp_dp - funnames (funsargs: (Name.t * glob_constr * bool) list list) + evd (funconstants: Term.pconstant list) (funsargs: (Name.t * glob_constr * bool) list list) returned_types (rtl:glob_constr list) = let _time1 = System.get_time () in + let funnames = List.map (fun c -> Label.to_id (KerName.label (Constant.canonical (fst c)))) funconstants in (* Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *) let funnames_as_set = List.fold_right Id.Set.add funnames Id.Set.empty in let funnames = Array.of_list funnames in @@ -1252,27 +1252,25 @@ let do_build_inductive let relnames = Array.map mk_rel_id funnames in let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.empty in (* Construction of the pseudo constructors *) - let env = - Array.fold_right - (fun id env -> - let c = - match mp_dp with - | None -> (Constrintern.global_reference id) - | Some(mp,dp) -> mkConst (make_con mp dp (Label.of_id id)) - in - Environ.push_named (id,None, - try - Typing.type_of env Evd.empty c - with Not_found -> - raise (UserError("do_build_inductive", str "Cannot handle partial fixpoint")) - ) env + let evd,env = + Array.fold_right2 + (fun id c (evd,env) -> + let evd,t = Typing.e_type_of env evd (mkConstU c) in + evd, + Environ.push_named (id,None,t) + (* try *) + (* Typing.e_type_of env evd (mkConstU c) *) + (* with Not_found -> *) + (* raise (UserError("do_build_inductive", str "Cannot handle partial fixpoint")) *) + env ) funnames - (Global.env ()) + (Array.of_list funconstants) + (evd,Global.env ()) in let resa = Array.map (build_entry_lc env funnames_as_set []) rta in let env_with_graphs = - let rel_arity i funargs = (* Reduilding arities (with parameters) *) + let rel_arity i funargs = (* Rebuilding arities (with parameters) *) let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list = funargs in @@ -1426,7 +1424,7 @@ let do_build_inductive (* in *) let _time2 = System.get_time () in try - with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds false false)) Decl_kinds.Finite + with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false)) Decl_kinds.Finite with | UserError(s,msg) as e -> let _time3 = System.get_time () in @@ -1461,9 +1459,9 @@ let do_build_inductive -let build_inductive mp_dp funnames funsargs returned_types rtl = +let build_inductive evd funconstants funsargs returned_types rtl = try - do_build_inductive mp_dp funnames funsargs returned_types rtl + do_build_inductive evd funconstants funsargs returned_types rtl with e when Errors.noncritical e -> raise (Building_graph e) diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli index b0a05ec3..5bb1376e 100644 --- a/plugins/funind/glob_term_to_relation.mli +++ b/plugins/funind/glob_term_to_relation.mli @@ -7,8 +7,11 @@ open Names *) val build_inductive : - (ModPath.t * DirPath.t) option -> - Id.t list -> (* The list of function name *) +(* (ModPath.t * DirPath.t) option -> + Id.t list -> (* The list of function name *) + *) + Evd.evar_map -> + Term.pconstant list -> (Name.t*Glob_term.glob_constr*bool) list list -> (* The list of function args *) Constrexpr.constr_expr list -> (* The list of function returned type *) Glob_term.glob_constr list -> (* the list of body *) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 6dbd61cf..e211b688 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -8,7 +8,6 @@ open Libnames open Globnames open Glob_term open Declarations -open Declareops open Misctypes open Decl_kinds @@ -29,48 +28,55 @@ let choose_dest_or_ind scheme_info = let functional_induction with_clean c princl pat = Dumpglob.pause (); - let res = let f,args = decompose_app c in - fun g -> - let princ,bindings, princ_type = - match princl with - | None -> (* No principle is given let's find the good one *) - begin - match kind_of_term f with - | Const (c',u) -> - let princ_option = - let finfo = (* we first try to find out a graph on f *) - try find_Function_infos c' - with Not_found -> - errorlabstrm "" (str "Cannot find induction information on "++ - Printer.pr_lconstr (mkConst c') ) - in - match Tacticals.elimination_sort_of_goal g with - | InProp -> finfo.prop_lemma - | InSet -> finfo.rec_lemma - | InType -> finfo.rect_lemma - in - let princ = (* then we get the principle *) - try mkConst (Option.get princ_option ) - with Option.IsNone -> - (*i If there is not default lemma defined then, + let res = + let f,args = decompose_app c in + fun g -> + let princ,bindings, princ_type,g' = + match princl with + | None -> (* No principle is given let's find the good one *) + begin + match kind_of_term f with + | Const (c',u) -> + let princ_option = + let finfo = (* we first try to find out a graph on f *) + try find_Function_infos c' + with Not_found -> + errorlabstrm "" (str "Cannot find induction information on "++ + Printer.pr_lconstr (mkConst c') ) + in + match Tacticals.elimination_sort_of_goal g with + | InProp -> finfo.prop_lemma + | InSet -> finfo.rec_lemma + | InType -> finfo.rect_lemma + in + let princ,g' = (* then we get the principle *) + try + let g',princ = + Tacmach.pf_eapply (Evd.fresh_global) g (Globnames.ConstRef (Option.get princ_option )) in + princ,g' + with Option.IsNone -> + (*i If there is not default lemma defined then, we cross our finger and try to find a lemma named f_ind (or f_rec, f_rect) i*) - let princ_name = - Indrec.make_elimination_ident - (Label.to_id (con_label c')) - (Tacticals.elimination_sort_of_goal g) - in - try - mkConst(const_of_id princ_name ) - with Not_found -> (* This one is neither defined ! *) - errorlabstrm "" (str "Cannot find induction principle for " - ++Printer.pr_lconstr (mkConst c') ) - in - (princ,NoBindings, Tacmach.pf_type_of g princ) - | _ -> raise (UserError("",str "functional induction must be used with a function" )) - end - | Some ((princ,binding)) -> - princ,binding,Tacmach.pf_type_of g princ + let princ_name = + Indrec.make_elimination_ident + (Label.to_id (con_label c')) + (Tacticals.elimination_sort_of_goal g) + in + try + let princ_ref = const_of_id princ_name in + let (a,b) = Tacmach.pf_eapply (Evd.fresh_global) g princ_ref in + (b,a) + (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *) + with Not_found -> (* This one is neither defined ! *) + errorlabstrm "" (str "Cannot find induction principle for " + ++Printer.pr_lconstr (mkConst c') ) + in + (princ,NoBindings, Tacmach.pf_type_of g' princ,g') + | _ -> raise (UserError("",str "functional induction must be used with a function" )) + end + | Some ((princ,binding)) -> + princ,binding,Tacmach.pf_type_of g princ,g in let princ_infos = Tactics.compute_elim_sig princ_type in let args_as_induction_constr = @@ -116,7 +122,7 @@ let functional_induction with_clean c princl pat = princ_infos (args_as_induction_constr,princ'))) subst_and_reduce - g + g' in Dumpglob.continue (); res @@ -222,34 +228,54 @@ let process_vernac_interp_error e = let derive_inversion fix_names = try + let evd' = Evd.empty in (* we first transform the fix_names identifier into their corresponding constant *) - let fix_names_as_constant = - List.map (fun id -> fst (destConst (Constrintern.global_reference id))) fix_names + let evd',fix_names_as_constant = + List.fold_right + (fun id (evd,l) -> + let evd,c = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in + evd, destConst c::l + ) + fix_names + (evd',[]) in (* Then we check that the graphs have been defined If one of the graphs haven't been defined we do nothing *) - List.iter (fun c -> ignore (find_Function_infos c)) fix_names_as_constant ; + List.iter (fun c -> ignore (find_Function_infos (fst c))) fix_names_as_constant ; try + let evd', lind = + List.fold_right + (fun id (evd,l) -> + let evd,id = + Evd.fresh_global + (Global.env ()) evd + (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) + in + evd,(fst (destInd id))::l + ) + fix_names + (evd',[]) + in Invfun.derive_correctness Functional_principles_types.make_scheme functional_induction fix_names_as_constant - (*i The next call to mk_rel_id is valid since we have just construct the graph - Ensures by : register_built - i*) - (List.map - (fun id -> fst (destInd (Constrintern.global_reference (mk_rel_id id)))) - fix_names - ) - with e when Errors.noncritical e -> + lind; + with e when Errors.noncritical e -> let e' = process_vernac_interp_error e in msg_warning (str "Cannot build inversion information" ++ if do_observe () then (fnl() ++ Errors.print e') else mt ()) - with e when Errors.noncritical e -> () + with e when Errors.noncritical e -> + let e' = process_vernac_interp_error e in + msg_warning + (str "Cannot build inversion information (early)" ++ + if do_observe () then (fnl() ++ Errors.print e') else mt ()) let warning_error names e = let e = process_vernac_interp_error e in @@ -293,7 +319,7 @@ let error_error names e = e_explain e) | _ -> raise e -let generate_principle mp_dp on_error +let generate_principle (evd:Evd.evar_map ref) pconstants on_error is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) recdefs interactive_proof (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) : unit = @@ -303,7 +329,7 @@ let generate_principle mp_dp on_error let funs_types = List.map (function ((_,_,_,types,_),_) -> types) fix_rec_l in try (* We then register the Inductive graphs of the functions *) - Glob_term_to_relation.build_inductive mp_dp names funs_args funs_types recdefs; + Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types recdefs; if do_built then begin @@ -328,14 +354,18 @@ let generate_principle mp_dp on_error let _ = List.map_i (fun i x -> - let princ = Indrec.lookup_eliminator (ind_kn,i) (InProp) in - let princ_type = Global.type_of_global_unsafe princ in - Functional_principles_types.generate_functional_principle + let princ = Indrec.lookup_eliminator (ind_kn,i) (InProp) in + let evd',uprinc = Evd.fresh_global (Global.env ()) !evd princ in + let evd',princ_type = Typing.e_type_of ~refresh:true (Global.env ()) evd' uprinc in + let _ = evd := evd' in + Functional_principles_types.generate_functional_principle + evd interactive_proof princ_type None None - funs_kn + (Array.of_list pconstants) + (* funs_kn *) i (continue_proof 0 [|funs_kn.(i)|]) ) @@ -352,10 +382,37 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp match fixpoint_exprl with | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in - Command.do_definition fname (Decl_kinds.Global,(*FIXME*)false,Decl_kinds.Definition) - bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ())) + Command.do_definition + fname + (Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) + bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ())); + let evd,rev_pconstants = + List.fold_left + (fun (evd,l) (((_,fname),_,_,_,_),_) -> + let evd,c = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in + evd,((destConst c)::l) + ) + (Evd.empty,[]) + fixpoint_exprl + in + evd,List.rev rev_pconstants | _ -> - Command.do_fixpoint Global false(*FIXME*) fixpoint_exprl + Command.do_fixpoint Global (Flags.is_universe_polymorphism ()) fixpoint_exprl; + let evd,rev_pconstants = + List.fold_left + (fun (evd,l) (((_,fname),_,_,_,_),_) -> + let evd,c = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in + evd,((destConst c)::l) + ) + (Evd.empty,[]) + fixpoint_exprl + in + evd,List.rev rev_pconstants + let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation @@ -400,10 +457,10 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas [(f_app_args,None);(body,None)]) in let eq = Constrexpr_ops.prod_constr_expr unbounded_eq args in - let hook (f_ref,_) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type + let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type nb_args relation = try - pre_hook + pre_hook [fconst] (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation ); @@ -551,7 +608,7 @@ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacex fixpoint_exprl_with_new_bl -let do_generate_principle mp_dp on_error register_built interactive_proof +let do_generate_principle pconstants on_error register_built interactive_proof (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) :unit = List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl; let _is_struct = @@ -566,9 +623,10 @@ let do_generate_principle mp_dp on_error register_built interactive_proof let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in - let pre_hook = + let pre_hook pconstants = generate_principle - mp_dp + (ref (Evd.empty)) + pconstants on_error true register_built @@ -589,9 +647,10 @@ let do_generate_principle mp_dp on_error register_built interactive_proof let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let using_lemmas = [] in let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in - let pre_hook = + let pre_hook pconstants = generate_principle - mp_dp + (ref Evd.empty) + pconstants on_error true register_built @@ -615,20 +674,26 @@ let do_generate_principle mp_dp on_error register_built interactive_proof let fix_names = List.map (function (((_,name),_,_,_,_),_) -> name) fixpoint_exprl in - (* ok all the expressions are structural *) + (* ok all the expressions are structural *) let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in - if register_built then register_struct is_rec fixpoint_exprl; + let evd,pconstants = + if register_built + then register_struct is_rec fixpoint_exprl + else (Evd.empty,pconstants) + in + let evd = ref evd in generate_principle - mp_dp + (ref !evd) + pconstants on_error false register_built fixpoint_exprl recdefs interactive_proof - (Functional_principles_proofs.prove_princ_for_struct interactive_proof); - if register_built then derive_inversion fix_names; + (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); + if register_built then begin derive_inversion fix_names; end; true; in () @@ -774,7 +839,7 @@ let make_graph (f_ref:global_reference) = with_full_print (fun () -> (Constrextern.extern_constr false env Evd.empty body, Constrextern.extern_type false env Evd.empty - ((*FIXNE*) Typeops.type_of_constant_type env c_body.const_type) + ((*FIXME*) Typeops.type_of_constant_type env c_body.const_type) ) ) () @@ -812,13 +877,13 @@ let make_graph (f_ref:global_reference) = [((Loc.ghost,id),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] in let mp,dp,_ = repr_con c in - do_generate_principle (Some (mp,dp)) error_error false false expr_list; + do_generate_principle [c,Univ.Instance.empty] error_error false false expr_list; (* We register the infos *) List.iter (fun (((_,id),_,_,_,_),_) -> add_Function false (make_con mp dp (Label.of_id id))) expr_list); Dumpglob.continue () -let do_generate_principle = do_generate_principle None warning_error true +let do_generate_principle = do_generate_principle [] warning_error true diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 76f8c6d2..738ade8c 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -108,7 +108,7 @@ let const_of_id id = let _,princ_ref = qualid_of_reference (Libnames.Ident (Loc.ghost,id)) in - try Nametab.locate_constant princ_ref + try Constrintern.locate_reference princ_ref with Not_found -> Errors.error ("cannot find "^ Id.to_string id) let def_of_const t = @@ -380,9 +380,9 @@ let find_Function_of_graph ind = Indmap.find ind !from_graph let update_Function finfo = -(* Pp.msgnl (pr_info finfo); *) + (* Pp.msgnl (pr_info finfo); *) Lib.add_anonymous_leaf (in_Function finfo) - + let add_Function is_general f = let f_id = Label.to_id (con_label f) in diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 67ddf374..10daf6e8 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -42,7 +42,7 @@ val chop_rprod_n : int -> Glob_term.glob_constr -> val def_of_const : Term.constr -> Term.constr val eq : Term.constr Lazy.t val refl_equal : Term.constr Lazy.t -val const_of_id: Id.t -> constant +val const_of_id: Id.t -> Globnames.global_reference(* constantyes *) val jmeq : unit -> Term.constr val jmeq_refl : unit -> Term.constr diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 0c7b0a0b..d10924f8 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -45,7 +45,7 @@ let pr_with_bindings prc prlc (c,bl) = let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = pr_with_bindings prc prc (c,bl) -(* The local debuging mechanism *) +(* The local debugging mechanism *) (* let msgnl = Pp.msgnl *) let observe strm = @@ -70,7 +70,7 @@ let do_observe_tac s tac g = with reraise -> let reraise = Errors.push reraise in let e = Cerrors.process_vernac_interp_error reraise in - msgnl (str "observation "++ s++str " raised exception " ++ + observe (str "observation "++ s++str " raised exception " ++ Errors.iprint e ++ str " on goal " ++ goal ); iraise reraise;; @@ -92,13 +92,24 @@ let nf_zeta = Evd.empty -(* [id_to_constr id] finds the term associated to [id] in the global environment *) -let id_to_constr id = +(* (\* [id_to_constr id] finds the term associated to [id] in the global environment *\) *) +(* let id_to_constr id = *) +(* try *) +(* Constrintern.global_reference id *) +(* with Not_found -> *) +(* raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id)) *) + + +let make_eq () = try - Constrintern.global_reference id - with Not_found -> - raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id)) + Universes.constr_of_global (Coqlib.build_coq_eq ()) + with _ -> assert false +let make_eq_refl () = + try + Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + with _ -> assert false + (* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. @@ -111,11 +122,13 @@ let id_to_constr id = res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion *) -let generate_type g_to_f f graph i = +let generate_type evd g_to_f f graph i = (*i we deduce the number of arguments of the function and its returned type from the graph i*) - let gr,u = destInd graph in - let graph_arity = Inductive.type_of_inductive (Global.env()) - (Global.lookup_inductive gr, u) in + let evd',graph = + Evd.fresh_global (Global.env ()) !evd (Globnames.IndRef (fst (destInd graph))) + in + let evd',graph_arity = Typing.e_type_of (Global.env ()) evd' graph in + evd:=evd'; let ctxt,_ = decompose_prod_assum graph_arity in let fun_ctxt,res_type = match ctxt with @@ -141,11 +154,10 @@ let generate_type g_to_f f graph i = the hypothesis [res = fv] can then be computed We will need to lift it by one in order to use it as a conclusion i*) - let make_eq () = -(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) + let make_eq = make_eq () in let res_eq_f_of_args = - mkApp(make_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|]) + mkApp(make_eq ,[|lift 2 res_type;mkRel 1;mkRel 2|]) in (*i The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed @@ -158,12 +170,12 @@ let generate_type g_to_f f graph i = \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) let pre_ctxt = - (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt + (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(f,args_as_rels)),res_type)::fun_ctxt in (*i and we can return the solution depending on which lemma type we are defining i*) if g_to_f - then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args) - else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied) + then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph + else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph (* @@ -171,7 +183,7 @@ let generate_type g_to_f f graph i = WARNING: while convertible, [type_of body] and [type] can be non equal *) -let find_induction_principle f = +let find_induction_principle evd f = let f_as_constant,u = match kind_of_term f with | Const c' -> c' | _ -> error "Must be used with a function" @@ -180,28 +192,10 @@ let find_induction_principle f = match infos.rect_lemma with | None -> raise Not_found | Some rect_lemma -> - let rect_lemma = mkConst rect_lemma in - let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in - rect_lemma,typ - - - -(* let fname = *) -(* match kind_of_term f with *) -(* | Const c' -> *) -(* Label.to_id (con_label c') *) -(* | _ -> error "Must be used with a function" *) -(* in *) - -(* let princ_name = *) -(* ( *) -(* Indrec.make_elimination_ident *) -(* fname *) -(* InType *) -(* ) *) -(* in *) -(* let c = (\* mkConst(mk_from_const (destConst f) princ_name ) in *\) failwith "" in *) -(* c,Typing.type_of (Global.env ()) Evd.empty c *) + let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (Globnames.ConstRef rect_lemma) in + let evd',typ = Typing.e_type_of ~refresh:true (Global.env ()) evd' rect_lemma in + evd:=evd'; + rect_lemma,typ let rec generate_fresh_id x avoid i = @@ -211,11 +205,6 @@ let rec generate_fresh_id x avoid i = let id = Namegen.next_ident_away_in_goal x avoid in id::(generate_fresh_id x (id::avoid) (pred i)) -let make_eq () = -(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) -let make_eq_refl () = -(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) - (* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] is the tactic used to prove correctness lemma. @@ -241,7 +230,7 @@ let make_eq_refl () = \end{enumerate} *) -let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic = +let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic = fun g -> (* first of all we recreate the lemmas types to be used as predicates of the induction principle that is~: @@ -255,12 +244,12 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let f_principle,princ_type = schemes.(i) in let princ_type = nf_zeta princ_type in let princ_infos = Tactics.compute_elim_sig princ_type in - (* The number of args of the function is then easilly computable *) + (* The number of args of the function is then easily computable *) let nb_fun_args = nb_prod (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 funcitonnal principle is defined in the - environement and due to the bug #1174, we will need to pose the principle + (* 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") ids in @@ -286,46 +275,6 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem (* The tactic to prove the ith branch of the principle *) let prove_branche i g = (* We get the identifiers of this branch *) - (* - let this_branche_ids = - List.fold_right - (fun (_,pat) acc -> - match pat with - | Genarg.IntroIdentifier id -> Id.Set.add id acc - | _ -> anomaly (Pp.str "Not an identifier") - ) - (List.nth intro_pats (pred i)) - Id.Set.empty - in - let pre_args g = - List.fold_right - (fun (id,b,t) pre_args -> - if Id.Set.mem id this_branche_ids - then - match b with - | None -> id::pre_args - | Some b -> pre_args - else pre_args - ) - (pf_hyps g) - ([]) - in - let pre_args g = List.rev (pre_args g) in - let pre_tac g = - List.fold_right - (fun (id,b,t) pre_tac -> - if Id.Set.mem id this_branche_ids - then - match b with - | None -> pre_tac - | Some b -> - tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.AllOccurrences,EvalVarRef id])) allHyps) pre_tac - else pre_tac - ) - (pf_hyps g) - tclIDTAC - in -*) let pre_args = List.fold_right (fun (_,pat) acc -> @@ -345,7 +294,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem If [hid] has another type the corresponding argument of the constructor is [hid] *) let constructor_args g = - List.fold_right + List.fold_right (fun hid acc -> let type_of_hid = pf_type_of g (mkVar hid) in match kind_of_term type_of_hid with @@ -358,7 +307,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem | App(eq,args), App(graph',_) when (eq_constr eq eq_ind) && - Array.exists (eq_constr graph') graphs_constr -> + Array.exists (Constr.eq_constr_nounivs graph') graphs_constr -> (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) ::acc) | _ -> mkVar hid :: acc @@ -395,7 +344,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem end in (* we can then build the final proof term *) - let app_constructor g = applist((mkConstruct(constructor)),constructor_args g) in + 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 @@ -428,7 +377,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem (* 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) + observe_tac "exact" (fun g -> + Proofview.V82.of_tactic (exact_check (app_constructor g)) g) ] ) g @@ -436,13 +386,15 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem (* end of branche proof *) let lemmas = Array.map - (fun (_,(ctxt,concl)) -> + (fun ((_,(ctxt,concl))) -> match ctxt with | [] | [_] | [_;_] -> anomaly (Pp.str "bad context") | hres::res::(x,_,t)::ctxt -> - Termops.it_mkLambda_or_LetIn - (Termops.it_mkProd_or_LetIn concl [hres;res]) - ((x,None,t)::ctxt) + let res = Termops.it_mkLambda_or_LetIn + (Termops.it_mkProd_or_LetIn concl [hres;res]) + ((x,None,t)::ctxt) + in + res ) lemmas_types_infos in @@ -457,7 +409,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> let id = Namegen.next_ident_away (Nameops.out_name x) avoid in - (*(Loc.ghost,Glob_term.NamedHyp id,p)*)p::bindings,id::avoid + p::bindings,id::avoid ) ([],pf_ids_of_hyps g) princ_infos.params @@ -467,12 +419,12 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem List.rev (fst (List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> let id = Namegen.next_ident_away (Nameops.out_name x) avoid in - (*(Loc.ghost,Glob_term.NamedHyp id,(nf_zeta p))*) (nf_zeta p)::bindings,id::avoid) + (nf_zeta p)::bindings,id::avoid) ([],avoid) princ_infos.predicates (lemmas))) in - (* Glob_term.ExplicitBindings *) (params_bindings@lemmas_bindings) + (params_bindings@lemmas_bindings) in tclTHENSEQ [ @@ -484,10 +436,11 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem (* 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.e_type_of gl term in + (observe_tac + "functional_induction" ( + (fun gl -> + let term = mkApp (mkVar principle_id,Array.of_list bindings) in + let gl', _ty = pf_eapply (Typing.e_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 ) @@ -495,230 +448,6 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem g -(* -let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic = - 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\] - *) - let lemmas = - Array.map - (fun (_,(ctxt,concl)) -> - match ctxt with - | [] | [_] | [_;_] -> anomaly (Pp.str "bad context") - | hres::res::(x,_,t)::ctxt -> - Termops.it_mkLambda_or_LetIn - (Termops.it_mkProd_or_LetIn concl [hres;res]) - ((x,None,t)::ctxt) - ) - lemmas_types_infos - in - (* we the get the definition of the graphs block *) - let graph_ind = destInd 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 = nf_zeta princ_type in - let princ_infos = Tactics.compute_elim_sig princ_type in - (* The number of args of the function is then easilly computable *) - let nb_fun_args = nb_prod (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 funcitonnal principle is defined in the - environement 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") ids in - let ids = principle_id :: ids in - (* We get the branches of the principle *) - let branches = List.rev princ_infos.branches in - (* and built the intro pattern for each of them *) - let intro_pats = - List.map - (fun (_,_,br_type) -> - List.map - (fun id -> Loc.ghost, Genarg.IntroIdentifier id) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) - ) - branches - in - (* before building the full intro pattern for the principle *) - let pat = Some (Loc.ghost,Genarg.IntroOrAndPattern intro_pats) in - let eq_ind = Coqlib.build_coq_eq () in - let eq_construct = mkConstruct((destInd 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 this_branche_ids = - List.fold_right - (fun (_,pat) acc -> - match pat with - | Genarg.IntroIdentifier id -> Id.Set.add id acc - | _ -> anomaly (Pp.str "Not an identifier") - ) - (List.nth intro_pats (pred i)) - Id.Set.empty - in - (* and get the real args of the branch by unfolding the defined constant *) - let pre_args,pre_tac = - List.fold_right - (fun (id,b,t) (pre_args,pre_tac) -> - if Id.Set.mem id this_branche_ids - then - match b with - | None -> (id::pre_args,pre_tac) - | Some b -> - (pre_args, - tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.AllOccurrences,EvalVarRef id])) allHyps) pre_tac - ) - else (pre_args,pre_tac) - ) - (pf_hyps g) - ([],tclIDTAC) - in - (* - 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 = - List.fold_right - (fun hid acc -> - let type_of_hid = pf_type_of g (mkVar hid) in - match kind_of_term type_of_hid with - | Prod(_,_,t') -> - begin - match kind_of_term t' with - | Prod(_,t'',t''') -> - begin - match kind_of_term t'',kind_of_term t''' with - | App(eq,args), App(graph',_) - when - (eq_constr eq eq_ind) && - Array.exists (eq_constr graph') graphs_constr -> - ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) - ::args.(2)::acc) - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - ) pre_args [] - in - (* in fact we must also add the parameters to the constructor args *) - let constructor_args = - let params_id = fst (List.chop princ_infos.nparams args_names) in - (List.map mkVar params_id)@(List.rev constructor_args) - 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 - if constructor_num <= length - then - begin - (kn,!ind_number),constructor_num - end - 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 = applist((mkConstruct(constructor)),constructor_args) 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); - ( - tclTHENSEQ - [ - (* unfolding of all the defined variables introduced by this branch *) - observe_tac "unfolding" pre_tac; - (* $zeta$ normalizing of the conclusion *) - h_reduce - (Glob_term.Cbv - { Glob_term.all_flags with - Glob_term.rDelta = false ; - Glob_term.rConst = [] - } - ) - onConcl; - (* introducing the the result of the graph and the equality hypothesis *) - observe_tac "introducing" (tclMAP h_intro [res;hres]); - (* replacing [res] with its value *) - observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres)); - (* Conclusion *) - observe_tac "exact" (exact_check app_constructor) - ] - ) - g - in - (* end of branche proof *) - 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) (x,_,_) p -> - let id = Namegen.next_ident_away (Nameops.out_name x) avoid in - (Loc.ghost,Glob_term.NamedHyp id,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) (x,_,_) p -> - let id = Namegen.next_ident_away (Nameops.out_name x) avoid in - (Loc.ghost,Glob_term.NamedHyp id,(nf_zeta p))::bindings,id::avoid) - ([],avoid) - princ_infos.predicates - (lemmas))) - in - Glob_term.ExplicitBindings (params_bindings@lemmas_bindings) - in - tclTHENSEQ - [ observe_tac "intro args_names" (tclMAP h_intro args_names); - observe_tac "principle" (assert_by - (Name principle_id) - princ_type - (exact_check f_principle)); - tclTHEN_i - (observe_tac "functional_induction" ( - fun g -> - observe - (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g)) (mkVar principle_id,bindings)); - functional_induction false (applist(funs_constr.(i),List.map mkVar args_names)) - (Some (mkVar principle_id,bindings)) - pat g - )) - (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) - ] - g -*) (* [generalize_dependent_of x hyp g] @@ -735,12 +464,9 @@ let generalize_dependent_of x hyp g = g - - - - (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis +(* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis (unfolding, substituting, destructing cases \ldots) - *) + *) let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g and intros_with_rewrite_aux : tactic = @@ -1020,11 +746,6 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = g - - -let do_save () = Lemmas.save_proof (Vernacexpr.Proved(false,None)) - - (* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness lemmas for each function in [funs] w.r.t. [graphs] @@ -1032,21 +753,28 @@ let do_save () = Lemmas.save_proof (Vernacexpr.Proved(false,None)) [functional_induction] is Indfun.functional_induction (same pb) *) -let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = +let derive_correctness make_scheme functional_induction (funs: pconstant list) (graphs:inductive list) = + assert (funs <> []); + assert (graphs <> []); let funs = Array.of_list funs and graphs = Array.of_list graphs in - let funs_constr = Array.map mkConst funs in - States.with_state_protection_on_exception (fun () -> - let graphs_constr = Array.map mkInd graphs in - let lemmas_types_infos = - Util.Array.map2_i - (fun i f_constr graph -> - let const_of_f,u = destConst f_constr in - let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = - generate_type false const_of_f graph i - in - let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in + let funs_constr = Array.map mkConstU funs in + States.with_state_protection_on_exception + (fun () -> + let evd = ref Evd.empty in + let graphs_constr = Array.map mkInd graphs in + let lemmas_types_infos = + Util.Array.map2_i + (fun i f_constr graph -> + (* let const_of_f,u = destConst f_constr in *) + let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = + generate_type evd false f_constr graph i + in + let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in + let _ = evd := fst (Typing.e_type_of (Global.env ()) !evd type_of_lemma) in let type_of_lemma = nf_zeta type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); + observe (str "type_of_lemma := " ++ Printer.pr_lconstr_env (Global.env ()) !evd type_of_lemma); type_of_lemma,type_info ) funs_constr @@ -1055,65 +783,79 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g let schemes = (* The functional induction schemes are computed and not saved if there is more that one function if the block contains only one function we can safely reuse [f_rect] - *) + *) try if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; - [| find_induction_principle funs_constr.(0) |] + [| find_induction_principle evd funs_constr.(0) |] with Not_found -> + ( + Array.of_list (List.map (fun entry -> (fst (fst(Future.force entry.Entries.const_entry_body)), Option.get entry.Entries.const_entry_type ) ) - (make_scheme (Array.map_to_list (fun const -> const,GType []) funs)) + (make_scheme evd (Array.map_to_list (fun const -> const,GType []) funs)) ) + ) in let proving_tac = - prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos + prove_fun_correct !evd functional_induction funs_constr graphs_constr schemes lemmas_types_infos in Array.iteri (fun i f_as_constant -> - let f_id = Label.to_id (con_label f_as_constant) in + let f_id = Label.to_id (con_label (fst f_as_constant)) in (*i The next call to mk_correct_id is valid since we are constructing the lemma Ensures by: obvious i*) let lem_id = mk_correct_id f_id in - Lemmas.start_proof lem_id - (Decl_kinds.Global,false(*FIXME*),(Decl_kinds.Proof Decl_kinds.Theorem)) - (*FIXME*) Evd.empty - (fst lemmas_types_infos.(i)) + let (typ,_) = lemmas_types_infos.(i) in + Lemmas.start_proof + lem_id + (Decl_kinds.Global,Flags.is_universe_polymorphism (),((Decl_kinds.Proof Decl_kinds.Theorem))) + !evd + typ (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by - (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") - (proving_tac i)))); - do_save (); - let finfo = find_Function_infos f_as_constant in - let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in - update_Function {finfo with correctness_lemma = Some lem_cst} + (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") + (proving_tac i)))); + (Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None)))); + let finfo = find_Function_infos (fst f_as_constant) in + (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) + let _,lem_cst_constr = Evd.fresh_global + (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in + let (lem_cst,_) = destConst lem_cst_constr in + update_Function {finfo with correctness_lemma = Some lem_cst}; + ) funs; + (* let evd = ref Evd.empty in *) let lemmas_types_infos = Util.Array.map2_i (fun i f_constr graph -> - let const_of_f = fst (destConst f_constr) in - let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = - generate_type true const_of_f graph i - in - let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let type_of_lemma = nf_zeta type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); - type_of_lemma,type_info + let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = + generate_type evd true f_constr graph i + in + let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = + Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt + in + let type_of_lemma = nf_zeta type_of_lemma in + observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); + type_of_lemma,type_info ) funs_constr graphs_constr in - let kn,_ as graph_ind = fst (destInd graphs_constr.(0)) in - let mib,mip = Global.lookup_inductive graph_ind in + + let (kn,_) as graph_ind,u = (destInd graphs_constr.(0)) in + let mib,mip = Global.lookup_inductive graph_ind in let sigma, scheme = - (Indrec.build_mutual_induction_scheme (Global.env ()) Evd.empty + (Indrec.build_mutual_induction_scheme (Global.env ()) !evd (Array.to_list (Array.mapi - (fun i _ -> ((kn,i),Univ.Instance.empty)(*FIXME*),true,InType) + (fun i _ -> ((kn,i),u(* Univ.Instance.empty *)),true,InType) mib.Declarations.mind_packets ) ) @@ -1127,26 +869,27 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g in Array.iteri (fun i f_as_constant -> - let f_id = Label.to_id (con_label f_as_constant) in + let f_id = Label.to_id (con_label (fst f_as_constant)) in (*i The next call to mk_complete_id is valid since we are constructing the lemma Ensures by: obvious i*) let lem_id = mk_complete_id f_id in Lemmas.start_proof lem_id - (Decl_kinds.Global,false(*FIXME*),(Decl_kinds.Proof Decl_kinds.Theorem)) - (*FIXME*) Evd.empty + (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) !evd (fst lemmas_types_infos.(i)) (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") - (proving_tac i)))); - do_save (); - let finfo = find_Function_infos f_as_constant in - let lem_cst,u = destConst (Constrintern.global_reference lem_id) in + (proving_tac i)))) ; + (Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None)))); + let finfo = find_Function_infos (fst f_as_constant) in + let _,lem_cst_constr = Evd.fresh_global + (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in + let (lem_cst,_) = destConst lem_cst_constr in update_Function {finfo with completeness_lemma = Some lem_cst} ) funs) - () + () (***********************************************) @@ -1257,7 +1000,7 @@ let invfun qhyp f g = match f with | Some f -> invfun qhyp f g | None -> - Proofview.V82.of_tactic begin + Proofview.V82.of_tactic begin Tactics.try_intros_until (fun hid -> Proofview.V82.tactic begin fun g -> let hyp_typ = pf_type_of g (mkVar hid) in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 5558556e..0999b95d 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -60,7 +60,7 @@ let declare_fun f_id kind ?(ctx=Univ.UContext.empty) value = let ce = definition_entry ~univs:ctx value (*FIXME *) in ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; -let defined () = Lemmas.save_proof (Vernacexpr.Proved (false,None)) +let defined () = Lemmas.save_proof (Vernacexpr.(Proved (Transparent,None))) let def_of_const t = match (kind_of_term t) with @@ -217,7 +217,7 @@ let rec print_debug_queue b e = begin Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal); end; - print_debug_queue false e; + (* print_debug_queue false e; *) end let observe strm = @@ -246,6 +246,18 @@ let observe_tac s tac g = then do_observe_tac s tac g else tac g + +let observe_tclTHENLIST s tacl = + if do_observe () + then + let rec aux n = function + | [] -> tclIDTAC + | [tac] -> observe_tac (s ++ spc () ++ int n) tac + | tac::tacl -> observe_tac (s ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) + in + aux 0 tacl + else tclTHENLIST tacl + (* Conclusion tactics *) (* The boolean value is_mes expresses that the termination is expressed @@ -256,11 +268,11 @@ let tclUSER tac is_mes l g = | None -> clear [] | Some l -> tclMAP (fun id -> tclTRY (clear [id])) (List.rev l) in - tclTHENLIST + observe_tclTHENLIST (str "tclUSER1") [ clear_tac; if is_mes - then tclTHENLIST + then observe_tclTHENLIST (str "tclUSER2") [ unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force Indfun_common.ltof_ref))]; @@ -378,12 +390,12 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = ) [] 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 - tclTHENLIST + observe_tclTHENLIST (str "treat_case1") [ h_intros (List.rev rev_ids); Proofview.V82.of_tactic (intro_using teq_id); onLastHypId (fun heq -> - tclTHENLIST[ + observe_tclTHENLIST (str "treat_case2")[ thin to_intros; h_intros to_intros; (fun g' -> @@ -508,14 +520,14 @@ let rec prove_lt hyple g = in let y = List.hd (List.tl (snd (decompose_app (pf_type_of g (mkVar h))))) in - tclTHENLIST[ + observe_tclTHENLIST (str "prove_lt1")[ Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); observe_tac (str "prove_lt") (prove_lt hyple) ] with Not_found -> ( ( - tclTHENLIST[ + observe_tclTHENLIST (str "prove_lt2")[ Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); (observe_tac (str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) ]) @@ -533,7 +545,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = 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 - tclTHENLIST[ + observe_tclTHENLIST (str "destruct_bounds_aux1")[ Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); Proofview.V82.of_tactic (intro_then (fun id -> @@ -541,18 +553,18 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = observe_tac (str "destruct_bounds_aux") (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) [ - tclTHENLIST[Proofview.V82.of_tactic (intro_using h_id); + observe_tclTHENLIST (str "")[Proofview.V82.of_tactic (intro_using h_id); Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); Proofview.V82.of_tactic default_full_auto]; - tclTHENLIST[ + observe_tclTHENLIST (str "destruct_bounds_aux2")[ observe_tac (str "clearing k ") (clear [id]); h_intros [k;h';def]; observe_tac (str "simple_iter") (simpl_iter Locusops.onConcl); observe_tac (str "unfold functional") (unfold_in_concl[(Locus.OnlyOccurrences [1], evaluable_of_global_reference infos.func)]); - observe_tac (str "test" ) ( - tclTHENLIST[ + ( + observe_tclTHENLIST (str "test")[ list_rewrite true (List.fold_right (fun e acc -> (mkVar e,true)::acc) @@ -572,7 +584,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = )end)) ] g | (_,v_bound)::l -> - tclTHENLIST[ + observe_tclTHENLIST (str "destruct_bounds_aux3")[ Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); clear [v_bound]; tclDO 2 (Proofview.V82.of_tactic intro); @@ -580,7 +592,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = (fun p_hyp -> (onNthHypId 2 (fun p -> - tclTHENLIST[ + observe_tclTHENLIST (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); @@ -604,7 +616,7 @@ 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 - tclTHENLIST[ + observe_tclTHENLIST (str "terminate_app1")[ continuation_tac infos; observe_tac (str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); @@ -615,7 +627,7 @@ let terminate_app f_and_args expr_info continuation_tac infos = let terminate_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - tclTHENLIST[ + observe_tclTHENLIST (str "terminate_others")[ continuation_tac infos; observe_tac (str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); @@ -671,17 +683,17 @@ let mkDestructEq : let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in pf_typel new_hyps (fun _ -> - tclTHENLIST + observe_tclTHENLIST (str "mkDestructEq") [Simple.generalize new_hyps; (fun g2 -> Proofview.V82.of_tactic (change_in_concl None - (fun sigma -> + (fun patvars sigma -> pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2))) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = - let b = + let f_is_present = try check_not_nested (expr_info.f_id::expr_info.forbidden_ids) a; false @@ -697,11 +709,11 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let 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 (str "treating case " ++ int (Array.length l) ++ spc () ++ Printer.pr_lconstr a') + observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_lconstr a') (try (tclTHENS destruct_tac - (List.map_i (fun i e -> observe_tac (str "do treat case") (treat_case b to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l) + (List.map_i (fun i e -> observe_tac (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("Refiner.thensn_tac3",_) @@ -717,11 +729,11 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = try let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in - tclTHENLIST[ + observe_tclTHENLIST (str "terminate_app_rec")[ continuation_tac new_infos; if expr_info.is_final && expr_info.is_main_branch then - tclTHENLIST[ + observe_tclTHENLIST (str "terminate_app_rec1")[ observe_tac (str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); observe_tac (str "destruct_bounds (3)") @@ -734,7 +746,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = observe_tac (str "terminate_app_rec not found") (tclTHENS (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) [ - tclTHENLIST[ + observe_tclTHENLIST (str "terminate_app_rec2")[ Proofview.V82.of_tactic (intro_using rec_res_id); Proofview.V82.of_tactic intro; onNthHypId 1 @@ -747,11 +759,11 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = (v,v_bound)::expr_info.values_and_bounds; args_assoc=(args,mkVar v)::expr_info.args_assoc } in - tclTHENLIST[ + observe_tclTHENLIST (str "terminate_app_rec3")[ continuation_tac new_infos; if expr_info.is_final && expr_info.is_main_branch then - tclTHENLIST[ + observe_tclTHENLIST (str "terminate_app_rec4")[ observe_tac (str "first split") (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); observe_tac (str "destruct_bounds (2)") @@ -769,7 +781,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) [ observe_tac (str "assumption") (Proofview.V82.of_tactic assumption); - tclTHENLIST + observe_tclTHENLIST (str "terminate_app_rec5") [ tclTRY(list_rewrite true (List.map @@ -805,7 +817,7 @@ let prove_terminate = travel terminate_info (* Equation proof *) let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = - terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos + observe_tac (str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) let rec prove_le g = let x,z = @@ -826,7 +838,7 @@ let rec prove_le g = let _,args = decompose_app t in List.hd (List.tl args) in - tclTHENLIST[ + observe_tclTHENLIST (str "prove_le")[ Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); observe_tac (str "prove_le (rec)") (prove_le) ] @@ -856,7 +868,7 @@ let rec make_rewrite_list expr_info max = function (f_S max)]) false) g) ) ) [make_rewrite_list expr_info max l; - tclTHENLIST[ (* x < S max proof *) + observe_tclTHENLIST (str "make_rewrite_list")[ (* x < S max proof *) Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); observe_tac (str "prove_le(2)") prove_le ] @@ -883,7 +895,7 @@ let make_rewrite expr_info l hp max = (f_S (f_S max))]) false)) g) [observe_tac(str "make_rewrite finalize") ( (* tclORELSE( h_reflexivity) *) - (tclTHENLIST[ + (observe_tclTHENLIST (str "make_rewrite")[ simpl_iter Locusops.onConcl; observe_tac (str "unfold functional") (unfold_in_concl[(Locus.OnlyOccurrences [1], @@ -891,9 +903,12 @@ let make_rewrite expr_info l hp max = (list_rewrite true (List.map (fun e -> mkVar e,true) expr_info.eqs)); - (observe_tac (str "h_reflexivity") (Proofview.V82.of_tactic intros_reflexivity))])) + (observe_tac (str "h_reflexivity") + (Proofview.V82.of_tactic intros_reflexivity) + ) + ])) ; - tclTHENLIST[ (* x < S (S max) proof *) + observe_tclTHENLIST (str "make_rewrite1")[ (* x < S (S max) proof *) Proofview.V82.of_tactic (apply (delayed_force le_lt_SS)); observe_tac (str "prove_le (3)") prove_le ] @@ -904,7 +919,7 @@ let rec compute_max rew_tac max l = match l with | [] -> rew_tac max | (_,p,_)::l -> - tclTHENLIST[ + observe_tclTHENLIST (str "compute_max")[ Proofview.V82.of_tactic (simplest_elim (mkApp(delayed_force max_constr, [| max; mkVar p|]))); tclDO 3 (Proofview.V82.of_tactic intro); @@ -924,7 +939,7 @@ let rec destruct_hex expr_info acc l = observe_tac (str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) end | (v,hex)::l -> - tclTHENLIST[ + observe_tclTHENLIST (str "destruct_hex")[ Proofview.V82.of_tactic (simplest_case (mkVar hex)); clear [hex]; tclDO 2 (Proofview.V82.of_tactic intro); @@ -939,7 +954,7 @@ let rec destruct_hex expr_info acc l = let rec intros_values_eq expr_info acc = tclORELSE( - tclTHENLIST[ + observe_tclTHENLIST (str "intros_values_eq")[ tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 (fun hex -> (onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc))) @@ -952,14 +967,15 @@ let rec intros_values_eq expr_info acc = let equation_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - tclTHEN + observe_tac (str "equation_others (cont_tac +intros) " ++ Printer.pr_lconstr expr_info.info) + (tclTHEN (continuation_tac infos) - (intros_values_eq expr_info []) - else continuation_tac infos + (observe_tac (str "intros_values_eq equation_others " ++ Printer.pr_lconstr expr_info.info) (intros_values_eq expr_info []))) + else observe_tac (str "equation_others (cont_tac) " ++ Printer.pr_lconstr expr_info.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 intros_values_eq expr_info [] + then ((observe_tac (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 = @@ -971,13 +987,13 @@ let equation_app_rec (f,args) expr_info continuation_tac info = with Not_found -> if expr_info.is_final && expr_info.is_main_branch then - tclTHENLIST + observe_tclTHENLIST (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 (str "app_rec intros_values_eq") (intros_values_eq expr_info []) ] else - tclTHENLIST[ + observe_tclTHENLIST (str "equation_app_rec1")[ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); observe_tac (str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) ] @@ -1089,7 +1105,7 @@ let termination_proof_header is_mes input_type ids args_id relation ] ; (* rest of the proof *) - tclTHENLIST + observe_tclTHENLIST (str "rest of proof") [observe_tac (str "generalize") (onNLastHypsId (nargs+1) (tclMAP (fun id -> @@ -1247,9 +1263,9 @@ let build_new_goal_type () = let is_opaque_constant c = let cb = Global.lookup_constant c in match cb.Declarations.const_body with - | Declarations.OpaqueDef _ -> true - | Declarations.Undef _ -> true - | Declarations.Def _ -> false + | Declarations.OpaqueDef _ -> Vernacexpr.Opaque None + | Declarations.Undef _ -> Vernacexpr.Opaque None + | Declarations.Def _ -> Vernacexpr.Transparent let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) @@ -1280,7 +1296,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp build_proof Evd.empty ( fun gls -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in - tclTHENLIST + observe_tclTHENLIST (str "") [ Simple.generalize [lemma]; Proofview.V82.of_tactic (Simple.intro hid); @@ -1340,7 +1356,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp (tclFIRST (List.map (fun c -> - Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST + 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 @@ -1402,13 +1418,13 @@ let start_equation (f:global_reference) (term_f:global_reference) let terminate_constr = constr_of_global term_f in let nargs = nb_prod (fst (type_of_const terminate_constr)) (*FIXME*) in let x = n_x_id ids nargs in - tclTHENLIST [ + observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [ h_intros x; unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]; observe_tac (str "simplest_case") (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x))))); - observe_tac (str "prove_eq") (cont_tactic x)] g;; + observe_tac (str "prove_eq") (cont_tactic x)]) g;; let (com_eqn : int -> Id.t -> global_reference -> global_reference -> global_reference diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 22ddd549..8b959c27 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -34,7 +34,7 @@ Extract Inductive sumor => option [ Some None ]. - rightmost choice (Inright) is (None) *) -(** To preserve its laziness, andb is normally expansed. +(** To preserve its laziness, andb is normally expanded. Let's rather use the ocaml && *) Extract Inlined Constant andb => "(&&)". diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v index 7400d462..a5f90dd6 100644 --- a/plugins/omega/Omega.v +++ b/plugins/omega/Omega.v @@ -13,10 +13,11 @@ (* *) (**************************************************************************) -(* We do not require [ZArith] anymore, but only what's necessary for Omega *) +(* We import what is necessary for Omega *) Require Export ZArith_base. Require Export OmegaLemmas. Require Export PreOmega. + Declare ML Module "omega_plugin". Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l @@ -25,11 +26,6 @@ Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l Require Export Zhints. -(* -(* The constant minus is required in coq_omega.ml *) -Require Minus. -*) - Hint Extern 10 (_ = _ :>nat) => abstract omega: zarith. Hint Extern 10 (_ <= _) => abstract omega: zarith. Hint Extern 10 (_ < _) => abstract omega: zarith. diff --git a/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v index 9e5c1484..9f101dbf 100644 --- a/plugins/omega/OmegaPlugin.v +++ b/plugins/omega/OmegaPlugin.v @@ -6,4 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(* To strictly import the omega tactic *) + +Require ZArith_base. +Require OmegaLemmas. +Require PreOmega. + Declare ML Module "omega_plugin". diff --git a/toplevel/whelp.mli b/plugins/omega/OmegaTactic.v index 62272c50..9f101dbf 100644 --- a/toplevel/whelp.mli +++ b/plugins/omega/OmegaTactic.v @@ -6,15 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** Coq interface to the Whelp query engine developed at - the University of Bologna *) +(* To strictly import the omega tactic *) -open Names -open Term +Require ZArith_base. +Require OmegaLemmas. +Require PreOmega. -type whelp_request = - | Locate of string - | Elim of inductive - | Constr of string * constr - -val whelp : whelp_request -> unit +Declare ML Module "omega_plugin". diff --git a/plugins/omega/vo.itarget b/plugins/omega/vo.itarget index 9d9a77a8..842210e2 100644 --- a/plugins/omega/vo.itarget +++ b/plugins/omega/vo.itarget @@ -1,4 +1,5 @@ OmegaLemmas.vo OmegaPlugin.vo +OmegaTactic.vo Omega.vo PreOmega.vo diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 637e0e28..2a2ef30f 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -211,9 +211,9 @@ let compute_rhs bodyi index_of_f = let i = destRel (Array.last args) in PMeta (Some (coerce_meta_in i)) | App (f,args) -> - PApp (snd (pattern_of_constr (Global.env()) Evd.empty f), Array.map aux args) + PApp (pi3 (pattern_of_constr (Global.env()) Evd.empty f), Array.map aux args) | Cast (c,_,_) -> aux c - | _ -> snd (pattern_of_constr (Global.env())(*FIXME*) Evd.empty c) + | _ -> pi3 (pattern_of_constr (Global.env())(*FIXME*) Evd.empty c) in aux bodyi diff --git a/pretyping/cases.ml b/pretyping/cases.ml index fdb19d37..fcbe90b6 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -285,11 +285,13 @@ let inductive_template evdref env tmloc ind = applist (mkIndU indu,List.rev evarl) let try_find_ind env sigma typ realnames = - let (IndType(_,realargs) as ind) = find_rectype env sigma typ in + let (IndType(indf,realargs) as ind) = find_rectype env sigma typ in let names = match realnames with | Some names -> names - | None -> List.make (List.length realargs) Anonymous in + | None -> + let ind = fst (fst (dest_ind_family indf)) in + List.make (inductive_nrealdecls ind) Anonymous in IsInd (typ,ind,names) let inh_coerce_to_ind evdref env loc ty tyi = @@ -730,7 +732,17 @@ let set_declaration_name x (_,c,t) = (x,c,t) let recover_initial_subpattern_names = List.map2 set_declaration_name -let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t)) +let recover_and_adjust_alias_names names sign = + let rec aux = function + | [],[] -> + [] + | x::names, (_,None,t)::sign -> + (x,(alias_of_pat x,None,t)) :: aux (names,sign) + | names, (na,(Some _ as c),t)::sign -> + (PatVar (Loc.ghost,na),(na,c,t)) :: aux (names,sign) + | _ -> assert false + in + List.split (aux (names,sign)) let push_rels_eqn sign eqn = {eqn with @@ -1644,7 +1656,7 @@ let abstract_tycon loc env evdref subst tycon extenv t = in aux (0,extenv,subst0) t0 -let build_tycon loc env tycon_env subst tycon extenv evdref t = +let build_tycon loc env tycon_env s subst tycon extenv evdref t = let t,tt = match t with | None -> (* This is the situation we are building a return predicate and @@ -1659,6 +1671,8 @@ let build_tycon loc env tycon_env subst tycon extenv evdref t = let evd,tt = Typing.e_type_of extenv !evdref t in evdref := evd; (t,tt) in + let b = e_cumul env evdref tt (mkSort s) (* side effect *) in + if not b then anomaly (Pp.str "Build_tycon: should be a type"); { uj_val = t; uj_type = tt } (* For a multiple pattern-matching problem Xi on t1..tn with return @@ -1693,11 +1707,12 @@ let build_inversion_problem loc env sigma tms t = let pat,acc = make_patvar t acc in let indf' = lift_inductive_family n indf in let sign = make_arity_signature env true indf' in - let sign = recover_alias_names alias_of_pat (pat :: List.rev patl) sign in - let p = List.length realargs in + let patl = pat :: List.rev patl in + let patl,sign = recover_and_adjust_alias_names patl sign in + let p = List.length patl in let env' = push_rel_context sign env in - let patl',acc_sign,acc = aux (n+p+1) env' (sign@acc_sign) tms acc in - patl@pat::patl',acc_sign,acc + let patl',acc_sign,acc = aux (n+p) env' (sign@acc_sign) tms acc in + List.rev_append patl patl',acc_sign,acc | (t, NotInd (bo,typ)) :: tms -> let pat,acc = make_patvar t acc in let d = (alias_of_pat pat,None,typ) in @@ -1780,7 +1795,7 @@ let build_inversion_problem loc env sigma tms t = mat = [eqn1;eqn2]; caseloc = loc; casestyle = RegularStyle; - typing_function = build_tycon loc env pb_env subst} in + typing_function = build_tycon loc env pb_env s subst} in let pred = (compile pb).uj_val in (!evdref,pred) diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 559f5fe6..055996de 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -60,9 +60,9 @@ let coe_info_typ_equal c1 c2 = let cl_typ_ord t1 t2 = match t1, t2 with | CL_SECVAR v1, CL_SECVAR v2 -> Id.compare v1 v2 - | CL_CONST c1, CL_CONST c2 -> con_user_ord c1 c2 - | CL_PROJ c1, CL_PROJ c2 -> con_user_ord c1 c2 - | CL_IND i1, CL_IND i2 -> ind_user_ord i1 i2 + | CL_CONST c1, CL_CONST c2 -> con_ord c1 c2 + | CL_PROJ c1, CL_PROJ c2 -> con_ord c1 c2 + | CL_IND i1, CL_IND i2 -> ind_ord i1 i2 | _ -> Pervasives.compare t1 t2 (** OK *) module ClTyp = struct diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index a6e2bc19..161cffa8 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -351,34 +351,45 @@ let authorized_occ env sigma partial_app closed pat c mk_ctx next = else mkresult subst (mk_ctx (mkMeta special_meta)) next with PatternMatchingFailure -> next () +let subargs env v = Array.map_to_list (fun c -> (env, c)) v + (* Tries to match a subterm of [c] with [pat] *) let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = let rec aux env c mk_ctx next = match kind_of_term c with | Cast (c1,k,c2) -> - let next_mk_ctx lc = mk_ctx (mkCast (List.hd lc, k,c2)) in - let next () = try_aux [env] [c1] next_mk_ctx next in + let next_mk_ctx = function + | [c1] -> mk_ctx (mkCast (c1, k, c2)) + | _ -> assert false + in + let next () = try_aux [env, c1] next_mk_ctx next in authorized_occ env sigma partial_app closed pat c mk_ctx next | Lambda (x,c1,c2) -> - let next_mk_ctx lc = mk_ctx (mkLambda (x,List.hd lc,List.nth lc 1)) in + let next_mk_ctx = function + | [c1; c2] -> mk_ctx (mkLambda (x, c1, c2)) + | _ -> assert false + in let next () = let env' = Environ.push_rel (x,None,c1) env in - try_aux [env;env'] [c1; c2] next_mk_ctx next in + try_aux [(env, c1); (env', c2)] next_mk_ctx next in authorized_occ env sigma partial_app closed pat c mk_ctx next | Prod (x,c1,c2) -> - let next_mk_ctx lc = mk_ctx (mkProd (x,List.hd lc,List.nth lc 1)) in + let next_mk_ctx = function + | [c1; c2] -> mk_ctx (mkProd (x, c1, c2)) + | _ -> assert false + in let next () = let env' = Environ.push_rel (x,None,c1) env in - try_aux [env;env'] [c1;c2] next_mk_ctx next in + try_aux [(env, c1); (env', c2)] next_mk_ctx next in authorized_occ env sigma partial_app closed pat c mk_ctx next | LetIn (x,c1,t,c2) -> let next_mk_ctx = function - | [c1;c2] -> mkLetIn (x,c1,t,c2) + | [c1; c2] -> mk_ctx (mkLetIn (x, c1, t, c2)) | _ -> assert false in let next () = let env' = Environ.push_rel (x,Some c1,t) env in - try_aux [env;env'] [c1;c2] next_mk_ctx next in + try_aux [(env, c1); (env', c2)] next_mk_ctx next in authorized_occ env sigma partial_app closed pat c mk_ctx next | App (c1,lc) -> let next () = @@ -390,14 +401,15 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = let mk_ctx = function | [app';c] -> mk_ctx (mkApp (app',[|c|])) | _ -> assert false in - try_aux [env] [app;Array.last lc] mk_ctx next + try_aux [(env, app); (env, Array.last lc)] mk_ctx next else let rec aux2 app args next = match args with | [] -> let mk_ctx le = mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in - try_aux [env] (c1::Array.to_list lc) mk_ctx next + let sub = (env, c1) :: subargs env lc in + try_aux sub mk_ctx next | arg :: args -> let app = mkApp (app,[|arg|]) in let next () = aux2 app args next in @@ -407,7 +419,8 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = else let mk_ctx le = mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in - try_aux [env] (c1::Array.to_list lc) mk_ctx next + let sub = (env, c1) :: subargs env lc in + try_aux sub mk_ctx next in authorized_occ env sigma partial_app closed pat c mk_ctx next | Case (ci,hd,c1,lc) -> @@ -415,24 +428,24 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = | [] -> assert false | c1 :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc)) in - let next () = try_aux [env] (c1 :: Array.to_list lc) next_mk_ctx next in + let sub = (env, c1) :: subargs env lc in + let next () = try_aux sub next_mk_ctx next in authorized_occ env sigma partial_app closed pat c mk_ctx next | Fix (indx,(names,types,bodies)) -> let nb_fix = Array.length types in let next_mk_ctx le = let (ntypes,nbodies) = CList.chop nb_fix le in mk_ctx (mkFix (indx,(names, Array.of_list ntypes, Array.of_list nbodies))) in - let next () = - try_aux - [env] ((Array.to_list types)@(Array.to_list bodies)) next_mk_ctx next in + let sub = subargs env types @ subargs env bodies in + let next () = try_aux sub next_mk_ctx next in authorized_occ env sigma partial_app closed pat c mk_ctx next | CoFix (i,(names,types,bodies)) -> let nb_fix = Array.length types in let next_mk_ctx le = let (ntypes,nbodies) = CList.chop nb_fix le in mk_ctx (mkCoFix (i,(names, Array.of_list ntypes, Array.of_list nbodies))) in - let next () = - try_aux [env] ((Array.to_list types)@(Array.to_list bodies)) next_mk_ctx next in + let sub = subargs env types @ subargs env bodies in + let next () = try_aux sub next_mk_ctx next in authorized_occ env sigma partial_app closed pat c mk_ctx next | Proj (p,c') -> let next_mk_ctx le = mk_ctx (mkProj (p,List.hd le)) in @@ -441,27 +454,24 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = try let term = Retyping.expand_projection env sigma p c' [] in aux env term mk_ctx next - with Retyping.RetypeError _ -> raise PatternMatchingFailure + with Retyping.RetypeError _ -> next () else - try_aux [env] [c'] next_mk_ctx next in + try_aux [env, c'] next_mk_ctx next in authorized_occ env sigma partial_app closed pat c mk_ctx next | Construct _| Ind _|Evar _|Const _ | Rel _|Meta _|Var _|Sort _ -> authorized_occ env sigma partial_app closed pat c mk_ctx next (* Tries [sub_match] for all terms in the list *) - and try_aux lenv lc mk_ctx next = - let rec try_sub_match_rec lacc lenv lc = - match lenv, lc with - | _, [] -> next () - | env :: tlenv, c::tl -> - let mk_ctx ce = mk_ctx (List.rev_append lacc (ce::tl)) in - let next () = - let env' = match tlenv with [] -> lenv | _ -> tlenv in - try_sub_match_rec (c::lacc) env' tl - in - aux env c mk_ctx next - | _ -> assert false in - try_sub_match_rec [] lenv lc in + and try_aux lc mk_ctx next = + let rec try_sub_match_rec lacc lc = + match lc with + | [] -> next () + | (env, c) :: tl -> + let mk_ctx ce = mk_ctx (List.rev_append lacc (ce :: List.map snd tl)) in + let next () = try_sub_match_rec (c :: lacc) tl in + aux env c mk_ctx next + in + try_sub_match_rec [] lc in let lempty () = IStream.Nil in let result () = aux env c (fun x -> x) lempty in IStream.thunk result diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 046ee0da..28fb8cbe 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -498,16 +498,17 @@ let rec detype flags avoid env sigma t = else noparams () | Evar (evk,cl) -> - let bound_to_itself id c = + let bound_to_itself_or_letin (id,b,_) c = + b != None || try let n = List.index Name.equal (Name id) (fst env) in - isRelN n c + isRelN n c with Not_found -> isVarId id c in let id,l = try let id = Evd.evar_ident evk sigma in - let l = Evd.evar_instance_array bound_to_itself (Evd.find sigma evk) cl in - let fvs,rels = List.fold_left (fun (fvs,rels) (_,c) -> (Id.Set.union fvs (collect_vars c), Int.Set.union rels (free_rels c))) (Id.Set.empty,Int.Set.empty) l in - let l = Evd.evar_instance_array (fun id c -> not !print_evar_arguments && (bound_to_itself id c && not (isRel c && Int.Set.mem (destRel c) rels || isVar c && (Id.Set.mem (destVar c) fvs)))) (Evd.find sigma evk) cl in + let l = Evd.evar_instance_array bound_to_itself_or_letin (Evd.find sigma evk) cl in + let fvs,rels = List.fold_left (fun (fvs,rels) (_,c) -> match kind_of_term c with Rel n -> (fvs,Int.Set.add n rels) | Var id -> (Id.Set.add id fvs,rels) | _ -> (fvs,rels)) (Id.Set.empty,Int.Set.empty) l in + let l = Evd.evar_instance_array (fun d c -> not !print_evar_arguments && (bound_to_itself_or_letin d c && not (isRel c && Int.Set.mem (destRel c) rels || isVar c && (Id.Set.mem (destVar c) fvs)))) (Evd.find sigma evk) cl in id,l with Not_found -> Id.of_string ("X" ^ string_of_int (Evar.repr evk)), diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index a95af253..f388f900 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -324,18 +324,25 @@ let rec evar_conv_x ts env evd pbty term1 term2 = Note: incomplete heuristic... *) let ground_test = if is_ground_term evd term1 && is_ground_term evd term2 then ( - let evd, b = - try infer_conv ~pb:pbty ~ts:(fst ts) env evd term1 term2 - with Univ.UniverseInconsistency _ -> evd, false + let evd, e = + try + let evd, b = infer_conv ~catch_incon:false ~pb:pbty ~ts:(fst ts) + env evd term1 term2 + in + if b then evd, None + else evd, Some (ConversionFailed (env,term1,term2)) + with Univ.UniverseInconsistency e -> evd, Some (UnifUnivInconsistency e) in - if b then Some (evd, true) - else if is_ground_env evd env then Some (evd, false) - else None) + match e with + | None -> Some (evd, e) + | Some e -> + if is_ground_env evd env then Some (evd, Some e) + else None) else None in match ground_test with - | Some (evd, true) -> Success evd - | Some (evd, false) -> UnifFailure (evd,ConversionFailed (env,term1,term2)) + | Some (evd, None) -> Success evd + | Some (evd, Some e) -> UnifFailure (evd,e) | None -> (* Until pattern-unification is used consistently, use nohdbeta to not destroy beta-redexes that can be used for 1st-order unification *) @@ -555,8 +562,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | LetIn (na,b1,t1,c'1), LetIn (_,b2,t2,c'2) -> let f1 i = ise_and i - [(fun i -> evar_conv_x ts env i CONV t1 t2); - (fun i -> evar_conv_x ts env i CONV b1 b2); + [(fun i -> evar_conv_x ts env i CONV b1 b2); (fun i -> let b = nf_evar i b1 in let t = nf_evar i t1 in diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 5aa72c90..bfd19c6c 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -64,30 +64,33 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = in modified := true; evdref := evd; mkSort s' | Prod (na,u,v) -> - mkProd (na,u,refresh dir v) + mkProd (na,u,refresh dir v) | _ -> t (** Refresh the types of evars under template polymorphic references *) - and refresh_term_evars onevars t = + and refresh_term_evars onevars top t = match kind_of_term t with | App (f, args) when is_template_polymorphic env f -> let pos = get_polymorphic_positions f in refresh_polymorphic_positions args pos + | App (f, args) when top && isEvar f -> + refresh_term_evars true false f; + Array.iter (refresh_term_evars onevars false) args | Evar (ev, a) when onevars -> let evi = Evd.find !evdref ev in let ty' = refresh true evi.evar_concl in if !modified then evdref := Evd.add !evdref ev {evi with evar_concl = ty'} else () - | _ -> iter_constr (refresh_term_evars onevars) t + | _ -> iter_constr (refresh_term_evars onevars false) t and refresh_polymorphic_positions args pos = let rec aux i = function | Some l :: ls -> if i < Array.length args then - ignore(refresh_term_evars true args.(i)); + ignore(refresh_term_evars true false args.(i)); aux (succ i) ls | None :: ls -> if i < Array.length args then - ignore(refresh_term_evars false args.(i)); + ignore(refresh_term_evars false false args.(i)); aux (succ i) ls | [] -> () in aux 0 pos @@ -97,7 +100,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = (match pbty with | None -> t | Some dir -> refresh dir t) - else (refresh_term_evars false t; t) + else (refresh_term_evars false true t; t) in if !modified then !evdref, t' else !evdref, t @@ -118,11 +121,11 @@ let is_success = function Success _ -> true | UnifFailure _ -> false let test_success conv_algo env evd c c' rhs = is_success (conv_algo env evd c c' rhs) -let add_conv_oriented_pb (pbty,env,t1,t2) evd = +let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd = match pbty with - | Some true -> add_conv_pb (Reduction.CUMUL,env,t1,t2) evd - | Some false -> add_conv_pb (Reduction.CUMUL,env,t2,t1) evd - | None -> add_conv_pb (Reduction.CONV,env,t1,t2) evd + | Some true -> add_conv_pb ~tail (Reduction.CUMUL,env,t1,t2) evd + | Some false -> add_conv_pb ~tail (Reduction.CUMUL,env,t2,t1) evd + | None -> add_conv_pb ~tail (Reduction.CONV,env,t1,t2) evd (*------------------------------------* * Restricting existing evars * @@ -175,20 +178,31 @@ let restrict_instance evd evk filter argsv = Filter.filter_array (Filter.compose (evar_filter evi) filter) argsv let noccur_evar env evd evk c = - let rec occur_rec k c = match kind_of_term c with + let cache = ref Int.Set.empty (* cache for let-ins *) in + let rec occur_rec (k, env as acc) c = + match kind_of_term c with | Evar (evk',args' as ev') -> (match safe_evar_value evd ev' with - | Some c -> occur_rec k c + | Some c -> occur_rec acc c | None -> if Evar.equal evk evk' then raise Occur - else Array.iter (occur_rec k) args') + else Array.iter (occur_rec acc) args') | Rel i when i > k -> - (match pi2 (Environ.lookup_rel (i-k) env) with + if not (Int.Set.mem (i-k) !cache) then + (match pi2 (Environ.lookup_rel i env) with | None -> () - | Some b -> occur_rec k (lift i b)) - | _ -> iter_constr_with_binders succ occur_rec k c + | Some b -> cache := Int.Set.add (i-k) !cache; occur_rec acc (lift i b)) + | Proj (p,c) -> + let c = + try Retyping.expand_projection env evd p c [] + with Retyping.RetypeError _ -> + (* Can happen when called from w_unify which doesn't assign evars/metas + eagerly enough *) c + in occur_rec acc c + | _ -> iter_constr_with_full_binders (fun rd (k,env) -> (succ k, push_rel rd env)) + occur_rec acc c in - try occur_rec 0 c; true with Occur -> false + try occur_rec (0,env) c; true with Occur -> false (***************************************) (* Managing chains of local definitons *) @@ -213,7 +227,7 @@ let compute_var_aliases sign = sign Id.Map.empty let compute_rel_aliases var_aliases rels = - snd (List.fold_right (fun (_,b,t) (n,aliases) -> + snd (List.fold_right (fun (_,b,u) (n,aliases) -> (n-1, match b with | Some t -> @@ -227,7 +241,7 @@ let compute_rel_aliases var_aliases rels = try Int.Map.find (p+n) aliases with Not_found -> [] in Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases | _ -> - Int.Map.add n [lift n t] aliases) + Int.Map.add n [lift n (mkCast(t,DEFAULTcast,u))] aliases) | None -> aliases)) rels (List.length rels,Int.Map.empty)) @@ -311,6 +325,7 @@ let expand_vars_in_term env = expand_vars_in_term_using (make_alias_map env) let free_vars_and_rels_up_alias_expansion aliases c = let acc1 = ref Int.Set.empty and acc2 = ref Id.Set.empty in + let acc3 = ref Int.Set.empty and acc4 = ref Id.Set.empty in let cache_rel = ref Int.Set.empty and cache_var = ref Id.Set.empty in let is_in_cache depth = function | Rel n -> Int.Set.mem (n-depth) !cache_rel @@ -325,8 +340,13 @@ let free_vars_and_rels_up_alias_expansion aliases c = | Rel _ | Var _ as ck -> if is_in_cache depth ck then () else begin put_in_cache depth ck; - let c = expansion_of_var aliases c in + let c' = expansion_of_var aliases c in + (if c != c' then (* expansion, hence a let-in *) match kind_of_term c with + | Var id -> acc4 := Id.Set.add id !acc4 + | Rel n -> if n >= depth+1 then acc3 := Int.Set.add (n-depth) !acc3 + | _ -> ()); + match kind_of_term c' with | Var id -> acc2 := Id.Set.add id !acc2 | Rel n -> if n >= depth+1 then acc1 := Int.Set.add (n-depth) !acc1 | _ -> frec (aliases,depth) c end @@ -338,7 +358,7 @@ let free_vars_and_rels_up_alias_expansion aliases c = frec (aliases,depth) c in frec (aliases,0) c; - (!acc1,!acc2) + (!acc1,!acc2,!acc3,!acc4) (********************************) (* Managing pattern-unification *) @@ -374,7 +394,7 @@ let get_actual_deps aliases l t = l else (* Probably strong restrictions coming from t being evar-closed *) - let (fv_rels,fv_ids) = free_vars_and_rels_up_alias_expansion aliases t in + let (fv_rels,fv_ids,_,_) = free_vars_and_rels_up_alias_expansion aliases t in List.filter (fun c -> match kind_of_term c with | Var id -> Id.Set.mem id fv_ids @@ -1013,52 +1033,52 @@ exception CannotProject of evar_map * existential of subterms to eventually discard so as to be allowed to keep ti. *) -let rec is_constrainable_in top k (ev,(fv_rels,fv_ids) as g) t = - let f,args = decompose_app_vect t in +let rec is_constrainable_in top evd k (ev,(fv_rels,fv_ids) as g) t = + let f,args2 = decompose_app_vect t in + let f,args1 = decompose_app_vect (whd_evar evd f) in + let args = Array.append args1 args2 in match kind_of_term f with | Construct ((ind,_),u) -> let n = Inductiveops.inductive_nparams ind in if n > Array.length args then true (* We don't try to be more clever *) else let params = fst (Array.chop n args) in - Array.for_all (is_constrainable_in false k g) params - | Ind _ -> Array.for_all (is_constrainable_in false k g) args - | Prod (_,t1,t2) -> is_constrainable_in false k g t1 && is_constrainable_in false k g t2 + Array.for_all (is_constrainable_in false evd k g) params + | Ind _ -> Array.for_all (is_constrainable_in false evd k g) args + | Prod (na,t1,t2) -> is_constrainable_in false evd k g t1 && is_constrainable_in false evd k g t2 | Evar (ev',_) -> top || not (Evar.equal ev' ev) (*If ev' needed, one may also try to restrict it*) | Var id -> Id.Set.mem id fv_ids | Rel n -> n <= k || Int.Set.mem n fv_rels | Sort _ -> true | _ -> (* We don't try to be more clever *) true -let has_constrainable_free_vars evd aliases k ev (fv_rels,fv_ids as fvs) t = - let t = expansion_of_var aliases t in - match kind_of_term t with - | Var id -> Id.Set.mem id fv_ids - | Rel n -> n <= k || Int.Set.mem n fv_rels - | _ -> is_constrainable_in true k (ev,fvs) t - -let ensure_evar_independent g env evd (evk1,argsv1 as ev1) (evk2,argsv2 as ev2)= - let filter1 = - restrict_upon_filter evd evk1 (noccur_evar env evd evk2) argsv1 - in - let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in - let evd,(evk1,_ as ev1) = do_restrict_hyps evd ev1 filter1 candidates1 in - let filter2 = - restrict_upon_filter evd evk2 (noccur_evar env evd evk1) argsv2 - in - let candidates2 = restrict_candidates g env evd filter2 ev2 ev1 in - let evd,ev2 = do_restrict_hyps evd ev2 filter2 candidates2 in - evd,ev1,ev2 +let has_constrainable_free_vars env evd aliases force k ev (fv_rels,fv_ids,let_rels,let_ids) t = + let t' = expansion_of_var aliases t in + if t' != t then + (* t is a local definition, we keep it only if appears in the list *) + (* of let-in variables effectively occurring on the right-hand side, *) + (* which is the only reason to keep it when inverting arguments *) + match kind_of_term t with + | Var id -> Id.Set.mem id let_ids + | Rel n -> Int.Set.mem n let_rels + | _ -> assert false + else + (* t is an instance for a proper variable; we filter it along *) + (* the free variables allowed to occur *) + match kind_of_term t with + | Var id -> Id.Set.mem id fv_ids + | Rel n -> n <= k || Int.Set.mem n fv_rels + | _ -> (not force || noccur_evar env evd ev t) && is_constrainable_in true evd k (ev,(fv_rels,fv_ids)) t exception EvarSolvedOnTheFly of evar_map * constr (* Try to project evk1[argsv1] on evk2[argsv2], if [ev1] is a pattern on the common domain of definition *) -let project_evar_on_evar g env evd aliases k2 pbty (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) = +let project_evar_on_evar force g env evd aliases k2 pbty (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) = (* Apply filtering on ev1 so that fvs(ev1) are in fvs(ev2). *) let fvs2 = free_vars_and_rels_up_alias_expansion aliases (mkEvar ev2) in let filter1 = restrict_upon_filter evd evk1 - (has_constrainable_free_vars evd aliases k2 evk2 fvs2) + (has_constrainable_free_vars env evd aliases force k2 evk2 fvs2) argsv1 in let candidates1 = try restrict_candidates g env evd filter1 ev1 ev2 @@ -1094,9 +1114,9 @@ let check_evar_instance evd evk1 body conv_algo = | Success evd -> evd | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) -let solve_evar_evar_l2r f g env evd aliases pbty ev1 (evk2,_ as ev2) = +let solve_evar_evar_l2r force f g env evd aliases pbty ev1 (evk2,_ as ev2) = try - let evd,body = project_evar_on_evar g env evd aliases 0 pbty ev1 ev2 in + let evd,body = project_evar_on_evar force g env evd aliases 0 pbty ev1 ev2 in let evd' = Evd.define evk2 body evd in check_evar_instance evd' evk2 body g with EvarSolvedOnTheFly (evd,c) -> @@ -1113,27 +1133,23 @@ let preferred_orientation evd evk1 evk2 = | _,Evar_kinds.QuestionMark _ -> false | _ -> true -let solve_evar_evar_aux f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = +let solve_evar_evar_aux force f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = let aliases = make_alias_map env in if preferred_orientation evd evk1 evk2 then - try solve_evar_evar_l2r f g env evd aliases (opp_problem pbty) ev2 ev1 + try solve_evar_evar_l2r force f g env evd aliases (opp_problem pbty) ev2 ev1 with CannotProject (evd,ev2) -> - try solve_evar_evar_l2r f g env evd aliases pbty ev1 ev2 + try solve_evar_evar_l2r force f g env evd aliases pbty ev1 ev2 with CannotProject (evd,ev1) -> - add_conv_oriented_pb (pbty,env,mkEvar ev1,mkEvar ev2) evd + add_conv_oriented_pb ~tail:true (pbty,env,mkEvar ev1,mkEvar ev2) evd else - try solve_evar_evar_l2r f g env evd aliases pbty ev1 ev2 + try solve_evar_evar_l2r force f g env evd aliases pbty ev1 ev2 with CannotProject (evd,ev1) -> - try solve_evar_evar_l2r f g env evd aliases (opp_problem pbty) ev2 ev1 + try solve_evar_evar_l2r force f g env evd aliases (opp_problem pbty) ev2 ev1 with CannotProject (evd,ev2) -> - add_conv_oriented_pb (pbty,env,mkEvar ev1,mkEvar ev2) evd - -let solve_evar_evar ?(force=false) f g env evd pbty ev1 ev2 = - let (evd,(evk1,args1 as ev1),(evk2,args2 as ev2)),pbty = - (* If an evar occurs in the instance of the other evar and the - use of an heuristic is forced, we restrict *) - if force then ensure_evar_independent g env evd ev1 ev2, None - else (evd,ev1,ev2),pbty in + add_conv_oriented_pb ~tail:true (pbty,env,mkEvar ev1,mkEvar ev2) evd + +let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = + let pbty = if force then None else pbty in let evi = Evd.find evd evk1 in let evd = try @@ -1162,7 +1178,7 @@ let solve_evar_evar ?(force=false) f g env evd pbty ev1 ev2 = downcast evk2 t2 (downcast evk1 t1 evd) with Reduction.NotArity -> evd in - solve_evar_evar_aux f g env evd pbty ev1 ev2 + solve_evar_evar_aux force f g env evd pbty ev1 ev2 type conv_fun = env -> evar_map -> conv_pb -> constr -> constr -> unification_result @@ -1321,7 +1337,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let aliases = lift_aliases k aliases in (try let ev = (evk,Array.map (lift k) argsv) in - let evd,body = project_evar_on_evar conv_algo env' !evdref aliases k None ev' ev in + let evd,body = project_evar_on_evar false conv_algo env' !evdref aliases k None ev' ev in evdref := evd; body with @@ -1338,7 +1354,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let evd = (* Try to project (a restriction of) the left evar ... *) try - let evd,body = project_evar_on_evar conv_algo env' evd aliases 0 None ev'' ev' in + let evd,body = project_evar_on_evar false conv_algo env' evd aliases 0 None ev'' ev' in let evd = Evd.define evk' body evd in check_evar_instance evd evk' body conv_algo with @@ -1384,19 +1400,6 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) imitate envk t in - let _fast rhs = - let filter_ctxt = evar_filtered_context evi in - let names = ref Idset.empty in - let rec is_id_subst ctxt s = - match ctxt, s with - | ((id, _, _) :: ctxt'), (c :: s') -> - names := Idset.add id !names; - isVarId id c && is_id_subst ctxt' s' - | [], [] -> true - | _ -> false in - is_id_subst filter_ctxt (Array.to_list argsv) && - closed0 rhs && - Idset.subset (collect_vars rhs) !names in let rhs = whd_beta evd rhs (* heuristic *) in let fast rhs = let filter_ctxt = evar_filtered_context evi in diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index d286b98e..201a16eb 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -212,9 +212,11 @@ let whd_head_evar sigma c = (* Creating new metas *) (**********************) +let meta_counter_summary_name = "meta counter" + (* Generator of metavariables *) let new_meta = - let meta_ctr = Summary.ref 0 ~name:"meta counter" in + let meta_ctr = Summary.ref 0 ~name:meta_counter_summary_name in fun () -> incr meta_ctr; !meta_ctr let mk_new_meta () = mkMeta(new_meta()) @@ -241,9 +243,11 @@ let make_pure_subst evi args = (* Creating new evars *) (**********************) +let evar_counter_summary_name = "evar counter" + (* Generator of existential names *) let new_untyped_evar = - let evar_ctr = Summary.ref 0 ~name:"evar counter" in + let evar_ctr = Summary.ref 0 ~name:evar_counter_summary_name in fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr (*------------------------------------* @@ -838,3 +842,8 @@ let subterm_source evk (loc,k) = | Evar_kinds.SubEvar (evk) -> evk | _ -> evk in (loc,Evar_kinds.SubEvar evk) + + +(** Term exploration up to isntantiation. *) +let kind_of_term_upto sigma t = + Constr.kind (Reductionops.whd_evar sigma t) diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index f89266a6..49036798 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -199,6 +199,13 @@ val nf_evar_map_universes : evar_map -> evar_map * (constr -> constr) exception Uninstantiated_evar of existential_key val flush_and_check_evars : evar_map -> constr -> constr +(** {6 Term manipulation up to instantiation} *) + +(** Like {!Constr.kind} except that [kind_of_term sigma t] exposes [t] + as an evar [e] only if [e] is uninstantiated in [sigma]. Otherwise the + value of [e] in [sigma] is (recursively) used. *) +val kind_of_term_upto : evar_map -> constr -> (constr,types) kind_of_term + (** {6 debug pretty-printer:} *) val pr_tycon : env -> type_constraint -> Pp.std_ppcmds @@ -236,3 +243,6 @@ val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> val subterm_source : existential_key -> Evar_kinds.t Loc.located -> Evar_kinds.t Loc.located + +val meta_counter_summary_name : string +val evar_counter_summary_name : string diff --git a/pretyping/evd.ml b/pretyping/evd.ml index ee72d314..bf519fb7 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -230,20 +230,20 @@ let evar_instance_array test_id info args = else instance_mismatch () | false :: filter, _ :: ctxt -> instrec filter ctxt i - | true :: filter, (id, _, _) :: ctxt -> + | true :: filter, (id,_,_ as d) :: ctxt -> if i < len then let c = Array.unsafe_get args i in - if test_id id c then instrec filter ctxt (succ i) + if test_id d c then instrec filter ctxt (succ i) else (id, c) :: instrec filter ctxt (succ i) else instance_mismatch () | _ -> instance_mismatch () in match Filter.repr (evar_filter info) with | None -> - let map i (id, _, _) = + let map i (id,_,_ as d) = if (i < len) then let c = Array.unsafe_get args i in - if test_id id c then None else Some (id,c) + if test_id d c then None else Some (id,c) else instance_mismatch () in List.map_filter_i map (evar_context info) @@ -251,7 +251,7 @@ let evar_instance_array test_id info args = instrec filter (evar_context info) 0 let make_evar_instance_array info args = - evar_instance_array isVarId info args + evar_instance_array (fun (id,_,_) -> isVarId id) info args let instantiate_evar_array info c args = let inst = make_evar_instance_array info args in @@ -568,14 +568,6 @@ type evar_map = { (*** Lifting primitive from Evar.Map. ***) -(* HH: The progress tactical now uses this function. *) -let progress_evar_map d1 d2 = - let is_new k v = - assert (v.evar_body == Evar_empty); - EvMap.mem k d2.defn_evars - in - not (d1 == d2) && EvMap.exists is_new d1.undf_evars - let add_name_newly_undefined naming evk evi (evtoid,idtoev) = let id = match naming with | Misctypes.IntroAnonymous -> @@ -779,7 +771,9 @@ let merge_universe_context evd uctx' = let set_universe_context evd uctx' = { evd with universes = uctx' } -let add_conv_pb pb d = {d with conv_pbs = pb::d.conv_pbs} +let add_conv_pb ?(tail=false) pb d = + if tail then {d with conv_pbs = d.conv_pbs @ [pb]} + else {d with conv_pbs = pb::d.conv_pbs} let evar_source evk d = (find d evk).evar_source @@ -1195,6 +1189,18 @@ let abstract_undefined_variables uctx = in { uctx with uctx_local = Univ.ContextSet.empty; uctx_univ_algebraic = vars' } +let fix_undefined_variables ({ universes = uctx } as evm) = + let algs', vars' = + Univ.LMap.fold (fun u v (algs, vars as acc) -> + if v == None then (Univ.LSet.remove u algs, Univ.LMap.remove u vars) + else acc) + uctx.uctx_univ_variables + (uctx.uctx_univ_algebraic, uctx.uctx_univ_variables) + in + {evm with universes = + { uctx with uctx_univ_variables = vars'; + uctx_univ_algebraic = algs' } } + let refresh_undefined_univ_variables uctx = let subst, ctx' = Universes.fresh_universe_context_set_instance uctx.uctx_local in @@ -1301,27 +1307,6 @@ let e_eq_constr_univs evdref t u = let eq_constr_univs_test evd t u = snd (eq_constr_univs evd t u) -let eq_named_context_val d ctx1 ctx2 = - ctx1 == ctx2 || - let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in - let eq_named_declaration (i1, c1, t1) (i2, c2, t2) = - Id.equal i1 i2 && Option.equal (eq_constr_univs_test d) c1 c2 - && (eq_constr_univs_test d) t1 t2 - in List.equal eq_named_declaration c1 c2 - -let eq_evar_body d b1 b2 = match b1, b2 with -| Evar_empty, Evar_empty -> true -| Evar_defined t1, Evar_defined t2 -> eq_constr_univs_test d t1 t2 -| _ -> false - -let eq_evar_info d ei1 ei2 = - ei1 == ei2 || - eq_constr_univs_test d ei1.evar_concl ei2.evar_concl && - eq_named_context_val d (ei1.evar_hyps) (ei2.evar_hyps) && - eq_evar_body d ei1.evar_body ei2.evar_body - (** ppedrot: [eq_constr] may be a bit too permissive here *) - - (**********************************************************) (* Accessing metas *) diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 53f8b0db..fe785a83 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -12,7 +12,6 @@ open Names open Term open Context open Environ -open Mod_subst (** {5 Existential variables and unification states} @@ -127,10 +126,6 @@ type evar_map (** Type of unification state. Essentially a bunch of state-passing data needed to handle incremental term construction. *) -val progress_evar_map : evar_map -> evar_map -> bool -(** Assuming that the second map extends the first one, this says if - some existing evar has been refined *) - val empty : evar_map (** The empty evar map. *) @@ -205,9 +200,6 @@ val add_constraints : evar_map -> Univ.constraints -> evar_map val undefined_map : evar_map -> evar_info Evar.Map.t (** Access the undefined evar mapping directly. *) -val eq_evar_info : evar_map -> evar_info -> evar_info -> bool -(** Compare the evar_info's up to the universe constraints of the evar map. *) - val drop_all_defined : evar_map -> evar_map (** {6 Instantiating partial terms} *) @@ -224,7 +216,7 @@ val existential_opt_value : evar_map -> existential -> constr option (** Same as {!existential_value} but returns an option instead of raising an exception. *) -val evar_instance_array : (Id.t -> 'a -> bool) -> evar_info -> +val evar_instance_array : (named_declaration -> 'a -> bool) -> evar_info -> 'a array -> (Id.t * 'a) list val instantiate_evar_array : evar_info -> constr -> constr array -> constr @@ -398,7 +390,7 @@ type clbinding = (** Unification constraints *) type conv_pb = Reduction.conv_pb type evar_constraint = conv_pb * env * constr * constr -val add_conv_pb : evar_constraint -> evar_map -> evar_map +val add_conv_pb : ?tail:bool -> evar_constraint -> evar_map -> evar_map val extract_changed_conv_pbs : evar_map -> (Evar.Set.t -> evar_constraint -> bool) -> @@ -538,6 +530,8 @@ val with_context_set : rigid -> evar_map -> 'a Univ.in_universe_context_set -> e val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst val abstract_undefined_variables : evar_universe_context -> evar_universe_context +val fix_undefined_variables : evar_map -> evar_map + val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_subst val nf_constraints : evar_map -> evar_map diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index 7f7f4d76..95a6ba79 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -11,7 +11,6 @@ open Util open Errors open Names open Locus -open Context open Term open Nameops open Termops diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index 82330b84..47d9654e 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Names open Locus open Context open Term diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 67f3cb41..e514fd52 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -13,6 +13,9 @@ open Glob_term val cases_pattern_eq : cases_pattern -> cases_pattern -> bool +val cast_type_eq : ('a -> 'a -> bool) -> + 'a Misctypes.cast_type -> 'a Misctypes.cast_type -> bool + val glob_constr_eq : glob_constr -> glob_constr -> bool (** Operations on [glob_constr] *) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 654f914b..dfdc24d4 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -18,7 +18,6 @@ open Declarations open Declareops open Environ open Reductionops -open Inductive (* The following three functions are similar to the ones defined in Inductive, but they expect an env *) @@ -274,7 +273,7 @@ let projection_nparams p = projection_nparams_env (Global.env ()) p let make_case_info env ind style = let (mib,mip) = Inductive.lookup_mind_specif env ind in let ind_tags = - rel_context_tags (List.firstn mip.mind_nrealargs mip.mind_arity_ctxt) in + rel_context_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in let cstr_tags = Array.map2 (fun c n -> let d,_ = decompose_prod_assum c in @@ -366,14 +365,16 @@ let get_arity env ((ind,u),params) = let (mib,mip) = Inductive.lookup_mind_specif env ind in let parsign = (* Dynamically detect if called with an instance of recursively - uniform parameter only or also of non recursively uniform + uniform parameter only or also of recursively non-uniform parameters *) - let parsign = mib.mind_params_ctxt in - let nnonrecparams = mib.mind_nparams - mib.mind_nparams_rec in - if Int.equal (List.length params) (rel_context_nhyps parsign - nnonrecparams) then - snd (List.chop nnonrecparams mib.mind_params_ctxt) - else - parsign in + let nparams = List.length params in + if Int.equal nparams mib.mind_nparams then + mib.mind_params_ctxt + else begin + assert (Int.equal nparams mib.mind_nparams_rec); + let nnonrecparamdecls = List.length mib.mind_params_ctxt - mib.mind_nparams_rec in + snd (List.chop nnonrecparamdecls mib.mind_params_ctxt) + end in let parsign = Vars.subst_instance_context u parsign in let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in let arsign,_ = List.chop arproperlength mip.mind_arity_ctxt in @@ -527,7 +528,7 @@ let type_case_branches_with_names env indspec p c = let (params,realargs) = List.chop nparams args in let lbrty = Inductive.build_branches_type ind specif params p in (* Build case type *) - let conclty = Reduction.beta_appvect p (Array.of_list (realargs@[c])) in + let conclty = Reduction.betazeta_appvect (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in (* Adjust names *) if is_elim_predicate_explicitly_dependent env p (ind,params) then (set_pattern_names env (fst ind) lbrty, conclty) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index af1783b7..7959759a 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -25,7 +25,9 @@ val type_of_constructors : env -> pinductive -> types array (** Return constructor types in normal form *) val arities_of_constructors : env -> pinductive -> types array -(** An inductive type with its parameters *) +(** An inductive type with its parameters (transparently supports + reasoning either with only recursively uniform parameters or with all + parameters including the recursively non-uniform ones *) type inductive_family val make_ind_family : inductive puniverses * constr list -> inductive_family val dest_ind_family : inductive_family -> inductive puniverses * constr list @@ -138,10 +140,14 @@ val lift_constructor : int -> constructor_summary -> constructor_summary val get_constructor : pinductive * mutual_inductive_body * one_inductive_body * constr list -> int -> constructor_summary -val get_arity : env -> inductive_family -> rel_context * sorts_family val get_constructors : env -> inductive_family -> constructor_summary array val get_projections : env -> inductive_family -> constant array option +(** [get_arity] returns the arity of the inductive family instantiated + with the parameters; if recursively non-uniform parameters are not + part of the inductive family, they appears in the arity *) +val get_arity : env -> inductive_family -> rel_context * sorts_family + val build_dependent_constructor : constructor_summary -> constr val build_dependent_inductive : env -> inductive_family -> constr val make_arity_signature : env -> bool -> inductive_family -> rel_context diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index c49bec9a..705e594a 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -123,6 +123,8 @@ let head_of_constr_reference c = match kind_of_term c with let pattern_of_constr env sigma t = let ctx = ref [] in + let keep = ref Evar.Set.empty in + let remove = ref Evar.Set.empty in let rec pattern_of_constr env t = match kind_of_term t with | Rel n -> PRel n @@ -141,28 +143,38 @@ let pattern_of_constr env sigma t = | App (f,a) -> (match match kind_of_term f with - Evar (evk,args as ev) -> - (match snd (Evd.evar_source evk sigma) with - Evar_kinds.MatchingVar (true,id) -> - ctx := (id,None,Evarutil.nf_evar sigma (existential_type sigma ev))::!ctx; - Some id - | _ -> None) - | _ -> None - with - | Some n -> PSoApp (n,Array.to_list (Array.map (pattern_of_constr env) a)) - | None -> PApp (pattern_of_constr env f,Array.map (pattern_of_constr env) a)) + | Evar (evk,args as ev) -> + (match snd (Evd.evar_source evk sigma) with + Evar_kinds.MatchingVar (true,id) -> + let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in + ctx := (id,None,ty)::!ctx; + keep := Evar.Set.union (evars_of_term ty) !keep; + remove := Evar.Set.add evk !remove; + Some id + | _ -> None) + | _ -> None + with + | Some n -> PSoApp (n,Array.to_list (Array.map (pattern_of_constr env) a)) + | None -> PApp (pattern_of_constr env f,Array.map (pattern_of_constr env) a)) | Const (sp,u) -> PRef (ConstRef (constant_of_kn(canonical_con sp))) | Ind (sp,u) -> PRef (canonical_gr (IndRef sp)) | Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp)) | Proj (p, c) -> pattern_of_constr env (Retyping.expand_projection env sigma p c []) | Evar (evk,ctxt as ev) -> - (match snd (Evd.evar_source evk sigma) with - | Evar_kinds.MatchingVar (b,id) -> - ctx := (id,None,Evarutil.nf_evar sigma (existential_type sigma ev))::!ctx; - assert (not b); PMeta (Some id) - | Evar_kinds.GoalEvar -> PEvar (evk,Array.map (pattern_of_constr env) ctxt) - | _ -> PMeta None) + remove := Evar.Set.add evk !remove; + (match snd (Evd.evar_source evk sigma) with + | Evar_kinds.MatchingVar (b,id) -> + let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in + ctx := (id,None,ty)::!ctx; + let () = ignore (pattern_of_constr env ty) in + assert (not b); PMeta (Some id) + | Evar_kinds.GoalEvar -> + PEvar (evk,Array.map (pattern_of_constr env) ctxt) + | _ -> + let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in + let () = ignore (pattern_of_constr env ty) in + PMeta None) | Case (ci,p,a,br) -> let cip = { cip_style = ci.ci_pp_info.style; @@ -178,9 +190,11 @@ let pattern_of_constr env sigma t = | Fix f -> PFix f | CoFix f -> PCoFix f in let p = pattern_of_constr env t in + let remove = Evar.Set.diff !remove !keep in + let sigma = Evar.Set.fold (fun ev acc -> Evd.remove acc ev) remove sigma in (* side-effect *) (* Warning: the order of dependencies in ctx is not ensured *) - (!ctx,p) + (sigma,!ctx,p) (* To process patterns, we need a translation without typing at all. *) @@ -220,7 +234,7 @@ let instantiate_pattern env sigma lvar c = ctx in let c = substl inst c in - snd (pattern_of_constr env sigma c) + pi3 (pattern_of_constr env sigma c) with Not_found (* List.index failed *) -> let vars = List.map_filter (function Name id -> Some id | _ -> None) vars in @@ -245,7 +259,7 @@ let rec subst_pattern subst pat = | PRef ref -> let ref',t = subst_global subst ref in if ref' == ref then pat else - snd (pattern_of_constr (Global.env()) Evd.empty t) + pi3 (pattern_of_constr (Global.env()) Evd.empty t) | PVar _ | PEvar _ | PRel _ -> pat diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index cf02421c..9e72280f 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -39,7 +39,8 @@ val head_of_constr_reference : Term.constr -> global_reference a pattern; currently, no destructor (Cases, Fix, Cofix) and no existential variable are allowed in [c] *) -val pattern_of_constr : Environ.env -> Evd.evar_map -> constr -> named_context * constr_pattern +val pattern_of_constr : Environ.env -> Evd.evar_map -> constr -> + Evd.evar_map * named_context * constr_pattern (** [pattern_of_glob_constr l c] translates a term [c] with metavariables into a pattern; variables bound in [l] are replaced by the pattern to which they diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 040792ef..0cadffa4 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -82,7 +82,7 @@ let search_guard loc env possible_indexes fixdefs = iraise (e, info)); indexes else - (* we now search recursively amoungst all combinations *) + (* we now search recursively among all combinations *) (try List.iter (fun l -> @@ -220,7 +220,7 @@ let process_inference_flags flags env initial_sigma (sigma,c) = let c = if flags.expand_evars then nf_evar sigma c else c in sigma,c -(* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *) +(* Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *) let allow_anonymous_refs = ref false (* Utilisé pour inférer le prédicat des Cases *) @@ -324,12 +324,6 @@ let pretype_id pretype loc env evdref lvar id = (* Check if [id] is a section or goal variable *) try let (_,_,typ) = lookup_named id env in - (* let _ = *) - (* try *) - (* let ctx = Decls.variable_context id in *) - (* evdref := Evd.merge_context_set univ_rigid !evdref ctx; *) - (* with Not_found -> () *) - (* in *) { uj_val = mkVar id; uj_type = typ } with Not_found -> (* [id] not found, standard error message *) diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 7d1e0c9b..142b5451 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -63,7 +63,7 @@ val all_no_fail_flags : inference_flags val all_and_fail_flags : inference_flags -(** Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *) +(** Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *) val allow_anonymous_refs : bool ref (** Generic call to the interpreter from glob_constr to open_constr, leaving diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index a23963ab..dd671f11 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -60,13 +60,20 @@ module ReductionBehaviour = struct let discharge = function | _,(ReqGlobal (ConstRef c, req), (_, b)) -> - let c' = pop_con c in - let vars, _subst, _ctx = Lib.section_segment_of_constant c in - let extra = List.length vars in - let nargs' = if b.b_nargs < 0 then b.b_nargs else b.b_nargs + extra in - let recargs' = List.map ((+) extra) b.b_recargs in - let b' = { b with b_nargs = nargs'; b_recargs = recargs' } in - Some (ReqGlobal (ConstRef c', req), (ConstRef c', b')) + let b = + if Lib.is_in_section (ConstRef c) then + let vars, _, _ = Lib.section_segment_of_constant c in + let extra = List.length vars in + let nargs' = + if b.b_nargs = max_int then max_int + else if b.b_nargs < 0 then b.b_nargs + else b.b_nargs + extra in + let recargs' = List.map ((+) extra) b.b_recargs in + { b with b_nargs = nargs'; b_recargs = recargs' } + else b + in + let c = Lib.discharge_con c in + Some (ReqGlobal (ConstRef c, req), (ConstRef c, b)) | _ -> None let rebuild = function @@ -842,7 +849,14 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = let (tm',sk'),cst_l' = whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) in - if equal_stacks (x, app_sk) (tm', sk') || Stack.will_expose_iota sk' + let rec is_case x = match kind_of_term x with + | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x + | App (hd, _) -> is_case hd + | Case _ -> true + | _ -> false in + if equal_stacks (x, app_sk) (tm', sk') + || Stack.will_expose_iota sk' + || is_case tm' then fold () else whrec cst_l' (tm', sk' @ sk) else match recargs with @@ -980,7 +994,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = | CoFix cofix -> if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then match Stack.strip_app stack with - |args, (Stack.Case(ci, _, lf,_)::s') -> + |args, ((Stack.Case _ |Stack.Proj _)::s') -> reduce_and_refold_cofix whrec env cst_l cofix stack |_ -> fold () else fold () @@ -1059,7 +1073,7 @@ let local_whd_state_gen flags sigma = | CoFix cofix -> if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then match Stack.strip_app stack with - |args, (Stack.Case(ci, _, lf,_)::s') -> + |args, ((Stack.Case _ | Stack.Proj _)::s') -> whrec (contract_cofix cofix, stack) |_ -> s else s @@ -1279,7 +1293,8 @@ let sigma_univ_state = { Reduction.compare = sigma_compare_sorts; Reduction.compare_instances = sigma_compare_instances } -let infer_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = +let infer_conv ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) + env sigma x y = try let b, sigma = let b, cstrs = @@ -1301,7 +1316,7 @@ let infer_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y sigma', true with | Reduction.NotConvertible -> sigma, false - | Univ.UniverseInconsistency _ -> sigma, false + | Univ.UniverseInconsistency _ when catch_incon -> sigma, false | e when is_anomaly e -> error "Conversion test raised an anomaly" (********************************************************************) @@ -1617,3 +1632,16 @@ let head_unfold_under_prod ts env _ c = | Const cst -> beta_applist (unfold cst,l) | _ -> c in aux c + +let betazetaevar_applist sigma n c l = + let rec stacklam n env t stack = + if Int.equal n 0 then applist (substl env t, stack) else + match kind_of_term t, stack with + | Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl + | LetIn(_,b,_,c), _ -> stacklam (n-1) (b::env) c stack + | Evar ev, _ -> + (match safe_evar_value sigma ev with + | Some body -> stacklam n env body stack + | None -> applist (substl env t, stack)) + | _ -> anomaly (Pp.str "Not enough lambda/let's") in + stacklam n [] c l diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 7c61d4e1..1df2a73b 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -268,9 +268,11 @@ val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> con (** [infer_fconv] Adds necessary universe constraints to the evar map. pb defaults to CUMUL and ts to a full transparent state. + @raises UniverseInconsistency iff catch_incon is set to false, + otherwise returns false in that case. *) -val infer_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> - evar_map * bool +val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> + env -> evar_map -> constr -> constr -> evar_map * bool (** {6 Special-Purpose Reduction Functions } *) @@ -278,6 +280,7 @@ val whd_meta : evar_map -> constr -> constr val plain_instance : constr Metamap.t -> constr -> constr val instance : evar_map -> constr Metamap.t -> constr -> constr val head_unfold_under_prod : transparent_state -> reduction_function +val betazetaevar_applist : evar_map -> int -> constr -> constr list -> constr (** {6 Heuristic for Conversion with Evar } *) diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index cd52ba44..a56861c6 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -100,7 +100,7 @@ let retype ?(polyprop=true) sigma = | Ind ind -> rename_type_of_inductive env ind | Construct cstr -> rename_type_of_constructor env cstr | Case (_,p,c,lf) -> - let Inductiveops.IndType(_,realargs) = + let Inductiveops.IndType(indf,realargs) = let t = type_of env c in try Inductiveops.find_rectype env sigma t with Not_found -> @@ -109,7 +109,8 @@ let retype ?(polyprop=true) sigma = Inductiveops.find_rectype env sigma t with Not_found -> retype_error BadRecursiveType in - let t = whd_beta sigma (applist (p, realargs)) in + let n = inductive_nrealdecls_env env (fst (fst (dest_ind_family indf))) in + let t = betazetaevar_applist sigma n p realargs in (match kind_of_term (whd_betadeltaiota env sigma (type_of env t)) with | Prod _ -> whd_beta sigma (applist (t, [c])) | _ -> t) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index b4e0459c..372b26aa 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -23,7 +23,6 @@ open Reductionops open Cbv open Patternops open Locus -open Pretype_errors (* Errors *) @@ -190,6 +189,7 @@ let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) = if Array.for_all (noccurn k) tys && Array.for_all (noccurn (k+nbfix)) bds + && k <= n then (k, List.nth labs (k-1)) else @@ -597,13 +597,6 @@ let reduce_proj env sigma whfun whfun' c = | _ -> raise Redelimination in redrec c - -let dont_expose_case = function - | EvalVar _ | EvalRel _ | EvalEvar _ -> false - | EvalConst c -> - Option.cata (fun (_,_,z) -> List.mem `ReductionDontExposeCase z) - false (ReductionBehaviour.get (ConstRef c)) - let whd_nothing_for_iota env sigma s = let rec whrec (x, stack as s) = match kind_of_term x with @@ -1212,9 +1205,10 @@ let one_step_reduce env sigma c = (ci,p,c,lf), stack) with Redelimination -> raise NotStepReducible) | Fix fix -> - (match reduce_fix (whd_construct_stack env) sigma fix stack with + (try match reduce_fix (whd_construct_stack env) sigma fix stack with | Reduced s' -> s' - | NotReducible -> raise NotStepReducible) + | NotReducible -> raise NotStepReducible + with Redelimination -> raise NotStepReducible) | _ when isEvalRef env x -> let ref,u = destEvalRefU x in (try diff --git a/pretyping/termops.ml b/pretyping/termops.ml index 5862a852..9f04faa8 100644 --- a/pretyping/termops.ml +++ b/pretyping/termops.ml @@ -15,7 +15,6 @@ open Term open Vars open Context open Environ -open Locus (* Sorts and sort family *) diff --git a/pretyping/termops.mli b/pretyping/termops.mli index 9f3efd72..2552c67e 100644 --- a/pretyping/termops.mli +++ b/pretyping/termops.mli @@ -11,7 +11,6 @@ open Names open Term open Context open Environ -open Locus (** printers *) val print_sort : sorts -> std_ppcmds diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 817d6878..18e83056 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -14,7 +14,6 @@ open Term open Vars open Context open Evd -open Environ open Util open Typeclasses_errors open Libobject @@ -427,7 +426,6 @@ let add_class cl = cl.cl_projs -open Declarations (* * interface functions @@ -485,15 +483,6 @@ let is_instance = function is_class (IndRef ind) | _ -> false -let is_implicit_arg = function -| Evar_kinds.GoalEvar -> false -| _ -> true - (* match k with *) - (* ImplicitArg (ref, (n, id), b) -> true *) - (* | InternalHole -> true *) - (* | _ -> false *) - - (* To embed a boolean for resolvability status. This is essentially a hack to mark which evars correspond to goals and do not need to be resolved when we have nested [resolve_all_evars] diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index 1a0b6696..b3170b97 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -77,8 +77,6 @@ val instance_priority : instance -> int option val is_class : global_reference -> bool val is_instance : global_reference -> bool -val is_implicit_arg : Evar_kinds.t -> bool - (** Returns the term and type for the given instance of the parameters and fields of the type class. *) diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml index 4f88dd86..585f066d 100644 --- a/pretyping/typeclasses_errors.ml +++ b/pretyping/typeclasses_errors.ml @@ -10,7 +10,6 @@ open Names open Term open Context -open Evd open Environ open Constrexpr open Globnames diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli index dd808771..7982fc85 100644 --- a/pretyping/typeclasses_errors.mli +++ b/pretyping/typeclasses_errors.mli @@ -10,7 +10,6 @@ open Loc open Names open Term open Context -open Evd open Environ open Constrexpr open Globnames diff --git a/pretyping/typing.mli b/pretyping/typing.mli index c933106d..1f822f1a 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Names open Term open Environ open Evd diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 203b1ec8..01e1154e 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -673,6 +673,10 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb (sigma,(k,lift (-nb) cM,fst (extract_instance_status pb))::metasubst, evarsubst) else error_cannot_unify_local curenv sigma (m,n,cM) + | Evar (evk,_ as ev), Evar (evk',_) + when not (Evar.Set.mem evk flags.frozen_evars) + && Evar.equal evk evk' -> + sigma,metasubst,((curenv,ev,cN)::evarsubst) | Evar (evk,_ as ev), _ when not (Evar.Set.mem evk flags.frozen_evars) && not (occur_evar evk cN) -> @@ -1673,11 +1677,13 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = matchrec t with ex when precatchable_exception ex -> matchrec c) + | Lambda (_,t,c) -> (try matchrec t with ex when precatchable_exception ex -> matchrec c) + | _ -> error "Match_subterm")) in try matchrec cl @@ -1774,7 +1780,12 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = try (* This is up to delta for subterms w/o metas ... *) w_unify_to_subterm env evd ~flags (strip_outer_cast op,t) - with PretypeError (env,_,NoOccurrenceFound _) when allow_K -> (evd,op) + with PretypeError (env,_,NoOccurrenceFound _) when + allow_K || + (* w_unify_to_subterm does not go through evars, so + the next step, which was already in <= 8.4, is + needed at least for compatibility of rewrite *) + dependent op t -> (evd,op) in if not allow_K && (* ensure we found a different instance *) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 19613c4e..8198db1b 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -166,8 +166,15 @@ and nf_whd env whd typ = mkApp(cfd,args) | Vconstr_const n -> construct_of_constr_const env n typ | Vconstr_block b -> - let capp,ctyp = construct_of_constr_block env (btag b) typ in - let args = nf_bargs env b ctyp in + let tag = btag b in + let (tag,ofs) = + if tag = Cbytecodes.last_variant_tag then + match whd_val (bfield b 0) with + | Vconstr_const tag -> (tag+Cbytecodes.last_variant_tag, 1) + | _ -> assert false + else (tag, 0) in + let capp,ctyp = construct_of_constr_block env tag typ in + let args = nf_bargs env b ofs ctyp in mkApp(capp,args) | Vatom_stk(Aid idkey, stk) -> let c,typ = constr_type_of_idkey env idkey in @@ -242,14 +249,14 @@ and nf_args env vargs t = t := subst1 c codom; c) in !t,args -and nf_bargs env b t = +and nf_bargs env b ofs t = let t = ref t in - let len = bsize b in + let len = bsize b - ofs in let args = Array.init len (fun i -> let _,dom,codom = decompose_prod env !t in - let c = nf_val env (bfield b i) dom in + let c = nf_val env (bfield b (i+ofs)) dom in t := subst1 c codom; c) in args diff --git a/printing/ppconstrsig.mli b/printing/ppconstrsig.mli index 15413d51..b7eb9b1f 100644 --- a/printing/ppconstrsig.mli +++ b/printing/ppconstrsig.mli @@ -12,8 +12,6 @@ open Libnames open Constrexpr open Names open Misctypes -open Locus -open Genredexpr module type Pp = sig diff --git a/printing/pptactic.mli b/printing/pptactic.mli index 284237f0..fa91aefc 100644 --- a/printing/pptactic.mli +++ b/printing/pptactic.mli @@ -15,9 +15,7 @@ open Names open Constrexpr open Tacexpr open Ppextend -open Environ -open Pattern -open Misctypes + type 'a raw_extra_genarg_printer = (constr_expr -> std_ppcmds) -> @@ -63,3 +61,4 @@ include Pptacticsig.Pp located in {!Ppannotation.t}. *) module Richpp : Pptacticsig.Pp +val ltop : tolerability diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli index 98b5757d..166a6675 100644 --- a/printing/pptacticsig.mli +++ b/printing/pptacticsig.mli @@ -8,7 +8,6 @@ open Pp open Genarg -open Names open Constrexpr open Tacexpr open Ppextend diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index e9e335ec..89ffae4b 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -740,9 +740,14 @@ module Make | VernacEndProof (Proved (opac,o)) -> return ( match o with - | None -> if opac then keyword "Qed" else keyword "Defined" + | None -> (match opac with + | Transparent -> keyword "Defined" + | Opaque None -> keyword "Qed" + | Opaque (Some l) -> + keyword "Qed" ++ spc() ++ str"export" ++ + prlist_with_sep (fun () -> str", ") pr_lident l) | Some (id,th) -> (match th with - | None -> (if opac then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id + | None -> (if opac <> Transparent then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id | Some tok -> keyword "Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id) ) | VernacExactProof c -> @@ -858,10 +863,14 @@ module Make | VernacNameSectionHypSet (id,set) -> return (hov 2 (keyword "Package" ++ spc() ++ pr_lident id ++ spc()++ str ":="++spc()++pr_using set)) - | VernacRequire (exp, l) -> + | VernacRequire (from, exp, l) -> + let from = match from with + | None -> mt () + | Some r -> keyword "From" ++ spc () ++ pr_module r ++ spc () + in return ( hov 2 - (keyword "Require" ++ spc() ++ pr_require_token exp ++ + (from ++ keyword "Require" ++ spc() ++ pr_require_token exp ++ prlist_with_sep sep pr_module l) ) | VernacImport (f,l) -> diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 223377c2..4a66c33d 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -109,7 +109,7 @@ let print_impargs_list prefix l = [(if ismt prefix then str "When" else prefix ++ str ", when") ++ str " applied to " ++ (if Int.equal n1 n2 then int_or_no n2 else - if Int.equal n1 0 then str "less than " ++ int n2 + if Int.equal n1 0 then str "no more than " ++ int n2 else int n1 ++ str " to " ++ int_or_no n2) ++ str (String.plural n2 " argument") ++ str ":"; v 0 (prlist_with_sep cut (fun x -> x) @@ -197,11 +197,13 @@ let print_opacity ref = let print_polymorphism ref = let poly = Global.is_polymorphic ref in let template_poly = Global.is_template_polymorphic ref in - pr_global ref ++ str " is " ++ str + if Flags.is_universe_polymorphism () || poly || template_poly then + [ pr_global ref ++ str " is " ++ str (if poly then "universe polymorphic" else if template_poly then "template universe polymorphic" - else "not universe polymorphic") + else "not universe polymorphic") ] + else [] let print_primitive_record mipv = function | Some (Some (_, ps,_)) -> @@ -214,9 +216,8 @@ let print_primitive ref = let mib,_ = Global.lookup_inductive ind in print_primitive_record mib.mind_packets mib.mind_record | _ -> [] - + let print_name_infos ref = - let poly = print_polymorphism ref in let impls = implicits_of_global ref in let scopes = Notation.find_arguments_scope ref in let renames = @@ -228,7 +229,8 @@ let print_name_infos ref = print_ref true ref; blankline] else [] in - poly :: print_primitive ref @ + print_polymorphism ref @ + print_primitive ref @ type_info_for_implicit @ print_renames_list (mt()) renames @ print_impargs_list (mt()) impls @ diff --git a/printing/printer.ml b/printing/printer.ml index 3403fb9c..0d3a1c17 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -11,7 +11,6 @@ open Errors open Util open Names open Term -open Vars open Environ open Globnames open Nametab @@ -446,6 +445,16 @@ let pr_evars_int sigma i evs = pr_evars_int_hd (fun i -> str "Existential " ++ i let pr_evars sigma evs = pr_evars_int_hd (fun i -> mt ()) sigma 1 (Evar.Map.bindings evs) +(* Display a list of evars given by their name, with a prefix *) +let pr_ne_evar_set hd tl sigma l = + if l != Evar.Set.empty then + let l = Evar.Set.fold (fun ev -> + Evar.Map.add ev (Evarutil.nf_evar_info sigma (Evd.find sigma ev))) + l Evar.Map.empty in + hd ++ pr_evars sigma l ++ tl + else + mt () + let default_pr_subgoal n sigma = let rec prrec p = function | [] -> error "No such goal." @@ -535,26 +544,27 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals else pr_rec 1 (g::l) in + (* Side effect! This has to be made more robust *) + let () = + match close_cmd with + | Some cmd -> msg_info cmd + | None -> () + in match goals with | [] -> begin - match close_cmd with - Some cmd -> - (str "Subproof completed, now type " ++ str cmd ++ - str ".") - | None -> - let exl = Evarutil.non_instantiated sigma in - if Evar.Map.is_empty exl then - (str"No more subgoals." - ++ emacs_print_dependent_evars sigma seeds) - else - let pei = pr_evars_int sigma 1 exl in - (str "No more subgoals but non-instantiated existential " ++ - str "variables:" ++ fnl () ++ (hov 0 pei) - ++ emacs_print_dependent_evars sigma seeds ++ fnl () ++ - str "You can use Grab Existential Variables.") + let exl = Evarutil.non_instantiated sigma in + if Evar.Map.is_empty exl then + (str"No more subgoals." + ++ emacs_print_dependent_evars sigma seeds) + else + let pei = pr_evars_int sigma 1 exl in + (str "No more subgoals but non-instantiated existential " ++ + str "variables:" ++ fnl () ++ (hov 0 pei) + ++ emacs_print_dependent_evars sigma seeds ++ fnl () ++ + str "You can use Grab Existential Variables.") end - | [g] when not !Flags.print_emacs -> + | [g] when not !Flags.print_emacs && pr_first -> let pg = default_pr_goal { it = g ; sigma = sigma; } in v 0 ( str "1" ++ focused_if_needed ++ str"subgoal" ++ print_extra @@ -563,8 +573,9 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals ) | g1::rest -> let goals = print_multiple_goals g1 rest in + let ngoals = List.length rest+1 in v 0 ( - int(List.length rest+1) ++ focused_if_needed ++ str"subgoals" ++ + int ngoals ++ focused_if_needed ++ str(String.plural ngoals "subgoal") ++ print_extra ++ str ((if display_name then (fun x -> x) else emacs_str) ", subgoal 1") ++ pr_goal_tag g1 @@ -578,7 +589,7 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals type printer_pr = { - pr_subgoals : ?pr_first:bool -> string option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> std_ppcmds; + pr_subgoals : ?pr_first:bool -> std_ppcmds option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> std_ppcmds; pr_subgoal : int -> evar_map -> goal list -> std_ppcmds; pr_goal : goal sigma -> std_ppcmds; } @@ -622,10 +633,14 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () = fnl () ++ pr_subgoals ~pr_first:false None bsigma seeds [] [] shelf | _ , _, _ -> - msg_info (str "This subproof is complete, but there are still unfocused goals." ++ - (match Proof_global.Bullet.suggest p - with None -> str"" | Some s -> fnl () ++ str s)); - fnl () ++ pr_subgoals ~pr_first:false None bsigma seeds shelf [] bgoals + let end_cmd = + strbrk "This subproof is complete, but there are still \ + unfocused goals." ++ + (match Proof_global.Bullet.suggest p + with None -> str"" | Some s -> fnl () ++ str s) ++ + fnl () + in + pr_subgoals ~pr_first:false (Some end_cmd) bsigma seeds shelf [] bgoals end | _ -> pr_subgoals None sigma seeds shelf stack goals end diff --git a/printing/printer.mli b/printing/printer.mli index 6b9c7081..a469a8db 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -128,7 +128,7 @@ val pr_transparent_state : transparent_state -> std_ppcmds (** Proofs *) val pr_goal : goal sigma -> std_ppcmds -val pr_subgoals : ?pr_first:bool -> string option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> std_ppcmds +val pr_subgoals : ?pr_first:bool -> std_ppcmds option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> std_ppcmds val pr_subgoal : int -> evar_map -> goal list -> std_ppcmds val pr_concl : int -> evar_map -> goal -> std_ppcmds @@ -137,6 +137,8 @@ val pr_nth_open_subgoal : int -> std_ppcmds val pr_evar : evar_map -> (evar * evar_info) -> std_ppcmds val pr_evars_int : evar_map -> int -> evar_info Evar.Map.t -> std_ppcmds val pr_evars : evar_map -> evar_info Evar.Map.t -> std_ppcmds +val pr_ne_evar_set : std_ppcmds -> std_ppcmds -> evar_map -> + Evar.Set.t -> std_ppcmds val pr_prim_rule : prim_rule -> std_ppcmds @@ -166,7 +168,7 @@ val pr_assumptionset : val pr_goal_by_id : string -> std_ppcmds type printer_pr = { - pr_subgoals : ?pr_first:bool -> string option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> std_ppcmds; + pr_subgoals : ?pr_first:bool -> std_ppcmds option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> std_ppcmds; pr_subgoal : int -> evar_map -> goal list -> std_ppcmds; pr_goal : goal sigma -> std_ppcmds; };; diff --git a/printing/richprinter.ml b/printing/richprinter.ml index d71dc82d..d95e1907 100644 --- a/printing/richprinter.ml +++ b/printing/richprinter.ml @@ -5,21 +5,20 @@ module RichppVernac = Ppvernac.Richpp module RichppTactic = Pptactic.Richpp type rich_pp = - string - * Ppannotation.t Richpp.located Xml_datatype.gxml + Ppannotation.t Richpp.located Xml_datatype.gxml * Xml_datatype.xml let get_annotations obj = Pp.Tag.prj obj Ppannotation.tag let make_richpp pr ast = - let raw_pp, rich_pp = + let rich_pp = rich_pp get_annotations (pr ast) in let xml = Ppannotation.( xml_of_rich_pp tag_of_annotation attributes_of_annotation rich_pp ) in - (raw_pp, rich_pp, xml) + (rich_pp, xml) let richpp_vernac = make_richpp RichppVernac.pr_vernac let richpp_constr = make_richpp RichppConstr.pr_constr_expr diff --git a/printing/richprinter.mli b/printing/richprinter.mli index c67d52c0..41c31351 100644 --- a/printing/richprinter.mli +++ b/printing/richprinter.mli @@ -20,12 +20,10 @@ (** A rich pretty-print is composed of: *) type rich_pp = - (** - a raw pretty-print ; *) - string (** - a generalized semi-structured document whose attributes are annotations ; *) - * Ppannotation.t Richpp.located Xml_datatype.gxml + Ppannotation.t Richpp.located Xml_datatype.gxml (** - an XML document, representing annotations as usual textual XML attributes. *) diff --git a/proofs/clenv.mli b/proofs/clenv.mli index 9b671bcf..eb108170 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -10,7 +10,6 @@ open Names open Term open Environ open Evd -open Mod_subst open Unification open Misctypes diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli index da40427c..ea204361 100644 --- a/proofs/clenvtac.mli +++ b/proofs/clenvtac.mli @@ -8,7 +8,6 @@ open Term open Clenv -open Proof_type open Tacexpr open Unification diff --git a/proofs/goal.ml b/proofs/goal.ml index e3570242..107ce7f8 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -9,8 +9,6 @@ open Util open Pp open Term -open Vars -open Context (* This module implements the abstract interface to goals *) (* A general invariant of the module, is that a goal whose associated diff --git a/proofs/logic.ml b/proofs/logic.ml index 53f8093e..b8206ca1 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -13,7 +13,6 @@ open Names open Nameops open Term open Vars -open Context open Termops open Environ open Reductionops @@ -83,12 +82,6 @@ let apply_to_hyp sign id f = if !check then error_no_such_hypothesis id else sign -let apply_to_hyp_and_dependent_on sign id f g = - try apply_to_hyp_and_dependent_on sign id f g - with Hyp_not_found -> - if !check then error_no_such_hypothesis id - else sign - let check_typability env sigma c = if !check then let _ = type_of env sigma c in () @@ -277,11 +270,6 @@ let move_hyp toleft (left,(idfrom,_,_ as declfrom),right) hto = List.fold_left (fun sign d -> push_named_context_val d sign) right left -let rename_hyp id1 id2 sign = - apply_to_hyp_and_dependent_on sign id1 - (fun (_,b,t) _ -> (id2,b,t)) - (fun d _ -> map_named_declaration (replace_vars [id1,mkVar id2]) d) - (**********************************************************************) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index fdc93bcb..d1b6afe2 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -156,6 +156,41 @@ let build_by_tactic env ctx ?(poly=false) typ tac = assert(Univ.ContextSet.is_empty ctx); cb, status, univs +let refine_by_tactic env sigma ty tac = + (** Save the initial side-effects to restore them afterwards. We set the + current set of side-effects to be empty so that we can retrieve the + ones created during the tactic invocation easily. *) + let eff = Evd.eval_side_effects sigma in + let sigma = Evd.drop_side_effects sigma in + (** Start a proof *) + let prf = Proof.start sigma [env, ty] in + let (prf, _) = + try Proof.run_tactic env tac prf + with Logic_monad.TacticFailure e as src -> + (** Catch the inner error of the monad tactic *) + let (_, info) = Errors.push src in + iraise (e, info) + in + (** Plug back the retrieved sigma *) + let sigma = Proof.in_proof prf (fun sigma -> sigma) in + let ans = match Proof.initial_goals prf with + | [c, _] -> c + | _ -> assert false + in + let ans = Reductionops.nf_evar sigma ans in + (** [neff] contains the freshly generated side-effects *) + let neff = Evd.eval_side_effects sigma in + (** Reset the old side-effects *) + let sigma = Evd.drop_side_effects sigma in + let sigma = Evd.emit_side_effects eff sigma in + (** Get rid of the fresh side-effects by internalizing them in the term + itself. Note that this is unsound, because the tactic may have solved + other goals that were already present during its invocation, so that + those goals rely on effects that are not present anymore. Hopefully, + this hack will work in most cases. *) + let ans = Term_typing.handle_side_effects env ans neff in + ans, sigma + (**********************************************************************) (* Support for resolution of evars in tactic interpretation, including resolution by application of tactics *) diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index edbc18a3..5e0fb4dd 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -157,6 +157,14 @@ val build_by_tactic : env -> Evd.evar_universe_context -> ?poly:polymorphic -> types -> unit Proofview.tactic -> constr * bool * Evd.evar_universe_context +val refine_by_tactic : env -> Evd.evar_map -> types -> unit Proofview.tactic -> + constr * Evd.evar_map +(** A variant of the above function that handles open terms as well. + Caveat: all effects are purged in the returned term at the end, but other + evars solved by side-effects are NOT purged, so that unexpected failures may + occur. Ideally all code using this function should be rewritten in the + monad. *) + (** Declare the default tactic to fill implicit arguments *) val declare_implicit_tactic : unit Proofview.tactic -> unit diff --git a/proofs/proof.mli b/proofs/proof.mli index 4ae64ae6..2b85ec87 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -134,7 +134,7 @@ exception FullyUnfocused exception CannotUnfocusThisWay (* This is raised when trying to focus on non-existing subgoals. It is - handled by an error message but one may need to catched it and + handled by an error message but one may need to catch it and settle a better error message in some case (suggesting a better bullet for example), see proof_global.ml function Bullet.pop and Bullet.push. *) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index f55ab700..5bff3c81 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -74,7 +74,7 @@ type proof_object = { } type proof_ending = - | Admitted + | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry | Proved of Vernacexpr.opacity_flag * (Vernacexpr.lident * Decl_kinds.theorem_kind option) option * proof_object @@ -295,7 +295,7 @@ let close_proof ~keep_body_ucst_sepatate ?feedback_id ~now fpl = let ctx = Evd.evar_universe_context_set universes in if keep_body_ucst_sepatate then (* For vi2vo compilation proofs are computed now but we need to - * completent the univ constraints of the typ with the ones of + * complement the univ constraints of the typ with the ones of * the body. So we keep the two sets distinct. *) let ctx_body = restrict_universe_context ctx used_univs_body in let ctx_typ = restrict_universe_context ctx used_univs_typ in @@ -338,21 +338,37 @@ let close_proof ~keep_body_ucst_sepatate ?feedback_id ~now fpl = type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.evar_universe_context -let return_proof () = - let { proof; strength = (_,poly,_) } = cur_pstate () in +let return_proof ?(allow_partial=false) () = + let { pid; proof; strength = (_,poly,_) } = cur_pstate () in + if allow_partial then begin + if Proof.is_done proof then begin + msg_warning (str"The proof of " ++ str (Names.Id.to_string pid) ++ + str" is complete, no need to end it with Admitted"); + end; + let proofs = Proof.partial_proof proof in + let _,_,_,_, evd = Proof.proof proof in + let eff = Evd.eval_side_effects evd in + (** ppedrot: FIXME, this is surely wrong. There is no reason to duplicate + side-effects... This may explain why one need to uniquize side-effects + thereafter... *) + let proofs = List.map (fun c -> c, eff) proofs in + proofs, Evd.evar_universe_context evd + end else let initial_goals = Proof.initial_goals proof in let evd = - let error s = raise (Errors.UserError("last tactic before Qed",s)) in + let error s = + let prf = str " (in proof " ++ Id.print pid ++ str ")" in + raise (Errors.UserError("last tactic before Qed",s ++ prf)) + in try Proof.return proof with | Proof.UnfinishedProof -> error(str"Attempt to save an incomplete proof") | Proof.HasShelvedGoals -> error(str"Attempt to save a proof with shelved goals") | Proof.HasGivenUpGoals -> - error(str"Attempt to save a proof with given up goals") + error(strbrk"Attempt to save a proof with given up goals. If this is really what you want to do, use Admitted in place of Qed.") | Proof.HasUnresolvedEvar-> - error(str"Attempt to save a proof with existential " ++ - str"variables still non-instantiated") in + error(strbrk"Attempt to save a proof with existential variables still non-instantiated") in let eff = Evd.eval_side_effects evd in let evd = if poly || !Flags.compilation_mode = Flags.BuildVo diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 2700e901..9d5038a3 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -66,7 +66,7 @@ type proof_object = { } type proof_ending = - | Admitted + | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry | Proved of Vernacexpr.opacity_flag * (Vernacexpr.lident * Decl_kinds.theorem_kind option) option * proof_object @@ -99,7 +99,9 @@ val close_proof : keep_body_ucst_sepatate:bool -> Future.fix_exn -> closed_proof type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.evar_universe_context -val return_proof : unit -> closed_proof_output +(* If allow_partial is set (default no) then an incomplete proof + * is allowed (no error), and a warn is given if the proof is complete. *) +val return_proof : ?allow_partial:bool -> unit -> closed_proof_output val close_future_proof : feedback_id:Stateid.t -> closed_proof_output Future.computation -> closed_proof diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml index 26bb78df..47b2b255 100644 --- a/proofs/proof_type.ml +++ b/proofs/proof_type.ml @@ -10,7 +10,6 @@ open Evd open Names open Term -open Context open Tacexpr open Glob_term open Nametab diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index e709be5b..f5e2bad2 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -9,7 +9,6 @@ open Evd open Names open Term -open Context open Tacexpr open Glob_term open Nametab diff --git a/proofs/proofview.ml b/proofs/proofview.ml index a25683bf..6f626341 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -192,8 +192,8 @@ let unfocus c sp = succeed). Another benefit is that it is possible to write tactics that can be executed even if there are no focused goals. - Tactics form a monad ['a tactic], in a sense a tactic can be - seens as a function (without argument) which returns a value of - type 'a and modifies the environement (in our case: the view). + seen as a function (without argument) which returns a value of + type 'a and modifies the environment (in our case: the view). Tactics of course have arguments, but these are given at the meta-level as OCaml functions. Most tactics in the sense we are used to return [()], that is no really interesting values. But @@ -719,22 +719,72 @@ let give_up = (** {7 Control primitives} *) -(** Equality function on goals *) -let goal_equal evars1 gl1 evars2 gl2 = - let evi1 = Evd.find evars1 gl1 in - let evi2 = Evd.find evars2 gl2 in - Evd.eq_evar_info evars2 evi1 evi2 + +module Progress = struct + + (** equality function up to evar instantiation in heterogeneous + contexts. *) + (* spiwack (2015-02-19): In the previous version of progress an + equality which considers two universes equal when it is consistent + tu unify them ([Evd.eq_constr_univs_test]) was used. Maybe this + behaviour has to be restored as well. This has to be established by + practice. *) + + let rec eq_constr sigma1 sigma2 t1 t2 = + Constr.equal_with + (fun t -> Evarutil.kind_of_term_upto sigma1 t) + (fun t -> Evarutil.kind_of_term_upto sigma2 t) + t1 t2 + + (** equality function on hypothesis contexts *) + let eq_named_context_val sigma1 sigma2 ctx1 ctx2 = + let open Environ in + let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in + let eq_named_declaration (i1, c1, t1) (i2, c2, t2) = + Names.Id.equal i1 i2 && Option.equal (eq_constr sigma1 sigma2) c1 c2 + && (eq_constr sigma1 sigma2) t1 t2 + in List.equal eq_named_declaration c1 c2 + + let eq_evar_body sigma1 sigma2 b1 b2 = + let open Evd in + match b1, b2 with + | Evar_empty, Evar_empty -> true + | Evar_defined t1, Evar_defined t2 -> eq_constr sigma1 sigma2 t1 t2 + | _ -> false + + let eq_evar_info sigma1 sigma2 ei1 ei2 = + let open Evd in + eq_constr sigma1 sigma2 ei1.evar_concl ei2.evar_concl && + eq_named_context_val sigma1 sigma2 (ei1.evar_hyps) (ei2.evar_hyps) && + eq_evar_body sigma1 sigma2 ei1.evar_body ei2.evar_body + + (** Equality function on goals *) + let goal_equal evars1 gl1 evars2 gl2 = + let evi1 = Evd.find evars1 gl1 in + let evi2 = Evd.find evars2 gl2 in + eq_evar_info evars1 evars2 evi1 evi2 + +end let tclPROGRESS t = let open Proof in Pv.get >>= fun initial -> t >>= fun res -> Pv.get >>= fun final -> + (* [*_test] test absence of progress. [quick_test] is approximate + whereas [exhaustive_test] is complete. *) + let quick_test = + initial.solution == final.solution && initial.comb == final.comb + in + let exhaustive_test = + Util.List.for_all2eq begin fun i f -> + Progress.goal_equal initial.solution i final.solution f + end initial.comb final.comb + in let test = - Evd.progress_evar_map initial.solution final.solution && - not (Util.List.for_all2eq (fun i f -> goal_equal initial.solution i final.solution f) initial.comb final.comb) + quick_test || exhaustive_test in - if test then + if not test then tclUNIT res else tclZERO (Errors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) @@ -1126,7 +1176,7 @@ module V82 = struct (* Returns the open goals of the proofview together with the evar_map to - interprete them. *) + interpret them. *) let goals { comb = comb ; solution = solution; } = { Evd.it = comb ; sigma = solution } diff --git a/proofs/proofview.mli b/proofs/proofview.mli index ec255f6a..5a9e7f39 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -37,7 +37,7 @@ type entry val compact : entry -> proofview -> entry * proofview (** Initialises a proofview, the main argument is a list of - environements (including a [named_context] which are used as + environments (including a [named_context] which are used as hypotheses) pair with conclusion types, creating accordingly many initial goals. Because a proof does not necessarily starts in an empty [evar_map] (indeed a proof can be triggered by an incomplete @@ -114,8 +114,8 @@ val unfocus : focus_context -> proofview -> proofview succeed). Another benefit is that it is possible to write tactics that can be executed even if there are no focused goals. - Tactics form a monad ['a tactic], in a sense a tactic can be - seens as a function (without argument) which returns a value of - type 'a and modifies the environement (in our case: the view). + seen as a function (without argument) which returns a value of + type 'a and modifies the environment (in our case: the view). Tactics of course have arguments, but these are given at the meta-level as OCaml functions. Most tactics in the sense we are used to return [()], that is no really interesting values. But @@ -230,7 +230,7 @@ val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic [i] to [j] (see {!focus}). The rest of the goals is restored after the tactic action. If the specified range doesn't correspond to existing goals, fails with [NoSuchGoals] (a user error). this - exception is catched at toplevel with a default message + a hook + exception is caught at toplevel with a default message + a hook message that can be customized by [set_nosuchgoals_hook] below. This hook is used to add a suggestion about bullets when applicable. *) @@ -547,7 +547,7 @@ module V82 : sig val grab : proofview -> proofview (* Returns the open goals of the proofview together with the evar_map to - interprete them. *) + interpret them. *) val goals : proofview -> Evar.t list Evd.sigma val top_goals : entry -> proofview -> Evar.t list Evd.sigma diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 18588867..1383d755 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -234,7 +234,7 @@ let reduction_of_red_expr env = with Not_found -> error("unknown user-defined reduction \""^s^"\""))) | CbvVm o -> (contextualize cbv_vm cbv_vm o, VMcast) - | CbvNative o -> (contextualize cbv_native cbv_native o, VMcast) + | CbvNative o -> (contextualize cbv_native cbv_native o, NATIVEcast) in reduction_of_red_expr diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 672527d9..e3fb0b60 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -177,7 +177,7 @@ module Make(T : Task) = struct if not (Worker.is_alive proc) then () else if cancelled () || !(!expiration_date) then let () = stop_waiting := true in - let () = TQueue.signal_destruction queue in + let () = TQueue.broadcast queue in Worker.kill proc else let () = Unix.sleep 1 in @@ -253,6 +253,8 @@ module Make(T : Task) = struct Pool.destroy active; TQueue.destroy queue + let broadcast { queue } = TQueue.broadcast queue + let enqueue_task { queue; active } (t, _ as item) = prerr_endline ("Enqueue task "^T.name_of_task t); TQueue.push queue item diff --git a/stm/asyncTaskQueue.mli b/stm/asyncTaskQueue.mli index 78f295d3..a3fe4b8c 100644 --- a/stm/asyncTaskQueue.mli +++ b/stm/asyncTaskQueue.mli @@ -61,6 +61,8 @@ module MakeQueue(T : Task) : sig val set_order : queue -> (T.task -> T.task -> int) -> unit + val broadcast : queue -> unit + (* Take a snapshot (non destructive but waits until all workers are * enqueued) *) val snapshot : queue -> T.task list diff --git a/stm/lemmas.ml b/stm/lemmas.ml index f2e68779..6cece32e 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -185,7 +185,7 @@ let look_for_possibly_mutual_statements = function (* Saving a goal *) -let save id const cstrs do_guard (locality,poly,kind) hook = +let save ?export_seff id const cstrs do_guard (locality,poly,kind) hook = let fix_exn = Future.fix_exn_of const.Entries.const_entry_body in try let const = adjust_guardness_conditions const do_guard in @@ -200,7 +200,8 @@ let save id const cstrs do_guard (locality,poly,kind) hook = | Local | Discharge -> true | Global -> false in - let kn = declare_constant id ~local (DefinitionEntry const, k) in + let kn = + declare_constant ?export_seff id ~local (DefinitionEntry const, k) in (locality, ConstRef kn) in definition_message id; call_hook (fun exn -> exn) hook l r @@ -273,35 +274,29 @@ let save_remaining_recthms (locality,p,kind) norm ctx body opaq i (id,(t_i,(_,im let save_hook = ref ignore let set_save_hook f = save_hook := f -let save_named proof = +let save_named ?export_seff proof = let id,const,cstrs,do_guard,persistence,hook = proof in - save id const cstrs do_guard persistence hook + save ?export_seff id const cstrs do_guard persistence hook let check_anonymity id save_ident = if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then error "This command can only be used for unnamed theorem." -let save_anonymous proof save_ident = +let save_anonymous ?export_seff proof save_ident = let id,const,cstrs,do_guard,persistence,hook = proof in check_anonymity id save_ident; - save save_ident const cstrs do_guard persistence hook + save ?export_seff save_ident const cstrs do_guard persistence hook -let save_anonymous_with_strength proof kind save_ident = +let save_anonymous_with_strength ?export_seff proof kind save_ident = let id,const,cstrs,do_guard,_,hook = proof in check_anonymity id save_ident; (* we consider that non opaque behaves as local for discharge *) - save save_ident const cstrs do_guard (Global, const.const_entry_polymorphic, Proof kind) hook + save ?export_seff save_ident const cstrs do_guard (Global, const.const_entry_polymorphic, Proof kind) hook (* Admitted *) -let admit hook () = - let (id,k,typ) = Pfedit.current_proof_statement () in - let ctx = - let evd = fst (Pfedit.get_current_goal_context ()) in - Evd.universe_context evd - in - let e = Pfedit.get_used_variables(), pi2 k, (typ, ctx), None in +let admit (id,k,e) hook () = let kn = declare_constant id (ParameterEntry e, IsAssumption Conjectural) in let () = match k with | Global, _, _ -> () @@ -325,34 +320,50 @@ let get_proof proof do_guard hook opacity = (** FIXME *) id,{const with const_entry_opaque = opacity},cstrs,do_guard,persistence,hook +let check_exist = + List.iter (fun (loc,id) -> + if not (Nametab.exists_cci (Lib.make_path id)) then + user_err_loc (loc,"",pr_id id ++ str " does not exist.") + ) + let standard_proof_terminator compute_guard hook = let open Proof_global in function - | Admitted -> - admit hook (); + | Admitted (id,k,pe) -> + admit (id,k,pe) hook (); Pp.feedback Feedback.AddedAxiom - | Proved (is_opaque,idopt,proof) -> + | Proved (opaque,idopt,proof) -> + let is_opaque, export_seff, exports = match opaque with + | Vernacexpr.Transparent -> false, true, [] + | Vernacexpr.Opaque None -> true, false, [] + | Vernacexpr.Opaque (Some l) -> true, true, l in let proof = get_proof proof compute_guard hook is_opaque in begin match idopt with - | None -> save_named proof - | Some ((_,id),None) -> save_anonymous proof id + | None -> save_named ~export_seff proof + | Some ((_,id),None) -> save_anonymous ~export_seff proof id | Some ((_,id),Some kind) -> - save_anonymous_with_strength proof kind id - end + save_anonymous_with_strength ~export_seff proof kind id + end; + check_exist exports let universe_proof_terminator compute_guard hook = let open Proof_global in function - | Admitted -> - admit (hook None) (); + | Admitted (id,k,pe) -> + admit (id,k,pe) (hook None) (); Pp.feedback Feedback.AddedAxiom - | Proved (is_opaque,idopt,proof) -> + | Proved (opaque,idopt,proof) -> + let is_opaque, export_seff, exports = match opaque with + | Vernacexpr.Transparent -> false, true, [] + | Vernacexpr.Opaque None -> true, false, [] + | Vernacexpr.Opaque (Some l) -> true, true, l in let proof = get_proof proof compute_guard (hook (Some proof.Proof_global.universes)) is_opaque in begin match idopt with - | None -> save_named proof - | Some ((_,id),None) -> save_anonymous proof id + | None -> save_named ~export_seff proof + | Some ((_,id),None) -> save_anonymous ~export_seff proof id | Some ((_,id),Some kind) -> - save_anonymous_with_strength proof kind id - end + save_anonymous_with_strength ~export_seff proof kind id + end; + check_exist exports let start_proof id kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook = let terminator = standard_proof_terminator compute_guard hook in @@ -458,7 +469,37 @@ let start_proof_com kind thms hook = let save_proof ?proof = function | Vernacexpr.Admitted -> - Proof_global.get_terminator() Proof_global.Admitted + let pe = + let open Proof_global in + match proof with + | Some ({ id; entries; persistence = k; universes }, _) -> + if List.length entries <> 1 then + error "Admitted does not support multiple statements"; + let { const_entry_secctx; const_entry_type } = List.hd entries in + if const_entry_type = None then + error "Admitted requires an explicit statement"; + let typ = Option.get const_entry_type in + let ctx = Evd.evar_context_universe_context universes in + Admitted(id, k, (const_entry_secctx, pi2 k, (typ, ctx), None)) + | None -> + let id, k, typ = Pfedit.current_proof_statement () in + let ctx = + let evd, _ = Pfedit.get_current_goal_context () in + Evd.universe_context evd in + (* This will warn if the proof is complete *) + let pproofs,_ = Proof_global.return_proof ~allow_partial:true () in + let sec_vars = + match Pfedit.get_used_variables(), pproofs with + | Some _ as x, _ -> x + | None, (pproof, _) :: _ -> + let env = Global.env () in + let ids_typ = Environ.global_vars_set env typ in + let ids_def = Environ.global_vars_set env pproof in + Some (Environ.keep_hyps env (Idset.union ids_typ ids_def)) + | _ -> None in + Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None)) + in + Proof_global.get_terminator() pe | Vernacexpr.Proved (is_opaque,idopt) -> let (proof_obj,terminator) = match proof with diff --git a/stm/lemmas.mli b/stm/lemmas.mli index d0669d7a..a0ddd265 100644 --- a/stm/lemmas.mli +++ b/stm/lemmas.mli @@ -10,7 +10,6 @@ open Names open Term open Decl_kinds open Constrexpr -open Tacexpr open Vernacexpr open Pfedit diff --git a/stm/spawned.ml b/stm/spawned.ml index 18159288..a8372195 100644 --- a/stm/spawned.ml +++ b/stm/spawned.ml @@ -81,6 +81,7 @@ let init_channels () = let get_channels () = match !channels with - | None -> Errors.anomaly(Pp.str "init_channels not called") + | None -> + Printf.eprintf "Fatal error: ideslave communication channels not set.\n"; + exit 1 | Some(ic, oc) -> ic, oc - @@ -8,7 +8,8 @@ let pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr -let prerr_endline s = if !Flags.debug then begin pr_err s end else () +let prerr_endline s = if false then begin pr_err s end else () +let prerr_debug s = if !Flags.debug then begin pr_err s end else () open Vernacexpr open Errors @@ -130,8 +131,9 @@ type cancel_switch = bool ref type branch_type = [ `Master | `Proof of proof_mode * depth - | `Edit of proof_mode * Stateid.t * Stateid.t ] + | `Edit of proof_mode * Stateid.t * Stateid.t * vernac_qed_type ] type cmd_t = { + ctac : bool; (* is a tactic, needed by the 8.4 semantics of Undo *) cast : ast; cids : Id.t list; cqueue : [ `MainQueue | `TacQueue of cancel_switch | `QueryQueue of cancel_switch ] } @@ -144,7 +146,7 @@ type qed_t = { brinfo : branch_type Vcs_.branch_info } type seff_t = ast option -type alias_t = Stateid.t +type alias_t = Stateid.t * ast type transaction = | Cmd of cmd_t | Fork of fork_t @@ -160,6 +162,11 @@ type step = | `Alias of alias_t ] type visit = { step : step; next : Stateid.t } + +(* Parts of the system state that are morally part of the proof state *) +let summary_pstate = [ Evarutil.meta_counter_summary_name; + Evarutil.evar_counter_summary_name; + "program-tcc-table" ] type state = { system : States.state; proof : Proof_global.state; @@ -315,7 +322,7 @@ end = struct (* {{{ *) (try string_of_ppcmds (pr_ast t) with _ -> "ERR") | Sideff None -> "EnvChange" | Noop -> " " - | Alias id -> sprintf "Alias(%s)" (Stateid.to_string id) + | Alias (id,_) -> sprintf "Alias(%s)" (Stateid.to_string id) | Qed { qast } -> string_of_ppcmds (pr_ast qast) in let is_green id = match get_info vcs id with @@ -442,7 +449,7 @@ end = struct (* {{{ *) if List.mem edit_branch (Vcs_.branches !vcs) then begin checkout edit_branch; match get_branch edit_branch with - | { kind = `Edit (mode, _, _) } -> Proof_global.activate_proof_mode mode + | { kind = `Edit (mode, _,_,_) } -> Proof_global.activate_proof_mode mode | _ -> assert false end else let pl = proof_nesting () in @@ -593,9 +600,12 @@ module State : sig type frozen_state val get_cached : Stateid.t -> frozen_state val same_env : frozen_state -> frozen_state -> bool + + type proof_part type partial_state = - [ `Full of frozen_state | `Proof of Stateid.t * Proof_global.state ] - val proof_part_of_frozen : frozen_state -> Proof_global.state + [ `Full of frozen_state + | `Proof of Stateid.t * proof_part ] + val proof_part_of_frozen : frozen_state -> proof_part val assign : Stateid.t -> partial_state -> unit end = struct (* {{{ *) @@ -619,9 +629,14 @@ end = struct (* {{{ *) (fun t -> let s,i = out_t t in unfreeze_global_state s; cur_id := i) type frozen_state = state + type proof_part = + Proof_global.state * Summary.frozen_bits (* only meta counters *) type partial_state = - [ `Full of frozen_state | `Proof of Stateid.t * Proof_global.state ] - let proof_part_of_frozen { proof } = proof + [ `Full of frozen_state + | `Proof of Stateid.t * proof_part ] + let proof_part_of_frozen { proof; system } = + proof, + Summary.project_summary (States.summary_of_state system) summary_pstate let freeze marhallable id = VCS.set_state id (freeze_global_state marhallable) @@ -656,9 +671,16 @@ end = struct (* {{{ *) if VCS.get_state id <> None then () else try match what with | `Full s -> VCS.set_state id s - | `Proof(ontop,p) -> - if is_cached ontop then ( - VCS.set_state id { (get_cached ontop) with proof = p }) + | `Proof(ontop,(pstate,counters)) -> + if is_cached ontop then + let s = get_cached ontop in + let s = { s with proof = pstate } in + let s = { s with system = + States.replace_summary s.system + (Summary.surgery_summary + (States.summary_of_state s.system) + counters) } in + VCS.set_state id s with VCS.Expired -> () let exn_on id ?valid (e, info) = @@ -769,19 +791,20 @@ end = struct (* {{{ *) match info.vcs_backup with | None, _ -> next acc | Some vcs, _ -> - let ids = - if id = Stateid.initial || id = Stateid.dummy then [] else + let ids, tactic, undo = + if id = Stateid.initial || id = Stateid.dummy then [],false,0 else match VCS.visit id with - | { step = `Fork ((_,_,_,l),_) } -> l - | { step = `Cmd { cids = l } } -> l - | _ -> [] in - match f acc (id, vcs, ids) with + | { step = `Fork ((_,_,_,l),_) } -> l, false,0 + | { step = `Cmd { cids = l; ctac } } -> l, ctac,0 + | { step = `Alias (_,{ expr = VernacUndo n}) } -> [], false, n + | _ -> [],false,0 in + match f acc (id, vcs, ids, tactic, undo) with | `Stop x -> x | `Cont acc -> next acc let back_safe () = let id = - fold_until (fun n (id,_,_) -> + fold_until (fun n (id,_,_,_,_) -> if n >= 0 && State.is_cached id then `Stop id else `Cont (succ n)) 0 (VCS.get_branch_pos (VCS.current_branch ())) in backto id @@ -797,7 +820,7 @@ end = struct (* {{{ *) let id = VCS.get_branch_pos (VCS.current_branch ()) in (try let oid = - fold_until (fun b (id,_,label) -> + fold_until (fun b (id,_,label,_,_) -> if b then `Stop id else `Cont (List.mem name label)) false id in VtStm (VtBack oid, true), VtNow @@ -805,17 +828,15 @@ end = struct (* {{{ *) VtStm (VtBack id, true), VtNow) | VernacBack n -> let id = VCS.get_branch_pos (VCS.current_branch ()) in - let oid = fold_until (fun n (id,_,_) -> + let oid = fold_until (fun n (id,_,_,_,_) -> if Int.equal n 0 then `Stop id else `Cont (n-1)) n id in VtStm (VtBack oid, true), VtNow | VernacUndo n -> let id = VCS.get_branch_pos (VCS.current_branch ()) in - let oid = fold_until (fun n (id,_,_) -> - if Int.equal n 0 then `Stop id else `Cont (n-1)) n id in - if n = 1 && !Flags.coqtop_ui && not !Flags.batch_mode && - not !Flags.print_emacs then - VtStm (VtBack oid, false), VtNow - else VtStm (VtBack oid, true), VtLater + let oid = fold_until (fun n (id,_,_,tactic,undo) -> + let value = (if tactic then 1 else 0) - undo in + if Int.equal n 0 then `Stop id else `Cont (n-value)) n id in + VtStm (VtBack oid, true), VtLater | VernacUndoTo _ | VernacRestart as e -> let m = match e with VernacUndoTo m -> m | _ -> 0 in @@ -826,15 +847,15 @@ end = struct (* {{{ *) | Some vcs, _ -> vcs in let cb, _ = Vcs_aux.find_proof_at_depth vcs (Vcs_aux.proof_nesting vcs) in - let n = fold_until (fun n (_,vcs,_) -> + let n = fold_until (fun n (_,vcs,_,_,_) -> if List.mem cb (Vcs_.branches vcs) then `Cont (n+1) else `Stop n) 0 id in - let oid = fold_until (fun n (id,_,_) -> + let oid = fold_until (fun n (id,_,_,_,_) -> if Int.equal n 0 then `Stop id else `Cont (n-1)) (n-m-1) id in VtStm (VtBack oid, true), VtLater | VernacAbortAll -> let id = VCS.get_branch_pos (VCS.current_branch ()) in - let oid = fold_until (fun () (id,vcs,_) -> + let oid = fold_until (fun () (id,vcs,_,_,_) -> match Vcs_.branches vcs with [_] -> `Stop id | _ -> `Cont ()) () id in VtStm (VtBack oid, true), VtLater @@ -885,6 +906,7 @@ module rec ProofTask : sig t_exn_info : Stateid.t * Stateid.t; t_start : Stateid.t; t_stop : Stateid.t; + t_drop : bool; t_states : competence; t_assign : Proof_global.closed_proof_output Future.assignement -> unit; t_loc : Loc.t; @@ -896,8 +918,8 @@ module rec ProofTask : sig | States of Stateid.t list type request = - | ReqBuildProof of (Future.UUID.t,VCS.vcs) Stateid.request * competence - | ReqStates of Stateid.t list + | ReqBuildProof of (Future.UUID.t,VCS.vcs) Stateid.request * bool * competence + | ReqStates of Stateid.t list include AsyncTaskQueue.Task with type task := task @@ -905,9 +927,13 @@ module rec ProofTask : sig and type request := request val build_proof_here : + drop_pt:bool -> Stateid.t * Stateid.t -> Loc.t -> Stateid.t -> Proof_global.closed_proof_output Future.computation - + + (* If set, only tasks overlapping with this list are processed *) + val set_perspective : Stateid.t list -> unit + end = struct (* {{{ *) let forward_feedback msg = Hooks.(call forward_feedback msg) @@ -917,6 +943,7 @@ end = struct (* {{{ *) t_exn_info : Stateid.t * Stateid.t; t_start : Stateid.t; t_stop : Stateid.t; + t_drop : bool; t_states : competence; t_assign : Proof_global.closed_proof_output Future.assignement -> unit; t_loc : Loc.t; @@ -928,8 +955,8 @@ end = struct (* {{{ *) | States of Stateid.t list type request = - | ReqBuildProof of (Future.UUID.t,VCS.vcs) Stateid.request * competence - | ReqStates of Stateid.t list + | ReqBuildProof of (Future.UUID.t,VCS.vcs) Stateid.request * bool * competence + | ReqStates of Stateid.t list type error = { e_error_at : Stateid.t; @@ -946,9 +973,14 @@ end = struct (* {{{ *) let name = ref "proofworker" let extra_env () = !async_proofs_workers_extra_env + let perspective = ref [] + let set_perspective l = perspective := l + let task_match age t = match age, t with - | `Fresh, BuildProof _ -> true + | `Fresh, BuildProof { t_states } -> + not !Flags.async_proofs_full || + List.exists (fun x -> CList.mem_f Stateid.equal x !perspective) t_states | `Old my_states, States l -> List.for_all (fun x -> CList.mem_f Stateid.equal x my_states) l | _ -> false @@ -957,12 +989,14 @@ end = struct (* {{{ *) | BuildProof t -> "proof: " ^ t.t_name | States l -> "states: " ^ String.concat "," (List.map Stateid.to_string l) let name_of_request = function - | ReqBuildProof(r,_) -> "proof: " ^ r.Stateid.name + | ReqBuildProof(r,_,_) -> "proof: " ^ r.Stateid.name | ReqStates l -> "states: "^String.concat "," (List.map Stateid.to_string l) let request_of_task age = function | States l -> Some (ReqStates l) - | BuildProof { t_exn_info;t_start;t_stop;t_loc;t_uuid;t_name;t_states } -> + | BuildProof { + t_exn_info;t_start;t_stop;t_loc;t_uuid;t_name;t_states;t_drop + } -> assert(age = `Fresh); try Some (ReqBuildProof ({ Stateid.exn_info = t_exn_info; @@ -970,20 +1004,21 @@ end = struct (* {{{ *) document = VCS.slice ~start:t_start ~stop:t_stop; loc = t_loc; uuid = t_uuid; - name = t_name }, t_states)) + name = t_name }, t_drop, t_states)) with VCS.Expired -> None let use_response (s : competence AsyncTaskQueue.worker_status) t r = match s, t, r with | `Old c, States _, RespStates l -> List.iter (fun (id,s) -> State.assign id s) l; `End - | `Fresh, BuildProof { t_assign; t_loc; t_name; t_states }, + | `Fresh, BuildProof { t_assign; t_loc; t_name; t_states; t_drop }, RespBuiltProof (pl, time) -> feedback (Feedback.InProgress ~-1); t_assign (`Val pl); record_pb_time t_name t_loc time; - if not !Flags.async_proofs_full then `End - else `Stay(t_states,[States t_states]) + if !Flags.async_proofs_full || t_drop + then `Stay(t_states,[States t_states]) + else `End | `Fresh, BuildProof { t_assign; t_loc; t_name; t_states }, RespError { e_error_at; e_safe_id = valid; e_msg; e_safe_states } -> feedback (Feedback.InProgress ~-1); @@ -1004,7 +1039,7 @@ end = struct (* {{{ *) Hooks.(call execution_error start Loc.ghost (strbrk s)); feedback (Feedback.InProgress ~-1) - let build_proof_here (id,valid) loc eop = + let build_proof_here ~drop_pt (id,valid) loc eop = Future.create (State.exn_on id ~valid) (fun () -> let wall_clock1 = Unix.gettimeofday () in if !Flags.batch_mode then Reach.known_state ~cache:`No eop @@ -1012,34 +1047,38 @@ end = struct (* {{{ *) let wall_clock2 = Unix.gettimeofday () in Aux_file.record_in_aux_at loc "proof_build_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); - Proof_global.return_proof ()) + let p = Proof_global.return_proof ~allow_partial:drop_pt () in + if drop_pt then Pp.feedback ~state_id:id Feedback.Complete; + p) - let perform_buildp { Stateid.exn_info; stop; document; loc } my_states = + let perform_buildp { Stateid.exn_info; stop; document; loc } drop my_states = try VCS.restore document; VCS.print (); let proof, future_proof, time = let wall_clock = Unix.gettimeofday () in - let fp = build_proof_here exn_info loc stop in + let fp = build_proof_here ~drop_pt:drop exn_info loc stop in let proof = Future.force fp in proof, fp, Unix.gettimeofday () -. wall_clock in (* We typecheck the proof with the kernel (in the worker) to spot * the few errors tactics don't catch, like the "fix" tactic building * a bad fixpoint *) let fix_exn = Future.fix_exn_of future_proof in - let checked_proof = Future.chain ~pure:false future_proof (fun p -> - let pobject, _ = - Proof_global.close_future_proof stop (Future.from_val ~fix_exn p) in - let terminator = (* The one sent by master is an InvalidKey *) - Lemmas.(standard_proof_terminator [] (mk_hook (fun _ _ -> ()))) in - vernac_interp stop - ~proof:(pobject, terminator) - { verbose = false; loc; - expr = (VernacEndProof (Proved (true,None))) }) in - ignore(Future.join checked_proof); + if not drop then begin + let checked_proof = Future.chain ~pure:false future_proof (fun p -> + let pobject, _ = + Proof_global.close_future_proof stop (Future.from_val ~fix_exn p) in + let terminator = (* The one sent by master is an InvalidKey *) + Lemmas.(standard_proof_terminator [] (mk_hook (fun _ _ -> ()))) in + vernac_interp stop + ~proof:(pobject, terminator) + { verbose = false; loc; + expr = (VernacEndProof (Proved (Opaque None,None))) }) in + ignore(Future.join checked_proof); + end; RespBuiltProof(proof,time) with - | e when Errors.noncritical e -> + | e when Errors.noncritical e || e = Stack_overflow -> let (e, info) = Errors.push e in (* This can happen if the proof is broken. The error has also been * signalled as a feedback, hence we can silently recover *) @@ -1054,6 +1093,9 @@ end = struct (* {{{ *) let perform_states query = if query = [] then [] else + let is_tac = function + | VernacSolve _ | VernacFocus _ | VernacUnfocus | VernacBullet _ -> true + | _ -> false in let initial = let rec aux id = try match VCS.visit id with { next } -> aux next @@ -1071,8 +1113,8 @@ end = struct (* {{{ *) if State.is_cached id then Some (State.get_cached id) else None in match prev, this with | _, None -> None - | Some (prev, o, `Cmd { cast = { expr = VernacSolve _ }}), Some n - when State.same_env o n -> (* A pure tactic *) + | Some (prev, o, `Cmd { cast = { expr }}), Some n + when is_tac expr && State.same_env o n -> (* A pure tactic *) Some (id, `Proof (prev, State.proof_part_of_frozen n)) | Some _, Some s -> msg_warning (str "Sending back a fat state"); @@ -1087,17 +1129,17 @@ end = struct (* {{{ *) aux [initial] query let perform = function - | ReqBuildProof (bp,states) -> perform_buildp bp states + | ReqBuildProof (bp,drop,states) -> perform_buildp bp drop states | ReqStates sl -> RespStates (perform_states sl) let on_marshal_error s = function | States _ -> msg_error(strbrk("Marshalling error: "^s^". "^ "The system state could not be sent to the master process.")) - | BuildProof { t_exn_info; t_stop; t_assign; t_loc } -> + | BuildProof { t_exn_info; t_stop; t_assign; t_loc; t_drop = drop_pt } -> msg_error(strbrk("Marshalling error: "^s^". "^ "The system state could not be sent to the worker process. "^ "Falling back to local, lazy, evaluation.")); - t_assign(`Comp(build_proof_here t_exn_info t_loc t_stop)); + t_assign(`Comp(build_proof_here ~drop_pt t_exn_info t_loc t_stop)); feedback (Feedback.InProgress ~-1) end (* }}} *) @@ -1106,7 +1148,8 @@ end (* }}} *) and Slaves : sig (* (eventually) remote calls *) - val build_proof : loc:Loc.t -> + val build_proof : + loc:Loc.t -> drop_pt:bool -> exn_info:(Stateid.t * Stateid.t) -> start:Stateid.t -> stop:Stateid.t -> name:string -> future_proof * cancel_switch @@ -1116,7 +1159,7 @@ and Slaves : sig (* initialize the whole machinery (optional) *) val init : unit -> unit - type 'a tasks = ('a,VCS.vcs) Stateid.request list + type 'a tasks = (('a,VCS.vcs) Stateid.request * bool) list val dump_snapshot : unit -> Future.UUID.t tasks val check_task : string -> int tasks -> int -> bool val info_tasks : 'a tasks -> (string * float * int) list @@ -1144,7 +1187,7 @@ end = struct (* {{{ *) queue := Some (TaskQueue.create 0) let check_task_aux extra name l i = - let { Stateid.stop; document; loc; name = r_name } = List.nth l i in + let { Stateid.stop; document; loc; name = r_name }, drop = List.nth l i in msg_info( str(Printf.sprintf "Checking task %d (%s%s) of %s" i r_name extra name)); VCS.restore document; @@ -1155,6 +1198,10 @@ end = struct (* {{{ *) aux stop in try Reach.known_state ~cache:`No stop; + if drop then + let _proof = Proof_global.return_proof ~allow_partial:true () in + `OK_ADMITTED + else begin (* The original terminator, a hook, has not been saved in the .vio*) Proof_global.set_terminator (Lemmas.standard_proof_terminator [] @@ -1166,8 +1213,9 @@ end = struct (* {{{ *) Reach.known_state ~cache:`No start; vernac_interp stop ~proof { verbose = false; loc; - expr = (VernacEndProof (Proved (true,None))) }; - Some proof + expr = (VernacEndProof (Proved (Opaque None,None))) }; + `OK proof + end with e -> let (e, info) = Errors.push e in (try match Stateid.get info with @@ -1192,13 +1240,19 @@ end = struct (* {{{ *) spc () ++ iprint (e, info)) with e -> msg_error (str"unable to print error message: " ++ - str (Printexc.to_string e))); None + str (Printexc.to_string e))); + if drop then `ERROR_ADMITTED else `ERROR let finish_task name (u,cst,_) d p l i = - let bucket = (List.nth l i).Stateid.uuid in - match check_task_aux (Printf.sprintf ", bucket %d" bucket) name l i with - | None -> exit 1 - | Some (po,_) -> + let { Stateid.uuid = bucket }, drop = List.nth l i in + let bucket_name = + if bucket < 0 then (assert drop; ", no bucket") + else Printf.sprintf ", bucket %d" bucket in + match check_task_aux bucket_name name l i with + | `ERROR -> exit 1 + | `ERROR_ADMITTED -> u, cst, false + | `OK_ADMITTED -> u, cst, false + | `OK (po,_) -> let discharge c = List.fold_right Cooking.cook_constr d.(bucket) c in let con = Nametab.locate_constant @@ -1225,11 +1279,11 @@ end = struct (* {{{ *) let check_task name l i = match check_task_aux "" name l i with - | Some _ -> true - | None -> false + | `OK _ | `OK_ADMITTED -> true + | `ERROR | `ERROR_ADMITTED -> false let info_tasks l = - CList.map_i (fun i { Stateid.loc; name } -> + CList.map_i (fun i ({ Stateid.loc; name }, _) -> let time1 = try float_of_string (Aux_file.get !hints loc "proof_build_time") with Not_found -> 0.0 in @@ -1239,6 +1293,8 @@ end = struct (* {{{ *) name, max (time1 +. time2) 0.0001,i) 0 l let set_perspective idl = + ProofTask.set_perspective idl; + TaskQueue.broadcast (Option.get !queue); let open Stateid in let open ProofTask in let overlap s1 s2 = @@ -1254,28 +1310,28 @@ end = struct (* {{{ *) BuildProof { t_states = s2 } -> overlap_rel s1 s2 | _ -> 0) - let build_proof ~loc ~exn_info ~start ~stop ~name:pname = + let build_proof ~loc ~drop_pt ~exn_info ~start ~stop ~name:pname = let id, valid as t_exn_info = exn_info in let cancel_switch = ref false in if TaskQueue.n_workers (Option.get !queue) = 0 then if !Flags.compilation_mode = Flags.BuildVio then begin let f,assign = - Future.create_delegate ~blocking:true (State.exn_on id ~valid) in + Future.create_delegate ~blocking:true ~name:pname (State.exn_on id ~valid) in let t_uuid = Future.uuid f in let task = ProofTask.(BuildProof { - t_exn_info; t_start = start; t_stop = stop; + t_exn_info; t_start = start; t_stop = stop; t_drop = drop_pt; t_assign = assign; t_loc = loc; t_uuid; t_name = pname; t_states = VCS.nodes_in_slice ~start ~stop }) in TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch); f, cancel_switch end else - ProofTask.build_proof_here t_exn_info loc stop, cancel_switch + ProofTask.build_proof_here ~drop_pt t_exn_info loc stop, cancel_switch else - let f, t_assign = Future.create_delegate (State.exn_on id ~valid) in + let f, t_assign = Future.create_delegate ~name:pname (State.exn_on id ~valid) in let t_uuid = Future.uuid f in feedback (Feedback.InProgress 1); let task = ProofTask.(BuildProof { - t_exn_info; t_start = start; t_stop = stop; t_assign; + t_exn_info; t_start = start; t_stop = stop; t_assign; t_drop = drop_pt; t_loc = loc; t_uuid; t_name = pname; t_states = VCS.nodes_in_slice ~start ~stop }) in TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch); @@ -1286,14 +1342,14 @@ end = struct (* {{{ *) let cancel_worker n = TaskQueue.cancel_worker (Option.get !queue) n (* For external users this name is nicer than request *) - type 'a tasks = ('a,VCS.vcs) Stateid.request list + type 'a tasks = (('a,VCS.vcs) Stateid.request * bool) list let dump_snapshot () = let tasks = TaskQueue.snapshot (Option.get !queue) in let reqs = CList.map_filter ProofTask.(fun x -> match request_of_task `Fresh x with - | Some (ReqBuildProof (r, _)) -> Some r + | Some (ReqBuildProof (r, b, _)) -> Some(r, b) | _ -> None) tasks in prerr_endline (Printf.sprintf "dumping %d tasks\n" (List.length reqs)); @@ -1426,7 +1482,10 @@ end = struct (* {{{ *) let goals, _, _, _, _ = Proof.proof p in let open TacTask in let res = CList.map_i (fun i g -> - let f,assign= Future.create_delegate (State.exn_on id ~valid:safe_id) in + let f, assign = + Future.create_delegate + ~name:(Printf.sprintf "subgoal %d" i) + (State.exn_on id ~valid:safe_id) in let t_ast = { verbose;loc;expr = VernacSolve(SelectNth i,None,e,etac) } in let t_name = Goal.uid g in @@ -1542,18 +1601,20 @@ and Reach : sig end = struct (* {{{ *) -let pstate = ["meta counter"; "evar counter"; "program-tcc-table"] +let pstate = summary_pstate let async_policy () = let open Flags in - if interactive () = `Yes then - (async_proofs_is_master () || !async_proofs_mode = Flags.APonLazy) + if is_universe_polymorphism () then false + else if interactive () = `Yes then + (async_proofs_is_master () || !async_proofs_mode = APonLazy) else - (!compilation_mode = Flags.BuildVio || !async_proofs_mode <> Flags.APoff) + (!compilation_mode = BuildVio || !async_proofs_mode <> APoff) let delegate name = let time = get_hint_bp_time name in time >= 1.0 || !Flags.compilation_mode = Flags.BuildVio + || !Flags.async_proofs_full let collect_proof keep cur hd brkind id = prerr_endline ("Collecting proof ending at "^Stateid.to_string id); @@ -1563,7 +1624,8 @@ let collect_proof keep cur hd brkind id = | id :: _ -> Id.to_string id in let loc = (snd cur).loc in let is_defined = function - | _, { expr = VernacEndProof (Proved (false,_)) } -> true + | _, { expr = VernacEndProof (Proved ((Transparent|Opaque (Some _)),_)) } -> + true | _ -> false in let proof_using_ast = function | Some (_, ({ expr = VernacProof(_,Some _) } as v)) -> Some v @@ -1575,11 +1637,18 @@ let collect_proof keep cur hd brkind id = let has_proof_no_using = function | Some (_, { expr = VernacProof(_,None) }) -> true | _ -> false in + let may_pierce_opaque = function + | { expr = VernacPrint (PrintName _) } -> true + | _ -> false in let parent = function Some (p, _) -> p | None -> assert false in + let is_empty = function `Async(_,_,[],_,_) | `MaybeASync(_,_,[],_,_) -> true | _ -> false in let rec collect last accn id = let view = VCS.visit id in match view.step with + | (`Sideff (`Ast(x,_)) | `Cmd { cast = x }) + when may_pierce_opaque x -> `Sync(no_name,None,`Print) | `Cmd { cast = x } -> collect (Some (id,x)) (id::accn) view.next + | `Sideff (`Ast(x,_)) -> collect (Some (id,x)) (id::accn) view.next (* An Alias could jump everywhere... we hope we can ignore it*) | `Alias _ -> `Sync (no_name,None,`Alias) | `Fork((_,_,_,_::_::_), _) -> @@ -1599,7 +1668,9 @@ let collect_proof keep cur hd brkind id = let t, v = proof_no_using last in v.expr <- VernacProof(t, Some hint); `ASync (parent last,proof_using_ast last,accn,name,delegate name) - with Not_found -> `Sync (no_name,None,`NoHint)) + with Not_found -> + let name = name ids in + `MaybeASync (parent last, None, accn, name, delegate name)) | `Fork((_, hd', GuaranteesOpacity, ids), _) -> assert (VCS.Branch.equal hd hd' || VCS.Branch.equal hd VCS.edit_branch); let name = name ids in @@ -1620,22 +1691,34 @@ let collect_proof keep cur hd brkind id = else if keep == VtDrop then `Sync (no_name,None,`Aborted) else let rc = collect (Some cur) [] id in - if keep == VtKeep && + if is_empty rc then make_sync `AlreadyEvaluated rc + else if (keep == VtKeep || keep == VtKeepAsAxiom) && (not(State.is_cached id) || !Flags.async_proofs_full) then check_policy rc else make_sync `AlreadyEvaluated rc let string_of_reason = function - | `Transparent -> "Transparent" - | `AlreadyEvaluated -> "AlreadyEvaluated" - | `Policy -> "Policy" - | `NestedProof -> "NestedProof" - | `Immediate -> "Immediate" - | `Alias -> "Alias" - | `NoHint -> "NoHint" - | `Doesn'tGuaranteeOpacity -> "Doesn'tGuaranteeOpacity" - | `Aborted -> "Aborted" - | _ -> "Unknown Reason" + | `Transparent -> "non opaque" + | `AlreadyEvaluated -> "proof already evaluated" + | `Policy -> "policy" + | `NestedProof -> "contains nested proof" + | `Immediate -> "proof term given explicitly" + | `Aborted -> "aborted proof" + | `Doesn'tGuaranteeOpacity -> "not a simple opaque lemma" + | `MutualProofs -> "block of mutually recursive proofs" + | `Alias -> "contains Undo-like command" + | `Print -> "contains Print-like command" + | `NoPU_NoHint_NoES -> "no 'Proof using..', no .aux file, inside a section" + | `Unknown -> "unsupported case" + +let log_string s = prerr_debug ("STM: " ^ s) +let log_processing_async id name = log_string Printf.(sprintf + "%s: proof %s: asynch" (Stateid.to_string id) name +) +let log_processing_sync id name reason = log_string Printf.(sprintf + "%s: proof %s: synch (cause: %s)" + (Stateid.to_string id) name (string_of_reason reason) +) let wall_clock_last_fork = ref 0.0 @@ -1664,7 +1747,7 @@ let known_state ?(redefine_qed=false) ~cache id = let step, cache_step, feedback_processed = let view = VCS.visit id in match view.step with - | `Alias id -> (fun () -> + | `Alias (id,_) -> (fun () -> reach view.next; reach id ), cache, true | `Cmd { cast = x; cqueue = `TacQueue cancel } -> (fun () -> @@ -1697,16 +1780,25 @@ let known_state ?(redefine_qed=false) ~cache id = | `Qed ({ qast = x; keep; brinfo; brname } as qed, eop) -> let rec aux = function | `ASync (start, pua, nodes, name, delegate) -> (fun () -> - assert(keep == VtKeep); + assert(keep == VtKeep || keep == VtKeepAsAxiom); + let drop_pt = keep == VtKeepAsAxiom in let stop, exn_info, loc = eop, (id, eop), x.loc in - prerr_endline ("Asynchronous " ^ Stateid.to_string id); + log_processing_async id name; VCS.create_cluster nodes ~qed:id ~start; begin match brinfo, qed.fproof with | { VCS.kind = `Edit _ }, None -> assert false - | { VCS.kind = `Edit _ }, Some (ofp, cancel) -> + | { VCS.kind = `Edit (_,_,_, okeep) }, Some (ofp, cancel) -> assert(redefine_qed = true); + if okeep != keep then + msg_error(strbrk("The command closing the proof changed. " + ^"The kernel cannot take this into account and will " + ^(if keep == VtKeep then "not check " else "reject ") + ^"the "^(if keep == VtKeep then "new" else "incomplete") + ^" proof. Reprocess the command declaring " + ^"the proof's statement to avoid that.")); let fp, cancel = - Slaves.build_proof ~loc ~exn_info ~start ~stop ~name in + Slaves.build_proof + ~loc ~drop_pt ~exn_info ~start ~stop ~name in Future.replace ofp fp; qed.fproof <- Some (fp, cancel) | { VCS.kind = `Proof _ }, Some _ -> assert false @@ -1714,9 +1806,11 @@ let known_state ?(redefine_qed=false) ~cache id = reach ~cache:`Shallow start; let fp, cancel = if delegate then - Slaves.build_proof ~loc ~exn_info ~start ~stop ~name + Slaves.build_proof + ~loc ~drop_pt ~exn_info ~start ~stop ~name else - ProofTask.build_proof_here exn_info loc stop, ref false + ProofTask.build_proof_here + ~drop_pt exn_info loc stop, ref false in qed.fproof <- Some (fp, cancel); let proof = @@ -1734,17 +1828,21 @@ let known_state ?(redefine_qed=false) ~cache id = reach eop; vernac_interp id x; Proof_global.discard_all () ), `Yes, true | `Sync (name, pua, reason) -> (fun () -> - prerr_endline ("Synchronous " ^ Stateid.to_string id ^ " " ^ - string_of_reason reason); + log_processing_sync id name reason; reach eop; let wall_clock = Unix.gettimeofday () in record_pb_time name x.loc (wall_clock -. !wall_clock_last_fork); let proof = - if keep != VtKeep then None - else Some(Proof_global.close_proof - ~keep_body_ucst_sepatate:false - (State.exn_on id ~valid:eop)) in - if proof = None then prerr_endline "NONE!!!!!"; + match keep with + | VtDrop -> None + | VtKeepAsAxiom -> + let ctx = Evd.empty_evar_universe_context in + let fp = Future.from_val ([],ctx) in + qed.fproof <- Some (fp, ref false); None + | VtKeep -> + Some(Proof_global.close_proof + ~keep_body_ucst_sepatate:false + (State.exn_on id ~valid:eop)) in reach view.next; if keep == VtKeepAsAxiom then Option.iter (vernac_interp id) pua; @@ -1756,12 +1854,11 @@ let known_state ?(redefine_qed=false) ~cache id = Proof_global.discard_all () ), `Yes, true | `MaybeASync (start, pua, nodes, name, delegate) -> (fun () -> - prerr_endline ("MaybeAsynchronous " ^ Stateid.to_string id); reach ~cache:`Shallow start; (* no sections *) if List.is_empty (Environ.named_context (Global.env ())) then pi1 (aux (`ASync (start, pua, nodes, name, delegate))) () - else pi1 (aux (`Sync (name, pua, `Unknown))) () + else pi1 (aux (`Sync (name, pua, `NoPU_NoHint_NoES))) () ), (if redefine_qed then `No else `Yes), true in aux (collect_proof keep (view.next, x) brname brinfo eop) @@ -1818,19 +1915,37 @@ let observe id = iraise e let finish ?(print_goals=false) () = - observe (VCS.get_branch_pos (VCS.current_branch ())); + let head = VCS.current_branch () in + observe (VCS.get_branch_pos head); if print_goals then msg_notice (pr_open_cur_subgoals ()); - VCS.print () + VCS.print (); + (* Some commands may by side effect change the proof mode *) + match VCS.get_branch head with + | { VCS.kind = `Edit (mode, _,_,_) } -> Proof_global.activate_proof_mode mode + | { VCS.kind = `Proof (mode, _) } -> Proof_global.activate_proof_mode mode + | _ -> () + let wait () = Slaves.wait_all_done (); VCS.print () +let rec join_admitted_proofs id = + if Stateid.equal id Stateid.initial then () else + let view = VCS.visit id in + match view.step with + | `Qed ({ keep = VtKeepAsAxiom; fproof = Some (fp,_) },_) -> + ignore(Future.force fp); + join_admitted_proofs view.next + | _ -> join_admitted_proofs view.next + let join () = finish (); wait (); prerr_endline "Joining the environment"; Global.join_safe_environment (); + prerr_endline "Joining Admitted proofs"; + join_admitted_proofs (VCS.get_branch_pos (VCS.current_branch ())); VCS.print (); VCS.print () @@ -1863,7 +1978,7 @@ let finish_tasks name u d p (t,rcbackup as tasks) = pperrnl (str"File " ++ str name ++ str ":" ++ spc () ++ iprint e); exit 1 -let merge_proof_branch ?id qast keep brname = +let merge_proof_branch ?valid ?id qast keep brname = let brinfo = VCS.get_branch brname in let qed fproof = { qast; keep; brname; brinfo; fproof } in match brinfo with @@ -1874,7 +1989,7 @@ let merge_proof_branch ?id qast keep brname = VCS.delete_branch brname; if keep <> VtDrop then VCS.propagate_sideff None; `Ok - | { VCS.kind = `Edit (mode, qed_id, master_id) } -> + | { VCS.kind = `Edit (mode, qed_id, master_id, _) } -> let ofp = match VCS.visit qed_id with | { step = `Qed ({ fproof }, _) } -> fproof @@ -1886,7 +2001,7 @@ let merge_proof_branch ?id qast keep brname = VCS.checkout VCS.Branch.master; `Unfocus qed_id | { VCS.kind = `Master } -> - iraise (State.exn_on Stateid.dummy (Proof_global.NoCurrentProof, Exninfo.null)) + iraise (State.exn_on ?valid Stateid.dummy (Proof_global.NoCurrentProof, Exninfo.null)) (* When tty is true, this code also does some of the job of the user interface: jump back to a state that is valid *) @@ -1965,11 +2080,11 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = List.iter (fun b -> if not(VCS.Branch.equal b head) then begin VCS.checkout b; - VCS.commit (VCS.new_node ()) (Alias oid); + VCS.commit (VCS.new_node ()) (Alias (oid,x)); end) (VCS.branches ()); VCS.checkout_shallowest_proof_branch (); - VCS.commit id (Alias oid); + VCS.commit id (Alias (oid,x)); Backtrack.record (); if w == VtNow then finish (); `Ok | VtStm (VtBack id, false), VtNow -> prerr_endline ("undo to state " ^ Stateid.to_string id); @@ -1998,7 +2113,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = let queue = if !Flags.async_proofs_full then `QueryQueue (ref false) else `MainQueue in - VCS.commit id (Cmd { cast = x; cids = []; cqueue = queue }); + VCS.commit id (Cmd {ctac=false;cast = x; cids = []; cqueue = queue }); Backtrack.record (); if w == VtNow then finish (); `Ok | VtQuery (false,_), VtLater -> anomaly(str"classifier: VtQuery + VtLater must imply part_of_script") @@ -2021,18 +2136,16 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = anomaly(str"VtProofMode must be executed VtNow") | VtProofMode mode, VtNow -> let id = VCS.new_node ~id:newtip () in - VCS.checkout VCS.Branch.master; - VCS.commit id (Cmd {cast = x; cids=[]; cqueue = `MainQueue}); - VCS.propagate_sideff (Some x); + VCS.commit id (Cmd {ctac=false;cast = x;cids=[];cqueue = `MainQueue}); List.iter (fun bn -> match VCS.get_branch bn with | { VCS.root; kind = `Master; pos } -> () | { VCS.root; kind = `Proof(_,d); pos } -> VCS.delete_branch bn; VCS.branch ~root ~pos bn (`Proof(mode,d)) - | { VCS.root; kind = `Edit(_,f,q); pos } -> + | { VCS.root; kind = `Edit(_,f,q,k); pos } -> VCS.delete_branch bn; - VCS.branch ~root ~pos bn (`Edit(mode,f,q))) + VCS.branch ~root ~pos bn (`Edit(mode,f,q,k))) (VCS.branches ()); VCS.checkout_shallowest_proof_branch (); Backtrack.record (); @@ -2041,10 +2154,11 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = | VtProofStep paral, w -> let id = VCS.new_node ~id:newtip () in let queue = if paral then `TacQueue (ref false) else `MainQueue in - VCS.commit id (Cmd {cast = x; cids = []; cqueue = queue }); + VCS.commit id (Cmd {ctac = true;cast = x;cids = [];cqueue = queue }); Backtrack.record (); if w == VtNow then finish (); `Ok | VtQed keep, w -> - let rc = merge_proof_branch ~id:newtip x keep head in + let valid = if tty then Some(VCS.get_branch_pos head) else None in + let rc = merge_proof_branch ?valid ~id:newtip x keep head in VCS.checkout_shallowest_proof_branch (); Backtrack.record (); if w == VtNow then finish (); rc @@ -2056,7 +2170,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = | VtSideff l, w -> let id = VCS.new_node ~id:newtip () in VCS.checkout VCS.Branch.master; - VCS.commit id (Cmd { cast = x; cids = l; cqueue = `MainQueue}); + VCS.commit id (Cmd {ctac=false;cast=x;cids=l;cqueue=`MainQueue}); VCS.propagate_sideff (Some x); VCS.checkout_shallowest_proof_branch (); Backtrack.record (); if w == VtNow then finish (); `Ok @@ -2080,7 +2194,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = VCS.branch bname (`Proof ("Classic", VCS.proof_nesting () + 1)); Proof_global.activate_proof_mode "Classic"; end else begin - VCS.commit id (Cmd { cast = x; cids = []; cqueue = `MainQueue}); + VCS.commit id (Cmd {ctac=false; cast = x; cids = []; cqueue = `MainQueue}); VCS.propagate_sideff (Some x); VCS.checkout_shallowest_proof_branch (); end in @@ -2184,13 +2298,13 @@ let edit_at id = | { step = `Sideff (`Ast(_,id)|`Id id) } -> id | { next } -> master_for_br root next in let reopen_branch start at_id mode qed_id tip = - let master_id, cancel_switch = + let master_id, cancel_switch, keep = (* Hum, this should be the real start_id in the clusted and not next *) match VCS.visit qed_id with - | { step = `Qed ({ fproof = Some (_,cs)},_) } -> start, cs + | { step = `Qed ({ fproof = Some (_,cs); keep },_) } -> start, cs, keep | _ -> anomaly (str "Cluster not ending with Qed") in VCS.branch ~root:master_id ~pos:id - VCS.edit_branch (`Edit (mode, qed_id, master_id)); + VCS.edit_branch (`Edit (mode, qed_id, master_id, keep)); VCS.delete_cluster_of id; cancel_switch := true; Reach.known_state ~cache:(interactive ()) id; @@ -2217,7 +2331,7 @@ let edit_at id = let focused = List.exists ((=) VCS.edit_branch) (VCS.branches ()) in let branch_info = match snd (VCS.get_info id).vcs_backup with - | Some{ mine = _, { VCS.kind = (`Proof(m,_)|`Edit(m,_,_)) }} -> Some m + | Some{ mine = _, { VCS.kind = (`Proof(m,_)|`Edit(m,_,_,_)) }} -> Some m | _ -> None in match focused, VCS.cluster_of id, branch_info with | _, Some _, None -> assert false @@ -2276,8 +2390,8 @@ let interp verb (_,e as lexpr) = let print_goals = verb && match clas with | VtQuery _, _ -> false - | (VtProofStep _ | VtStm (VtBack _, _)), _ -> true - | _ -> not !Flags.coqtop_ui || !Flags.print_emacs in + | (VtProofStep _ | VtStm (VtBack _, _) | VtStartProof _), _ -> true + | _ -> not !Flags.coqtop_ui in try finish ~print_goals () with e -> let e = Errors.push e in @@ -2328,7 +2442,7 @@ let get_script prf = find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next | `Sideff (`Id id) -> find acc id | `Cmd {cast = x} -> find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next - | `Alias id -> find acc id + | `Alias (id,_) -> find acc id | `Fork _ -> find acc view.next in find [] (VCS.get_branch_pos branch) diff --git a/stm/tQueue.ml b/stm/tQueue.ml index 8a62fe79..6fef895a 100644 --- a/stm/tQueue.ml +++ b/stm/tQueue.ml @@ -79,7 +79,7 @@ let pop ?(picky=(fun _ -> true)) ?(destroy=ref false) Mutex.unlock m; x -let signal_destruction { lock = m; cond = c } = +let broadcast { lock = m; cond = c } = Mutex.lock m; Condition.broadcast c; Mutex.unlock m diff --git a/stm/tQueue.mli b/stm/tQueue.mli index bc3922b3..7458de51 100644 --- a/stm/tQueue.mli +++ b/stm/tQueue.mli @@ -14,7 +14,9 @@ val pop : ?picky:('a -> bool) -> ?destroy:bool ref -> 'a t -> 'a val push : 'a t -> 'a -> unit val set_order : 'a t -> ('a -> 'a -> int) -> unit val wait_until_n_are_waiting_and_queue_empty : int -> 'a t -> unit -val signal_destruction : 'a t -> unit + +(* Wake up all waiting threads *) +val broadcast : 'a t -> unit (* Non destructive *) val wait_until_n_are_waiting_then_snapshot : int -> 'a t -> 'a list diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index d71c169d..180f20ae 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -15,7 +15,6 @@ open Bigint open Decl_kinds open Extend open Libnames -open Flags let unlock loc = let start, stop = Loc.unloc loc in @@ -118,8 +117,8 @@ let xmlReference ref = let xmlRequire loc ?(attr=[]) xml = xmlWithLoc loc "require" attr xml let xmlImport loc ?(attr=[]) xml = xmlWithLoc loc "import" attr xml -let xmlAddLoaPath loc ?(attr=[]) xml = xmlWithLoc loc "addloadpath" attr xml -let xmlRemoveLoaPath loc ?(attr=[]) = xmlWithLoc loc "removeloadpath" attr +let xmlAddLoadPath loc ?(attr=[]) xml = xmlWithLoc loc "addloadpath" attr xml +let xmlRemoveLoadPath loc ?(attr=[]) = xmlWithLoc loc "removeloadpath" attr let xmlAddMLPath loc ?(attr=[]) = xmlWithLoc loc "addmlpath" attr let xmlExtend loc xml = xmlWithLoc loc "extend" [] xml @@ -618,14 +617,17 @@ let rec tmpp v loc = | VernacBeginSection (_, id) -> xmlBeginSection loc (Id.to_string id) | VernacEndSegment (_, id) -> xmlEndSegment loc (Id.to_string id) | VernacNameSectionHypSet _ as x -> xmlTODO loc x - | VernacRequire (None,l) -> - xmlRequire loc (List.map (fun ref -> - xmlReference ref) l) - | VernacRequire (Some true,l) -> - xmlRequire loc ~attr:["export","true"] (List.map (fun ref -> - xmlReference ref) l) - | VernacRequire (Some false,l) -> - xmlRequire loc ~attr:["import","true"] (List.map (fun ref -> + | VernacRequire (from, import, l) -> + let import = match import with + | None -> [] + | Some true -> ["export","true"] + | Some false -> ["import","true"] + in + let from = match from with + | None -> [] + | Some r -> ["from", Libnames.string_of_reference r] + in + xmlRequire loc ~attr:(from @ import) (List.map (fun ref -> xmlReference ref) l) | VernacImport (true,l) -> xmlImport loc ~attr:["export","true"] (List.map (fun ref -> @@ -665,12 +667,11 @@ let rec tmpp v loc = (* Auxiliary file and library management *) | VernacAddLoadPath (recf,name,None) -> - xmlAddLoaPath loc ~attr:["rec",string_of_bool recf;"path",name] [] + xmlAddLoadPath loc ~attr:["rec",string_of_bool recf;"path",name] [] | VernacAddLoadPath (recf,name,Some dp) -> - xmlAddLoaPath loc ~attr:["rec",string_of_bool recf;"path",name] + xmlAddLoadPath loc ~attr:["rec",string_of_bool recf;"path",name] [PCData (Names.DirPath.to_string dp)] - - | VernacRemoveLoadPath name -> xmlRemoveLoaPath loc ~attr:["path",name] [] + | VernacRemoveLoadPath name -> xmlRemoveLoadPath loc ~attr:["path",name] [] | VernacAddMLPath (recf,name) -> xmlAddMLPath loc ~attr:["rec",string_of_bool recf;"path",name] [] | VernacDeclareMLModule sl -> xmlDeclareMLModule loc sl diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index e9302bb7..783ff2e1 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -65,6 +65,11 @@ let rec classify_vernac e = | VernacUnsetOption (["Silent"]|["Undo"]|["Printing";"Depth"]) | VernacSetOption ((["Silent"]|["Undo"]|["Printing";"Depth"]),_) when !Flags.print_emacs -> VtStm(VtPG,false), VtNow + (* Univ poly compatibility: we run it now, so that we can just + * look at Flags in stm.ml. Would be nicer to have the stm + * look at the entire dag to detect this option. *) + | VernacSetOption (["Universe"; "Polymorphism"],_) + | VernacUnsetOption (["Universe"; "Polymorphism"]) -> VtSideff [], VtNow (* Stm *) | VernacStm Finish -> VtStm (VtFinish, true), VtNow | VernacStm Wait -> VtStm (VtWait, true), VtNow @@ -151,8 +156,8 @@ let rec classify_vernac e = let ids = List.map snd (CList.map_filter (fun (x,_) -> x) l) in VtSideff ids, VtLater | VernacCombinedScheme ((_,id),_) -> VtSideff [id], VtLater + | VernacBeginSection (_,id) -> VtSideff [id], VtLater | VernacUniverse _ | VernacConstraint _ - | VernacBeginSection _ | VernacCanonical _ | VernacCoercion _ | VernacIdentityCoercion _ | VernacAddLoadPath _ | VernacRemoveLoadPath _ | VernacAddMLPath _ | VernacChdir _ diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index 84df3ecd..b2072221 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -119,7 +119,7 @@ let schedule_vio_compilation j fs = let rec filter_argv b = function | [] -> [] | "-schedule-vio2vo" :: rest -> filter_argv true rest - | s :: rest when s.[0] = '-' && b -> filter_argv false (s :: rest) + | s :: rest when String.length s > 0 && s.[0] = '-' && b -> filter_argv false (s :: rest) | _ :: rest when b -> filter_argv b rest | s :: rest -> s :: filter_argv b rest in let prog = Sys.argv.(0) in diff --git a/tactics/auto.ml b/tactics/auto.ml index 45052685..46274f83 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -359,8 +359,7 @@ and my_find_search_delta db_list local_db hdc concl = (local_db::db_list) and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) = - let tactic = - match t with + let tactic = function | Res_pf (c,cl) -> unify_resolve_gen poly flags (c,cl) | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf") | Give_exact (c, cl) -> exact poly (c, cl) @@ -378,7 +377,7 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) | Extern tacast -> conclPattern concl p tacast in - tclLOG dbg (fun () -> pr_autotactic t) tactic + tclLOG dbg (fun () -> pr_autotactic t) (run_auto_tactic t tactic) and trivial_resolve dbg mod_delta db_list local_db cl = try diff --git a/tactics/auto.mli b/tactics/auto.mli index ea3f0ac0..0cc8a0b1 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -8,7 +8,6 @@ open Names open Term -open Proof_type open Clenv open Pattern open Evd diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index ee8e1855..4eb8a792 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -211,6 +211,7 @@ let cache_hintrewrite (_,(rbase,lrl)) = let base = try raw_find_base rbase with Not_found -> HintDN.empty in let max = try fst (Util.List.last (HintDN.find_all base)) with Failure _ -> 0 in + let lrl = HintDN.refresh_metas lrl in let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in rewtab:=String.Map.add rbase (HintDN.union lrl base) !rewtab diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 1f5177c3..b87d6575 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -144,7 +144,7 @@ struct type t = Dn.t - let create = Dn.create + let empty = Dn.empty let add = function | None -> diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index 6c396b4c..f29d1861 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -28,7 +28,7 @@ module Make : sig type t - val create : unit -> t + val empty : t val add : transparent_state option -> t -> (constr_pattern * Z.t) -> t val rmv : transparent_state option -> t -> (constr_pattern * Z.t) -> t diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 1c15fa40..e11458c0 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -17,7 +17,6 @@ open Proof_type open Tacticals open Tacmach open Tactics -open Patternops open Clenv open Typeclasses open Globnames @@ -42,7 +41,7 @@ let get_typeclasses_dependency_order () = !typeclasses_dependency_order open Goptions -let set_typeclasses_modulo_eta = +let _ = declare_bool_option { optsync = true; optdepr = false; @@ -51,7 +50,7 @@ let set_typeclasses_modulo_eta = optread = get_typeclasses_modulo_eta; optwrite = set_typeclasses_modulo_eta; } -let set_typeclasses_dependency_order = +let _ = declare_bool_option { optsync = true; optdepr = false; @@ -222,20 +221,19 @@ and e_my_find_search db_list local_db hdc complete sigma concl = in let tac_of_hint = fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> - let tac = - match t with - | Res_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_resolve poly flags) - | ERes_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_e_resolve poly flags) - | Give_exact c -> e_give_exact flags poly c - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (with_prods nprods poly (term,cl) (unify_e_resolve poly flags)) - (if complete then tclIDTAC else e_trivial_fail_db db_list local_db) - | Unfold_nth c -> tclWEAK_PROGRESS (unfold_in_concl [AllOccurrences,c]) - | Extern tacast -> - Proofview.V82.of_tactic (conclPattern concl p tacast) + let tac = function + | Res_pf (term,cl) -> Proofview.V82.tactic (with_prods nprods poly (term,cl) (unify_resolve poly flags)) + | ERes_pf (term,cl) -> Proofview.V82.tactic (with_prods nprods poly (term,cl) (unify_e_resolve poly flags)) + | Give_exact c -> Proofview.V82.tactic (e_give_exact flags poly c) + | Res_pf_THEN_trivial_fail (term,cl) -> + Proofview.V82.tactic (tclTHEN (with_prods nprods poly (term,cl) (unify_e_resolve poly flags)) + (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)) + | Unfold_nth c -> Proofview.V82.tactic (tclWEAK_PROGRESS (unfold_in_concl [AllOccurrences,c])) + | Extern tacast -> conclPattern concl p tacast in + let tac = Proofview.V82.of_tactic (run_auto_tactic t tac) in let tac = if complete then tclCOMPLETE tac else tac in - match t with + match repr_auto_tactic t with | Extern _ -> (tac,b,true, name, lazy (pr_autotactic t)) | _ -> (* let tac gl = with_pattern (pf_env gl) (project gl) flags p concl tac gl in *) @@ -351,7 +349,9 @@ let make_autogoal_hints = let sign = pf_filtered_hyps g in let (onlyc, sign', cached_hints) = !cache in if onlyc == only_classes && - (sign == sign' || Environ.eq_named_context_val sign sign') then + (sign == sign' || Environ.eq_named_context_val sign sign') + && Hint_db.transparent_state cached_hints == st + then cached_hints else let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 9ee14b80..9b69481d 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -9,8 +9,6 @@ open Errors open Term open Hipattern -open Tacmach -open Tacticals open Tactics open Coqlib open Reductionops diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4 index 5c039e72..e909a14c 100644 --- a/tactics/coretactics.ml4 +++ b/tactics/coretactics.ml4 @@ -71,14 +71,14 @@ END TACTIC EXTEND left_with [ "left" "with" bindings(bl) ] -> [ let { Evd.sigma = sigma ; it = bl } = bl in - Proofview.Unsafe.tclEVARS sigma <*> Tactics.left_with_bindings false bl + Tacticals.New.tclWITHHOLES false (Tactics.left_with_bindings false bl) sigma ] END TACTIC EXTEND eleft_with [ "eleft" "with" bindings(bl) ] -> [ let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES true (Tactics.left_with_bindings true) sigma bl + Tacticals.New.tclWITHHOLES true (Tactics.left_with_bindings true bl) sigma ] END @@ -95,14 +95,14 @@ END TACTIC EXTEND right_with [ "right" "with" bindings(bl) ] -> [ let { Evd.sigma = sigma ; it = bl } = bl in - Proofview.Unsafe.tclEVARS sigma <*> Tactics.right_with_bindings false bl + Tacticals.New.tclWITHHOLES false (Tactics.right_with_bindings false bl) sigma ] END TACTIC EXTEND eright_with [ "eright" "with" bindings(bl) ] -> [ let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES true (Tactics.right_with_bindings true) sigma bl + Tacticals.New.tclWITHHOLES true (Tactics.right_with_bindings true bl) sigma ] END @@ -117,8 +117,8 @@ TACTIC EXTEND constructor | [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [ let { Evd.sigma = sigma; it = bl } = bl in let i = Tacinterp.interp_int_or_var ist i in - let tac c = Tactics.constructor_tac false None i c in - Proofview.Unsafe.tclEVARS sigma <*> tac bl + let tac = Tactics.constructor_tac false None i bl in + Tacticals.New.tclWITHHOLES false tac sigma ] END @@ -131,8 +131,8 @@ TACTIC EXTEND econstructor | [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [ let { Evd.sigma = sigma; it = bl } = bl in let i = Tacinterp.interp_int_or_var ist i in - let tac c = Tactics.constructor_tac true None i c in - Tacticals.New.tclWITHHOLES true tac sigma bl + let tac = Tactics.constructor_tac true None i bl in + Tacticals.New.tclWITHHOLES true tac sigma ] END @@ -141,8 +141,8 @@ END TACTIC EXTEND specialize [ "specialize" constr_with_bindings(c) ] -> [ let { Evd.sigma = sigma; it = c } = c in - let specialize c = Proofview.V82.tactic (Tactics.specialize c) in - Proofview.Unsafe.tclEVARS sigma <*> specialize c + let specialize = Proofview.V82.tactic (Tactics.specialize c) in + Tacticals.New.tclWITHHOLES false specialize sigma ] END @@ -163,14 +163,14 @@ END TACTIC EXTEND split_with [ "split" "with" bindings(bl) ] -> [ let { Evd.sigma = sigma ; it = bl } = bl in - Proofview.Unsafe.tclEVARS sigma <*> Tactics.split_with_bindings false [bl] + Tacticals.New.tclWITHHOLES false (Tactics.split_with_bindings false [bl]) sigma ] END TACTIC EXTEND esplit_with [ "esplit" "with" bindings(bl) ] -> [ let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES true (Tactics.split_with_bindings true) sigma [bl] + Tacticals.New.tclWITHHOLES true (Tactics.split_with_bindings true [bl]) sigma ] END @@ -196,6 +196,12 @@ TACTIC EXTEND simple_destruct [ "simple" "destruct" quantified_hypothesis(h) ] -> [ Tactics.simple_destruct h ] END +(* Admit *) + +TACTIC EXTEND admit + [ "admit" ] -> [ Proofview.give_up ] +END + (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) open Tacexpr diff --git a/tactics/dn.ml b/tactics/dn.ml index 3b1614d6..aed2c283 100644 --- a/tactics/dn.ml +++ b/tactics/dn.ml @@ -38,7 +38,7 @@ struct type t = Trie.t - let create () = Trie.empty + let empty = Trie.empty (* [path_of dna pat] returns the list of nodes of the pattern [pat] read in prefix ordering, [dna] is the function returning the main node of a pattern *) diff --git a/tactics/dn.mli b/tactics/dn.mli index 20407e9d..2a60c3eb 100644 --- a/tactics/dn.mli +++ b/tactics/dn.mli @@ -10,7 +10,7 @@ sig type t - val create : unit -> t + val empty : t (** [add t f (tree,inf)] adds a structured object [tree] together with the associated information [inf] to the table [t]; the function diff --git a/tactics/dnet.ml b/tactics/dnet.ml index 61a35866..93334db7 100644 --- a/tactics/dnet.ml +++ b/tactics/dnet.ml @@ -39,6 +39,7 @@ sig val inter : t -> t -> t val union : t -> t -> t val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t + val map_metas : (meta -> meta) -> t -> t end module Make = @@ -121,7 +122,7 @@ struct Idset.union acc s2 ) t Idset.empty) -(* (\* optimization hack: Not_found is catched in fold_pattern *\) *) +(* (\* optimization hack: Not_found is caught in fold_pattern *\) *) (* let fast_inter s1 s2 = *) (* if Idset.is_empty s1 || Idset.is_empty s2 then raise Not_found *) (* else Idset.inter s1 s2 *) @@ -176,7 +177,7 @@ struct let is_empty : t -> bool = function | None -> false | Some s -> S.is_empty s - (* optimization hack: Not_found is catched in fold_pattern *) + (* optimization hack: Not_found is caught in fold_pattern *) let fast_inter s1 s2 = if is_empty s1 || is_empty s2 then raise Not_found else let r = inter s1 s2 in @@ -288,4 +289,13 @@ struct | Node e -> Node (T.map (map sidset sterm) e) in Nodes (tmap_map sterm snode t, Mmap.map (idset_map sidset) m) + let rec map_metas f (Nodes (t, m)) : t = + let f_node = function + | Terminal (e, is) -> Terminal (T.map (map_metas f) e, is) + | Node e -> Node (T.map (map_metas f) e) + in + let m' = Mmap.fold (fun m s acc -> Mmap.add (f m) s acc) m Mmap.empty in + let t' = Tmap.fold (fun k n acc -> Tmap.add k (f_node n) acc) t Tmap.empty in + Nodes (t', m') + end diff --git a/tactics/dnet.mli b/tactics/dnet.mli index 4bfa7263..52853d70 100644 --- a/tactics/dnet.mli +++ b/tactics/dnet.mli @@ -113,6 +113,8 @@ sig (** apply a function on each identifier and node of terms in a dnet *) val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t + + val map_metas : (meta -> meta) -> t -> t end module Make : diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 30c5e686..27c3569d 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -125,6 +125,14 @@ let unify_e_resolve poly flags (c,clenv) gls = tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) (Proofview.V82.of_tactic (Tactics.Simple.eapply (Vars.subst_univs_level_constr subst c))) gls +let hintmap_of hdc concl = + match hdc with + | None -> fun db -> Hint_db.map_none db + | Some hdc -> + if occur_existential concl then (fun db -> Hint_db.map_existential hdc concl db) + else (fun db -> Hint_db.map_auto hdc concl db) + (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) + let e_exact poly flags (c,clenv) = let clenv', subst = if poly then Clenv.refresh_undefined_univs clenv @@ -145,47 +153,39 @@ let rec e_trivial_fail_db db_list local_db goal = tclFIRST (List.map tclCOMPLETE tacl) goal and e_my_find_search db_list local_db hdc concl = + let hint_of_db = hintmap_of hdc concl in let hintl = - if occur_existential concl then - List.map_append (fun db -> - let flags = auto_flags_of_state (Hint_db.transparent_state db) in - List.map (fun x -> flags, x) (Hint_db.map_existential hdc concl db) - (* FIXME: should be (Hint_db.map_eauto hdc concl db) *)) (local_db::db_list) - else List.map_append (fun db -> let flags = auto_flags_of_state (Hint_db.transparent_state db) in - List.map (fun x -> flags, x) (Hint_db.map_auto hdc concl db)) (local_db::db_list) + List.map (fun x -> flags, x) (hint_of_db db)) (local_db::db_list) in let tac_of_hint = fun (st, {pri = b; pat = p; code = t; poly = poly}) -> (b, - let tac = - match t with - | Res_pf (term,cl) -> Proofview.V82.of_tactic (unify_resolve poly st (term,cl)) - | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl) - | Give_exact (c,cl) -> e_exact poly st (c,cl) - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve poly st (term,cl)) - (e_trivial_fail_db db_list local_db) - | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl - | Extern tacast -> Proofview.V82.of_tactic (conclPattern concl p tacast) + let tac = function + | Res_pf (term,cl) -> unify_resolve poly st (term,cl) + | ERes_pf (term,cl) -> Proofview.V82.tactic (unify_e_resolve poly st (term,cl)) + | Give_exact (c,cl) -> Proofview.V82.tactic (e_exact poly st (c,cl)) + | Res_pf_THEN_trivial_fail (term,cl) -> + Proofview.V82.tactic (tclTHEN (unify_e_resolve poly st (term,cl)) + (e_trivial_fail_db db_list local_db)) + | Unfold_nth c -> Proofview.V82.tactic (reduce (Unfold [AllOccurrences,c]) onConcl) + | Extern tacast -> conclPattern concl p tacast in - (tac,lazy (pr_autotactic t))) + let tac = Proofview.V82.of_tactic (run_auto_tactic t tac) in + (tac, lazy (pr_autotactic t))) in List.map tac_of_hint hintl and e_trivial_resolve db_list local_db gl = - try - priority - (e_my_find_search db_list local_db - (decompose_app_bound gl) gl) - with Bound | Not_found -> [] + let hd = try Some (decompose_app_bound gl) with Bound -> None in + try priority (e_my_find_search db_list local_db hd gl) + with Not_found -> [] let e_possible_resolve db_list local_db gl = - try List.map snd - (e_my_find_search db_list local_db - (decompose_app_bound gl) gl) - with Bound | Not_found -> [] + let hd = try Some (decompose_app_bound gl) with Bound -> None in + try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) (e_my_find_search db_list local_db hd gl) + with Not_found -> [] let find_first_goal gls = try first_goal gls with UserError _ -> assert false @@ -194,6 +194,7 @@ let find_first_goal gls = exploration functor [Explore.Make]. *) type search_state = { + priority : int; depth : int; (*r depth of search before failing *) tacres : goal list sigma; last_tactic : std_ppcmds Lazy.t; @@ -221,12 +222,12 @@ module SearchProblem = struct (* msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *) let rec aux = function | [] -> [] - | (tac,pptac) :: tacl -> + | (tac, cost, pptac) :: tacl -> try let lgls = apply_tac_list tac glls in (* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) (* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) - (lgls,pptac) :: aux tacl + (lgls, cost, pptac) :: aux tacl with e when Errors.noncritical e -> let e = Errors.push e in Refiner.catch_failerror e; aux tacl @@ -236,8 +237,11 @@ module SearchProblem = struct number of remaining goals. *) let compare s s' = let d = s'.depth - s.depth in + let d' = Int.compare s.priority s'.priority in let nbgoals s = List.length (sig_it s.tacres) in - if not (Int.equal d 0) then d else nbgoals s - nbgoals s' + if not (Int.equal d' 0) then d' + else if not (Int.equal d 0) then d + else Int.compare (nbgoals s) (nbgoals s') let branching s = if Int.equal s.depth 0 then @@ -248,42 +252,39 @@ module SearchProblem = struct let nbgl = List.length (sig_it lg) in assert (nbgl > 0); let g = find_first_goal lg in + let map_assum id = (e_give_exact (mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in let assumption_tacs = - let l = - filter_tactics s.tacres - (List.map - (fun id -> (e_give_exact (mkVar id), - lazy (str "exact" ++ spc () ++ pr_id id))) - (pf_ids_of_hyps g)) - in - List.map (fun (res,pp) -> { depth = s.depth; tacres = res; + let tacs = List.map map_assum (pf_ids_of_hyps g) in + let l = filter_tactics s.tacres tacs in + List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = List.tl s.localdb; prev = ps}) l in let intro_tac = + let l = filter_tactics s.tacres [Proofview.V82.of_tactic Tactics.intro, (-1), lazy (str "intro")] in List.map - (fun (lgls as res,pp) -> + (fun (lgls, cost, pp) -> let g' = first_goal lgls in let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') in let ldb = Hint_db.add_list hintl (List.hd s.localdb) in - { depth = s.depth; tacres = res; + { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; dblist = s.dblist; localdb = ldb :: List.tl s.localdb; prev = ps }) - (filter_tactics s.tacres [Proofview.V82.of_tactic Tactics.intro,lazy (str "intro")]) + l in let rec_tacs = let l = filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) in List.map - (fun (lgls as res, pp) -> + (fun (lgls, cost, pp) -> let nbgl' = List.length (sig_it lgls) in if nbgl' < nbgl then - { depth = s.depth; tacres = res; last_tactic = pp; prev = ps; - dblist = s.dblist; localdb = List.tl s.localdb } + { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; + prev = ps; dblist = s.dblist; localdb = List.tl s.localdb } else let newlocal = let hyps = pf_hyps g in @@ -294,7 +295,7 @@ module SearchProblem = struct else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true []) (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) in - { depth = pred s.depth; tacres = res; + { depth = pred s.depth; priority = cost; tacres = lgls; dblist = s.dblist; last_tactic = pp; prev = ps; localdb = newlocal @ List.tl s.localdb }) l @@ -363,6 +364,7 @@ let pr_info dbg s = let make_initial_state dbg n gl dblist localdb = { depth = n; + priority = 0; tacres = tclIDTAC gl; last_tactic = lazy (mt()); dblist = dblist; @@ -566,7 +568,7 @@ let autounfold_one db cl = in if did then match cl with - | Some hyp -> change_in_hyp None (fun sigma -> sigma, c') hyp + | Some hyp -> change_in_hyp None (make_change_arg c') hyp | None -> convert_concl_no_check c' DEFAULTcast else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") end diff --git a/tactics/eauto.mli b/tactics/eauto.mli index 19e2f198..7073e8a2 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -8,7 +8,6 @@ open Term open Proof_type -open Auto open Evd open Hints diff --git a/tactics/elim.ml b/tactics/elim.ml index b7d5b102..3cb4fa9c 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -15,7 +15,6 @@ open Hipattern open Tacmach.New open Tacticals.New open Tactics -open Misctypes open Proofview.Notations let introElimAssumsThen tac ba = diff --git a/tactics/equality.ml b/tactics/equality.ml index c130fa15..7ab8d0c3 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -487,9 +487,6 @@ let apply_special_clear_request clear_flag f = e when catchable_exception e -> tclIDTAC end -type delayed_open_constr_with_bindings = - env -> evar_map -> evar_map * constr with_bindings - let general_multi_rewrite with_evars l cl tac = let do1 l2r f = Proofview.Goal.enter begin fun gl -> @@ -497,7 +494,7 @@ let general_multi_rewrite with_evars l cl tac = let env = Proofview.Goal.env gl in let sigma,c = f env sigma in tclWITHHOLES with_evars - (general_rewrite_clause l2r with_evars ?tac c) sigma cl + (general_rewrite_clause l2r with_evars ?tac c cl) sigma end in let rec doN l2r c = function @@ -1233,8 +1230,6 @@ let try_delta_expand env sigma t = let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined") let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k) -let eqdep_dec = qualid_of_string "Coq.Logic.Eqdep_dec" - let inject_if_homogenous_dependent_pair ty = Proofview.Goal.nf_enter begin fun gl -> try @@ -1257,7 +1252,7 @@ let inject_if_homogenous_dependent_pair ty = (* knows inductive types *) if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind) && pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit; - Library.require_library [Loc.ghost,eqdep_dec] (Some false); + Coqlib.check_required_library ["Coq";"Logic";"Eqdep_dec"]; let new_eq_args = [|pf_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in @@ -1474,8 +1469,6 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* then it uses the predicate "\x.phi(proj1_sig x,proj2_sig x)", and so *) (* on for further iterated sigma-tuples *) -exception NothingToRewrite - let cutSubstInConcl l2r eqn = Proofview.Goal.nf_enter begin fun gl -> let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in @@ -1500,10 +1493,10 @@ let cutSubstInHyp l2r eqn id = tclTHENFIRST (tclTHENLIST [ (Proofview.Unsafe.tclEVARS sigma); - (change_in_hyp None (fun s -> s,typ) (id,InHypTypeOnly)); + (change_in_hyp None (make_change_arg typ) (id,InHypTypeOnly)); (replace_core (onHyp id) l2r eqn) ]) - (change_in_hyp None (fun s -> s,expected) (id,InHypTypeOnly)) + (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly)) end let try_rewrite tac = @@ -1513,9 +1506,6 @@ let try_rewrite tac = | e when catchable_exception e -> tclZEROMSG (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.") - | NothingToRewrite -> - tclZEROMSG - (strbrk "Nothing to rewrite.") | e -> Proofview.tclZERO ~info e end diff --git a/tactics/equality.mli b/tactics/equality.mli index 90d8a224..3e13ee57 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -11,7 +11,6 @@ open Names open Term open Evd open Environ -open Tacmach open Tacexpr open Ind_tables open Locus diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index 2aafaf08..c3fe6b65 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -71,8 +71,11 @@ let let_evar name typ = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let id = Namegen.id_of_name_using_hdchar env typ name in - let id = Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) in + let id = match name with + | Names.Anonymous -> + let id = Namegen.id_of_name_using_hdchar env typ name in + Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) + | Names.Name id -> id in let sigma',evar = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS sigma')) (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere) diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli index 42d00e1e..2c4df060 100644 --- a/tactics/evar_tactics.mli +++ b/tactics/evar_tactics.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Tacmach open Names open Tacexpr open Locus diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index f3482c31..891e2dba 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -21,26 +21,22 @@ open Util open Evd open Equality open Misctypes -open Proofview.Notations DECLARE PLUGIN "extratactics" (**********************************************************************) -(* admit, replace, discriminate, injection, simplify_eq *) +(* replace, discriminate, injection, simplify_eq *) (* cutrewrite, dependent rewrite *) -TACTIC EXTEND admit - [ "admit" ] -> [ admit_as_an_axiom ] -END - -let replace_in_clause_maybe_by (sigma,c1) c2 cl tac = - Proofview.Unsafe.tclEVARS sigma <*> - (replace_in_clause_maybe_by c1 c2 cl) - (Option.map Tacinterp.eval_tactic tac) +let replace_in_clause_maybe_by (sigma1,c1) c2 cl tac = + Tacticals.New.tclWITHHOLES false + (replace_in_clause_maybe_by c1 c2 cl (Option.map Tacinterp.eval_tactic tac)) + sigma1 let replace_term dir_opt (sigma,c) cl = - Proofview.Unsafe.tclEVARS sigma <*> - (replace_term dir_opt c) cl + Tacticals.New.tclWITHHOLES false + (replace_term dir_opt c cl) + sigma TACTIC EXTEND replace ["replace" open_constr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] @@ -71,8 +67,8 @@ let induction_arg_of_quantified_hyp = function ElimOnIdent and not as "constr" *) let elimOnConstrWithHoles tac with_evars c = - Tacticals.New.tclWITHHOLES with_evars (tac with_evars) - c.sigma (Some (None,ElimOnConstr c.it)) + Tacticals.New.tclWITHHOLES with_evars + (tac with_evars (Some (None,ElimOnConstr c.it))) c.sigma TACTIC EXTEND simplify_eq_main | [ "simplify_eq" constr_with_bindings(c) ] -> @@ -202,7 +198,7 @@ END let onSomeWithHoles tac = function | None -> tac None - | Some c -> Proofview.Unsafe.tclEVARS c.sigma <*> tac (Some c.it) + | Some c -> Tacticals.New.tclWITHHOLES false (tac (Some c.it)) c.sigma TACTIC EXTEND contradiction [ "contradiction" constr_with_bindings_opt(c) ] -> @@ -246,8 +242,8 @@ END let rewrite_star clause orient occs (sigma,c) (tac : glob_tactic_expr option) = let tac' = Option.map (fun t -> Tacinterp.eval_tactic t, FirstSolved) tac in - Proofview.Unsafe.tclEVARS sigma <*> - general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true + Tacticals.New.tclWITHHOLES false + (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) sigma TACTIC EXTEND rewrite_star | [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> diff --git a/tactics/hints.ml b/tactics/hints.ml index 5621c365..55d62e15 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -68,7 +68,7 @@ let decompose_app_bound t = (* The Type of Constructions Autotactic Hints *) (************************************************************************) -type 'a auto_tactic = +type 'a auto_tactic_ast = | Res_pf of 'a (* Hint Apply *) | ERes_pf of 'a (* Hint EApply *) | Give_exact of 'a @@ -92,18 +92,23 @@ type hint_term = | IsGlobRef of global_reference | IsConstr of constr * Univ.universe_context_set +type 'a auto_tactic = 'a auto_tactic_ast + type 'a gen_auto_tactic = { pri : int; (* A number lower is higher priority *) poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (* A pattern for the concl of the Goal *) name : hints_path_atom; (* A potential name to refer to the hint *) - code : 'a auto_tactic (* the tactic to apply when the concl matches pat *) + code : 'a (* the tactic to apply when the concl matches pat *) } -type pri_auto_tactic = (constr * clausenv) gen_auto_tactic +type pri_auto_tactic = (constr * clausenv) auto_tactic gen_auto_tactic type hint_entry = global_reference option * - (constr * types * Univ.universe_context_set) gen_auto_tactic + (constr * types * Univ.universe_context_set) auto_tactic_ast gen_auto_tactic + +let run_auto_tactic tac k = k tac +let repr_auto_tactic tac = tac let eq_hints_path_atom p1 p2 = match p1, p2 with | PathHints gr1, PathHints gr2 -> List.equal eq_gr gr1 gr2 @@ -156,10 +161,19 @@ module Bounded_net = Btermdn.Make(struct let compare = pri_order_int end) -type search_entry = stored_data list * stored_data list * Bounded_net.t * bool array list - +type search_entry = { + sentry_nopat : stored_data list; + sentry_pat : stored_data list; + sentry_bnet : Bounded_net.t; + sentry_mode : bool array list; +} -let empty_se = ([],[],Bounded_net.create (),[]) +let empty_se = { + sentry_nopat = []; + sentry_pat = []; + sentry_bnet = Bounded_net.empty; + sentry_mode = []; +} let eq_pri_auto_tactic (_, x) (_, y) = if Int.equal x.pri y.pri && Option.equal constr_pattern_eq x.pat y.pat then @@ -177,27 +191,29 @@ let eq_pri_auto_tactic (_, x) (_, y) = else false -let add_tac pat t st (l,l',dn,m) = +let add_tac pat t st se = match pat with | None -> - if not (List.exists (eq_pri_auto_tactic t) l) then (List.insert pri_order t l, l', dn, m) - else (l, l', dn, m) + if List.exists (eq_pri_auto_tactic t) se.sentry_nopat then se + else { se with sentry_nopat = List.insert pri_order t se.sentry_nopat } | Some pat -> - if not (List.exists (eq_pri_auto_tactic t) l') - then (l, List.insert pri_order t l', Bounded_net.add st dn (pat,t), m) else (l, l', dn, m) + if List.exists (eq_pri_auto_tactic t) se.sentry_pat then se + else { se with + sentry_pat = List.insert pri_order t se.sentry_pat; + sentry_bnet = Bounded_net.add st se.sentry_bnet (pat, t); } -let rebuild_dn st ((l,l',dn,m) : search_entry) = +let rebuild_dn st se = let dn' = List.fold_left (fun dn (id, t) -> Bounded_net.add (Some st) dn (Option.get t.pat, (id, t))) - (Bounded_net.create ()) l' + Bounded_net.empty se.sentry_pat in - (l, l', dn', m) + { se with sentry_bnet = dn' } -let lookup_tacs concl st (l,l',dn) = - let l' = Bounded_net.lookup st dn concl in +let lookup_tacs concl st se = + let l' = Bounded_net.lookup st se.sentry_bnet concl in let sl' = List.stable_sort pri_order_int l' in - List.merge pri_order_int l sl' + List.merge pri_order_int se.sentry_nopat sl' module Constr_map = Map.Make(RefOrdered) @@ -378,7 +394,7 @@ module Hint_db = struct hintdb_state : Names.transparent_state; hintdb_cut : hints_path; hintdb_unfolds : Id.Set.t * Cset.t; - mutable hintdb_max_id : int; + hintdb_max_id : int; use_dn : bool; hintdb_map : search_entry Constr_map.t; (* A list of unindexed entries starting with an unfoldable constant @@ -386,8 +402,9 @@ module Hint_db = struct hintdb_nopat : (global_reference option * stored_data) list } - let next_hint_id t = - let h = t.hintdb_max_id in t.hintdb_max_id <- succ t.hintdb_max_id; h + let next_hint_id db = + let h = db.hintdb_max_id in + { db with hintdb_max_id = succ db.hintdb_max_id }, h let empty st use_dn = { hintdb_state = st; hintdb_cut = PathEmpty; @@ -411,34 +428,38 @@ module Hint_db = struct if List.is_empty modes then true else List.exists (matches_mode args) modes + let merge_entry db nopat pat = + let h = Sort.merge pri_order (List.map snd db.hintdb_nopat @ nopat) pat in + List.map realize_tac h + let map_none db = - List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) []) - + merge_entry db [] [] + let map_all k db = - let (l,l',_,_) = find k db in - List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l') + let se = find k db in + merge_entry db se.sentry_nopat se.sentry_pat (** Precondition: concl has no existentials *) let map_auto (k,args) concl db = - let (l,l',dn,m) = find k db in + let se = find k db in let st = if db.use_dn then (Some db.hintdb_state) else None in - let l' = lookup_tacs concl st (l,l',dn) in - List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) l') + let pat = lookup_tacs concl st se in + merge_entry db [] pat let map_existential (k,args) concl db = - let (l,l',_,m) = find k db in - if matches_modes args m then - List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l') - else List.map realize_tac (List.map snd db.hintdb_nopat) + let se = find k db in + if matches_modes args se.sentry_mode then + merge_entry db se.sentry_nopat se.sentry_pat + else merge_entry db [] [] (* [c] contains an existential *) let map_eauto (k,args) concl db = - let (l,l',dn,m) = find k db in - if matches_modes args m then - let st = if db.use_dn then Some db.hintdb_state else None in - let l' = lookup_tacs concl st (l,l',dn) in - List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) l') - else List.map realize_tac (List.map snd db.hintdb_nopat) + let se = find k db in + if matches_modes args se.sentry_mode then + let st = if db.use_dn then Some db.hintdb_state else None in + let pat = lookup_tacs concl st se in + merge_entry db [] pat + else merge_entry db [] [] let is_exact = function | Give_exact _ -> true @@ -490,16 +511,19 @@ module Hint_db = struct state, { db with hintdb_unfolds = unfs }, true | _ -> db.hintdb_state, db, false in - let db = if db.use_dn && rebuild then rebuild_db st' db else db - in addkv k (next_hint_id db) v db + let db = if db.use_dn && rebuild then rebuild_db st' db else db in + let db, id = next_hint_id db in + addkv k id v db let add_list l db = List.fold_left (fun db k -> add_one k db) db l let remove_sdl p sdl = List.smartfilter p sdl - let remove_he st p (sl1, sl2, dn, m as he) = - let sl1' = remove_sdl p sl1 and sl2' = remove_sdl p sl2 in - if sl1' == sl1 && sl2' == sl2 then he - else rebuild_dn st (sl1', sl2', dn, m) + + let remove_he st p se = + let sl1' = remove_sdl p se.sentry_nopat in + let sl2' = remove_sdl p se.sentry_pat in + if sl1' == se.sentry_nopat && sl2' == se.sentry_pat then se + else rebuild_dn st { se with sentry_nopat = sl1'; sentry_pat = sl2' } let remove_list grs db = let filter (_, h) = @@ -510,13 +534,16 @@ module Hint_db = struct let remove_one gr db = remove_list [gr] db + let get_entry se = List.map realize_tac (se.sentry_nopat @ se.sentry_pat) + let iter f db = + let iter_se k se = f (Some k) se.sentry_mode (get_entry se) in f None [] (List.map (fun x -> realize_tac (snd x)) db.hintdb_nopat); - Constr_map.iter (fun k (l,l',_,m) -> f (Some k) m (List.map realize_tac (l@l'))) db.hintdb_map + Constr_map.iter iter_se db.hintdb_map let fold f db accu = let accu = f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat) accu in - Constr_map.fold (fun k (l,l',_,m) -> f (Some k) m (List.map snd (l@l'))) db.hintdb_map accu + Constr_map.fold (fun k se -> f (Some k) se.sentry_mode (get_entry se)) db.hintdb_map accu let transparent_state db = db.hintdb_state @@ -528,8 +555,9 @@ module Hint_db = struct { db with hintdb_cut = normalize_path (PathOr (db.hintdb_cut, path)) } let add_mode gr m db = - let (l,l',dn,ms) = find gr db in - { db with hintdb_map = Constr_map.add gr (l,l',dn,m :: ms) db.hintdb_map } + let se = find gr db in + let se = { se with sentry_mode = m :: se.sentry_mode } in + { db with hintdb_map = Constr_map.add gr se db.hintdb_map } let cut db = db.hintdb_cut @@ -609,7 +637,7 @@ let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = match kind_of_term cty with | Prod _ -> failwith "make_exact_entry" | _ -> - let pat = snd (Patternops.pattern_of_constr env sigma cty) in + let pat = pi3 (Patternops.pattern_of_constr env sigma cty) in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_exact_entry" @@ -628,7 +656,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, let sigma' = Evd.merge_context_set univ_flexible sigma ctx in let ce = mk_clenv_from_env env sigma' None (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in - let pat = snd (Patternops.pattern_of_constr env ce.evd c') in + let pat = pi3 (Patternops.pattern_of_constr env ce.evd c') in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry" in @@ -726,7 +754,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = let ce = mk_clenv_from_env env sigma None (c,t) in (Some hd, { pri=1; poly = poly; - pat = Some (snd (Patternops.pattern_of_constr env ce.evd (clenv_type ce))); + pat = Some (pi3 (Patternops.pattern_of_constr env ce.evd (clenv_type ce))); name = name; code=Res_pf_THEN_trivial_fail(c,t,ctx) }) @@ -782,10 +810,15 @@ let add_mode dbname l m = let db' = Hint_db.add_mode l m db in searchtable_add (dbname, db') -type hint_obj = bool * string * hint_action (* locality, name, action *) +type hint_obj = { + hint_local : bool; + hint_name : string; + hint_action : hint_action; +} -let cache_autohint (_,(local,name,hints)) = - match hints with +let cache_autohint (_, h) = + let name = h.hint_name in + match h.hint_action with | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b) | AddTransparency (grs, b) -> add_transparency name grs b | AddHints hints -> add_hint name hints @@ -793,7 +826,7 @@ let cache_autohint (_,(local,name,hints)) = | AddCut path -> add_cut name path | AddMode (l, m) -> add_mode name l m -let subst_autohint (subst,(local,name,hintlist as obj)) = +let subst_autohint (subst, obj) = let subst_key gr = let (lab'', elab') = subst_global subst gr in let gr' = @@ -835,29 +868,30 @@ let subst_autohint (subst,(local,name,hintlist as obj)) = in if k' == k && data' == data then hint else (k',data') in - match hintlist with - | CreateDB _ -> obj + let action = match obj.hint_action with + | CreateDB _ -> obj.hint_action | AddTransparency (grs, b) -> - let grs' = List.smartmap (subst_evaluable_reference subst) grs in - if grs==grs' then obj else (local, name, AddTransparency (grs', b)) + let grs' = List.smartmap (subst_evaluable_reference subst) grs in + if grs == grs' then obj.hint_action else AddTransparency (grs', b) | AddHints hintlist -> - let hintlist' = List.smartmap subst_hint hintlist in - if hintlist' == hintlist then obj else - (local,name,AddHints hintlist') + let hintlist' = List.smartmap subst_hint hintlist in + if hintlist' == hintlist then obj.hint_action else AddHints hintlist' | RemoveHints grs -> - let grs' = List.smartmap (subst_global_reference subst) grs in - if grs==grs' then obj else (local, name, RemoveHints grs') + let grs' = List.smartmap (subst_global_reference subst) grs in + if grs == grs' then obj.hint_action else RemoveHints grs' | AddCut path -> let path' = subst_hints_path subst path in - if path' == path then obj else (local, name, AddCut path') + if path' == path then obj.hint_action else AddCut path' | AddMode (l,m) -> let l' = subst_global_reference subst l in - (local, name, AddMode (l', m)) + if l' == l then obj.hint_action else AddMode (l', m) + in + if action == obj.hint_action then obj else { obj with hint_action = action } -let classify_autohint ((local,name,hintlist) as obj) = - match hintlist with +let classify_autohint obj = + match obj.hint_action with | AddHints [] -> Dispose - | _ -> if local then Dispose else Substitute obj + | _ -> if obj.hint_local then Dispose else Substitute obj let inAutoHint : hint_obj -> obj = declare_object {(default_object "AUTOHINT") with @@ -866,14 +900,22 @@ let inAutoHint : hint_obj -> obj = subst_function = subst_autohint; classify_function = classify_autohint; } +let make_hint ?(local = false) name action = { + hint_local = local; + hint_name = name; + hint_action = action; +} + let create_hint_db l n st b = - Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB (b, st))) + let hint = make_hint ~local:l n (CreateDB (b, st)) in + Lib.add_anonymous_leaf (inAutoHint hint) let remove_hints local dbnames grs = let dbnames = if List.is_empty dbnames then ["core"] else dbnames in List.iter (fun dbname -> - Lib.add_anonymous_leaf (inAutoHint(local, dbname, RemoveHints grs))) + let hint = make_hint ~local dbname (RemoveHints grs) in + Lib.add_anonymous_leaf (inAutoHint hint)) dbnames (**************************************************************************) @@ -882,37 +924,42 @@ let remove_hints local dbnames grs = let add_resolves env sigma clist local dbnames = List.iter (fun dbname -> - Lib.add_anonymous_leaf - (inAutoHint - (local,dbname, AddHints - (List.flatten (List.map (fun (pri, poly, hnf, path, gr) -> - make_resolves env sigma (true,hnf,Flags.is_verbose()) - pri poly ~name:path gr) clist))))) + let r = + List.flatten (List.map (fun (pri, poly, hnf, path, gr) -> + make_resolves env sigma (true,hnf,Flags.is_verbose()) + pri poly ~name:path gr) clist) + in + let hint = make_hint ~local dbname (AddHints r) in + Lib.add_anonymous_leaf (inAutoHint hint)) dbnames let add_unfolds l local dbnames = List.iter - (fun dbname -> Lib.add_anonymous_leaf - (inAutoHint (local,dbname, AddHints (List.map make_unfold l)))) + (fun dbname -> + let hint = make_hint ~local dbname (AddHints (List.map make_unfold l)) in + Lib.add_anonymous_leaf (inAutoHint hint)) dbnames let add_cuts l local dbnames = List.iter - (fun dbname -> Lib.add_anonymous_leaf - (inAutoHint (local,dbname, AddCut l))) + (fun dbname -> + let hint = make_hint ~local dbname (AddCut l) in + Lib.add_anonymous_leaf (inAutoHint hint)) dbnames let add_mode l m local dbnames = List.iter - (fun dbname -> Lib.add_anonymous_leaf - (let m' = make_mode l m in - (inAutoHint (local,dbname, AddMode (l,m'))))) + (fun dbname -> + let m' = make_mode l m in + let hint = make_hint ~local dbname (AddMode (l, m')) in + Lib.add_anonymous_leaf (inAutoHint hint)) dbnames let add_transparency l b local dbnames = List.iter - (fun dbname -> Lib.add_anonymous_leaf - (inAutoHint (local,dbname, AddTransparency (l, b)))) + (fun dbname -> + let hint = make_hint ~local dbname (AddTransparency (l, b)) in + Lib.add_anonymous_leaf (inAutoHint hint)) dbnames let add_extern pri pat tacast local dbname = @@ -920,7 +967,7 @@ let add_extern pri pat tacast local dbname = | None -> None | Some (_, pat) -> Some pat in - let hint = local, dbname, AddHints [make_extern pri pat tacast] in + let hint = make_hint ~local dbname (AddHints [make_extern pri pat tacast]) in Lib.add_anonymous_leaf (inAutoHint hint) let add_externs pri pat tacast local dbnames = @@ -929,9 +976,9 @@ let add_externs pri pat tacast local dbnames = let add_trivials env sigma l local dbnames = List.iter (fun dbname -> - Lib.add_anonymous_leaf ( - inAutoHint(local,dbname, - AddHints (List.map (fun (name, poly, c) -> make_trivial env sigma poly ~name c) l)))) + let l = List.map (fun (name, poly, c) -> make_trivial env sigma poly ~name c) l in + let hint = make_hint ~local dbname (AddHints l) in + Lib.add_anonymous_leaf (inAutoHint hint)) dbnames let (forward_intern_tac, extern_intern_tac) = Hook.make () diff --git a/tactics/hints.mli b/tactics/hints.mli index 45cf562c..958cca1c 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -28,7 +28,7 @@ val decompose_app_bound : constr -> global_reference * constr array (** Pre-created hint databases *) -type 'a auto_tactic = +type 'a auto_tactic_ast = | Res_pf of 'a (* Hint Apply *) | ERes_pf of 'a (* Hint EApply *) | Give_exact of 'a @@ -36,26 +36,27 @@ type 'a auto_tactic = | Unfold_nth of evaluable_global_reference (* Hint Unfold *) | Extern of Tacexpr.glob_tactic_expr (* Hint Extern *) +type 'a auto_tactic + type hints_path_atom = | PathHints of global_reference list | PathAny -type 'a gen_auto_tactic = { +type 'a gen_auto_tactic = private { pri : int; (** A number between 0 and 4, 4 = lower priority *) poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (** A pattern for the concl of the Goal *) name : hints_path_atom; (** A potential name to refer to the hint *) - code : 'a auto_tactic; (** the tactic to apply when the concl matches pat *) + code : 'a; (** the tactic to apply when the concl matches pat *) } -type pri_auto_tactic = (constr * clausenv) gen_auto_tactic +type pri_auto_tactic = (constr * clausenv) auto_tactic gen_auto_tactic type search_entry (** The head may not be bound. *) -type hint_entry = global_reference option * - (constr * types * Univ.universe_context_set) gen_auto_tactic +type hint_entry type hints_path = | PathAtom of hints_path_atom @@ -196,6 +197,13 @@ val make_extern : int -> constr_pattern option -> Tacexpr.glob_tactic_expr -> hint_entry +val run_auto_tactic : 'a auto_tactic -> + ('a auto_tactic_ast -> 'r Proofview.tactic) -> 'r Proofview.tactic + +(** This function is for backward compatibility only, not to use in newly + written code. *) +val repr_auto_tactic : 'a auto_tactic -> 'a auto_tactic_ast + val extern_intern_tac : (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr) Hook.t diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index c200871e..27d25056 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -8,7 +8,6 @@ open Names open Term -open Evd open Coqlib (** High-order patterns *) @@ -145,8 +144,6 @@ val is_matching_sigma : constr -> bool val match_eqdec : constr -> bool * constr * constr * constr * constr (** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) -open Proof_type -open Tacmach val dest_nf_eq : [ `NF ] Proofview.Goal.t -> constr -> (constr * constr * constr) (** Match a negation *) diff --git a/tactics/inv.mli b/tactics/inv.mli index b3478dda..412f30c2 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Loc open Names open Term open Misctypes diff --git a/tactics/leminv.ml b/tactics/leminv.ml index f00ecf8f..9a64b03f 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -210,6 +210,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = end in let avoid = ref [] in let { sigma=sigma } = Proof.V82.subgoals pf in + let sigma = Evd.nf_constraints sigma in let rec fill_holes c = match kind_of_term c with | Evar (e,args) -> @@ -222,13 +223,13 @@ let inversion_scheme env sigma t sort dep_option inv_op = in let c = fill_holes pfterm in (* warning: side-effect on ownSign *) - let invProof = it_mkNamedLambda_or_LetIn c !ownSign - in - invProof + let invProof = it_mkNamedLambda_or_LetIn c !ownSign in + let p = Evarutil.nf_evars_universes sigma invProof in + p, Evd.universe_context sigma let add_inversion_lemma name env sigma t sort dep inv_op = - let invProof = inversion_scheme env sigma t sort dep inv_op in - let entry = definition_entry ~poly:true (*FIXME*) invProof in + let invProof, ctx = inversion_scheme env sigma t sort dep inv_op in + let entry = definition_entry ~poly:(Flags.use_polymorphic_flag ()) ~univs:ctx invProof in let _ = declare_constant name (DefinitionEntry entry, IsProof Lemma) in () @@ -236,7 +237,8 @@ let add_inversion_lemma name env sigma t sort dep inv_op = * inv_op = InvNoThining (derives de semi inversion lemma) *) let add_inversion_lemma_exn na com comsort bool tac = - let env = Global.env () and evd = ref Evd.empty in + let env = Global.env () in + let evd = ref (Evd.from_env env) in let c = Constrintern.interp_type_evars env evd com in let sigma, sort = Pretyping.interp_sort !evd comsort in try diff --git a/tactics/leminv.mli b/tactics/leminv.mli index 47a4de44..2f80d26f 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Loc open Names open Term open Constrexpr diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index a3914da1..ac8b4923 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -283,7 +283,7 @@ end) = struct (app_poly env evd arrow [| a; b |]), unfold_impl (* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *) else if bp then (* Dummy forall *) - (app_poly env evd coq_all [| a; mkLambda (Anonymous, a, b) |]), unfold_forall + (app_poly env evd coq_all [| a; mkLambda (Anonymous, a, lift 1 b) |]), unfold_forall else (* None in Prop, use arrow *) (app_poly env evd arrow [| a; b |]), unfold_impl @@ -629,11 +629,9 @@ let solve_remaining_by env sigma holes by = | None -> sigma (** Evar should not be defined, but just in case *) | Some evi -> - let ctx = Evd.evar_universe_context sigma in let env = Environ.reset_with_named_context evi.evar_hyps env in let ty = evi.evar_concl in - let c, _, ctx = Pfedit.build_by_tactic env ctx ty solve_tac in - let sigma = Evd.set_universe_context sigma ctx in + let c, sigma = Pfedit.refine_by_tactic env sigma ty solve_tac in Evd.define evk c sigma in List.fold_left solve sigma indep @@ -1446,7 +1444,14 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul let newt = Evarutil.nf_evar evars' res.rew_to in let evars = (* Keep only original evars (potentially instantiated) and goal evars, the rest has been defined and substituted already. *) - Evar.Set.fold (fun ev acc -> Evd.remove acc ev) cstrs evars' + Evar.Set.fold + (fun ev acc -> + if not (Evd.is_defined acc ev) then + errorlabstrm "rewrite" + (str "Unsolved constraint remaining: " ++ spc () ++ + Evd.pr_evar_info (Evd.find acc ev)) + else Evd.remove acc ev) + cstrs evars' in let res = match res.rew_prf with | RewCast c -> None @@ -1466,28 +1471,32 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul in Some proof in Some (Some (evars, res, newt)) +(** Insert a declaration after the last declaration it depends on *) +let rec insert_dependent env decl accu hyps = match hyps with +| [] -> List.rev_append accu [decl] +| (id, _, _ as ndecl) :: rem -> + if occur_var_in_decl env id decl then + List.rev_append accu (decl :: hyps) + else + insert_dependent env decl (ndecl :: accu) rem + let assert_replacing id newt tac = let prf = Proofview.Goal.nf_enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in - let nc' = - Environ.fold_named_context - (fun _ (n, b, t as decl) nc' -> - if Id.equal n id then (n, b, newt) :: nc' - else decl :: nc') - env ~init:[] + let ctx = Environ.named_context env in + let after, before = List.split_when (fun (n, b, t) -> Id.equal n id) ctx in + let nc = match before with + | [] -> assert false + | (id, b, _) :: rem -> insert_dependent env (id, b, newt) [] after @ rem in + let env' = Environ.reset_with_named_context (val_of_named_context nc) env in Proofview.Refine.refine ~unsafe:false begin fun sigma -> - let env' = Environ.reset_with_named_context (val_of_named_context nc') env in let sigma, ev = Evarutil.new_evar env' sigma concl in let sigma, ev' = Evarutil.new_evar env sigma newt in - let fold _ (n, b, t) inst = - if Id.equal n id then ev' :: inst - else mkVar n :: inst - in - let inst = fold_named_context fold env ~init:[] in - let (e, args) = destEvar ev in - sigma, mkEvar (e, Array.of_list inst) + let map (n, _, _) = if Id.equal n id then ev' else mkVar n in + let (e, _) = destEvar ev in + sigma, mkEvar (e, Array.map_of_list map nc) end end in Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml index 215713d9..ab71f5f2 100644 --- a/tactics/taccoerce.ml +++ b/tactics/taccoerce.ml @@ -176,6 +176,13 @@ let coerce_to_evaluable_ref env v = let id = out_gen (topwit wit_var) v in if Id.List.mem id (Termops.ids_of_context env) then EvalVarRef id else fail () + else if has_type v (topwit wit_ref) then + let open Globnames in + let r = out_gen (topwit wit_ref) v in + match r with + | VarRef var -> EvalVarRef var + | ConstRef c -> EvalConstRef c + | IndRef _ | ConstructRef _ -> fail () else let ev = match Value.to_constr v with | Some c when isConst c -> EvalConstRef (Univ.out_punivs (destConst c)) diff --git a/tactics/tacenv.ml b/tactics/tacenv.ml index cb20fc93..84c0a99b 100644 --- a/tactics/tacenv.ml +++ b/tactics/tacenv.ml @@ -71,7 +71,6 @@ let interp_ml_tactic s = (* Summary and Object declaration *) open Nametab -open Libnames open Libobject let mactab = @@ -84,7 +83,6 @@ let is_ltac_for_ml_tactic r = fst (KNmap.find r !mactab) (* Declaration of the TAC-DEFINITION object *) let add (kn,td) = mactab := KNmap.add kn td !mactab -let replace (kn,td) = mactab := KNmap.add kn td !mactab let load_md i ((sp, kn), (local, id, b, t)) = match id with | None -> diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index c8b9a208..5cc4c835 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -48,12 +48,10 @@ let error_tactic_expected loc = type glob_sign = Genintern.glob_sign = { ltacvars : Id.Set.t; (* ltac variables and the subset of vars introduced by Intro/Let/... *) - ltacrecvars : ltac_constant Id.Map.t; - (* ltac recursive names *) genv : Environ.env } let fully_empty_glob_sign = - { ltacvars = Id.Set.empty; ltacrecvars = Id.Map.empty; genv = Environ.empty_env } + { ltacvars = Id.Set.empty; genv = Environ.empty_env } let make_empty_glob_sign () = { fully_empty_glob_sign with genv = Global.env () } @@ -64,8 +62,6 @@ let find_ident id ist = Id.Set.mem id ist.ltacvars || Id.List.mem id (ids_of_named_context (Environ.named_context ist.genv)) -let find_recvar qid ist = Id.Map.find qid ist.ltacrecvars - (* a "var" is a ltac var or a var introduced by an intro tactic *) let find_var id ist = Id.Set.mem id ist.ltacvars @@ -116,9 +112,7 @@ let intern_ltac_variable ist = function if find_var id ist then (* A local variable of any type *) ArgVar (loc,id) - else - (* A recursive variable *) - ArgArg (loc,find_recvar id ist) + else raise Not_found | _ -> raise Not_found @@ -801,7 +795,7 @@ let glob_tactic_env l env x = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in Flags.with_option strict_check (intern_pure_tactic - { ltacvars; ltacrecvars = Id.Map.empty; genv = env }) + { ltacvars; genv = env }) x let split_ltac_fun = function diff --git a/tactics/tacintern.mli b/tactics/tacintern.mli index 2e662e58..a6e28d56 100644 --- a/tactics/tacintern.mli +++ b/tactics/tacintern.mli @@ -19,7 +19,6 @@ open Nametab type glob_sign = Genintern.glob_sign = { ltacvars : Id.Set.t; - ltacrecvars : ltac_constant Id.Map.t; genv : Environ.env } val fully_empty_glob_sign : glob_sign diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 23de47d5..f29680e1 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -318,18 +318,16 @@ let interp_ltac_var coerce ist env locid = try try_interp_ltac_var coerce ist env locid with Not_found -> anomaly (str "Detected '" ++ Id.print (snd locid) ++ str "' as ltac var at interning time") -let interp_ident_gen fresh ist env sigma id = - try try_interp_ltac_var (coerce_to_ident fresh env) ist (Some (env,sigma)) (dloc,id) +let interp_ident ist env sigma id = + try try_interp_ltac_var (coerce_to_ident false env) ist (Some (env,sigma)) (dloc,id) with Not_found -> id -let interp_ident = interp_ident_gen false -let interp_fresh_ident = interp_ident_gen true -let pf_interp_ident id gl = interp_ident_gen false id (pf_env gl) (project gl) +let pf_interp_ident id gl = interp_ident id (pf_env gl) (project gl) -(* Interprets an optional identifier which must be fresh *) -let interp_fresh_name ist env sigma = function +(* Interprets an optional identifier, bound or fresh *) +let interp_name ist env sigma = function | Anonymous -> Anonymous - | Name id -> Name (interp_fresh_ident ist env sigma id) + | Name id -> Name (interp_ident ist env sigma id) let interp_intro_pattern_var loc ist env sigma id = try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some (env,sigma)) (loc,id) @@ -497,8 +495,6 @@ let interp_fresh_id ist env sigma l = Id.of_string s in Tactics.fresh_id_in_env avoid id env - - (* Extract the uconstr list from lfun *) let extract_ltac_constr_context ist env = let open Glob_term in @@ -683,7 +679,7 @@ let interp_constr_with_occurrences ist env sigma (occs,c) = let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = let p = match a with | Inl b -> Inl (interp_evaluable ist env sigma b) - | Inr c -> Inr (snd (interp_typed_pattern ist env sigma c)) in + | Inr c -> Inr (pi3 (interp_typed_pattern ist env sigma c)) in interp_occurrences ist occs, p let interp_constr_with_occurrences_and_name_as_list = @@ -694,7 +690,7 @@ let interp_constr_with_occurrences_and_name_as_list = (fun ist env sigma (occ_c,na) -> let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma occ_c in sigma, (c_interp, - interp_fresh_name ist env sigma na)) + interp_name ist env sigma na)) let interp_red_expr ist env sigma = function | Unfold l -> sigma , Unfold (List.map (interp_unfold ist env sigma) l) @@ -844,7 +840,7 @@ let rec interp_intro_pattern ist env sigma = function | loc, IntroForthcoming _ as x -> sigma, x and interp_intro_pattern_naming loc ist env sigma = function - | IntroFresh id -> IntroFresh (interp_fresh_ident ist env sigma id) + | IntroFresh id -> IntroFresh (interp_ident ist env sigma id) | IntroIdentifier id -> interp_intro_pattern_naming_var loc ist env sigma id | IntroAnonymous as x -> x @@ -1032,7 +1028,7 @@ let use_types = false let eval_pattern lfun ist env sigma (_,pat as c) = if use_types then - snd (interp_typed_pattern ist env sigma c) + pi3 (interp_typed_pattern ist env sigma c) else instantiate_pattern env sigma lfun pat @@ -1189,7 +1185,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with msg_warning (strbrk "The general \"info\" tactic is currently not working." ++ spc()++ strbrk "There is an \"Info\" command to replace it." ++fnl () ++ - strbrk "Some specific verbose tactics may also exist, such as info_trivial, info_auto, info_eauto."); + strbrk "Some specific verbose tactics may also exist, such as info_eauto."); eval_tactic ist tac (* For extensions *) | TacAlias (loc,s,l) -> @@ -1215,7 +1211,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with | IntOrVarArgType -> Ftactic.return (mk_int_or_var_value ist (out_gen (glbwit wit_int_or_var) x)) | IdentArgType -> - Ftactic.return (value_of_ident (interp_fresh_ident ist env sigma + Ftactic.return (value_of_ident (interp_ident ist env sigma (out_gen (glbwit wit_ident) x))) | VarArgType -> Ftactic.return (mk_hyp_value ist env sigma (out_gen (glbwit wit_var) x)) @@ -1256,7 +1252,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with Ftactic.return (in_gen (topwit (wit_list wit_genarg)) ans) | ListArgType IdentArgType -> let wit = glbwit (wit_list wit_ident) in - let mk_ident x = value_of_ident (interp_fresh_ident ist env sigma x) in + let mk_ident x = value_of_ident (interp_ident ist env sigma x) in let ans = List.map mk_ident (out_gen wit x) in Ftactic.return (in_gen (topwit (wit_list wit_genarg)) ans) | ListArgType t -> @@ -1624,7 +1620,7 @@ and interp_genarg ist env sigma concl gl x = (ArgArg (interp_int_or_var ist (out_gen (glbwit wit_int_or_var) x))) | IdentArgType -> in_gen (topwit wit_ident) - (interp_fresh_ident ist env sigma (out_gen (glbwit wit_ident) x)) + (interp_ident ist env sigma (out_gen (glbwit wit_ident) x)) | VarArgType -> in_gen (topwit wit_var) (interp_hyp ist env sigma (out_gen (glbwit wit_var) x)) | GenArgType -> @@ -1785,19 +1781,19 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in - Proofview.Unsafe.tclEVARS sigma <*> - name_atomic ~env + Tacticals.New.tclWITHHOLES false + (name_atomic ~env (TacIntroPattern l) (* spiwack: print uninterpreted, not sure if it is the expected behaviour. *) - (Tactics.intros_patterns l') + (Tactics.intros_patterns l')) sigma end | TacIntroMove (ido,hto) -> Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let mloc = interp_move_location ist env sigma hto in - let ido = Option.map (interp_fresh_ident ist env sigma) ido in + let ido = Option.map (interp_ident ist env sigma) ido in name_atomic ~env (TacIntroMove(ido,mloc)) (Tactics.intro_move ido mloc) @@ -1824,11 +1820,11 @@ and interp_atomic ist tac : unit Proofview.tactic = (k,(loc,f))) cb in let sigma,tac = match cl with - | None -> sigma, fun l -> Tactics.apply_with_delayed_bindings_gen a ev l + | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l | Some cl -> let sigma,(clear,id,cl) = interp_in_hyp_as ist env sigma cl in - sigma, fun l -> Tactics.apply_delayed_in a ev clear id l cl in - Tacticals.New.tclWITHHOLES ev tac sigma l + sigma, Tactics.apply_delayed_in a ev clear id l cl in + Tacticals.New.tclWITHHOLES ev tac sigma end end | TacElim (ev,(keep,cb),cbo) -> @@ -1837,28 +1833,28 @@ and interp_atomic ist tac : unit Proofview.tactic = let sigma = Proofview.Goal.sigma gl in let sigma, cb = interp_constr_with_bindings ist env sigma cb in let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in - let named_tac cbo = + let named_tac = let tac = Tactics.elim ev keep cb cbo in name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac in - Tacticals.New.tclWITHHOLES ev named_tac sigma cbo + Tacticals.New.tclWITHHOLES ev named_tac sigma end | TacCase (ev,(keep,cb)) -> Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let sigma, cb = interp_constr_with_bindings ist env sigma cb in - let named_tac cb = + let named_tac = let tac = Tactics.general_case_analysis ev keep cb in name_atomic ~env (TacCase(ev,(keep,cb))) tac in - Tacticals.New.tclWITHHOLES ev named_tac sigma cb + Tacticals.New.tclWITHHOLES ev named_tac sigma end | TacFix (idopt,n) -> Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let idopt = Option.map (interp_fresh_ident ist env sigma) idopt in + let idopt = Option.map (interp_ident ist env sigma) idopt in name_atomic ~env (TacFix(idopt,n)) (Proofview.V82.tactic (Tactics.fix idopt n)) @@ -1870,13 +1866,13 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = pf_env gl in let f sigma (id,n,c) = let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in - sigma , (interp_fresh_ident ist env sigma id,n,c_interp) in + sigma , (interp_ident ist env sigma id,n,c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in tclTHEN (tclEVARS sigma) - (Tactics.mutual_fix (interp_fresh_ident ist env sigma id) n l_interp 0) + (Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0) gl end end @@ -1884,7 +1880,7 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let idopt = Option.map (interp_fresh_ident ist env sigma) idopt in + let idopt = Option.map (interp_ident ist env sigma) idopt in name_atomic ~env (TacCofix (idopt)) (Proofview.V82.tactic (Tactics.cofix idopt)) @@ -1896,13 +1892,13 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = pf_env gl in let f sigma (id,c) = let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in - sigma , (interp_fresh_ident ist env sigma id,c_interp) in + sigma , (interp_ident ist env sigma id,c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in tclTHEN (tclEVARS sigma) - (Tactics.mutual_cofix (interp_fresh_ident ist env sigma id) l_interp 0) + (Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0) gl end end @@ -1915,20 +1911,20 @@ and interp_atomic ist tac : unit Proofview.tactic = in let sigma, ipat' = interp_intro_pattern_option ist env sigma ipat in let tac = Option.map (interp_tactic ist) t in - Proofview.Unsafe.tclEVARS sigma <*> - name_atomic ~env + Tacticals.New.tclWITHHOLES false + (name_atomic ~env (TacAssert(b,t,ipat,c)) - (Tactics.forward b tac ipat' c) + (Tactics.forward b tac ipat' c)) sigma end | TacGeneralize cl -> Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in - Proofview.Unsafe.tclEVARS sigma <*> - name_atomic ~env + Tacticals.New.tclWITHHOLES false + (name_atomic ~env (TacGeneralize cl) - (Proofview.V82.tactic (Tactics.Simple.generalize_gen cl)) + (Proofview.V82.tactic (Tactics.Simple.generalize_gen cl))) sigma end | TacGeneralizeDep c -> (new_interp_constr ist c) (fun c -> @@ -1953,11 +1949,11 @@ and interp_atomic ist tac : unit Proofview.tactic = let with_eq = if b then None else Some (true,id) in Tactics.letin_tac with_eq na c None cl in - Proofview.Unsafe.tclEVARS sigma <*> - let na = interp_fresh_name ist env sigma na in - name_atomic ~env + let na = interp_name ist env sigma na in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env (TacLetTac(na,c_interp,clp,b,eqpat)) - (let_tac b na c_interp clp eqpat) + (let_tac b na c_interp clp eqpat)) sigma else (* We try to keep the pattern structure as much as possible *) let let_pat_tac b na c cl eqpat = @@ -1969,12 +1965,18 @@ and interp_atomic ist tac : unit Proofview.tactic = name_atomic ~env (TacLetTac(na,c,clp,b,eqpat)) (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*) - (let_pat_tac b (interp_fresh_name ist env sigma na) - ((sigma,sigma'),c) clp) sigma' eqpat) + (let_pat_tac b (interp_name ist env sigma na) + ((sigma,sigma'),c) clp eqpat) sigma') end (* Automation tactics *) | TacTrivial (debug,lems,l) -> + begin if debug == Tacexpr.Info then + msg_warning + (strbrk"The \"info_trivial\" tactic" ++ spc () + ++strbrk"does not print traces anymore." ++ spc() + ++strbrk"Use \"Info 1 trivial\", instead.") + end; Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in @@ -1986,6 +1988,12 @@ and interp_atomic ist tac : unit Proofview.tactic = (Option.map (List.map (interp_hint_base ist)) l)) end | TacAuto (debug,n,lems,l) -> + begin if debug == Tacexpr.Info then + msg_warning + (strbrk"The \"info_auto\" tactic" ++ spc () + ++strbrk"does not print traces anymore." ++ spc() + ++strbrk"Use \"Info 1 auto\", instead.") + end; Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in @@ -2067,7 +2075,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let l = List.map (fun (id1,id2) -> interp_hyp ist env sigma id1, - interp_fresh_ident ist env sigma (snd id2)) l + interp_ident ist env sigma (snd id2)) l in name_atomic ~env (TacRename l) @@ -2080,11 +2088,11 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let sigma, bll = List.fold_map (interp_bindings ist env) sigma bll in - let named_tac bll = + let named_tac = let tac = Tactics.split_with_bindings ev bll in name_atomic ~env (TacSplit (ev, bll)) tac in - Tacticals.New.tclWITHHOLES ev named_tac sigma bll + Tacticals.New.tclWITHHOLES ev named_tac sigma end (* Conversion *) | TacReduce (r,cl) -> @@ -2111,7 +2119,12 @@ and interp_atomic ist tac : unit Proofview.tactic = | AllOccurrences | NoOccurrences -> true | _ -> false in - let c_interp sigma = + let c_interp patvars sigma = + let lfun' = Id.Map.fold (fun id c lfun -> + Id.Map.add id (Value.of_constr c) lfun) + patvars ist.lfun + in + let ist = { ist with lfun = lfun' } in if is_onhyps && is_onconcl then interp_type ist (pf_env gl) sigma c else interp_constr ist (pf_env gl) sigma c @@ -2128,16 +2141,20 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in Proofview.V82.tactic begin fun gl -> - let sign,op = interp_typed_pattern ist env sigma op in + let (sigma,sign,op) = interp_typed_pattern ist env sigma op in let to_catch = function Not_found -> true | e -> Errors.is_anomaly e in - let env' = Environ.push_named_context sign env in - let c_interp sigma = - try interp_constr ist env' sigma c + let c_interp patvars sigma = + let lfun' = Id.Map.fold (fun id c lfun -> + Id.Map.add id (Value.of_constr c) lfun) + patvars ist.lfun + in + let ist = { ist with lfun = lfun' } in + try interp_constr ist env sigma c with e when to_catch e (* Hack *) -> errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") in - (Tactics.change (Some op) c_interp (interp_clause ist env sigma cl)) - gl + (Tactics.change (Some op) c_interp (interp_clause ist env sigma cl)) + { gl with sigma = sigma } end end end @@ -2184,10 +2201,10 @@ and interp_atomic ist tac : unit Proofview.tactic = in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let sigma,ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in - Proofview.Unsafe.tclEVARS sigma <*> - name_atomic ~env + Tacticals.New.tclWITHHOLES false + (name_atomic ~env (TacInversion(DepInversion(k,c_interp,ids),dqhyps)) - (Inv.dinv k c_interp ids_interp dqhyps) + (Inv.dinv k c_interp ids_interp dqhyps)) sigma end | TacInversion (NonDepInversion (k,idl,ids),hyp) -> Proofview.Goal.enter begin fun gl -> @@ -2196,10 +2213,10 @@ and interp_atomic ist tac : unit Proofview.tactic = let hyps = interp_hyp_list ist env sigma idl in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let sigma, ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in - Proofview.Unsafe.tclEVARS sigma <*> - name_atomic ~env + Tacticals.New.tclWITHHOLES false + (name_atomic ~env (TacInversion (NonDepInversion (k,hyps,ids),dqhyps)) - (Inv.inv_clause k ids_interp hyps dqhyps) + (Inv.inv_clause k ids_interp hyps dqhyps)) sigma end | TacInversion (InversionUsing (c,idl),hyp) -> Proofview.Goal.enter begin fun gl -> @@ -2241,8 +2258,7 @@ let interp_tac_gen lfun avoid_ids debug t = let ltacvars = Id.Map.domain lfun in interp_tactic ist (intern_pure_tactic { - ltacvars; ltacrecvars = Id.Map.empty; - genv = env } t) + ltacvars; genv = env } t) end let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t @@ -2252,8 +2268,7 @@ let _ = Proof_global.set_interp_tac interp (* [global] means that [t] should be internalized outside of goals. *) let hide_interp global t ot = let hide_interp env = - let ist = { ltacvars = Id.Set.empty; ltacrecvars = Id.Map.empty; - genv = env } in + let ist = { ltacvars = Id.Set.empty; genv = env } in let te = intern_pure_tactic ist t in let t = eval_tactic te in match ot with @@ -2349,39 +2364,7 @@ let _ = if has_type arg (glbwit wit_tactic) then let tac = out_gen (glbwit wit_tactic) arg in let tac = interp_tactic ist tac in - (** Save the initial side-effects to restore them afterwards. We set the - current set of side-effects to be empty so that we can retrieve the - ones created during the tactic invocation easily. *) - let eff = Evd.eval_side_effects sigma in - let sigma = Evd.drop_side_effects sigma in - (** Start a proof *) - let prf = Proof.start sigma [env, ty] in - let (prf, _) = - try Proof.run_tactic env tac prf - with Logic_monad.TacticFailure e as src -> - (** Catch the inner error of the monad tactic *) - let (_, info) = Errors.push src in - iraise (e, info) - in - (** Plug back the retrieved sigma *) - let sigma = Proof.in_proof prf (fun sigma -> sigma) in - let ans = match Proof.initial_goals prf with - | [c, _] -> c - | _ -> assert false - in - let ans = Reductionops.nf_evar sigma ans in - (** [neff] contains the freshly generated side-effects *) - let neff = Evd.eval_side_effects sigma in - (** Reset the old side-effects *) - let sigma = Evd.drop_side_effects sigma in - let sigma = Evd.emit_side_effects eff sigma in - (** Get rid of the fresh side-effects by internalizing them in the term - itself. Note that this is unsound, because the tactic may have solved - other goals that were already present during its invocation, so that - those goals rely on effects that are not present anymore. Hopefully, - this hack will work in most cases. *) - let ans = Term_typing.handle_side_effects env ans neff in - ans, sigma + Pfedit.refine_by_tactic env sigma ty tac else failwith "not a tactic" in diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml index 59cd065d..afffaffb 100644 --- a/tactics/tacsubst.ml +++ b/tactics/tacsubst.ml @@ -27,9 +27,8 @@ let subst_quantified_hypothesis _ x = x let subst_declared_or_quantified_hypothesis _ x = x -let subst_glob_constr_and_expr subst (c,e) = - assert (Option.is_empty e); (* e<>None only for toplevel tactics *) - (Detyping.subst_glob_constr subst c,None) +let subst_glob_constr_and_expr subst (c, e) = + (Detyping.subst_glob_constr subst c, e) let subst_glob_constr = subst_glob_constr_and_expr (* shortening *) @@ -100,20 +99,11 @@ let subst_evaluable subst = let subst_eval_ref = subst_evaluable_reference subst in subst_or_var (subst_and_short_name subst_eval_ref) -let subst_unfold subst (l,e) = - (l,subst_evaluable subst e) - -let subst_flag subst red = - { red with rConst = List.map (subst_evaluable subst) red.rConst } - let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) let subst_glob_constr_or_pattern subst (c,p) = (subst_glob_constr subst c,subst_pattern subst p) -let subst_pattern_with_occurrences subst (l,p) = - (l,subst_glob_constr_or_pattern subst p) - let subst_redexp subst = Miscops.map_red_expr_gen (subst_glob_constr subst) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index cf2126f8..9b16fe3f 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -16,7 +16,6 @@ open Context open Declarations open Tacmach open Clenv -open Misctypes (************************************************************************) (* Tacticals re-exported from the Refiner module *) @@ -494,26 +493,23 @@ module New = struct let (loc,_) = evi.Evd.evar_source in Pretype_errors.error_unsolvable_implicit loc env sigma evk None - let tclWITHHOLES accept_unresolved_holes tac sigma x = + let tclWITHHOLES accept_unresolved_holes tac sigma = tclEVARMAP >>= fun sigma_initial -> - if sigma == sigma_initial then tac x + if sigma == sigma_initial then tac else - let check_evars env new_sigma sigma initial_sigma = - try - check_evars env new_sigma sigma initial_sigma; - tclUNIT () - with e when Errors.noncritical e -> - tclZERO e - in - let check_evars_if = + let check_evars_if x = if not accept_unresolved_holes then tclEVARMAP >>= fun sigma_final -> tclENV >>= fun env -> - check_evars env sigma_final sigma sigma_initial + try + let () = check_evars env sigma_final sigma sigma_initial in + tclUNIT x + with e when Errors.noncritical e -> + tclZERO e else - tclUNIT () + tclUNIT x in - Proofview.Unsafe.tclEVARS sigma <*> tac x <*> check_evars_if + Proofview.Unsafe.tclEVARS sigma <*> tac >>= check_evars_if let tclTIMEOUT n t = Proofview.tclOR diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 6249bbc5..4e860892 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -6,14 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Loc open Pp open Names open Term open Context open Tacmach open Proof_type -open Clenv open Tacexpr open Locus open Misctypes @@ -220,7 +218,7 @@ module New : sig val tclCOMPLETE : 'a tactic -> 'a tactic val tclSOLVE : unit tactic list -> unit tactic val tclPROGRESS : unit tactic -> unit tactic - val tclWITHHOLES : bool -> ('a -> unit tactic) -> Evd.evar_map -> 'a -> unit tactic + val tclWITHHOLES : bool -> 'a tactic -> Evd.evar_map -> 'a tactic val tclTIMEOUT : int -> unit tactic -> unit tactic val tclTIME : string option -> 'a tactic -> 'a tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f1f1248d..7484139c 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -59,22 +59,7 @@ let dloc = Loc.ghost let typ_of = Retyping.get_type_of -(* Option for 8.4 compatibility *) open Goptions -let legacy_elim_if_not_fully_applied_argument = ref false - -let use_legacy_elim_if_not_fully_applied_argument () = - !legacy_elim_if_not_fully_applied_argument - || Flags.version_less_or_equal Flags.V8_4 - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "partially applied elimination argument legacy"; - optkey = ["Legacy";"Partially";"Applied";"Elimination";"Argument"]; - optread = (fun () -> !legacy_elim_if_not_fully_applied_argument) ; - optwrite = (fun b -> legacy_elim_if_not_fully_applied_argument := b) } (* Option for 8.2 compatibility *) let dependent_propositions_elimination = ref true @@ -440,7 +425,7 @@ let pf_reduce_decl redfun where (id,c,ty) gl = match c with | None -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str "has no value."); + errorlabstrm "" (pr_id id ++ str " has no value."); (id,None,redfun' ty) | Some b -> let b' = if where != InHypTypeOnly then redfun' b else b in @@ -537,7 +522,7 @@ let pf_e_reduce_decl redfun where (id,c,ty) gl = match c with | None -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str "has no value."); + errorlabstrm "" (pr_id id ++ str " has no value."); let sigma, ty' = redfun sigma ty in sigma, (id,None,ty') | Some b -> @@ -580,12 +565,16 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where (id,c,ty) env match c with | None -> if where == InHypValueOnly then - errorlabstrm "" (pr_id id ++ str "has no value."); + errorlabstrm "" (pr_id id ++ str " has no value."); let sigma',ty' = redfun false env sigma ty in sigma', (id,None,ty') | Some b -> - let sigma',b' = if where != InHypTypeOnly then redfun true env sigma b else sigma, b in - let sigma',ty' = if where != InHypValueOnly then redfun false env sigma ty else sigma', ty in + let sigma',b' = + if where != InHypTypeOnly then redfun true env sigma b else sigma, b + in + let sigma',ty' = + if where != InHypValueOnly then redfun false env sigma' ty else sigma', ty + in sigma', (id,Some b',ty') let e_change_in_hyp redfun (id,where) = @@ -595,7 +584,10 @@ let e_change_in_hyp redfun (id,where) = (Proofview.Goal.env gl) (Proofview.Goal.sigma gl)) convert_hyp -type change_arg = evar_map -> evar_map * constr +type change_arg = Pattern.patvar_map -> evar_map -> evar_map * constr + +let make_change_arg c = + fun pats sigma -> (sigma, replace_vars (Id.Map.bindings pats) c) let check_types env sigma mayneedglobalcheck deep newc origc = let t1 = Retyping.get_type_of env sigma newc in @@ -623,21 +615,15 @@ let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = if not b then errorlabstrm "convert-check-hyp" (str "Not convertible."); sigma, t' -let change_and_check_subst cv_pb mayneedglobalcheck subst t env sigma c = - let t' sigma = - let sigma, t = t sigma in - sigma, replace_vars (Id.Map.bindings subst) t - in change_and_check cv_pb mayneedglobalcheck true t' env sigma c - (* Use cumulativity only if changing the conclusion not a subterm *) let change_on_subterm cv_pb deep t where env sigma c = let mayneedglobalcheck = ref false in let sigma,c = match where with - | None -> change_and_check cv_pb mayneedglobalcheck deep t env sigma c + | None -> change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty) env sigma c | Some occl -> e_contextually false occl (fun subst -> - change_and_check_subst Reduction.CONV mayneedglobalcheck subst t) + change_and_check Reduction.CONV mayneedglobalcheck true (t subst)) env sigma c in if !mayneedglobalcheck then begin @@ -667,7 +653,7 @@ let change chg c cls gl = cls) gl let change_concl t = - change_in_concl None (fun sigma -> sigma, t) + change_in_concl None (make_change_arg t) (* Pour usage interne (le niveau User est pris en compte par reduce) *) let red_in_concl = reduct_in_concl (red_product,REVERTcast) @@ -780,8 +766,6 @@ let intro = intro_gen (NamingAvoid []) MoveLast false false let introf = intro_gen (NamingAvoid []) MoveLast true false let intro_avoiding l = intro_gen (NamingAvoid l) MoveLast false false -let intro_then_force = intro_then_gen (NamingAvoid []) MoveLast true false - let intro_move_avoid idopt avoid hto = match idopt with | None -> intro_gen (NamingAvoid avoid) hto true false | Some id -> intro_gen (NamingMustBe (dloc,id)) hto true false @@ -895,7 +879,7 @@ let msg_quantified_hypothesis = function | NamedHyp id -> str "quantified hypothesis named " ++ pr_id id | AnonHyp n -> - int n ++ str (match n with 1 -> "st" | 2 -> "nd" | _ -> "th") ++ + pr_nth n ++ str " non dependent hypothesis" let depth_of_quantified_hypothesis red h gl = @@ -1135,11 +1119,18 @@ let enforce_prop_bound_names rename tac = | _ -> tac +let rec contract_letin_in_lam_header c = + match kind_of_term c with + | Lambda (x,t,c) -> mkLambda (x,t,contract_letin_in_lam_header c) + | LetIn (x,b,t,c) -> contract_letin_in_lam_header (subst1 b c) + | _ -> c + let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ()) rename i (elim, elimty, bindings) indclause = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in + let elim = contract_letin_in_lam_header elim in let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in let indmv = (match kind_of_term (nth_arg i elimclause.templval.rebus) with @@ -1293,6 +1284,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in + let elim = contract_letin_in_lam_header elim in let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in let indmv = destMeta (nth_arg i elimclause.templval.rebus) in let hypmv = @@ -1518,7 +1510,7 @@ let apply_with_delayed_bindings_gen b e l = let env = Proofview.Goal.env gl in let sigma, cb = f env sigma in Tacticals.New.tclWITHHOLES e - (general_apply b b e k) sigma (loc,cb) + (general_apply b b e k (loc,cb)) sigma end in let rec aux = function @@ -1621,8 +1613,8 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam let sigma, c = f env sigma in Tacticals.New.tclWITHHOLES with_evars (apply_in_once sidecond_first with_delta with_destruct with_evars - naming id (clear_flag,(loc,c))) - sigma tac + naming id (clear_flag,(loc,c)) tac) + sigma end (* A useful resolution tactic which, if c:A->B, transforms |- C into @@ -1975,21 +1967,25 @@ let intro_decomp_eq_function = ref (fun _ -> failwith "Not implemented") let declare_intro_decomp_eq f = intro_decomp_eq_function := f let my_find_eq_data_decompose gl t = - try find_eq_data_decompose gl t + try Some (find_eq_data_decompose gl t) with e when is_anomaly e (* Hack in case equality is not yet defined... one day, maybe, known equalities will be dynamically registered *) - -> raise Constr_matching.PatternMatchingFailure + -> None + | Constr_matching.PatternMatchingFailure -> None let intro_decomp_eq loc l thin tac id = Proofview.Goal.nf_enter begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_type_of gl c in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in - let eq,u,eq_args = my_find_eq_data_decompose gl t in - !intro_decomp_eq_function + match my_find_eq_data_decompose gl t with + | Some (eq,u,eq_args) -> + !intro_decomp_eq_function (fun n -> tac ((dloc,id)::thin) (Some (true,n)) l) (eq,t,eq_args) (c, t) + | None -> + Tacticals.New.tclZEROMSG (str "Not a primitive equality here.") end let intro_or_and_pattern loc bracketed ll thin tac id = @@ -2151,12 +2147,12 @@ and intro_pattern_action loc b style pat thin tac id = match pat with let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let sigma,c = f env sigma in - Proofview.Unsafe.tclEVARS sigma <*> + Tacticals.New.tclWITHHOLES false (Tacticals.New.tclTHENFIRST (* Skip the side conditions of the apply *) (apply_in_once false true true true naming id - (None,(sigma,(c,NoBindings))) tac_ipat)) - (tac thin None []) + (None,(sigma,(c,NoBindings))) tac_ipat) (tac thin None [])) + sigma end and prepare_intros_loc loc dft = function @@ -2327,7 +2323,10 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let heq = match ido with | IntroAnonymous -> fresh_id_in_env [id] (add_prefix "Heq" id) env | IntroFresh heq_base -> fresh_id_in_env [id] heq_base env - | IntroIdentifier id -> id in + | IntroIdentifier id -> + if List.mem id (ids_of_named_context (named_context env)) then + user_err_loc (loc,"",pr_id id ++ str" is already used."); + id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in let sigma, eq = Evd.fresh_global env sigma eqdata.eq in @@ -2767,7 +2766,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = if Int.equal i nparams then let t = applist (hd, params@args) in Tacticals.New.tclTHEN - (change_in_hyp None (fun sigma -> sigma, t) (hyp0,InHypTypeOnly)) + (change_in_hyp None (make_change_arg t) (hyp0,InHypTypeOnly)) (tac avoid) else let c = List.nth argl (i-1) in @@ -2805,12 +2804,6 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = atomize_one (List.length argl) [] [] end -let find_atomic_param_of_ind nparams indtyp = - let argl = snd (decompose_app indtyp) in - let params,args = List.chop nparams argl in - let test c = isVar c && not (List.exists (dependent c) params) in - List.map destVar (List.filter test args) - (* [cook_sign] builds the lists [beforetoclear] (preceding the ind. var.) and [aftertoclear] (coming after the ind. var.) of hyps that must be erased, the lists of hyps to be generalize [decldeps] on the @@ -3668,6 +3661,7 @@ let induction_tac with_evars params indvars elim gl = let ({elimindex=i;elimbody=(elimc,lbindelimc);elimrename=rename},elimt) = elim in let i = match i with None -> index_of_ind_arg elimt | Some i -> i in (* elimclause contains this: (elimc ?i ?j ?k...?l) *) + let elimc = contract_letin_in_lam_header elimc in let elimc = mkCast (elimc, DEFAULTcast, elimt) in let elimclause = pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in @@ -3784,7 +3778,7 @@ let clear_unselected_context id inhyps cls gl = thin ids gl | None -> tclIDTAC gl -let use_bindings env sigma elim (c,lbind) typ = +let use_bindings env sigma elim must_be_closed (c,lbind) typ = let typ = if elim == None then (* w/o an scheme, the term has to be applied at least until @@ -3803,6 +3797,8 @@ let use_bindings env sigma elim (c,lbind) typ = let rec find_clause typ = try let indclause = make_clenv_binding env sigma (c,typ) lbind in + if must_be_closed && occur_meta (clenv_value indclause) then + error "Need a fully applied argument."; (* We lose the possibility of coercions in with-bindings *) pose_all_metas_as_evars env indclause.evd (clenv_value indclause) with e when catchable_exception e -> @@ -3848,7 +3844,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim let ccl = Proofview.Goal.raw_concl gl in let store = Proofview.Goal.extra gl in let check = check_enough_applied env sigma elim in - let (sigma',c) = use_bindings env sigma elim (c0,lbind) t0 in + let (sigma',c) = use_bindings env sigma elim false (c0,lbind) t0 in let abs = AbstractPattern (from_prefix,check,Name id,(pending,c),cls,false) in let (id,sign,_,lastlhyp,ccl,res) = make_abstraction env sigma' ccl abs in match res with @@ -3868,7 +3864,8 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim (Tacticals.New.tclTHENLIST [ Proofview.Unsafe.tclEVARS sigma; Proofview.Refine.refine ~unsafe:true (fun sigma -> - let (sigma,c) = use_bindings env sigma elim (c0,lbind) t0 in + let b = not with_evars && with_eq != None in + let (sigma,c) = use_bindings env sigma elim b (c0,lbind) t0 in let t = Retyping.get_type_of env sigma c in mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t)); Proofview.(if with_evars then shelve_unifiable else guard_no_unifiable); @@ -4411,11 +4408,6 @@ let tclABSTRACT name_op tac = in abstract_subproof s gk tac -let admit_as_an_axiom = - Proofview.tclUNIT () >>= fun () -> (* delay for Coqlib.build_coq_proof_admitted *) - simplest_case (Coqlib.build_coq_proof_admitted ()) <*> - Proofview.mark_as_unsafe - let unify ?(state=full_transparent_state) x y = Proofview.Goal.nf_enter begin fun gl -> try diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 6025883f..0069d100 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -125,8 +125,9 @@ val exact_proof : Constrexpr.constr_expr -> tactic type tactic_reduction = env -> evar_map -> constr -> constr -type change_arg = evar_map -> evar_map * constr +type change_arg = patvar_map -> evar_map -> evar_map * constr +val make_change_arg : constr -> change_arg val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> tactic val reduct_option : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> tactic val reduct_in_concl : tactic_reduction * cast_kind -> tactic @@ -393,8 +394,6 @@ val unify : ?state:Names.transparent_state -> constr -> constr -> unit val tclABSTRACT : Id.t option -> unit Proofview.tactic -> unit Proofview.tactic -val admit_as_an_axiom : unit Proofview.tactic - val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> Id.t -> unit Proofview.tactic val specialize_eqs : Id.t -> tactic diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index e637b2e3..e79fc6dc 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -371,6 +371,17 @@ struct let find_all dn = Idset.elements (TDnet.find_all dn) let map f dn = TDnet.map f (fun x -> x) dn + + let refresh_metas dn = + let new_metas = ref Int.Map.empty in + let refresh_one_meta i = + try Int.Map.find i !new_metas + with Not_found -> + let new_meta = fresh_meta () in + let () = new_metas := Int.Map.add i new_meta !new_metas in + new_meta + in + TDnet.map_metas refresh_one_meta dn end module type S = @@ -385,4 +396,5 @@ sig val search_pattern : t -> constr -> ident list val find_all : t -> ident list val map : (ident -> ident) -> t -> t + val refresh_metas : t -> t end diff --git a/tactics/term_dnet.mli b/tactics/term_dnet.mli index a5c80cc0..58f95ac6 100644 --- a/tactics/term_dnet.mli +++ b/tactics/term_dnet.mli @@ -80,6 +80,8 @@ sig val find_all : t -> ident list val map : (ident -> ident) -> t -> t + + val refresh_metas : t -> t end module Make : diff --git a/test-suite/Makefile b/test-suite/Makefile index 4a3a287c..cffbe481 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -273,6 +273,7 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out | grep -v "Welcome to Coq" \ | grep -v "\[Loading ML file" \ | grep -v "Skipping rcfile loading" \ + | grep -v "^<W>" \ > $$tmpoutput; \ diff -u $*.out $$tmpoutput 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ diff --git a/test-suite/_CoqProject b/test-suite/_CoqProject new file mode 100644 index 00000000..dc121311 --- /dev/null +++ b/test-suite/_CoqProject @@ -0,0 +1 @@ +-Q prerequisite TestSuite diff --git a/test-suite/bugs/closed/1704.v b/test-suite/bugs/closed/1704.v index 4b02d5f9..7d8ba5b8 100644 --- a/test-suite/bugs/closed/1704.v +++ b/test-suite/bugs/closed/1704.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Require Import Setoid. Parameter E : nat -> nat -> Prop. diff --git a/test-suite/bugs/closed/2378.v b/test-suite/bugs/closed/2378.v index 35c69db2..85ad41d1 100644 --- a/test-suite/bugs/closed/2378.v +++ b/test-suite/bugs/closed/2378.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* test with Coq 8.3rc1 *) Require Import Program. diff --git a/test-suite/bugs/closed/2406.v b/test-suite/bugs/closed/2406.v index 1bd66ffc..3766e795 100644 --- a/test-suite/bugs/closed/2406.v +++ b/test-suite/bugs/closed/2406.v @@ -1,6 +1,6 @@ (* Check correct handling of unsupported notations *) Notation "''" := (fun x => x) (at level 20). -(* This fails with a syntax error but it is not catched by Fail +(* This fails with a syntax error but it is not caught by Fail Fail Definition crash_the_rooster f := . *) diff --git a/test-suite/bugs/closed/2473.v b/test-suite/bugs/closed/2473.v index 4c302512..fb676c7e 100644 --- a/test-suite/bugs/closed/2473.v +++ b/test-suite/bugs/closed/2473.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Require Import Relations Program Setoid Morphisms. diff --git a/test-suite/bugs/closed/2590.v b/test-suite/bugs/closed/2590.v new file mode 100644 index 00000000..4300de16 --- /dev/null +++ b/test-suite/bugs/closed/2590.v @@ -0,0 +1,20 @@ +Require Import TestSuite.admit. +Require Import Relation_Definitions RelationClasses Setoid SetoidClass. + +Section Bug. + + Context {A : Type} (R : relation A). + Hypothesis pre : PreOrder R. + Context `{SA : Setoid A}. + + Goal True. + set (SA' := SA). + assert ( forall SA0 : Setoid A, + @PartialOrder A (@equiv A SA0) (@setoid_equiv A SA0) R pre ). + rename SA into SA0. + intro SA. + admit. + admit. +Qed. +End Bug. + diff --git a/test-suite/bugs/closed/2602.v b/test-suite/bugs/closed/2602.v new file mode 100644 index 00000000..f0744788 --- /dev/null +++ b/test-suite/bugs/closed/2602.v @@ -0,0 +1,8 @@ +Goal exists m, S m > 0. +eexists. +match goal with + | |- context [ S ?a ] => + match goal with + | |- S a > 0 => idtac + end +end.
\ No newline at end of file diff --git a/test-suite/bugs/closed/2613.v b/test-suite/bugs/closed/2613.v index 4f0470b1..15f3bf52 100644 --- a/test-suite/bugs/closed/2613.v +++ b/test-suite/bugs/closed/2613.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* Check that eq_sym is still pointing to Logic.eq_sym after use of Function *) Require Import ZArith. diff --git a/test-suite/bugs/closed/2615.v b/test-suite/bugs/closed/2615.v index dde6a6a5..38c1cfc8 100644 --- a/test-suite/bugs/closed/2615.v +++ b/test-suite/bugs/closed/2615.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* This failed with an anomaly in pre-8.4 because of let-in not properly taken into account in the test for unification pattern *) diff --git a/test-suite/bugs/closed/2775.v b/test-suite/bugs/closed/2775.v new file mode 100644 index 00000000..f1f384bd --- /dev/null +++ b/test-suite/bugs/closed/2775.v @@ -0,0 +1,6 @@ +Inductive typ : forall (T:Type), list T -> Type -> Prop := + | Get : forall (T:Type) (l:list T), typ T l T. + + +Derive Inversion inv with +(forall (X: Type) (y: list nat), typ nat y X) Sort Prop. diff --git a/test-suite/bugs/closed/2830.v b/test-suite/bugs/closed/2830.v index b72c821d..bb607b78 100644 --- a/test-suite/bugs/closed/2830.v +++ b/test-suite/bugs/closed/2830.v @@ -123,6 +123,7 @@ Module C. Reserved Notation "a ~> b" (at level 70, right associativity). Reserved Notation "a ≈ b" (at level 54). +Reserved Notation "a ∘ b" (at level 50, left associativity). Generalizable All Variables. Class Category (Object:Type) (Hom:Object -> Object -> Type) := { diff --git a/test-suite/bugs/closed/2883.v b/test-suite/bugs/closed/2883.v index 5a5d90a4..f027b5eb 100644 --- a/test-suite/bugs/closed/2883.v +++ b/test-suite/bugs/closed/2883.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Require Import List. Require Import Coq.Program.Equality. diff --git a/test-suite/bugs/closed/2946.v b/test-suite/bugs/closed/2946.v new file mode 100644 index 00000000..d8138e14 --- /dev/null +++ b/test-suite/bugs/closed/2946.v @@ -0,0 +1,8 @@ +Lemma toto (E : nat -> nat -> Prop) (x y : nat) + (Ex_ : forall z, E x z) (E_y : forall z, E z y) : True. + +(* OK *) +assert (pairE1 := let Exy := _ in (Ex_ y, E_y _) : Exy * Exy). + +(* FAIL *) +assert (pairE2 := let Exy := _ in (Ex_ _, E_y x) : Exy * Exy). diff --git a/test-suite/bugs/closed/2951.v b/test-suite/bugs/closed/2951.v new file mode 100644 index 00000000..87d54441 --- /dev/null +++ b/test-suite/bugs/closed/2951.v @@ -0,0 +1,2 @@ +Record C (A: Type) : Type := { f: A }. +Existing Class C. diff --git a/test-suite/bugs/closed/2969.v b/test-suite/bugs/closed/2969.v index ff75a1f3..a03adbd7 100644 --- a/test-suite/bugs/closed/2969.v +++ b/test-suite/bugs/closed/2969.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* Check that Goal.V82.byps and Goal.V82.env are consistent *) (* This is a shorten variant of the initial bug which raised anomaly *) diff --git a/test-suite/bugs/closed/2996.v b/test-suite/bugs/closed/2996.v index 440cda61..d5409289 100644 --- a/test-suite/bugs/closed/2996.v +++ b/test-suite/bugs/closed/2996.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* Test on definitions referring to section variables that are not any longer in the current context *) diff --git a/test-suite/bugs/closed/3068.v b/test-suite/bugs/closed/3068.v index 03e5af61..ced6d959 100644 --- a/test-suite/bugs/closed/3068.v +++ b/test-suite/bugs/closed/3068.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Section Counted_list. Variable A : Type. diff --git a/test-suite/bugs/opened/3071.v b/test-suite/bugs/closed/3071.v index 611ac606..53c2ef7b 100644 --- a/test-suite/bugs/opened/3071.v +++ b/test-suite/bugs/closed/3071.v @@ -2,4 +2,4 @@ Definition foo := True. Section foo. Global Arguments foo / . -Fail End foo. +End foo. diff --git a/test-suite/bugs/closed/3199.v b/test-suite/bugs/closed/3199.v new file mode 100644 index 00000000..08bf6249 --- /dev/null +++ b/test-suite/bugs/closed/3199.v @@ -0,0 +1,18 @@ +Axiom P : nat -> Prop. +Axiom admit : forall n : nat, P n -> P n -> n = S n. +Axiom foo : forall n, P n. + +Create HintDb bar. +Hint Extern 3 => symmetry : bar. +Hint Resolve admit : bar. +Hint Immediate foo : bar. + +Lemma qux : forall n : nat, n = S n. +Proof. +intros n. +eauto with bar. +Defined. + +Goal True. +pose (e := eq_refl (qux 0)); unfold qux in e. +match type of e with context [eq_sym] => fail 1 | _ => idtac end. diff --git a/test-suite/bugs/closed/3210.v b/test-suite/bugs/closed/3210.v new file mode 100644 index 00000000..bb673f38 --- /dev/null +++ b/test-suite/bugs/closed/3210.v @@ -0,0 +1,22 @@ +(* Test support of let-in in arity of inductive types *) + +Inductive Foo : let X := Set in X := +| I : Foo. + +Definition foo (x : Foo) : bool := + match x with + I => true + end. + +Definition foo' (x : Foo) : x = x. +case x. +match goal with |- I = I => idtac end. (* check form of the goal *) +Undo 2. +elim x. +match goal with |- I = I => idtac end. (* check form of the goal *) +Undo 2. +induction x. +match goal with |- I = I => idtac end. (* check form of the goal *) +Undo 2. +destruct x. +match goal with |- I = I => idtac end. (* check form of the goal *) diff --git a/test-suite/bugs/closed/3249.v b/test-suite/bugs/closed/3249.v new file mode 100644 index 00000000..d41d2317 --- /dev/null +++ b/test-suite/bugs/closed/3249.v @@ -0,0 +1,11 @@ +Set Implicit Arguments. + +Ltac ret_and_left T := + let t := type of T in + lazymatch eval hnf in t with + | ?a /\ ?b => constr:(proj1 T) + | forall x : ?T', @?f x => + constr:(fun x : T' => $(let fx := constr:(T x) in + let t := ret_and_left fx in + exact t)$) + end. diff --git a/test-suite/bugs/closed/3258.v b/test-suite/bugs/closed/3258.v index a1390e30..b263c6ba 100644 --- a/test-suite/bugs/closed/3258.v +++ b/test-suite/bugs/closed/3258.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Require Import Coq.Classes.Morphisms Coq.Classes.RelationClasses Coq.Program.Program Coq.Setoids.Setoid. Global Set Implicit Arguments. diff --git a/test-suite/bugs/closed/3259.v b/test-suite/bugs/closed/3259.v index 0306c686..aa91fc3d 100644 --- a/test-suite/bugs/closed/3259.v +++ b/test-suite/bugs/closed/3259.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Goal forall m n, n+n = m+m -> m+m = m+m. Proof. intros. diff --git a/test-suite/bugs/opened/3298.v b/test-suite/bugs/closed/3298.v index bce7c3f2..f07ee1e6 100644 --- a/test-suite/bugs/opened/3298.v +++ b/test-suite/bugs/closed/3298.v @@ -1,11 +1,11 @@ +Require Import TestSuite.admit. Module JGross. Hint Extern 1 => match goal with |- match ?E with end => case E end. Goal forall H : False, match H return Set with end. Proof. intros. - Fail solve [ eauto ]. (* No applicable tactic *) - admit. + solve [ eauto ]. Qed. End JGross. @@ -17,7 +17,6 @@ Section BenDelaware. Qed. Goal forall (H : False), match H return Set with end. Proof. - Fail solve [ eauto ] . - admit. + solve [ eauto ] . Qed. End BenDelaware. diff --git a/test-suite/bugs/closed/3309.v b/test-suite/bugs/closed/3309.v index fcebdec7..98043157 100644 --- a/test-suite/bugs/closed/3309.v +++ b/test-suite/bugs/closed/3309.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* -*- coq-prog-args: ("-emacs" "-impredicative-set") -*- *) (* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines *) Set Universe Polymorphism. @@ -321,6 +322,13 @@ Definition ispartlbinopabmonoidfracrel_type : Type := forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ), @abmonoidfracrel X A ( ( admit + z ) )admit. -Axiom ispartlbinopabmonoidfracrel : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in +Fail Timeout 1 Axiom ispartlbinopabmonoidfracrel' : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in + ispartlbinopabmonoidfracrel_type in exact t)$. + +Unset Kernel Term Sharing. + +Axiom ispartlbinopabmonoidfracrel : forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ) , @abmonoidfracrel X A ( ( admit + z ) )admit. + +Axiom ispartlbinopabmonoidfracrel' : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in ispartlbinopabmonoidfracrel_type in exact t)$. diff --git a/test-suite/bugs/closed/3314.v b/test-suite/bugs/closed/3314.v index 64786263..e63c46da 100644 --- a/test-suite/bugs/closed/3314.v +++ b/test-suite/bugs/closed/3314.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Set Universe Polymorphism. Definition Lift : $(let U1 := constr:(Type) in diff --git a/test-suite/bugs/closed/3319.v b/test-suite/bugs/closed/3319.v index bb5853dd..3b37e39e 100644 --- a/test-suite/bugs/closed/3319.v +++ b/test-suite/bugs/closed/3319.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 5353 lines to 4545 lines, then from 4513 lines to 4504 lines, then from 4515 lines to 4508 lines, then from 4519 lines to 132 lines, then from 111 lines to 66 lines, then from 68 lines to 35 lines *) Set Implicit Arguments. Inductive paths {A : Type} (a : A) : A -> Type := diff --git a/test-suite/bugs/closed/3321.v b/test-suite/bugs/closed/3321.v index 07e3b3cb..b6f10e53 100644 --- a/test-suite/bugs/closed/3321.v +++ b/test-suite/bugs/closed/3321.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 5302 lines to 4649 lines, then from 4660 lines to 355 lines, then from 360 lines to 269 lines, then from 269 lines to 175 lines, then from 144 lines to 119 lines, then from 103 lines to 83 lines, then from 86 lines to 36 lines, then from 37 lines to 17 lines *) Axiom admit : forall {T}, T. diff --git a/test-suite/bugs/closed/3322.v b/test-suite/bugs/closed/3322.v index 925f22a2..ab3025a6 100644 --- a/test-suite/bugs/closed/3322.v +++ b/test-suite/bugs/closed/3322.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 11971 lines to 11753 lines, then from 7702 lines to 564 lines, then from 571 lines to 61 lines *) Set Asymmetric Patterns. Axiom admit : forall {T}, T. diff --git a/test-suite/bugs/closed/3323.v b/test-suite/bugs/closed/3323.v index fb5a8a7e..22b1603b 100644 --- a/test-suite/bugs/closed/3323.v +++ b/test-suite/bugs/closed/3323.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* -*- coq-prog-args: ("-emacs" "-indices-matter") -*- *) (* File reduced by coq-bug-finder from original input, then from 5302 lines to 4649 lines, then from 4660 lines to 355 lines, then from 360 lines to 269 lines, then from 269 lines to 175 lines, then from 144 lines to 119 lines, then from 297 lines to 117 lines, then from 95 lines to 79 lines, then from 82 lines to 68 lines *) diff --git a/test-suite/bugs/closed/3324.v b/test-suite/bugs/closed/3324.v index 9cd6e4c2..45dbb57a 100644 --- a/test-suite/bugs/closed/3324.v +++ b/test-suite/bugs/closed/3324.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Module ETassi. Axiom admit : forall {T}, T. Class IsHProp (A : Type) : Type := {}. diff --git a/test-suite/bugs/closed/3329.v b/test-suite/bugs/closed/3329.v index f7e368f8..ecb09e84 100644 --- a/test-suite/bugs/closed/3329.v +++ b/test-suite/bugs/closed/3329.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 12095 lines to 869 lines, then from 792 lines to 504 lines, then from 487 lines to 353 lines, then from 258 lines to 174 lines, then from 164 lines to 132 lines, then from 129 lines to 99 lines *) Set Universe Polymorphism. Generalizable All Variables. diff --git a/test-suite/bugs/closed/3330.v b/test-suite/bugs/closed/3330.v index 15303cca..4cd7c39e 100644 --- a/test-suite/bugs/closed/3330.v +++ b/test-suite/bugs/closed/3330.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 12106 lines to 1070 lines *) Set Universe Polymorphism. Definition setleq (A : Type@{i}) (B : Type@{j}) := A : Type@{j}. diff --git a/test-suite/bugs/closed/3344.v b/test-suite/bugs/closed/3344.v index 8255fd6c..880851c5 100644 --- a/test-suite/bugs/closed/3344.v +++ b/test-suite/bugs/closed/3344.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 716 lines to 197 lines, then from 206 lines to 162 lines, then from 163 lines to 73 lines *) Require Import Coq.Sets.Ensembles. Require Import Coq.Strings.String. diff --git a/test-suite/bugs/closed/3347.v b/test-suite/bugs/closed/3347.v index 37c0d87e..63d5c7a5 100644 --- a/test-suite/bugs/closed/3347.v +++ b/test-suite/bugs/closed/3347.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 12653 lines to 12453 lines, then from 11673 lines to 681 lines, then from 693 lines to 469 lines, then from 375 lines to 56 lines *) Set Universe Polymorphism. Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing). diff --git a/test-suite/bugs/closed/3350.v b/test-suite/bugs/closed/3350.v index 30fdf169..c041c401 100644 --- a/test-suite/bugs/closed/3350.v +++ b/test-suite/bugs/closed/3350.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Require Coq.Vectors.Fin. Require Coq.Vectors.Vector. diff --git a/test-suite/bugs/closed/3373.v b/test-suite/bugs/closed/3373.v index 5ecf2801..051e6952 100644 --- a/test-suite/bugs/closed/3373.v +++ b/test-suite/bugs/closed/3373.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then diff --git a/test-suite/bugs/closed/3374.v b/test-suite/bugs/closed/3374.v index 3c67703a..d8e72f4f 100644 --- a/test-suite/bugs/closed/3374.v +++ b/test-suite/bugs/closed/3374.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines, then from 331 lines to 59 lines *) Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/3375.v b/test-suite/bugs/closed/3375.v index fe323fcb..d7ce02ea 100644 --- a/test-suite/bugs/closed/3375.v +++ b/test-suite/bugs/closed/3375.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* -*- mode: coq; coq-prog-args: ("-emacs" "-impredicative-set") -*- *) (* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines, then from 330 lines to 45 lines *) diff --git a/test-suite/bugs/closed/3382.v b/test-suite/bugs/closed/3382.v index 1d8e9167..3e374d90 100644 --- a/test-suite/bugs/closed/3382.v +++ b/test-suite/bugs/closed/3382.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from 9039 lines to 7786 lines, then from 7245 lines to 476 lines, then from 417 lines to 249 lines, then from 171 lines to 127 lines, then from 139 lines to 114 lines, then from 93 lines to 77 lines *) Set Implicit Arguments. diff --git a/test-suite/bugs/closed/3392.v b/test-suite/bugs/closed/3392.v index 29ee1487..3a598695 100644 --- a/test-suite/bugs/closed/3392.v +++ b/test-suite/bugs/closed/3392.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 12105 lines to 142 lines, then from 83 lines to 57 lines *) Generalizable All Variables. Axiom admit : forall {T}, T. @@ -24,9 +25,8 @@ Proof. intros. refine (isequiv_adjointify (functor_forall f g) (functor_forall (f^-1) - (fun (x:A) (y:Q (f^-1 x)) => @eisretr _ _ f _ x # (g (f^-1 x))^-1 y - )) _ _); - intros h. + (fun (x:A) (y:Q (f^-1 x)) => @eisretr _ _ f H x # (g (f^-1 x))^-1 y + )) _ _); intros h. - abstract ( apply path_forall; intros b; unfold functor_forall; rewrite eisadj; @@ -37,4 +37,4 @@ Proof. rewrite eissect; apply apD ). -Defined. +Defined.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3393.v b/test-suite/bugs/closed/3393.v index ec25e682..f7ab5f76 100644 --- a/test-suite/bugs/closed/3393.v +++ b/test-suite/bugs/closed/3393.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* -*- coq-prog-args: ("-emacs" "-indices-matter") -*- *) (* File reduced by coq-bug-finder from original input, then from 8760 lines to 7519 lines, then from 7050 lines to 909 lines, then from 846 lines to 578 lines, then from 497 lines to 392 lines, then from 365 lines to 322 lines, then from 252 lines to 205 lines, then from 215 lines to 204 lines, then from 210 lines to 182 lines, then from 175 lines to 157 lines *) Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/3422.v b/test-suite/bugs/closed/3422.v index d984f623..460ae8f1 100644 --- a/test-suite/bugs/closed/3422.v +++ b/test-suite/bugs/closed/3422.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Generalizable All Variables. Set Implicit Arguments. Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/3427.v b/test-suite/bugs/closed/3427.v index 8483a4ec..374a5392 100644 --- a/test-suite/bugs/closed/3427.v +++ b/test-suite/bugs/closed/3427.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) (* File reduced by coq-bug-finder from original input, then from 0 lines to 7171 lines, then from 7184 lines to 558 lines, then from 556 lines to 209 lines *) Generalizable All Variables. diff --git a/test-suite/bugs/closed/3439.v b/test-suite/bugs/closed/3439.v index bba6140f..1ea24bf1 100644 --- a/test-suite/bugs/closed/3439.v +++ b/test-suite/bugs/closed/3439.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 3154 lines to 149 lines, then from 89 lines to 55 lines, then from 44 lines to 20 lines *) Set Primitive Projections. Generalizable All Variables. diff --git a/test-suite/bugs/opened/3467.v b/test-suite/bugs/closed/3467.v index 900bfc34..7e371162 100644 --- a/test-suite/bugs/opened/3467.v +++ b/test-suite/bugs/closed/3467.v @@ -2,5 +2,5 @@ Module foo. Notation x := $(exact I)$. End foo. Module bar. - Fail Include foo. + Include foo. End bar. diff --git a/test-suite/bugs/closed/3480.v b/test-suite/bugs/closed/3480.v index 99ac2efa..a81837e7 100644 --- a/test-suite/bugs/closed/3480.v +++ b/test-suite/bugs/closed/3480.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Set Primitive Projections. Axiom admit : forall {T}, T. Notation "( x ; y )" := (existT _ x y) : fibration_scope. diff --git a/test-suite/bugs/closed/3484.v b/test-suite/bugs/closed/3484.v index 6c40a426..dc88a332 100644 --- a/test-suite/bugs/closed/3484.v +++ b/test-suite/bugs/closed/3484.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 14259 lines to 305 lines, then from 237 lines to 120 lines, then from 100 lines to 30 lines *) Set Primitive Projections. Set Implicit Arguments. diff --git a/test-suite/bugs/opened/3490.v b/test-suite/bugs/closed/3490.v index e7a5caa1..e7a5caa1 100644 --- a/test-suite/bugs/opened/3490.v +++ b/test-suite/bugs/closed/3490.v diff --git a/test-suite/bugs/closed/3491.v b/test-suite/bugs/closed/3491.v new file mode 100644 index 00000000..fd394ddb --- /dev/null +++ b/test-suite/bugs/closed/3491.v @@ -0,0 +1,4 @@ +(* Was failing while building the _rect scheme, due to wrong computation of *) +(* the number of non recursively uniform parameters in the presence of let-ins*) +Inductive list (A : Type) (T := A) : Type := + nil : list A | cons : T -> list T -> list A. diff --git a/test-suite/bugs/closed/3513.v b/test-suite/bugs/closed/3513.v new file mode 100644 index 00000000..fcdfa005 --- /dev/null +++ b/test-suite/bugs/closed/3513.v @@ -0,0 +1,76 @@ +Require Import TestSuite.admit. +(* File reduced by coq-bug-finder from original input, then from 5752 lines to 3828 lines, then from 2707 lines to 558 lines, then from 472 lines to 168 lines, then from 110 lines to 101 lines, then from 96 lines to 77 lines, then from 80 lines to 64 lines *) +Require Coq.Setoids.Setoid. +Import Coq.Setoids.Setoid. +Generalizable All Variables. +Axiom admit : forall {T}, T. +Class Equiv (A : Type) := equiv : relation A. +Class type (A : Type) {e : Equiv A} := eq_equiv : Equivalence equiv. +Class ILogicOps Frm := { lentails: relation Frm; + ltrue: Frm; + land: Frm -> Frm -> Frm; + lor: Frm -> Frm -> Frm }. +Infix "|--" := lentails (at level 79, no associativity). +Class ILogic Frm {ILOps: ILogicOps Frm} := { lentailsPre:> PreOrder lentails }. +Definition lequiv `{ILogic Frm} P Q := P |-- Q /\ Q |-- P. +Infix "-|-" := lequiv (at level 85, no associativity). +Instance lequiv_inverse_lentails `{ILogic Frm} : subrelation lequiv (inverse lentails) := admit. +Record ILFunFrm (T : Type) `{e : Equiv T} `{ILOps : ILogicOps Frm} := mkILFunFrm { ILFunFrm_pred :> T -> Frm }. +Section ILogic_Fun. + Context (T: Type) `{TType: type T}. + Context `{IL: ILogic Frm}. + Local Instance ILFun_Ops : ILogicOps (@ILFunFrm T _ Frm _) := admit. + Definition ILFun_ILogic : ILogic (@ILFunFrm T _ Frm _) := admit. +End ILogic_Fun. +Implicit Arguments ILFunFrm [[ILOps] [e]]. +Instance ILogicOps_Prop : ILogicOps Prop | 2 := {| lentails P Q := (P : Prop) -> Q; + ltrue := True; + land P Q := P /\ Q; + lor P Q := P \/ Q |}. +Axiom Action : Set. +Definition Actions := list Action. +Instance ActionsEquiv : Equiv Actions := { equiv a1 a2 := a1 = a2 }. +Definition OPred := ILFunFrm Actions Prop. +Local Existing Instance ILFun_Ops. +Local Existing Instance ILFun_ILogic. +Definition catOP (P Q: OPred) : OPred := admit. +Add Parametric Morphism : catOP with signature lentails ==> lentails ==> lentails as catOP_entails_m. +admit. +Defined. +Definition catOPA (P Q R : OPred) : catOP (catOP P Q) R -|- catOP P (catOP Q R) := admit. +Class IsPointed (T : Type) := point : T. +Notation IsPointed_OPred P := (IsPointed (exists x : Actions, (P : OPred) x)). +Record PointedOPred := mkPointedOPred { + OPred_pred :> OPred; + OPred_inhabited: IsPointed_OPred OPred_pred + }. +Existing Instance OPred_inhabited. +Canonical Structure default_PointedOPred O `{IsPointed_OPred O} : PointedOPred + := {| OPred_pred := O ; OPred_inhabited := _ |}. +Instance IsPointed_catOP `{IsPointed_OPred P, IsPointed_OPred Q} : IsPointed_OPred (catOP P Q) := admit. +Goal forall (T : Type) (O0 : T -> OPred) (O1 : T -> PointedOPred) + (tr : T -> T) (O2 : PointedOPred) (x : T) + (H : forall x0 : T, catOP (O0 x0) (O1 (tr x0)) |-- O1 x0), + exists e1 e2, + catOP (O0 e1) (OPred_pred e2) |-- catOP (O1 x) O2. + intros; do 2 esplit. + rewrite <- catOPA. + lazymatch goal with + | |- ?R (?f ?a ?b) (?f ?a' ?b') => + let P := constr:(fun H H' => @Morphisms.proper_prf (OPred -> OPred -> OPred) + (@Morphisms.respectful OPred (OPred -> OPred) + (@lentails OPred + (@ILFun_Ops Actions ActionsEquiv Prop ILogicOps_Prop)) + (@lentails OPred + (@ILFun_Ops Actions ActionsEquiv Prop ILogicOps_Prop) ==> + @lentails OPred + (@ILFun_Ops Actions ActionsEquiv Prop ILogicOps_Prop))) catOP + catOP_entails_m_Proper a a' H b b' H') in + pose P; + refine (P _ _) + end; unfold Basics.flip. + 2: solve [ apply reflexivity ]. + Undo. + 2: reflexivity. (* Toplevel input, characters 18-29: +Error: +Tactic failure: The relation lentails is not a declared reflexive relation. Maybe you need to require the Setoid library. *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3531.v b/test-suite/bugs/closed/3531.v index fd080a6b..764a7334 100644 --- a/test-suite/bugs/closed/3531.v +++ b/test-suite/bugs/closed/3531.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 270 lines to 198 lines, then from 178 lines to 82 lines, then from 88 lines to 59 lines *) (* coqc version trunk (August 2014) compiled on Aug 19 2014 14:40:15 with OCaml diff --git a/test-suite/bugs/closed/3560.v b/test-suite/bugs/closed/3560.v new file mode 100644 index 00000000..65ce4fb6 --- /dev/null +++ b/test-suite/bugs/closed/3560.v @@ -0,0 +1,15 @@ + +(* File reduced by coq-bug-finder from original input, then from 6236 lines to 1049 lines, then from 920 lines to 209 lines, then from 179 lines to 30 lines *) +(* coqc version trunk (August 2014) compiled on Aug 31 2014 10:12:32 with OCaml 4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (437b91a3ffd7327975a129b95b24d3f66ad7f3e4) *) + +Set Primitive Projections. +Set Implicit Arguments. +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Notation "x * y" := (prod x y) : type_scope. +Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv : forall P, P equiv_fun }. +Goal forall (A B : Type) (C : Type), Equiv (A -> B -> C) (A * B -> C). +Proof. + intros. + exists (fun u => fun x => u (fst x) (snd x)). +Abort.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3561.v b/test-suite/bugs/closed/3561.v index b4dfd17f..f6cbc929 100644 --- a/test-suite/bugs/closed/3561.v +++ b/test-suite/bugs/closed/3561.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 6343 lines to 2362 lines, then from 2115 lines to 303 lines, then from 321 lines to 90 lines, then from 95 lines to 41 lines *) (* coqc version trunk (August 2014) compiled on Aug 31 2014 10:12:32 with OCaml 4.01.0 coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (437b91a3ffd7327975a129b95b24d3f66ad7f3e4) *) diff --git a/test-suite/bugs/closed/3590.v b/test-suite/bugs/closed/3590.v new file mode 100644 index 00000000..3ef9270d --- /dev/null +++ b/test-suite/bugs/closed/3590.v @@ -0,0 +1,12 @@ +Set Implicit Arguments. +Record prod A B := pair { fst : A ; snd : B }. +Definition idS := Set. +Goal forall x y : prod Set Set, forall H : fst x = fst y, fst x = fst y. + intros. + change (@fst _ _ ?z) with (@fst Set idS z) at 2. + apply H. +Qed. + +(* Toplevel input, characters 20-58: +Error: Failed to get enough information from the left-hand side to type the +right-hand side. *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3596.v b/test-suite/bugs/closed/3596.v index d6c1c949..49dd7be5 100644 --- a/test-suite/bugs/closed/3596.v +++ b/test-suite/bugs/closed/3596.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Set Implicit Arguments. Record foo := { fx : nat }. Set Primitive Projections. diff --git a/test-suite/bugs/closed/3612.v b/test-suite/bugs/closed/3612.v new file mode 100644 index 00000000..9125ab16 --- /dev/null +++ b/test-suite/bugs/closed/3612.v @@ -0,0 +1,47 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter" "-nois") -*- *) +(* File reduced by coq-bug-finder from original input, then from 3595 lines to 3518 lines, then from 3133 lines to 2950 lines, then from 2911 lines to 415 lines, then from 431 lines to 407 \ +lines, then from 421 lines to 428 lines, then from 444 lines to 429 lines, then from 434 lines to 66 lines, then from 163 lines to 48 lines *) +(* coqc version trunk (September 2014) compiled on Sep 11 2014 14:48:8 with OCaml 4.01.0 + coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (580b25e05c7cc9e7a31430b3d9edb14ae12b7598) *) +Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). +Reserved Notation "x = y :> T" (at level 70, y at next level, no associativity). +Reserved Notation "x = y" (at level 70, no associativity). +Open Scope type_scope. +Global Set Universe Polymorphism. +Notation "A -> B" := (forall (_ : A), B) : type_scope. +Generalizable All Variables. +Local Set Primitive Projections. +Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. +Arguments projT1 {A P} _ / . +Arguments projT2 {A P} _ / . +Notation "( x ; y )" := (existT _ x y) : fibration_scope. +Open Scope fibration_scope. +Notation pr1 := projT1. +Notation pr2 := projT2. +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. +Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y . +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope. +Local Open Scope path_scope. +Axiom pr1_path : forall `{P : A -> Type} {u v : sigT P} (p : u = v), u.1 = v.1. +Notation "p ..1" := (pr1_path p) (at level 3) : fibration_scope. +Axiom pr2_path : forall `{P : A -> Type} {u v : sigT P} (p : u = v), p..1 # u.2 = v.2. +Notation "p ..2" := (pr2_path p) (at level 3) : fibration_scope. +Axiom path_path_sigma : forall {A : Type} (P : A -> Type) (u v : sigT P) + (p q : u = v) + (r : p..1 = q..1) + (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2), +p = q. +Goal forall (A : Type) (B : forall _ : A, Type) (x : @sigT A (fun x : A => B x)) + (xx : @paths (@sigT A (fun x0 : A => B x0)) x x), + @paths (@paths (@sigT A (fun x0 : A => B x0)) x x) xx + (@idpath (@sigT A (fun x0 : A => B x0)) x). + intros A B x xx. + Set Printing All. + change (fun x => B x) with B in xx. + pose (path_path_sigma B x x xx) as x''. + clear x''. + Check (path_path_sigma B x x xx). diff --git a/test-suite/bugs/closed/3625.v b/test-suite/bugs/closed/3625.v index 3d30b62f..d4b2cc5c 100644 --- a/test-suite/bugs/closed/3625.v +++ b/test-suite/bugs/closed/3625.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Set Implicit Arguments. Set Primitive Projections. Record prod A B := pair { fst : A ; snd : B }. diff --git a/test-suite/bugs/closed/3647.v b/test-suite/bugs/closed/3647.v index cd542c8a..495e67e0 100644 --- a/test-suite/bugs/closed/3647.v +++ b/test-suite/bugs/closed/3647.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Require Coq.Setoids.Setoid. Axiom BITS : nat -> Set. diff --git a/test-suite/bugs/closed/3649.v b/test-suite/bugs/closed/3649.v new file mode 100644 index 00000000..06188e7b --- /dev/null +++ b/test-suite/bugs/closed/3649.v @@ -0,0 +1,57 @@ +(* -*- coq-prog-args: ("-emacs" "-nois") -*- *) +(* File reduced by coq-bug-finder from original input, then from 9518 lines to 404 lines, then from 410 lines to 208 lines, then from 162 lines to 77 lines *) +(* coqc version trunk (September 2014) compiled on Sep 18 2014 21:0:5 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (07e4438bd758c2ced8caf09a6961ccd77d84e42b) *) +Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). +Reserved Notation "x = y" (at level 70, no associativity). +Open Scope type_scope. +Axiom admit : forall {T}, T. +Notation "A -> B" := (forall (_ : A), B) : type_scope. +Reserved Infix "o" (at level 40, left associativity). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Ltac constr_eq a b := let test := constr:(@idpath _ _ : a = b) in idtac. +Global Set Primitive Projections. +Delimit Scope morphism_scope with morphism. +Record PreCategory := + { object :> Type; + morphism : object -> object -> Type; + + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g) }. +Infix "o" := (@compose _ _ _ _) : morphism_scope. +Set Implicit Arguments. +Local Open Scope morphism_scope. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d) }. +Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := + { morphism_inverse : morphism C d s }. +Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }. +Definition composeT C D (F F' F'' : Functor C D) (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F') +: NaturalTransformation F F''. + exact admit. +Defined. +Definition functor_category (C D : PreCategory) : PreCategory. + exact (@Build_PreCategory (Functor C D) + (@NaturalTransformation C D) + admit + (@composeT C D)). +Defined. +Goal forall (C D : PreCategory) (G G' : Functor C D) + (T : @NaturalTransformation C D G G') + (H : @IsIsomorphism (@functor_category C D) G G' T) + (x : C), + @paths (morphism D (G x) (G x)) + (@compose D (G x) (G' x) (G x) + ((@morphism_inverse (@functor_category C D) G G' T H) x) + (T x)) (@identity D (G x)). + intros. + (** This [change] succeeded, but did not progress, in 07e4438bd758c2ced8caf09a6961ccd77d84e42b, because [T0 x o T1 x] was not found in the goal *) + let T0 := match goal with |- context[components_of ?T0 ?x o components_of ?T1 ?x] => constr:(T0) end in + let T1 := match goal with |- context[components_of ?T0 ?x o components_of ?T1 ?x] => constr:(T1) end in + progress change (T0 x o T1 x) with ((fun y => y) (T0 x o T1 x)).
\ No newline at end of file diff --git a/test-suite/bugs/closed/3653.v b/test-suite/bugs/closed/3653.v index 947b3601..b9768967 100644 --- a/test-suite/bugs/closed/3653.v +++ b/test-suite/bugs/closed/3653.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Require Setoid. Variables P Q : forall {T : Set}, T -> Prop. diff --git a/test-suite/bugs/closed/3658.v b/test-suite/bugs/closed/3658.v index b1158b9a..622c3c94 100644 --- a/test-suite/bugs/closed/3658.v +++ b/test-suite/bugs/closed/3658.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 12178 lines to 457 lines, then from 500 lines to 147 lines, then from 175 lines to 56 lines *) (* coqc version trunk (September 2014) compiled on Sep 21 2014 16:34:4 with OCaml 4.01.0 coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (eaf864354c3fda9ddc1f03f0b1c7807b6fd44322) *) diff --git a/test-suite/bugs/closed/3660.v b/test-suite/bugs/closed/3660.v index ed8964ce..39eb89c4 100644 --- a/test-suite/bugs/closed/3660.v +++ b/test-suite/bugs/closed/3660.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Generalizable All Variables. Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope. diff --git a/test-suite/bugs/closed/3664.v b/test-suite/bugs/closed/3664.v index 41de74ff..63a81b6d 100644 --- a/test-suite/bugs/closed/3664.v +++ b/test-suite/bugs/closed/3664.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Module NonPrim. Unset Primitive Projections. Record c := { d : Set }. diff --git a/test-suite/bugs/closed/3668.v b/test-suite/bugs/closed/3668.v index 547159b9..da01ed00 100644 --- a/test-suite/bugs/closed/3668.v +++ b/test-suite/bugs/closed/3668.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 6329 lines to 110 lines, then from 115 lines to 88 lines, then from 93 lines to 72 lines *) (* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0 coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *) diff --git a/test-suite/bugs/opened/3681.v b/test-suite/bugs/closed/3681.v index 194113c6..194113c6 100644 --- a/test-suite/bugs/opened/3681.v +++ b/test-suite/bugs/closed/3681.v diff --git a/test-suite/bugs/closed/3682.v b/test-suite/bugs/closed/3682.v index b8c5b4d5..2a282d22 100644 --- a/test-suite/bugs/closed/3682.v +++ b/test-suite/bugs/closed/3682.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Class Foo. Definition bar `{Foo} (x : Set) := Set. Instance: Foo. diff --git a/test-suite/bugs/closed/3684.v b/test-suite/bugs/closed/3684.v index 94ce4a60..f7b13738 100644 --- a/test-suite/bugs/closed/3684.v +++ b/test-suite/bugs/closed/3684.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Definition foo : Set. Proof. refine ($(abstract admit)$). diff --git a/test-suite/bugs/closed/3686.v b/test-suite/bugs/closed/3686.v index ee6b334b..b650920b 100644 --- a/test-suite/bugs/closed/3686.v +++ b/test-suite/bugs/closed/3686.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Set Universe Polymorphism. Set Implicit Arguments. Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. diff --git a/test-suite/bugs/closed/3690.v b/test-suite/bugs/closed/3690.v new file mode 100644 index 00000000..4069e380 --- /dev/null +++ b/test-suite/bugs/closed/3690.v @@ -0,0 +1,52 @@ +Set Printing Universes. +Set Universe Polymorphism. +Definition foo (a := Type) (b := Type) (c := Type) := Type. +Print foo. +(* foo = +let a := Type@{Top.1} in +let b := Type@{Top.2} in let c := Type@{Top.3} in Type@{Top.4} + : Type@{Top.4+1} +(* Top.1 + Top.2 + Top.3 + Top.4 |= *) *) +Check @foo. (* foo@{Top.5 Top.6 Top.7 +Top.8} + : Type@{Top.8+1} +(* Top.5 + Top.6 + Top.7 + Top.8 |= *) *) +Definition bar := $(let t := eval compute in foo in exact t)$. +Check @bar. (* bar@{Top.13 Top.14 Top.15 +Top.16} + : Type@{Top.16+1} +(* Top.13 + Top.14 + Top.15 + Top.16 |= *) *) +(* The following should fail, since [bar] should only need one universe. *) +Check @bar@{i j}. +Definition baz (a := Type) (b := Type : a) (c := Type : b) := a -> c. +Definition qux := Eval compute in baz. +Check @qux. (* qux@{Top.24 Top.25 +Top.26} + : Type@{max(Top.24+1, Top.26+1)} +(* Top.24 + Top.25 + Top.26 |= Top.25 < Top.24 + Top.26 < Top.25 + *) *) +Print qux. (* qux = +Type@{Top.21} -> Type@{Top.23} + : Type@{max(Top.21+1, Top.23+1)} +(* Top.21 + Top.22 + Top.23 |= Top.22 < Top.21 + Top.23 < Top.22 + *) *) +Fail Check @qux@{Set Set}. +Fail Check @qux@{Set Set Set}. +(* [qux] should only need two universes *) +Check @qux@{i j k}. (* Error: The command has not failed!, but I think this is suboptimal *) +Fail Check @qux@{i j}. diff --git a/test-suite/bugs/closed/3698.v b/test-suite/bugs/closed/3698.v index 3c53d243..31de8ec4 100644 --- a/test-suite/bugs/closed/3698.v +++ b/test-suite/bugs/closed/3698.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 5479 lines to 4682 lines, then from 4214 lines to 86 lines, then from 60 lines to 25 lines *) (* coqc version trunk (October 2014) compiled on Oct 1 2014 18:13:54 with OCaml 4.01.0 coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (68846802a7be637ec805a5e374655a426b5723a5) *) diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v index 99b3d79e..62137f0c 100644 --- a/test-suite/bugs/closed/3699.v +++ b/test-suite/bugs/closed/3699.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 9593 lines to 104 lines, then from 187 lines to 103 lines, then from 113 lines to 90 lines *) (* coqc version trunk (October 2014) compiled on Oct 1 2014 18:13:54 with OCaml 4.01.0 coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (68846802a7be637ec805a5e374655a426b5723a5) *) diff --git a/test-suite/bugs/closed/3703.v b/test-suite/bugs/closed/3703.v new file mode 100644 index 00000000..72825007 --- /dev/null +++ b/test-suite/bugs/closed/3703.v @@ -0,0 +1,32 @@ +Require Import TestSuite.admit. +(* File reduced by coq-bug-finder from original input, then from 6746 lines to 4190 lines, then from 29 lines to 18 lines, then fro\ +m 30 lines to 19 lines *) +(* coqc version trunk (October 2014) compiled on Oct 7 2014 12:42:41 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (2313bde0116a5916912bebbaca77d291f7b2760a) *) +Record PreCategory := { identity : forall x, x -> x }. +Definition set_cat : PreCategory := @Build_PreCategory (fun T x => x). +Module UnKeyed. + Global Unset Keyed Unification. + Goal forall (T : Type) (g0 g1 : T) (k : T) (H' : forall x : T, k = @identity set_cat T x), + ((fun x : T => x) g0) = ((fun x : T => x) g1). + intros T g0 g1 k H'. + change (identity _ _) with (fun y : T => y) in H'; + rewrite <- H' || fail "too early". + Undo. + rewrite <- H'. + admit. + Defined. +End UnKeyed. +Module Keyed. + Global Set Keyed Unification. + Declare Equivalent Keys (fun x => _) identity. + Goal forall (T : Type) (g0 g1 : T) (k : T) (H' : forall x : T, k = @identity set_cat T x), + ((fun x : T => x) g0) = ((fun x : T => x) g1). + intros T g0 g1 k H'. + change (identity _ _) with (fun y : T => y) in H'; + rewrite <- H' || fail "too early". + Undo. + rewrite <- H'. + admit. + Defined. +End Keyed.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3709.v b/test-suite/bugs/closed/3709.v index 7f01be7a..815f5b95 100644 --- a/test-suite/bugs/closed/3709.v +++ b/test-suite/bugs/closed/3709.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Module NonPrim. Unset Primitive Projections. Record hProp := hp { hproptype :> Type }. diff --git a/test-suite/bugs/closed/3732.v b/test-suite/bugs/closed/3732.v new file mode 100644 index 00000000..76beedf6 --- /dev/null +++ b/test-suite/bugs/closed/3732.v @@ -0,0 +1,105 @@ +Require Import TestSuite.admit. +(* File reduced by coq-bug-finder from original input, then from 2073 lines to 358 lines, then from 359 lines to 218 lines, then from 107 lines to 92 lines *) +(* coqc version trunk (October 2014) compiled on Oct 11 2014 1:13:41 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d65496f09c4b68fa318783e53f9cd6d5c18e1eb7) *) +Require Coq.Lists.List. + +Import Coq.Lists.List. + +Set Implicit Arguments. +Global Set Asymmetric Patterns. + +Section machine. + Variables pc state : Type. + + Inductive propX (i := pc) (j := state) : list Type -> Type := + | Inj : forall G, Prop -> propX G + | ExistsX : forall G A, propX (A :: G) -> propX G. + + Implicit Arguments Inj [G]. + + Definition PropX := propX nil. + Fixpoint last (G : list Type) : Type. + exact (match G with + | nil => unit + | T :: nil => T + | _ :: G' => last G' + end). + Defined. + Fixpoint eatLast (G : list Type) : list Type. + exact (match G with + | nil => nil + | _ :: nil => nil + | x :: G' => x :: eatLast G' + end). + Defined. + + Fixpoint subst G (p : propX G) : (last G -> PropX) -> propX (eatLast G) := + match p with + | Inj _ P => fun _ => Inj P + | ExistsX G A p1 => fun p' => + match G return propX (A :: G) -> propX (eatLast (A :: G)) -> propX (eatLast G) with + | nil => fun p1 _ => ExistsX p1 + | _ :: _ => fun _ rc => ExistsX rc + end p1 (subst p1 (match G return (last G -> PropX) -> last (A :: G) -> PropX with + | nil => fun _ _ => Inj True + | _ => fun p' => p' + end p')) + end. + + Definition spec := state -> PropX. + Definition codeSpec := pc -> option spec. + + Inductive valid (specs : codeSpec) (G : list PropX) : PropX -> Prop := Env : forall P, In P G -> valid specs G P. + Definition interp specs := valid specs nil. +End machine. +Notation "'ExX' : A , P" := (ExistsX (A := A) P) (at level 89) : PropX_scope. +Bind Scope PropX_scope with PropX propX. +Variables pc state : Type. + +Inductive subs : list Type -> Type := +| SNil : subs nil +| SCons : forall T Ts, (last (T :: Ts) -> PropX pc state) -> subs (eatLast (T :: Ts)) -> subs (T :: Ts). + +Fixpoint SPush G T (s : subs G) (f : T -> PropX pc state) : subs (T :: G) := + match s in subs G return subs (T :: G) with + | SNil => SCons _ nil f SNil + | SCons T' Ts f' s' => SCons T (T' :: Ts) f' (SPush s' f) + end. + +Fixpoint Substs G (s : subs G) : propX pc state G -> PropX pc state := + match s in subs G return propX pc state G -> PropX pc state with + | SNil => fun p => p + | SCons _ _ f s' => fun p => Substs s' (subst p f) + end. +Variable specs : codeSpec pc state. + +Lemma simplify_fwd_ExistsX : forall G A s (p : propX pc state (A :: G)), + interp specs (Substs s (ExX : A, p)) + -> exists a, interp specs (Substs (SPush s a) p). +admit. +Defined. + +Goal forall (G : list Type) (A : Type) (p : propX pc state (@cons Type A G)) + (s : subs G) + (_ : @interp pc state specs (@Substs G s (@ExistsX pc state G A p))) + (P : forall _ : subs (@cons Type A G), Prop) + (_ : forall (s0 : subs (@cons Type A G)) + (_ : @interp pc state specs (@Substs (@cons Type A G) s0 p)), + P s0), + @ex (forall _ : A, PropX pc state) + (fun a : forall _ : A, PropX pc state => P (@SPush G A s a)). + intros ? ? ? ? H ? H'. + apply simplify_fwd_ExistsX in H. + firstorder. +Qed. + (* Toplevel input, characters 15-19: +Error: Illegal application: +The term "cons" of type "forall A : Type, A -> list A -> list A" +cannot be applied to the terms + "Type" : "Type" + "T" : "Type" + "G0" : "list Type" +The 2nd term has type "Type@{Top.53}" which should be coercible to + "Type@{Top.12}". + *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3755.v b/test-suite/bugs/closed/3755.v new file mode 100644 index 00000000..77427ace --- /dev/null +++ b/test-suite/bugs/closed/3755.v @@ -0,0 +1,16 @@ +(* File reduced by coq-bug-finder from original input, then from 6729 lines to +411 lines, then from 148 lines to 115 lines, then from 99 lines to 70 lines, +then from 85 lines to 63 lines, then from 76 lines to 55 lines, then from 61 +lines to 17 lines *) +(* coqc version trunk (January 2015) compiled on Jan 17 2015 21:58:5 with OCaml +4.01.0 + coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk +(9e6b28c04ad98369a012faf3bd4d630cf123a473) *) +Set Printing Universes. +Section param. + Variable typeD : Set -> Set. + Variable STex : forall (T : Type) (p : T -> Set), Set. + Definition existsEach_cons' v (P : @sigT _ typeD -> Set) := + @STex _ (fun x => P (@existT _ _ v x)). + + Check @existT _ _ STex STex. diff --git a/test-suite/bugs/closed/3782.v b/test-suite/bugs/closed/3782.v index 08d456fc..2dc50c17 100644 --- a/test-suite/bugs/closed/3782.v +++ b/test-suite/bugs/closed/3782.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 2674 lines to 136 lines, then from 115 lines to 61 lines *) (* coqc version trunk (October 2014) compiled on Oct 28 2014 14:33:38 with OCaml 4.01.0 coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-trunk,(no branch) (53bfe9cf58a3c40e6eb7120d25c1633a9cea3126) *) diff --git a/test-suite/bugs/closed/3783.v b/test-suite/bugs/closed/3783.v new file mode 100644 index 00000000..e2171296 --- /dev/null +++ b/test-suite/bugs/closed/3783.v @@ -0,0 +1,33 @@ +Require Import TestSuite.admit. +Fixpoint exp (n : nat) (T : Set) + := match n with + | 0 => T + | S n' => exp n' (T * T) + end. +Definition big := Eval compute in exp 13 nat. +Module NonPrim. + Unset Primitive Projections. + Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. + Definition x : sigT (fun x => x). + Proof. + exists big; admit. + Defined. + Goal True. + pose ((fun y => y = y) (projT1 _ x)) as y. + Time cbv beta in y. (* 0s *) + admit. + Defined. +End NonPrim. +Module Prim. + Set Primitive Projections. + Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. + Definition x : sigT (fun x => x). + Proof. + exists big; admit. + Defined. + Goal True. + pose ((fun y => y = y) (projT1 _ x)) as y. + Timeout 1 cbv beta in y. (* takes around 2s. Grows with the value passed to [exp] above *) + admit. + Defined. +End Prim.
\ No newline at end of file diff --git a/test-suite/bugs/opened/3786.v b/test-suite/bugs/closed/3786.v index 5a124115..23d19e94 100644 --- a/test-suite/bugs/opened/3786.v +++ b/test-suite/bugs/closed/3786.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Require Coq.Lists.List. Require Coq.Sets.Ensembles. Import Coq.Sets.Ensembles. @@ -26,15 +27,7 @@ Definition sumUniqueImpl (ls : list nat) Proof. eexists. match goal with - | [ |- refine ?a ?b ] => let a' := eval hnf in a in refine (_ : refine a' b) - end; - try setoid_rewrite (@finite_set_handle_cardinal). - Undo. - match goal with | [ |- refine ?a ?b ] => let a' := eval hnf in a in change (refine a' b) end. - try setoid_rewrite (@finite_set_handle_cardinal). (* Anomaly: Uncaught exception Invalid_argument("decomp_pointwise"). -Please report. *) - instantiate (1 := admit). - admit. -Defined. + try setoid_rewrite (@finite_set_handle_cardinal). +Abort. diff --git a/test-suite/bugs/closed/3798.v b/test-suite/bugs/closed/3798.v new file mode 100644 index 00000000..b9f0daa7 --- /dev/null +++ b/test-suite/bugs/closed/3798.v @@ -0,0 +1,12 @@ +Require Import TestSuite.admit. +Require Setoid. + +Parameter f : nat -> nat. +Axiom a : forall n, 0 < n -> f n = 0. +Hint Rewrite a using ( simpl; admit ). + +Goal f 1 = 0. +Proof. + rewrite_strat (topdown (hints core)). + reflexivity. +Qed. diff --git a/test-suite/bugs/closed/3808.v b/test-suite/bugs/closed/3808.v new file mode 100644 index 00000000..6e19ddf8 --- /dev/null +++ b/test-suite/bugs/closed/3808.v @@ -0,0 +1,2 @@ +Inductive Foo : (let enforce := (fun x => x) : Type@{j} -> Type@{i} in Type@{i}) + := foo : Foo.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3815.v b/test-suite/bugs/closed/3815.v new file mode 100644 index 00000000..5fb48398 --- /dev/null +++ b/test-suite/bugs/closed/3815.v @@ -0,0 +1,9 @@ +Require Import Setoid Coq.Program.Basics. +Global Open Scope program_scope. +Axiom foo : forall A (f : A -> A), f ∘ f = f. +Require Import Coq.Program.Combinators. +Hint Rewrite foo. +Theorem t {A B C D} (f : A -> A) (g : B -> C) (h : C -> D) +: f ∘ f = f. +Proof. + rewrite_strat topdown (hints core). diff --git a/test-suite/bugs/closed/3854.v b/test-suite/bugs/closed/3854.v index f8329cdd..7e915f20 100644 --- a/test-suite/bugs/closed/3854.v +++ b/test-suite/bugs/closed/3854.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Definition relation (A : Type) := A -> A -> Type. Class Reflexive {A} (R : relation A) := reflexivity : forall x : A, R x x. Axiom IsHProp : Type -> Type. diff --git a/test-suite/bugs/closed/3881.v b/test-suite/bugs/closed/3881.v new file mode 100644 index 00000000..4408ab88 --- /dev/null +++ b/test-suite/bugs/closed/3881.v @@ -0,0 +1,35 @@ +(* -*- coq-prog-args: ("-emacs" "-nois" "-R" "../theories" "Coq") -*- *) +(* File reduced by coq-bug-finder from original input, then from 2236 lines to 1877 lines, then from 1652 lines to 160 lines, then from 102 lines to 34 lines *) +(* coqc version trunk (December 2014) compiled on Dec 23 2014 22:6:43 with OCaml 4.01.0 + coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (90ed6636dea41486ddf2cc0daead83f9f0788163) *) +Generalizable All Variables. +Require Import Coq.Init.Notations. +Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). +Notation "A -> B" := (forall (_ : A), B) : type_scope. +Axiom admit : forall {T}, T. +Notation "g 'o' f" := (fun x => g (f x)) (at level 40, left associativity). +Notation "g 'o' f" := $(let g' := g in let f' := f in exact (fun x => g' (f' x)))$ (at level 40, left associativity). (* Ensure that x is not captured in [g] or [f] in case they contain holes *) +Inductive eq {A} (x:A) : A -> Prop := eq_refl : x = x where "x = y" := (@eq _ x y) : type_scope. +Arguments eq_refl {_ _}. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with eq_refl => eq_refl end. +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : forall x, f (equiv_inv x) = x }. +Arguments eisretr {A B} f {_} _. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'"). +Global Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} : IsEquiv (g o f) | 1000 := admit. +Definition isequiv_homotopic {A B} (f : A -> B) (g : A -> B) `{IsEquiv A B f} (h : forall x, f x = g x) : IsEquiv g := admit. +Global Instance isequiv_inverse {A B} (f : A -> B) {feq : IsEquiv f} : IsEquiv f^-1 | 10000 := admit. +Definition cancelR_isequiv {A B C} (f : A -> B) {g : B -> C} `{IsEquiv A B f} `{IsEquiv A C (g o f)} : IsEquiv g. +Proof. + pose (fun H => @isequiv_homotopic _ _ ((g o f) o f^-1) _ H + (fun b => ap g (eisretr f b))) as k. + revert k. + let x := match goal with |- let k := ?x in _ => constr:x end in + intro k; clear k; + pose (x _). + pose (@isequiv_homotopic _ _ ((g o f) o f^-1) g _ + (fun b => ap g (eisretr f b))). + Undo. + apply (@isequiv_homotopic _ _ ((g o f) o f^-1) g _ + (fun b => ap g (eisretr f b))). +Qed. +
\ No newline at end of file diff --git a/test-suite/bugs/closed/3900.v b/test-suite/bugs/closed/3900.v new file mode 100644 index 00000000..6be2161c --- /dev/null +++ b/test-suite/bugs/closed/3900.v @@ -0,0 +1,13 @@ +Global Set Primitive Projections. +Set Implicit Arguments. +Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Variable A : PreCategory. +Variable Pobj : A -> Type. +Local Notation obj := (sigT Pobj). +Variable Pmor : forall s d : obj, morphism A (projT1 s) (projT1 d) -> Type. +Class Foo (x : Type) := { _ : forall y, y }. +Local Instance ishset_pmor {s d m} : Foo (Pmor s d m). +Proof. +SearchAbout ((forall _ _, _) -> Foo _). +Abort. diff --git a/test-suite/bugs/closed/3916.v b/test-suite/bugs/closed/3916.v new file mode 100644 index 00000000..55c3a35c --- /dev/null +++ b/test-suite/bugs/closed/3916.v @@ -0,0 +1,3 @@ +Require Import List. +Fail Hint Resolve -> in_map. + diff --git a/test-suite/bugs/closed/3922.v b/test-suite/bugs/closed/3922.v new file mode 100644 index 00000000..93208489 --- /dev/null +++ b/test-suite/bugs/closed/3922.v @@ -0,0 +1,84 @@ +Require Import TestSuite.admit. +Set Universe Polymorphism. +Notation Type0 := Set. + +Definition Type1 := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}. + +Notation compose := (fun g f x => g (f x)). + +Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope. +Open Scope function_scope. + +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) + := forall x:A, f x = g x. + +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) +}. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope. +Local Open Scope trunc_scope. +Notation "-2" := minus_two (at level 0) : trunc_scope. +Notation "-1" := (-2.+1) (at level 0) : trunc_scope. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | -2 => Contr_internal A + | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. + +Notation Contr := (IsTrunc -2). +Notation IsHProp := (IsTrunc -1). + +Monomorphic Axiom dummy_funext_type : Type0. +Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }. + +Inductive Unit : Type1 := + tt : Unit. + +Record TruncType (n : trunc_index) := BuildTruncType { + trunctype_type : Type ; + istrunc_trunctype_type : IsTrunc n trunctype_type +}. + +Arguments BuildTruncType _ _ {_}. + +Coercion trunctype_type : TruncType >-> Sortclass. + +Notation "n -Type" := (TruncType n) (at level 1) : type_scope. +Notation hProp := (-1)-Type. + +Notation BuildhProp := (BuildTruncType -1). + +Private Inductive Trunc (n : trunc_index) (A :Type) : Type := + tr : A -> Trunc n A. +Arguments tr {n A} a. + +Global Instance istrunc_truncation (n : trunc_index) (A : Type@{i}) +: IsTrunc@{j} n (Trunc@{i} n A). +Admitted. + +Definition Trunc_ind {n A} + (P : Trunc n A -> Type) {Pt : forall aa, IsTrunc n (P aa)} + : (forall a, P (tr a)) -> (forall aa, P aa) +:= (fun f aa => match aa with tr a => fun _ => f a end Pt). +Definition merely (A : Type@{i}) : hProp@{i} := BuildhProp (Trunc -1 A). +Definition cconst_factors_contr `{Funext} {X Y : Type} (f : X -> Y) + (P : Type) `{Pc : X -> Contr P} + (g : X -> P) (h : P -> Y) (p : h o g == f) +: Unit. +Proof. + assert (merely X -> IsHProp P) by admit. + refine (let g' := Trunc_ind (fun _ => P) g : merely X -> P in _); + [ assumption.. | ]. + pose (g'' := Trunc_ind (fun _ => P) g : merely X -> P). diff --git a/test-suite/bugs/closed/3938.v b/test-suite/bugs/closed/3938.v new file mode 100644 index 00000000..859e9f01 --- /dev/null +++ b/test-suite/bugs/closed/3938.v @@ -0,0 +1,8 @@ +Require Import TestSuite.admit. +Require Import Coq.Arith.PeanoNat. +Hint Extern 1 => admit : typeclass_instances. +Require Import Setoid. +Goal forall a b (f : nat -> Set) (R : nat -> nat -> Prop), + Equivalence R -> R a b -> f a = f b. + intros a b f H. + intros. Fail rewrite H1. diff --git a/test-suite/bugs/closed/3944.v b/test-suite/bugs/closed/3944.v new file mode 100644 index 00000000..58e60f4f --- /dev/null +++ b/test-suite/bugs/closed/3944.v @@ -0,0 +1,5 @@ +Require Import Setoid. +Definition C (T : Type) := T. +Goal forall T (i : C T) (v : T), True. +Proof. +Fail setoid_rewrite plus_n_Sm. diff --git a/test-suite/bugs/closed/3953.v b/test-suite/bugs/closed/3953.v new file mode 100644 index 00000000..167cecea --- /dev/null +++ b/test-suite/bugs/closed/3953.v @@ -0,0 +1,5 @@ +(* Checking subst on instances of evars (was bugged in 8.5 beta 1) *) +Goal forall (a b : unit), a = b -> exists c, b = c. + intros. + eexists. + subst. diff --git a/test-suite/bugs/closed/3960.v b/test-suite/bugs/closed/3960.v new file mode 100644 index 00000000..e56dcef7 --- /dev/null +++ b/test-suite/bugs/closed/3960.v @@ -0,0 +1,26 @@ +Require Program.Tactics. + +Axiom foo : nat -> Prop. + +Axiom fooP : forall n, foo n. + +Class myClass (A: Type) := + { + bar : A -> Prop + }. + +Program Instance myInstance : myClass nat := + { + bar := foo + }. + +Class myClassP (A : Type) := + { + super :> myClass A; + barP : forall (a : A), bar a + }. + +Instance myInstanceP : myClassP nat := + { + barP := fooP + }.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3978.v b/test-suite/bugs/closed/3978.v new file mode 100644 index 00000000..26e021e7 --- /dev/null +++ b/test-suite/bugs/closed/3978.v @@ -0,0 +1,27 @@ +Require Import Structures.OrderedType. +Require Import Structures.OrderedTypeEx. + +Module Type M. Parameter X : Type. + +Declare Module Export XOrd : OrderedType + with Definition t := X + with Definition eq := @Logic.eq X. +End M. + +Module M' : M. + Definition X := nat. + + Module XOrd := Nat_as_OT. +End M'. + +Module Type MyOt. + Parameter t : Type. + Parameter eq : t -> t -> Prop. +End MyOt. + +Module Type M2. Parameter X : Type. + +Declare Module Export XOrd : MyOt + with Definition t := X + with Definition eq := @Logic.eq X. +End M2. diff --git a/test-suite/bugs/closed/3993.v b/test-suite/bugs/closed/3993.v new file mode 100644 index 00000000..086d8dd0 --- /dev/null +++ b/test-suite/bugs/closed/3993.v @@ -0,0 +1,3 @@ +(* Test smooth failure on not fully applied term to destruct with eqn: given *) +Goal True. +Fail induction S eqn:H. diff --git a/test-suite/bugs/closed/4001.v b/test-suite/bugs/closed/4001.v new file mode 100644 index 00000000..25d78f4b --- /dev/null +++ b/test-suite/bugs/closed/4001.v @@ -0,0 +1,18 @@ +(* Computing the type constraints to be satisfied when building the + return clause of a match with a match *) + +Set Implicit Arguments. +Set Asymmetric Patterns. + +Variable A : Type. +Variable typ : A -> Type. + +Inductive t : list A -> Type := +| snil : t nil +| scons : forall (x : A) (e : typ x) (lx : list A) (le : t lx), t (x::lx). + +Definition car (x:A) (lx : list A) (s: t (x::lx)) : typ x := + match s in t l' with + | snil => False + | scons _ e _ _ => e + end. diff --git a/test-suite/bugs/closed/4012.v b/test-suite/bugs/closed/4012.v new file mode 100644 index 00000000..1748e3ba --- /dev/null +++ b/test-suite/bugs/closed/4012.v @@ -0,0 +1,5 @@ +Goal (forall T : Type, T = T) -> Type. +Proof. + intro H. + Fail specialize (H _). +Abort. diff --git a/test-suite/bugs/closed/4016.v b/test-suite/bugs/closed/4016.v new file mode 100644 index 00000000..41cb1a88 --- /dev/null +++ b/test-suite/bugs/closed/4016.v @@ -0,0 +1,12 @@ +Require Import Setoid. + +Parameter eq : relation nat. +Declare Instance Equivalence_eq : Equivalence eq. + +Lemma foo : forall z, eq z 0 -> forall x, eq x 0 -> eq z x. +Proof. +intros z Hz x Hx. +rewrite <- Hx in Hz. +destruct z. +Abort. + diff --git a/test-suite/bugs/closed/4017.v b/test-suite/bugs/closed/4017.v new file mode 100644 index 00000000..aa810f4f --- /dev/null +++ b/test-suite/bugs/closed/4017.v @@ -0,0 +1,8 @@ +Set Implicit Arguments. + +(* Use of implicit arguments was lost in multiple variable declarations *) +Variables + (A1 : Type) + (A2 : forall (x1 : A1), Type) + (A3 : forall (x1 : A1) (x2 : A2 x1), Type) + (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type). diff --git a/test-suite/bugs/closed/4018.v b/test-suite/bugs/closed/4018.v new file mode 100644 index 00000000..8895e09e --- /dev/null +++ b/test-suite/bugs/closed/4018.v @@ -0,0 +1,3 @@ +(* Catching PatternMatchingFailure was lost at some point *) +Goal nat -> True. +Fail intros [=]. diff --git a/test-suite/bugs/closed/4031.v b/test-suite/bugs/closed/4031.v new file mode 100644 index 00000000..2b8641eb --- /dev/null +++ b/test-suite/bugs/closed/4031.v @@ -0,0 +1,14 @@ +Definition something (P:Type) (e:P) := e. + +Inductive myunit : Set := mytt. + (* Proof below works when definition is in Type, + however builtin types such as unit are in Set. *) + +Lemma demo_hide_generic : + let x := mytt in x = x. +Proof. + intros. + change mytt with (@something _ mytt) in x. + subst x. (* Proof works if this line is removed *) + reflexivity. +Qed.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4035.v b/test-suite/bugs/closed/4035.v new file mode 100644 index 00000000..ec246d09 --- /dev/null +++ b/test-suite/bugs/closed/4035.v @@ -0,0 +1,13 @@ +(* Supporting tactic notations within Ltac in the presence of an + "ident" entry which does not expect a fresh ident *) +(* Of course, this is a matter of convention of what "ident" is + supposed to denote, but in practice, it seems more convenient to + have less constraints on ident at interpretation time, as + otherwise more ad hoc entries would be necessary (as e.g. a special + "quantified_hypothesis" entry for dependent destruction). *) +Require Import Program. +Goal nat -> Type. + intro x. + lazymatch goal with + | [ x : nat |- _ ] => dependent destruction x + end. diff --git a/test-suite/bugs/closed/4046.v b/test-suite/bugs/closed/4046.v new file mode 100644 index 00000000..8f8779b7 --- /dev/null +++ b/test-suite/bugs/closed/4046.v @@ -0,0 +1,6 @@ +Module Import Foo. + Class Foo := { foo : Type }. +End Foo. + +Instance f : Foo := { foo := nat }. (* works fine *) +Instance f' : Foo.Foo := { Foo.foo := nat }. diff --git a/test-suite/bugs/closed/4078.v b/test-suite/bugs/closed/4078.v new file mode 100644 index 00000000..236cd2fb --- /dev/null +++ b/test-suite/bugs/closed/4078.v @@ -0,0 +1,14 @@ +Module Type S. + +Axiom foo : nat. + +End S. + +Module M : S. + +Definition bar := 0. +Definition foo := bar. + +End M. + +Print All Dependencies M.foo. diff --git a/test-suite/bugs/closed/4089.v b/test-suite/bugs/closed/4089.v new file mode 100644 index 00000000..1449f242 --- /dev/null +++ b/test-suite/bugs/closed/4089.v @@ -0,0 +1,374 @@ +Require Import TestSuite.admit. +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) +(* File reduced by coq-bug-finder from original input, then from 6522 lines to 318 lines, then from 1139 lines to 361 lines *) +(* coqc version 8.5beta1 (February 2015) compiled on Feb 23 2015 18:32:3 with OCaml 4.01.0 + coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (ebfc19d792492417b129063fb511aa423e9d9e08) *) +Open Scope type_scope. + +Global Set Universe Polymorphism. +Module Export Datatypes. + +Set Implicit Arguments. + +Record prod (A B : Type) := pair { fst : A ; snd : B }. + +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. + +End Datatypes. +Module Export Specif. + +Set Implicit Arguments. + +Record sig {A} (P : A -> Type) := exist { proj1_sig : A ; proj2_sig : P proj1_sig }. + +Notation sigT := sig (only parsing). +Notation existT := exist (only parsing). + +Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. + +Notation projT1 := proj1_sig (only parsing). +Notation projT2 := proj2_sig (only parsing). + +End Specif. + +Ltac rapply p := + refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _ _) || + refine (p _ _ _ _ _ _) || + refine (p _ _ _ _ _) || + refine (p _ _ _ _) || + refine (p _ _ _) || + refine (p _ _) || + refine (p _) || + refine p. + +Local Unset Elimination Schemes. + +Definition relation (A : Type) := A -> A -> Type. + +Class Symmetric {A} (R : relation A) := + symmetry : forall x y, R x y -> R y x. + +Class Transitive {A} (R : relation A) := + transitivity : forall x y z, R x y -> R y z -> R x z. + +Tactic Notation "etransitivity" open_constr(y) := + let R := match goal with |- ?R ?x ?z => constr:(R) end in + let x := match goal with |- ?R ?x ?z => constr:(x) end in + let z := match goal with |- ?R ?x ?z => constr:(z) end in + let pre_proof_term_head := constr:(@transitivity _ R _) in + let proof_term_head := (eval cbn in pre_proof_term_head) in + refine (proof_term_head x y z _ _); [ change (R x y) | change (R y z) ]. + +Ltac transitivity x := etransitivity x. + +Definition Type1 := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}. + +Notation idmap := (fun x => x). +Delimit Scope function_scope with function. +Delimit Scope path_scope with path. +Delimit Scope fibration_scope with fibration. +Open Scope fibration_scope. +Open Scope function_scope. + +Notation "( x ; y )" := (existT _ x y) : fibration_scope. + +Notation pr1 := projT1. +Notation pr2 := projT2. + +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. +Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope. + +Notation compose := (fun g f x => g (f x)). + +Notation "g 'o' f" := (compose g%function f%function) (at level 40, left associativity) : function_scope. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Scheme paths_ind := Induction for paths Sort Type. + +Definition paths_rect := paths_ind. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Local Open Scope path_scope. + +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. + +Arguments concat {A x y z} p q : simpl nomatch. + +Notation "1" := idpath : path_scope. + +Notation "p @ q" := (concat p%path q%path) (at level 20) : path_scope. + +Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : path_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) + := forall x:A, f x = g x. + +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. + +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) + : f == g + := fun x => match h with idpath => 1 end. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) +}. + +Arguments eisretr {A B}%type_scope f%function_scope {_} _. +Arguments eissect {A B}%type_scope f%function_scope {_} _. +Arguments eisadj {A B}%type_scope f%function_scope {_} _. + +Record Equiv A B := BuildEquiv { + equiv_fun : A -> B ; + equiv_isequiv : IsEquiv equiv_fun +}. + +Coercion equiv_fun : Equiv >-> Funclass. + +Global Existing Instance equiv_isequiv. + +Bind Scope equiv_scope with Equiv. + +Notation "A <~> B" := (Equiv A B) (at level 85) : type_scope. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : function_scope. + +Inductive Unit : Type1 := + tt : Unit. + +Ltac done := + trivial; intros; solve + [ repeat first + [ solve [trivial] + | solve [symmetry; trivial] + | reflexivity + + | contradiction + | split ] + | match goal with + H : ~ _ |- _ => solve [destruct H; trivial] + end ]. +Tactic Notation "by" tactic(tac) := + tac; done. + +Definition concat_p1 {A : Type} {x y : A} (p : x = y) : + p @ 1 = p + := + match p with idpath => 1 end. + +Definition concat_1p {A : Type} {x y : A} (p : x = y) : + 1 @ p = p + := + match p with idpath => 1 end. + +Definition ap_pp {A B : Type} (f : A -> B) {x y z : A} (p : x = y) (q : y = z) : + ap f (p @ q) = (ap f p) @ (ap f q) + := + match q with + idpath => + match p with idpath => 1 end + end. + +Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) : + ap (g o f) p = ap g (ap f p) + := + match p with idpath => 1 end. + +Definition concat_A1p {A : Type} {f : A -> A} (p : forall x, f x = x) {x y : A} (q : x = y) : + (ap f q) @ (p y) = (p x) @ q + := + match q with + | idpath => concat_1p _ @ ((concat_p1 _) ^) + end. + +Definition concat2 {A} {x y z : A} {p p' : x = y} {q q' : y = z} (h : p = p') (h' : q = q') + : p @ q = p' @ q' +:= match h, h' with idpath, idpath => 1 end. + +Notation "p @@ q" := (concat2 p q)%path (at level 20) : path_scope. + +Definition whiskerL {A : Type} {x y z : A} (p : x = y) + {q r : y = z} (h : q = r) : p @ q = p @ r +:= 1 @@ h. + +Definition ap02 {A B : Type} (f:A->B) {x y:A} {p q:x=y} (r:p=q) : ap f p = ap f q + := match r with idpath => 1 end. +Module Export Equivalences. + +Generalizable Variables A B C f g. + +Global Instance isequiv_idmap (A : Type) : IsEquiv idmap | 0 := + BuildIsEquiv A A idmap idmap (fun _ => 1) (fun _ => 1) (fun _ => 1). + +Definition equiv_idmap (A : Type) : A <~> A := BuildEquiv A A idmap _. + +Arguments equiv_idmap {A} , A. + +Notation "1" := equiv_idmap : equiv_scope. + +Global Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} + : IsEquiv (compose g f) | 1000 + := BuildIsEquiv A C (compose g f) + (compose f^-1 g^-1) + (fun c => ap g (eisretr f (g^-1 c)) @ eisretr g c) + (fun a => ap (f^-1) (eissect g (f a)) @ eissect f a) + (fun a => + (whiskerL _ (eisadj g (f a))) @ + (ap_pp g _ _)^ @ + ap02 g + ( (concat_A1p (eisretr f) (eissect g (f a)))^ @ + (ap_compose f^-1 f _ @@ eisadj f a) @ + (ap_pp f _ _)^ + ) @ + (ap_compose f g _)^ + ). + +Definition equiv_compose {A B C : Type} (g : B -> C) (f : A -> B) + `{IsEquiv B C g} `{IsEquiv A B f} + : A <~> C + := BuildEquiv A C (compose g f) _. + +Global Instance transitive_equiv : Transitive Equiv | 0 := + fun _ _ _ f g => equiv_compose g f. + +Theorem equiv_inverse {A B : Type} : (A <~> B) -> (B <~> A). +admit. +Defined. + +Global Instance symmetric_equiv : Symmetric Equiv | 0 := @equiv_inverse. + +End Equivalences. + +Definition path_prod_uncurried {A B : Type} (z z' : A * B) + (pq : (fst z = fst z') * (snd z = snd z')) + : (z = z'). +admit. +Defined. + +Global Instance isequiv_path_prod {A B : Type} {z z' : A * B} +: IsEquiv (path_prod_uncurried z z') | 0. +admit. +Defined. + +Definition equiv_path_prod {A B : Type} (z z' : A * B) + : (fst z = fst z') * (snd z = snd z') <~> (z = z') + := BuildEquiv _ _ (path_prod_uncurried z z') _. + +Generalizable Variables X A B C f g n. + +Definition functor_sigma `{P : A -> Type} `{Q : B -> Type} + (f : A -> B) (g : forall a, P a -> Q (f a)) +: sigT P -> sigT Q + := fun u => (f u.1 ; g u.1 u.2). + +Global Instance isequiv_functor_sigma `{P : A -> Type} `{Q : B -> Type} + `{IsEquiv A B f} `{forall a, @IsEquiv (P a) (Q (f a)) (g a)} +: IsEquiv (functor_sigma f g) | 1000. +admit. +Defined. + +Definition equiv_functor_sigma `{P : A -> Type} `{Q : B -> Type} + (f : A -> B) `{IsEquiv A B f} + (g : forall a, P a -> Q (f a)) + `{forall a, @IsEquiv (P a) (Q (f a)) (g a)} +: sigT P <~> sigT Q + := BuildEquiv _ _ (functor_sigma f g) _. + +Definition equiv_functor_sigma' `{P : A -> Type} `{Q : B -> Type} + (f : A <~> B) + (g : forall a, P a <~> Q (f a)) +: sigT P <~> sigT Q + := equiv_functor_sigma f g. + +Definition equiv_functor_sigma_id `{P : A -> Type} `{Q : A -> Type} + (g : forall a, P a <~> Q a) +: sigT P <~> sigT Q + := equiv_functor_sigma' 1 g. + +Definition Bip : Type := { C : Type & C * C }. + +Definition BipMor (X Y : Bip) : Type := + match X, Y with (C;(c0,c1)), (D;(d0,d1)) => + { f : C -> D & (f c0 = d0) * (f c1 = d1) } + end. + +Definition bipmor2map {X Y : Bip} : BipMor X Y -> X.1 -> Y.1 := + match X, Y with (C;(c0,c1)), (D;(d0,d1)) => fun i => + match i with (f;_) => f end + end. + +Definition bipidmor {X : Bip} : BipMor X X := + match X with (C;(c0,c1)) => (idmap; (1, 1)) end. + +Definition bipcompmor {X Y Z : Bip} : BipMor X Y -> BipMor Y Z -> BipMor X Z := + match X, Y, Z with (C;(c0,c1)), (D;(d0,d1)), (E;(e0,e1)) => fun i j => + match i, j with (f;(f0,f1)), (g;(g0,g1)) => + (g o f; (ap g f0 @ g0, ap g f1 @ g1)) + end + end. + +Definition isbipequiv {X Y : Bip} (i : BipMor X Y) : Type := + { l : BipMor Y X & bipcompmor i l = bipidmor } * + { r : BipMor Y X & bipcompmor r i = bipidmor }. + +Lemma bipequivEQequiv : forall {X Y : Bip} (i : BipMor X Y), + isbipequiv i <~> IsEquiv (bipmor2map i). +Proof. +assert (equivcompmor : forall {X Y : Bip} (i : BipMor X Y) j, +(bipcompmor i j = bipidmor) <~> Unit). + intros; set (U := X); set (V := Y); destruct X as [C [c0 c1]], Y as [D [d0 d1]]. + transitivity { n : (bipcompmor i j).1 = (@bipidmor U).1 & + (bipcompmor i j).2 = transport (fun h => (h c0 = c0) * (h c1 = c1)) n^ (@bipidmor U).2}. + admit. + destruct i as [f [f0 f1]]; destruct j as [g [g0 g1]]. + + transitivity { n : g o f = idmap & (ap g f0 @ g0 = apD10 n c0 @ 1) * + (ap g f1 @ g1 = apD10 n c1 @ 1)}. + apply equiv_functor_sigma_id; intro n. + assert (Ggen : forall (h0 h1 : C -> C) (p : h0 = h1) u0 u1 v0 v1, + ((u0, u1) = transport (fun h => (h c0 = c0) * (h c1 = c1)) p^ (v0, v1)) <~> + (u0 = apD10 p c0 @ v0) * (u1 = apD10 p c1 @ v1)). + induction p; intros; simpl; rewrite !concat_1p; apply symmetry. + by apply (equiv_path_prod (u0,u1) (v0,v1)). + rapply Ggen. + pose (@paths C). + Check (@paths C). + Undo. + Check (@paths C). (* Toplevel input, characters 0-17: +Error: Illegal application: +The term "@paths" of type "forall A : Type, A -> A -> Type" +cannot be applied to the term + "C" : "Type" +This term has type "Type@{Top.892}" which should be coercible to + "Type@{Top.882}". +*) diff --git a/test-suite/bugs/closed/4097.v b/test-suite/bugs/closed/4097.v new file mode 100644 index 00000000..02aa25e0 --- /dev/null +++ b/test-suite/bugs/closed/4097.v @@ -0,0 +1,65 @@ +Require Import TestSuite.admit. +(* File reduced by coq-bug-finder from original input, then from 6082 lines to 81 lines, then from 436 lines to 93 lines *) +(* coqc version 8.5beta1 (February 2015) compiled on Feb 27 2015 15:10:37 with OCaml 4.01.0 + coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (fc1b3ef9d7270938cd83c524aae0383093b7a4b5) *) +Global Set Primitive Projections. +Record sigT {A} (P : A -> Type) := exist { projT1 : A ; projT2 : P projT1 }. +Arguments projT1 {A P} _ / . +Arguments projT2 {A P} _ / . +Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. +Delimit Scope path_scope with path. +Delimit Scope fibration_scope with fibration. +Open Scope path_scope. +Open Scope fibration_scope. +Notation "( x ; y )" := (exist _ _ x y) : fibration_scope. +Notation pr1 := projT1. +Notation pr2 := projT2. +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. +Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope. +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. +Notation "p @ q" := (concat p%path q%path) (at level 20) : path_scope. +Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : path_scope. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope. +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. +Definition apD {A:Type} {B:A->Type} (f:forall a:A, B a) {x y:A} (p:x=y): + p # (f x) = f y + := + match p with idpath => idpath end. +Lemma transport_compose {A B} {x y : A} (P : B -> Type) (f : A -> B) + (p : x = y) (z : P (f x)) + : transport (fun x => P (f x)) p z = transport P (ap f p) z. +admit. +Defined. +Generalizable Variables X A B C f g n. +Definition pr1_path `{P : A -> Type} {u v : sigT P} (p : u = v) +: u.1 = v.1 + := ap pr1 p. +Notation "p ..1" := (pr1_path p) (at level 3) : fibration_scope. +Definition pr2_path `{P : A -> Type} {u v : sigT P} (p : u = v) +: p..1 # u.2 = v.2 + := (transport_compose P pr1 p u.2)^ + @ (@apD {x:A & P x} _ pr2 _ _ p). +Notation "p ..2" := (pr2_path p) (at level 3) : fibration_scope. +Definition path_path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P) + (p q : u = v) + (rs : {r : p..1 = q..1 & transport (fun x => transport P x u.2 = v.2) r p..2 = q..2}) +: p = q. +admit. +Defined. +Set Debug Unification. +Definition path_path_sigma {A : Type} (P : A -> Type) (u v : sigT P) + (p q : u = v) + (r : p..1 = q..1) + (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2) +: p = q + := path_path_sigma_uncurried P u v p q (r; s).
\ No newline at end of file diff --git a/test-suite/bugs/closed/4101.v b/test-suite/bugs/closed/4101.v new file mode 100644 index 00000000..a38b0509 --- /dev/null +++ b/test-suite/bugs/closed/4101.v @@ -0,0 +1,19 @@ +(* File reduced by coq-bug-finder from original input, then from 10940 lines to 152 lines, then from 509 lines to 163 lines, then from 178 lines to 66 lines *) +(* coqc version 8.5beta1 (March 2015) compiled on Mar 2 2015 18:53:10 with OCaml 4.01.0 + coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (e77f178e60918f14eacd1ec0364a491d4cfd0f3f) *) + +Global Set Primitive Projections. +Set Implicit Arguments. +Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }. +Axiom path_forall : forall {A : Type} {P : A -> Type} (f g : forall x : A, P x), + (forall x, f x = g x) -> f = g. +Lemma sigT_obj_eq +: forall (T : Type) (T0 : T -> Type) + (s s0 : forall s : sigT T0, + sigT (fun _ : T0 (projT1 s) => unit) -> + sigT (fun _ : T0 (projT1 s) => unit)), + s0 = s. +Proof. + intros. + Set Debug Tactic Unification. + apply path_forall.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4103.v b/test-suite/bugs/closed/4103.v new file mode 100644 index 00000000..92cc0279 --- /dev/null +++ b/test-suite/bugs/closed/4103.v @@ -0,0 +1,12 @@ +Set Primitive Projections. + +CoInductive stream A := { hd : A; tl : stream A }. + +CoFixpoint ticks (n : nat) : stream unit := {| hd := tt; tl := ticks n |}. + +Lemma expand : exists n : nat, (ticks n) = (ticks n).(tl _). +Proof. + eexists. + (* Set Debug Tactic Unification. *) + (* Set Debug RAKAM. *) + reflexivity. diff --git a/test-suite/bugs/closed/4120.v b/test-suite/bugs/closed/4120.v new file mode 100644 index 00000000..00db8f7f --- /dev/null +++ b/test-suite/bugs/closed/4120.v @@ -0,0 +1,5 @@ +Definition id {T} (x : T) := x. +Goal sigT (fun x => id x)%type. + change (fun x => ?f x) with f. + exists Type. exact Set. +Defined. (* Error: Attempt to save a proof with shelved goals (in proof Unnamed_thm) *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/4121.v b/test-suite/bugs/closed/4121.v new file mode 100644 index 00000000..5f8c411c --- /dev/null +++ b/test-suite/bugs/closed/4121.v @@ -0,0 +1,15 @@ +(* -*- coq-prog-args: ("-emacs" "-nois") -*- *) +(* File reduced by coq-bug-finder from original input, then from 830 lines to 47 lines, then from 25 lines to 11 lines *) +(* coqc version 8.5beta1 (March 2015) compiled on Mar 11 2015 18:51:36 with OCaml 4.01.0 + coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (8dbfee5c5f897af8186cb1bdfb04fd4f88eca677) *) + +Set Universe Polymorphism. +Class Contr_internal (A : Type) := BuildContr { center : A }. +Arguments center A {_}. +Class Contr (A : Type) : Type := Contr_is_trunc : Contr_internal A. +Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances. +Definition contr_paths_contr0 {A} `{Contr A} : Contr A := {| center := center A |}. +Instance contr_paths_contr1 {A} `{Contr A} : Contr A := {| center := center A |}. +Check @contr_paths_contr0@{i}. +Check @contr_paths_contr1@{i}. (* Error: Universe instance should have length 2 *) +(** It should have length 1, just like contr_paths_contr0 *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/4165.v b/test-suite/bugs/closed/4165.v new file mode 100644 index 00000000..8e0a62d3 --- /dev/null +++ b/test-suite/bugs/closed/4165.v @@ -0,0 +1,7 @@ +Lemma foo : True. +Proof. +pose (fun x : nat => (let H:=true in x)) as s. +match eval cbv delta [s] in s with +| context C[true] => + let C':=context C[false] in pose C' as s' +end. diff --git a/test-suite/bugs/closed/4190.v b/test-suite/bugs/closed/4190.v new file mode 100644 index 00000000..2843488b --- /dev/null +++ b/test-suite/bugs/closed/4190.v @@ -0,0 +1,15 @@ +Module Type A . + Tactic Notation "bar" := idtac "ITSME". +End A. + +Module Type B. + Tactic Notation "foo" := fail "NOTME". +End B. + +Module Type C := A <+ B. + +Module Type F (Import M : C). + +Lemma foo : True. +Proof. +bar. diff --git a/test-suite/bugs/closed/4193.v b/test-suite/bugs/closed/4193.v new file mode 100644 index 00000000..885d04a9 --- /dev/null +++ b/test-suite/bugs/closed/4193.v @@ -0,0 +1,7 @@ +Module Type E. +End E. + +Module Type A (M : E). +End A. + +Fail Module Type F (Import X : A). diff --git a/test-suite/bugs/closed/HoTT_coq_007.v b/test-suite/bugs/closed/HoTT_coq_007.v index 8592c729..0b8bb235 100644 --- a/test-suite/bugs/closed/HoTT_coq_007.v +++ b/test-suite/bugs/closed/HoTT_coq_007.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Module Comment1. Set Implicit Arguments. diff --git a/test-suite/bugs/closed/HoTT_coq_014.v b/test-suite/bugs/closed/HoTT_coq_014.v index 63548a64..ae3e50d7 100644 --- a/test-suite/bugs/closed/HoTT_coq_014.v +++ b/test-suite/bugs/closed/HoTT_coq_014.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Set Implicit Arguments. Generalizable All Variables. Set Universe Polymorphism. @@ -121,6 +122,7 @@ Section GraphObj. Definition GraphIndex_Compose s d d' (m1 : GraphIndex_Morphism d d') (m2 : GraphIndex_Morphism s d) : GraphIndex_Morphism s d'. + Proof using. (* This makes no sense, but it makes this test behave as before the no admit commit *) Admitted. Definition GraphIndexingCategory : @SpecializedCategory GraphIndex. diff --git a/test-suite/bugs/closed/HoTT_coq_020.v b/test-suite/bugs/closed/HoTT_coq_020.v index b16c1df2..4938b80f 100644 --- a/test-suite/bugs/closed/HoTT_coq_020.v +++ b/test-suite/bugs/closed/HoTT_coq_020.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Set Implicit Arguments. Generalizable All Variables. diff --git a/test-suite/bugs/closed/HoTT_coq_029.v b/test-suite/bugs/closed/HoTT_coq_029.v index 4fd54b56..161c4d21 100644 --- a/test-suite/bugs/closed/HoTT_coq_029.v +++ b/test-suite/bugs/closed/HoTT_coq_029.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Module FirstComment. Set Implicit Arguments. Generalizable All Variables. diff --git a/test-suite/bugs/closed/HoTT_coq_030.v b/test-suite/bugs/closed/HoTT_coq_030.v index fa5ee25c..9f892483 100644 --- a/test-suite/bugs/closed/HoTT_coq_030.v +++ b/test-suite/bugs/closed/HoTT_coq_030.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. diff --git a/test-suite/bugs/closed/HoTT_coq_035.v b/test-suite/bugs/closed/HoTT_coq_035.v index 4ad2fc02..133bf6c7 100644 --- a/test-suite/bugs/closed/HoTT_coq_035.v +++ b/test-suite/bugs/closed/HoTT_coq_035.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Fail Check Prop : Prop. (* Prop:Prop : Prop *) Fail Check Set : Prop. (* Set:Prop diff --git a/test-suite/bugs/closed/HoTT_coq_042.v b/test-suite/bugs/closed/HoTT_coq_042.v index 6b206a2f..432cf705 100644 --- a/test-suite/bugs/closed/HoTT_coq_042.v +++ b/test-suite/bugs/closed/HoTT_coq_042.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Set Implicit Arguments. Set Universe Polymorphism. Generalizable All Variables. diff --git a/test-suite/bugs/closed/HoTT_coq_055.v b/test-suite/bugs/closed/HoTT_coq_055.v index 92d70ad1..a2509877 100644 --- a/test-suite/bugs/closed/HoTT_coq_055.v +++ b/test-suite/bugs/closed/HoTT_coq_055.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/HoTT_coq_056.v b/test-suite/bugs/closed/HoTT_coq_056.v index 6e65320d..3e3a987a 100644 --- a/test-suite/bugs/closed/HoTT_coq_056.v +++ b/test-suite/bugs/closed/HoTT_coq_056.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from 10455 lines to 8350 lines, then from 7790 lines to 710 lines, then from 7790 lines to 710 lines, then from 566 lines to 340 lines, then from 191 lines to 171 lines, then from 191 lines to 171 lines. *) Set Implicit Arguments. diff --git a/test-suite/bugs/closed/HoTT_coq_058.v b/test-suite/bugs/closed/HoTT_coq_058.v index 9ce7dba9..5e5d5ab3 100644 --- a/test-suite/bugs/closed/HoTT_coq_058.v +++ b/test-suite/bugs/closed/HoTT_coq_058.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from 10044 lines to 493 lines, then from 425 lines to 160 lines. *) Set Universe Polymorphism. Notation idmap := (fun x => x). diff --git a/test-suite/bugs/closed/HoTT_coq_061.v b/test-suite/bugs/closed/HoTT_coq_061.v index 26c1f963..19551dc9 100644 --- a/test-suite/bugs/closed/HoTT_coq_061.v +++ b/test-suite/bugs/closed/HoTT_coq_061.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* There are some problems in materialize_evar with local definitions, as CO below; this is not completely sorted out yet, but at least it fails in a smooth way at the time of today [HH] *) diff --git a/test-suite/bugs/closed/HoTT_coq_062.v b/test-suite/bugs/closed/HoTT_coq_062.v index db895316..b7db22a6 100644 --- a/test-suite/bugs/closed/HoTT_coq_062.v +++ b/test-suite/bugs/closed/HoTT_coq_062.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) (* File reduced by coq-bug-finder from 5012 lines to 4659 lines, then from 4220 lines to 501 lines, then from 513 lines to 495 lines, then from 513 lines to 495 lines, then from 412 lines to 79 lines, then from 412 lines to 79 lines. *) Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/HoTT_coq_064.v b/test-suite/bugs/closed/HoTT_coq_064.v index 5f0a541b..b4c74537 100644 --- a/test-suite/bugs/closed/HoTT_coq_064.v +++ b/test-suite/bugs/closed/HoTT_coq_064.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from 279 lines to 219 lines. *) Set Implicit Arguments. diff --git a/test-suite/bugs/closed/HoTT_coq_067.v b/test-suite/bugs/closed/HoTT_coq_067.v index ad32a60c..84a5bc02 100644 --- a/test-suite/bugs/closed/HoTT_coq_067.v +++ b/test-suite/bugs/closed/HoTT_coq_067.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Set Universe Polymorphism. Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. diff --git a/test-suite/bugs/closed/HoTT_coq_088.v b/test-suite/bugs/closed/HoTT_coq_088.v index b3e1df57..0428af0d 100644 --- a/test-suite/bugs/closed/HoTT_coq_088.v +++ b/test-suite/bugs/closed/HoTT_coq_088.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. diff --git a/test-suite/bugs/closed/HoTT_coq_090.v b/test-suite/bugs/closed/HoTT_coq_090.v index 5c704147..5fa16703 100644 --- a/test-suite/bugs/closed/HoTT_coq_090.v +++ b/test-suite/bugs/closed/HoTT_coq_090.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (** I'm not sure if this tests what I want it to test... *) Set Implicit Arguments. Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/HoTT_coq_098.v b/test-suite/bugs/closed/HoTT_coq_098.v index fc99daab..bdcd8ba9 100644 --- a/test-suite/bugs/closed/HoTT_coq_098.v +++ b/test-suite/bugs/closed/HoTT_coq_098.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Set Implicit Arguments. Generalizable All Variables. diff --git a/test-suite/bugs/closed/HoTT_coq_099.v b/test-suite/bugs/closed/HoTT_coq_099.v index 9b6ace82..cd5b0c8f 100644 --- a/test-suite/bugs/closed/HoTT_coq_099.v +++ b/test-suite/bugs/closed/HoTT_coq_099.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from 138 lines to 78 lines. *) Set Implicit Arguments. Generalizable All Variables. diff --git a/test-suite/bugs/closed/HoTT_coq_100.v b/test-suite/bugs/closed/HoTT_coq_100.v index c39b7093..663b6280 100644 --- a/test-suite/bugs/closed/HoTT_coq_100.v +++ b/test-suite/bugs/closed/HoTT_coq_100.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from 335 lines to 115 lines. *) Set Implicit Arguments. Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/HoTT_coq_101.v b/test-suite/bugs/closed/HoTT_coq_101.v index 9c89a6ab..3ef56892 100644 --- a/test-suite/bugs/closed/HoTT_coq_101.v +++ b/test-suite/bugs/closed/HoTT_coq_101.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Set Universe Polymorphism. Set Implicit Arguments. Generalizable All Variables. diff --git a/test-suite/bugs/closed/HoTT_coq_102.v b/test-suite/bugs/closed/HoTT_coq_102.v index 71becfd2..996aaaa4 100644 --- a/test-suite/bugs/closed/HoTT_coq_102.v +++ b/test-suite/bugs/closed/HoTT_coq_102.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from 64 lines to 30 lines. *) Set Implicit Arguments. Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/HoTT_coq_107.v b/test-suite/bugs/closed/HoTT_coq_107.v index c3a83627..7c1ab8dc 100644 --- a/test-suite/bugs/closed/HoTT_coq_107.v +++ b/test-suite/bugs/closed/HoTT_coq_107.v @@ -1,4 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-nois" "-emacs") -*- *) +(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-R" "../theories" "Coq") -*- *) (* File reduced by coq-bug-finder from 4897 lines to 2605 lines, then from 2297 lines to 236 lines, then from 239 lines to 137 lines, then from 118 lines to 67 lines, then from 520 lines to 76 lines. *) (** Note: The bug here is the same as the #113, that is, HoTT_coq_113.v *) Require Import Coq.Init.Logic. @@ -59,7 +59,7 @@ Instance trunc_sigma `{P : A -> Type} Proof. generalize dependent A. - induction n; [ | admit ]; simpl; intros A P ac Pc. + induction n; [ | apply admit ]; simpl; intros A P ac Pc. (exists (existT _ (center A) (center (P (center A))))). intros [a ?]. refine (path_sigma' P (contr a) (path_contr _ _)). @@ -102,5 +102,5 @@ The term | false => B end))" (Universe inconsistency: Cannot enforce Top.197 = Set)). *) - admit. + apply admit. Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_108.v b/test-suite/bugs/closed/HoTT_coq_108.v index cc304802..4f5ef997 100644 --- a/test-suite/bugs/closed/HoTT_coq_108.v +++ b/test-suite/bugs/closed/HoTT_coq_108.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) (* NOTE: This bug is only triggered with -load-vernac-source / in interactive mode. *) (* File reduced by coq-bug-finder from 139 lines to 124 lines. *) diff --git a/test-suite/bugs/closed/HoTT_coq_112.v b/test-suite/bugs/closed/HoTT_coq_112.v index 150f2ecc..5bee69fc 100644 --- a/test-suite/bugs/closed/HoTT_coq_112.v +++ b/test-suite/bugs/closed/HoTT_coq_112.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from 4464 lines to 4137 lines, then from 3683 lines to 118 lines, then from 124 lines to 75 lines. *) Set Universe Polymorphism. Definition admit {T} : T. diff --git a/test-suite/bugs/closed/HoTT_coq_113.v b/test-suite/bugs/closed/HoTT_coq_113.v index 3ef531bc..05e76784 100644 --- a/test-suite/bugs/closed/HoTT_coq_113.v +++ b/test-suite/bugs/closed/HoTT_coq_113.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 3329 lines to 153 lines, then from 118 lines to 49 lines, then from 55 lines to 38 lines, then from 46 lines to 16 lines *) Generalizable All Variables. diff --git a/test-suite/bugs/closed/HoTT_coq_118.v b/test-suite/bugs/closed/HoTT_coq_118.v index 14ad0e49..e41689cb 100644 --- a/test-suite/bugs/closed/HoTT_coq_118.v +++ b/test-suite/bugs/closed/HoTT_coq_118.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 5631 lines to 557 lines, then from 526 lines to 181 lines, then from 189 lines to 154 lines, then from 153 lines to 107 lines, then from 97 lines to 56 lines, then from 50 lines to 37 lines *) Generalizable All Variables. Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/HoTT_coq_121.v b/test-suite/bugs/closed/HoTT_coq_121.v index cce288cf..90493a53 100644 --- a/test-suite/bugs/closed/HoTT_coq_121.v +++ b/test-suite/bugs/closed/HoTT_coq_121.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 8249 lines to 907 lines, then from 843 lines to 357 lines, then from 351 lines to 260 lines, then from 208 lines to 162 lines, then from 167 lines to 154 lines, then from 146 lines to 72 lines, then from 82 lines to 70 lines, then from 79 lines to 49 lines, then from 59 lines to 16 lines *) Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/HoTT_coq_123.v b/test-suite/bugs/closed/HoTT_coq_123.v index 994dff63..6ee6e653 100644 --- a/test-suite/bugs/closed/HoTT_coq_123.v +++ b/test-suite/bugs/closed/HoTT_coq_123.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") *) (* File reduced by coq-bug-finder from original input, then from 4988 lines to 856 lines, then from 648 lines to 398 lines, then from 401 lines to 332 lines, then from 287 lines to 250 lines, then from 257 lines to 241 lines, then from 223 lines to 175 lines *) Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/2456.v b/test-suite/bugs/opened/2456.v index 56f046c4..6cca5c9f 100644 --- a/test-suite/bugs/closed/2456.v +++ b/test-suite/bugs/opened/2456.v @@ -46,8 +46,8 @@ Lemma CatchCommuteUnique2 : Proof with auto. intros. set (X := commute2). -dependent destruction commute1; +Fail dependent destruction commute1; dependent destruction catchCommuteDetails; dependent destruction commute2; dependent destruction catchCommuteDetails generalizing X. -Admitted.
\ No newline at end of file +Admitted. diff --git a/test-suite/bugs/opened/2951.v b/test-suite/bugs/opened/2951.v deleted file mode 100644 index 3739247b..00000000 --- a/test-suite/bugs/opened/2951.v +++ /dev/null @@ -1 +0,0 @@ -Class C (A: Type) : Type := { f: A }. diff --git a/test-suite/bugs/opened/3263.v b/test-suite/bugs/opened/3263.v index 6de13f74..f0c707bd 100644 --- a/test-suite/bugs/opened/3263.v +++ b/test-suite/bugs/opened/3263.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from originally 10918 lines, then 3649 lines to 3177 lines, then from 3189 lines to 3164 lines, then from 2653 lines to 2496 lines, 2653 lines, then from 1642 lines to 651 lines, then from 736 lines to 473 lines, then from 433 lines to 275 lines, then from 258 lines to 235 lines. *) Generalizable All Variables. Set Implicit Arguments. diff --git a/test-suite/bugs/opened/3345.v b/test-suite/bugs/opened/3345.v index b61174a8..3e3da6df 100644 --- a/test-suite/bugs/opened/3345.v +++ b/test-suite/bugs/opened/3345.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 1972 lines to 136 lines, then from 119 lines to 105 lines *) Global Set Implicit Arguments. Require Import Coq.Lists.List Program. diff --git a/test-suite/bugs/opened/3395.v b/test-suite/bugs/opened/3395.v index ff0dbf97..5ca48fc9 100644 --- a/test-suite/bugs/opened/3395.v +++ b/test-suite/bugs/opened/3395.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from originally 10918 lines, then 3649 lines to 3177 lines, then from 3189 lines to 3164 lines, then from 2653 lines to 2496 lines, 2653 lines, then from 1642 lines to 651 lines, then from 736 lines to 473 lines, then from 433 lines to 275 lines, then from 258 lines to 235 lines. *) Generalizable All Variables. Set Implicit Arguments. diff --git a/test-suite/bugs/opened/3491.v b/test-suite/bugs/opened/3491.v deleted file mode 100644 index 9837b0ec..00000000 --- a/test-suite/bugs/opened/3491.v +++ /dev/null @@ -1,2 +0,0 @@ -Fail Inductive list (A : Type) (T := A) : Type := - nil : list A | cons : T -> list T -> list A. diff --git a/test-suite/bugs/opened/3509.v b/test-suite/bugs/opened/3509.v index 02e47a8b..3913bbb4 100644 --- a/test-suite/bugs/opened/3509.v +++ b/test-suite/bugs/opened/3509.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Lemma match_bool_fn b A B xT xF : match b as b return forall x : A, B b x with | true => xT diff --git a/test-suite/bugs/opened/3510.v b/test-suite/bugs/opened/3510.v index 25285636..daf26507 100644 --- a/test-suite/bugs/opened/3510.v +++ b/test-suite/bugs/opened/3510.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Lemma match_option_fn T (b : option T) A B s n : match b as b return forall x : A, B b x with | Some k => s k diff --git a/test-suite/bugs/closed/3593.v b/test-suite/bugs/opened/3593.v index 25f9db6b..d83b9006 100644 --- a/test-suite/bugs/closed/3593.v +++ b/test-suite/bugs/opened/3593.v @@ -5,6 +5,6 @@ Record prod A B := pair { fst : A ; snd : B }. Goal forall x : prod Set Set, let f := @fst _ in f _ x = @fst _ _ x. simpl; intros. constr_eq (@fst Set Set x) (fst (A := Set) (B := Set) x). - Fail progress change (@fst Set Set x) with (fst (A := Set) (B := Set) x). + Fail Fail progress change (@fst Set Set x) with (fst (A := Set) (B := Set) x). reflexivity. Qed. diff --git a/test-suite/bugs/opened/3685.v b/test-suite/bugs/opened/3685.v index d647b5a8..b2b5db6b 100644 --- a/test-suite/bugs/opened/3685.v +++ b/test-suite/bugs/opened/3685.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Set Universe Polymorphism. Class Funext := { }. Delimit Scope category_scope with category. diff --git a/test-suite/bugs/opened/3754.v b/test-suite/bugs/opened/3754.v index c7441882..9b3f94d9 100644 --- a/test-suite/bugs/opened/3754.v +++ b/test-suite/bugs/opened/3754.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 9113 lines to 279 lines *) (* coqc version trunk (October 2014) compiled on Oct 19 2014 18:56:9 with OCaml 3.12.1 coqtop version trunk (October 2014) *) diff --git a/test-suite/bugs/opened/3794.v b/test-suite/bugs/opened/3794.v new file mode 100644 index 00000000..99ca6cb3 --- /dev/null +++ b/test-suite/bugs/opened/3794.v @@ -0,0 +1,7 @@ +Hint Extern 10 ((?X = ?Y) -> False) => intros; discriminate. +Hint Unfold not : core. + +Goal true<>false. +Set Typeclasses Debug. +Fail typeclasses eauto with core. +Abort.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3848.v b/test-suite/bugs/opened/3848.v index b66aecca..a03e8ffd 100644 --- a/test-suite/bugs/closed/3848.v +++ b/test-suite/bugs/opened/3848.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. @@ -18,4 +19,4 @@ Proof. refine (functor_forall (f^-1) (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)). -Defined. (* Error: Attempt to save an incomplete proof *) +Fail Defined. (* Error: Attempt to save an incomplete proof *) diff --git a/test-suite/bugs/opened/HoTT_coq_120.v b/test-suite/bugs/opened/HoTT_coq_120.v index 7847c5e4..05ee6c7b 100644 --- a/test-suite/bugs/opened/HoTT_coq_120.v +++ b/test-suite/bugs/opened/HoTT_coq_120.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 8249 lines to 907 lines, then from 843 lines to 357 lines, then from 351 lines to 260 lines, then from 208 lines to 162 lines, then from 167 lines to 154 lines *) Set Universe Polymorphism. Generalizable All Variables. diff --git a/test-suite/complexity/bug4076.v b/test-suite/complexity/bug4076.v new file mode 100644 index 00000000..3cf9e8b0 --- /dev/null +++ b/test-suite/complexity/bug4076.v @@ -0,0 +1,29 @@ +(* Check behavior of evar-evar subtyping problems in the presence of + nested let-ins *) +(* Expected time < 2.00s *) + +Set Implicit Arguments. +Unset Strict Implicit. + +Parameter f : forall P, forall (i : nat), P i -> P i. +Parameter P : nat -> Type. + +Time Definition g (n : nat) (a0 : P n) : P n := + let a1 := f a0 in + let a2 := f a1 in + let a3 := f a2 in + let a4 := f a3 in + let a5 := f a4 in + let a6 := f a5 in + let a7 := f a6 in + let a8 := f a7 in + let a9 := f a8 in + let a10 := f a9 in + let a11 := f a10 in + let a12 := f a11 in + let a13 := f a12 in + let a14 := f a13 in + let a15 := f a14 in + let a16 := f a15 in + let a17 := f a16 in + a17. diff --git a/test-suite/complexity/bug4076bis.v b/test-suite/complexity/bug4076bis.v new file mode 100644 index 00000000..f3996e6a --- /dev/null +++ b/test-suite/complexity/bug4076bis.v @@ -0,0 +1,31 @@ +(* Another check of evar-evar subtyping problems in the presence of + nested let-ins *) +(* Expected time < 2.00s *) + +Set Implicit Arguments. +Unset Strict Implicit. + +Parameter f : forall P, forall (i j : nat), P i j -> P i j. +Parameter P : nat -> nat -> Type. + +Time Definition g (n : nat) (a0 : P n n) : P n n := + let a1 := f a0 in + let a2 := f a1 in + let a3 := f a2 in + let a4 := f a3 in + let a5 := f a4 in + let a6 := f a5 in + let a7 := f a6 in + let a8 := f a7 in + let a9 := f a8 in + let a10 := f a9 in + let a11 := f a10 in + let a12 := f a11 in + let a13 := f a12 in + let a14 := f a13 in + let a15 := f a14 in + let a16 := f a15 in + let a17 := f a16 in + let a18 := f a17 in + let a19 := f a18 in + a19. diff --git a/test-suite/ide/undo020.fake b/test-suite/ide/undo020.fake index 2adde908..aa1d9bb2 100644 --- a/test-suite/ide/undo020.fake +++ b/test-suite/ide/undo020.fake @@ -12,8 +12,8 @@ ADD { Qed. } # second proof ADD { Lemma b : False. } ADD { Proof using. } -ADD { admit. } -ADD last { Qed. } +ADD { give_up. } +ADD last { Admitted. } # We join and expect some proof to fail WAIT # Going back to the error diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index 629a1ab6..2c7b04c6 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -1,13 +1,11 @@ Nat.sub : nat -> nat -> nat -Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub but avoid exposing match constructs Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat -Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub when applied to 1 argument but avoid exposing match constructs @@ -15,7 +13,6 @@ Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat -Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub when the 1st argument evaluates to a constructor and @@ -24,7 +21,6 @@ Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat -Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub when the 1st and 2nd arguments evaluate to a constructor and when applied to 2 arguments @@ -32,7 +28,6 @@ Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat -Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub when the 1st and 2nd arguments evaluate to a constructor @@ -42,7 +37,6 @@ pf : forall D1 C1 : Type, (D1 -> C1) -> forall D2 C2 : Type, (D2 -> C2) -> D1 * D2 -> C1 * C2 -pf is not universe polymorphic Arguments D2, C2 are implicit Arguments D1, C1 are implicit and maximally inserted Argument scopes are [foo_scope type_scope _ _ _ _ _] @@ -51,7 +45,6 @@ pf is transparent Expands to: Constant Top.pf fcomp : forall A B C : Type, (B -> C) -> (A -> B) -> A -> C -fcomp is not universe polymorphic Arguments A, B, C are implicit and maximally inserted Argument scopes are [type_scope type_scope type_scope _ _ _] The reduction tactics unfold fcomp when applied to 6 arguments @@ -59,20 +52,17 @@ fcomp is transparent Expands to: Constant Top.fcomp volatile : nat -> nat -volatile is not universe polymorphic Argument scope is [nat_scope] The reduction tactics always unfold volatile volatile is transparent Expands to: Constant Top.volatile f : T1 -> T2 -> nat -> unit -> nat -> nat -f is not universe polymorphic Argument scopes are [_ _ nat_scope _ nat_scope] f is transparent Expands to: Constant Top.S1.S2.f f : T1 -> T2 -> nat -> unit -> nat -> nat -f is not universe polymorphic Argument scopes are [_ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 3rd, 4th and 5th arguments evaluate to a constructor @@ -80,7 +70,6 @@ f is transparent Expands to: Constant Top.S1.S2.f f : forall T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat -f is not universe polymorphic Argument T2 is implicit Argument scopes are [type_scope _ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 4th, 5th and @@ -89,7 +78,6 @@ f is transparent Expands to: Constant Top.S1.f f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat -f is not universe polymorphic Arguments T1, T2 are implicit Argument scopes are [type_scope type_scope _ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 5th, 6th and @@ -102,7 +90,6 @@ Expands to: Constant Top.f : Prop f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat -f is not universe polymorphic The reduction tactics unfold f when the 5th, 6th and 7th arguments evaluate to a constructor f is transparent @@ -110,8 +97,8 @@ Expands to: Constant Top.f forall w : r, w 3 true = tt : Prop The command has indeed failed with message: -=> Error: Unknown interpretation for notation "$". +Error: Unknown interpretation for notation "$". w 3 true = tt : Prop The command has indeed failed with message: -=> Error: Extra argument _. +Error: Extra argument _. diff --git a/test-suite/output/ArgumentsScope.out b/test-suite/output/ArgumentsScope.out index 71d5fc78..6643c142 100644 --- a/test-suite/output/ArgumentsScope.out +++ b/test-suite/output/ArgumentsScope.out @@ -1,70 +1,56 @@ a : bool -> bool -a is not universe polymorphic Argument scope is [bool_scope] Expands to: Variable a b : bool -> bool -b is not universe polymorphic Argument scope is [bool_scope] Expands to: Variable b negb'' : bool -> bool -negb'' is not universe polymorphic Argument scope is [bool_scope] negb'' is transparent Expands to: Constant Top.A.B.negb'' negb' : bool -> bool -negb' is not universe polymorphic Argument scope is [bool_scope] negb' is transparent Expands to: Constant Top.A.negb' negb : bool -> bool -negb is not universe polymorphic Argument scope is [bool_scope] negb is transparent Expands to: Constant Coq.Init.Datatypes.negb a : bool -> bool -a is not universe polymorphic Expands to: Variable a b : bool -> bool -b is not universe polymorphic Expands to: Variable b negb : bool -> bool -negb is not universe polymorphic negb is transparent Expands to: Constant Coq.Init.Datatypes.negb negb' : bool -> bool -negb' is not universe polymorphic negb' is transparent Expands to: Constant Top.A.negb' negb'' : bool -> bool -negb'' is not universe polymorphic negb'' is transparent Expands to: Constant Top.A.B.negb'' a : bool -> bool -a is not universe polymorphic Expands to: Variable a negb : bool -> bool -negb is not universe polymorphic negb is transparent Expands to: Constant Coq.Init.Datatypes.negb negb' : bool -> bool -negb' is not universe polymorphic negb' is transparent Expands to: Constant Top.negb' negb'' : bool -> bool -negb'' is not universe polymorphic negb'' is transparent Expands to: Constant Top.negb'' diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index c29f5649..1e3cc37d 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -1,8 +1,8 @@ The command has indeed failed with message: -=> Error: To rename arguments the "rename" flag must be specified. +Error: To rename arguments the "rename" flag must be specified. Argument A renamed to B. The command has indeed failed with message: -=> Error: To rename arguments the "rename" flag must be specified. +Error: To rename arguments the "rename" flag must be specified. Argument A renamed to T. @eq_refl : forall (B : Type) (y : B), y = y @@ -20,7 +20,6 @@ For eq: Argument scopes are [type_scope _ _] For eq_refl: Argument scopes are [type_scope _] eq_refl : forall (A : Type) (x : A), x = x -eq_refl is not universe polymorphic Arguments are renamed to B, y When applied to no arguments: Arguments B, y are implicit and maximally inserted @@ -36,7 +35,6 @@ For myEq: Argument scopes are [type_scope _ _] For myrefl: Argument scopes are [type_scope _ _] myrefl : forall (B : Type) (x : A), B -> myEq B x x -myrefl is not universe polymorphic Arguments are renamed to C, x, _ Argument C is implicit and maximally inserted Argument scopes are [type_scope _ _] @@ -49,13 +47,11 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat -myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] myplus : forall T : Type, T -> nat -> nat -> nat -myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] @@ -74,7 +70,6 @@ For myEq: Argument scopes are [type_scope type_scope _ _] For myrefl: Argument scopes are [type_scope type_scope _ _] myrefl : forall (A B : Type) (x : A), B -> myEq A B x x -myrefl is not universe polymorphic Arguments are renamed to A, C, x, _ Argument C is implicit and maximally inserted Argument scopes are [type_scope type_scope _ _] @@ -89,13 +84,11 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat -myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] myplus : forall T : Type, T -> nat -> nat -> nat -myplus is not universe polymorphic Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] @@ -106,15 +99,15 @@ Expands to: Constant Top.myplus @myplus : forall Z : Type, Z -> nat -> nat -> nat The command has indeed failed with message: -=> Error: All arguments lists must declare the same names. +Error: All arguments lists must declare the same names. The command has indeed failed with message: -=> Error: The following arguments are not declared: x. +Error: The following arguments are not declared: x. The command has indeed failed with message: -=> Error: Arguments names must be distinct. +Error: Arguments names must be distinct. The command has indeed failed with message: -=> Error: Argument z cannot be declared implicit. +Error: Argument z cannot be declared implicit. The command has indeed failed with message: -=> Error: Extra argument y. +Error: Extra argument y. The command has indeed failed with message: -=> Error: To rename arguments the "rename" flag must be specified. +Error: To rename arguments the "rename" flag must be specified. Argument A renamed to R. diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index d5903483..09f032d4 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -6,8 +6,6 @@ fix F (t : t) : P t := end : forall P : t -> Type, (let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t - -t_rect is not universe polymorphic = fun d : TT => match d with | @CTT _ _ b => b end @@ -26,7 +24,6 @@ match Nat.eq_dec x y with end : forall (x y : nat) (P : nat -> Type), P x -> P y -> P y -proj is not universe polymorphic Argument scopes are [nat_scope nat_scope _ _ _] foo = fix foo (A : Type) (l : list A) {struct l} : option A := @@ -37,7 +34,6 @@ fix foo (A : Type) (l : list A) {struct l} : option A := end : forall A : Type, list A -> option A -foo is not universe polymorphic Argument scopes are [type_scope list_scope] uncast = fun (A : Type) (x : I A) => match x with @@ -45,12 +41,9 @@ fun (A : Type) (x : I A) => match x with end : forall A : Type, I A -> A -uncast is not universe polymorphic Argument scopes are [type_scope _] foo' = if A 0 then true else false : bool - -foo' is not universe polymorphic f = fun H : B => match H with @@ -61,5 +54,3 @@ match H with else fun _ : P false => Logic.I) x end : B -> True - -f is not universe polymorphic diff --git a/test-suite/output/Errors.out b/test-suite/output/Errors.out index bcc37b63..6354ad46 100644 --- a/test-suite/output/Errors.out +++ b/test-suite/output/Errors.out @@ -1,7 +1,7 @@ The command has indeed failed with message: -=> Error: The field t is missing in Top.M. +The field t is missing in Top.M. The command has indeed failed with message: -=> Error: Unable to unify "nat" with "True". +Unable to unify "nat" with "True". The command has indeed failed with message: -=> In nested Ltac calls to "f" and "apply x", last call failed. -Error: Unable to unify "nat" with "True". +In nested Ltac calls to "f" and "apply x", last call failed. +Unable to unify "nat" with "True". diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out index 0b0f501f..3b65003c 100644 --- a/test-suite/output/Implicit.out +++ b/test-suite/output/Implicit.out @@ -5,7 +5,6 @@ ex_intro (P:=fun _ : nat => True) (x:=0) I d2 = fun x : nat => d1 (y:=x) : forall x x0 : nat, x0 = x -> x0 = x -d2 is not universe polymorphic Arguments x, x0 are implicit Argument scopes are [nat_scope nat_scope _] map id (1 :: nil) diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 60ee72b3..6efd671a 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -41,29 +41,29 @@ fun x : nat => ifn x is succ n then n else 0 -4 : Z The command has indeed failed with message: -=> Error: x should not be bound in a recursive pattern of the right-hand side. +Error: x should not be bound in a recursive pattern of the right-hand side. The command has indeed failed with message: -=> Error: in the right-hand side, y and z should appear in +Error: in the right-hand side, y and z should appear in term position as part of a recursive pattern. The command has indeed failed with message: -=> Error: The reference w was not found in the current environment. +The reference w was not found in the current environment. The command has indeed failed with message: -=> Error: in the right-hand side, y and z should appear in +Error: in the right-hand side, y and z should appear in term position as part of a recursive pattern. The command has indeed failed with message: -=> Error: z is expected to occur in binding position in the right-hand side. +Error: z is expected to occur in binding position in the right-hand side. The command has indeed failed with message: -=> Error: as y is a non-closed binder, no such "," is allowed to occur. +Error: as y is a non-closed binder, no such "," is allowed to occur. The command has indeed failed with message: -=> Error: Cannot find where the recursive pattern starts. +Error: Cannot find where the recursive pattern starts. The command has indeed failed with message: -=> Error: Cannot find where the recursive pattern starts. +Error: Cannot find where the recursive pattern starts. The command has indeed failed with message: -=> Error: Cannot find where the recursive pattern starts. +Error: Cannot find where the recursive pattern starts. The command has indeed failed with message: -=> Error: Cannot find where the recursive pattern starts. +Error: Cannot find where the recursive pattern starts. The command has indeed failed with message: -=> Error: Both ends of the recursive pattern are the same. +Error: Both ends of the recursive pattern are the same. SUM (nat * nat) nat : Set FST (0; 1) diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index 0457c860..ba076f05 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -25,7 +25,6 @@ For eq: Argument scopes are [type_scope _ _] For eq_refl: Argument scopes are [type_scope _] eq_refl : forall (A : Type) (x : A), x = x -eq_refl is not universe polymorphic When applied to no arguments: Arguments A, x are implicit and maximally inserted When applied to 1 argument: @@ -46,11 +45,9 @@ fix add (n m : nat) {struct n} : nat := end : nat -> nat -> nat -Nat.add is not universe polymorphic Argument scopes are [nat_scope nat_scope] Nat.add : nat -> nat -> nat -Nat.add is not universe polymorphic Argument scopes are [nat_scope nat_scope] Nat.add is transparent Expands to: Constant Coq.Init.Nat.add @@ -58,7 +55,6 @@ Nat.add : nat -> nat -> nat plus_n_O : forall n : nat, n = n + 0 -plus_n_O is not universe polymorphic Argument scope is [nat_scope] plus_n_O is opaque Expands to: Constant Coq.Init.Peano.plus_n_O @@ -80,13 +76,11 @@ For le_n: Argument scope is [nat_scope] For le_S: Argument scopes are [nat_scope nat_scope _] comparison : Set -comparison is not universe polymorphic Expands to: Inductive Coq.Init.Datatypes.comparison Inductive comparison : Set := Eq : comparison | Lt : comparison | Gt : comparison bar : foo -bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 @@ -94,14 +88,12 @@ Argument x is implicit and maximally inserted Expands to: Constant Top.bar *** [ bar : foo ] -bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 Argument x is implicit and maximally inserted bar : foo -bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 @@ -109,7 +101,6 @@ Argument x is implicit and maximally inserted Expands to: Constant Top.bar *** [ bar : foo ] -bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 diff --git a/test-suite/output/TranspModtype.out b/test-suite/output/TranspModtype.out index 67b65d4b..f94ed642 100644 --- a/test-suite/output/TranspModtype.out +++ b/test-suite/output/TranspModtype.out @@ -1,15 +1,7 @@ TrM.A = M.A : Set - -TrM.A is not universe polymorphic OpM.A = M.A : Set - -OpM.A is not universe polymorphic TrM.B = M.B : Set - -TrM.B is not universe polymorphic *** [ OpM.B : Set ] - -OpM.B is not universe polymorphic diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index d69baaec..b1952aec 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -4,8 +4,6 @@ fun e : option L => match e with | None => None end : option L -> option L - -P is not universe polymorphic fun (m n p : nat) (H : S m <= S n + p) => le_S_n m (n + p) H : forall m n p : nat, S m <= S n + p -> m <= n + p fun n : nat => let x := A n in ?y ?y0:T n diff --git a/test-suite/output/names.out b/test-suite/output/names.out index 2892dfd5..9471b892 100644 --- a/test-suite/output/names.out +++ b/test-suite/output/names.out @@ -1,5 +1,4 @@ The command has indeed failed with message: -=> Error: In environment y : nat The term "a y" has type "{y0 : nat | y = y0}" diff --git a/test-suite/output/rewrite-2172.out b/test-suite/output/rewrite-2172.out index 30385072..27b0dc1b 100644 --- a/test-suite/output/rewrite-2172.out +++ b/test-suite/output/rewrite-2172.out @@ -1,2 +1,2 @@ The command has indeed failed with message: -=> Error: Unable to find an instance for the variable E. +Unable to find an instance for the variable E. diff --git a/test-suite/output/simpl.v b/test-suite/output/simpl.v index 89638eed..5f1926f1 100644 --- a/test-suite/output/simpl.v +++ b/test-suite/output/simpl.v @@ -4,10 +4,10 @@ Goal forall x, 0+x = 1+x. intro x. simpl (_ + x). Show. -Undo 2. +Undo. simpl (_ + x) at 2. Show. -Undo 2. +Undo. simpl (0 + _). Show. -Undo 2. +Undo. diff --git a/test-suite/prerequisite/admit.v b/test-suite/prerequisite/admit.v new file mode 100644 index 00000000..fb327663 --- /dev/null +++ b/test-suite/prerequisite/admit.v @@ -0,0 +1,2 @@ +Axiom proof_admitted : False. +Ltac admit := case proof_admitted. diff --git a/test-suite/success/AdvancedCanonicalStructure.v b/test-suite/success/AdvancedCanonicalStructure.v index d819dc47..56333973 100644 --- a/test-suite/success/AdvancedCanonicalStructure.v +++ b/test-suite/success/AdvancedCanonicalStructure.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Section group_morphism. (* An example with default canonical structures *) diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v index 4eb2dbe9..ce9050d4 100644 --- a/test-suite/success/Case22.v +++ b/test-suite/success/Case22.v @@ -5,3 +5,15 @@ Lemma a : forall x:I eq_refl, match x in I a b c return b = b with C => eq_refl intro. match goal with |- ?c => let x := eval cbv in c in change x end. Abort. + +Check forall x:I eq_refl, match x in I x return x = x with C => eq_refl end = eq_refl. + +(* This is bug #3210 *) + +Inductive I' : let X := Set in X := +| C' : I'. + +Definition foo (x : I') : bool := + match x with + C' => true + end. diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v index 3d425754..9661b3bf 100644 --- a/test-suite/success/Inductive.v +++ b/test-suite/success/Inductive.v @@ -121,3 +121,44 @@ Inductive foo1 : forall p, Prop := cc1 : foo1 0. (* Check cross inference of evars from constructors *) Inductive foo2 : forall p, Prop := cc2 : forall q, foo2 q | cc3 : foo2 0. + +(* An example with reduction removing an occurrence of the inductive type in one of its argument *) + +Inductive IND1 (A:Type) := CONS1 : IND1 ((fun x => A) IND1). + +(* These types were considered as ill-formed before March 2015, while they + could be accepted considering that the type IND1 above was accepted *) + +Inductive IND2 (A:Type) (T:=fun _ : Type->Type => A) := CONS2 : IND2 A -> IND2 (T IND2). + +Inductive IND3 (A:Type) (T:=fun _ : Type->Type => A) := CONS3 : IND3 (T IND3) -> IND3 A. + +Inductive IND4 (A:Type) := CONS4 : IND4 ((fun x => A) IND4) -> IND4 A. + +(* This type was ok before March 2015 *) + +Inductive IND5 (A : Type) (T := A) : Type := CONS5 : IND5 ((fun _ => A) 0) -> IND5 A. + +(* An example of nested positivity which was rejected by the kernel + before 24 March 2015 (even with Unset Elimination Schemes to avoid + the _rect bug) due to the wrong computation of non-recursively + uniform parameters in list' *) + +Inductive list' (A:Type) (B:=A) := +| nil' : list' A +| cons' : A -> list' B -> list' A. + +Inductive tree := node : list' tree -> tree. + +(* This type was raising an anomaly when building the _rect scheme, + because of a bug in Inductiveops.get_arity in the presence of + let-ins and recursively non-uniform parameters. *) + +Inductive L (A:Type) (T:=A) : Type := C : L nat -> L A. + +(* This type was raising an anomaly when building the _rect scheme, + because of a wrong computation of the number of non-recursively + uniform parameters when conversion is needed, leading the example to + hit the Inductiveops.get_arity bug mentioned above (see #3491) *) + +Inductive IND6 (A:Type) (T:=A) := CONS6 : IND6 T -> IND6 A. diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v index 6a488244..25e464d6 100644 --- a/test-suite/success/Injection.v +++ b/test-suite/success/Injection.v @@ -1,3 +1,5 @@ +Require Eqdep_dec. + (* Check the behaviour of Injection *) (* Check that Injection tries Intro until *) diff --git a/test-suite/success/Nsatz.v b/test-suite/success/Nsatz.v index d316e4a0..e38affd7 100644 --- a/test-suite/success/Nsatz.v +++ b/test-suite/success/Nsatz.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* compile en user 3m39.915s sur cachalot *) Require Import Nsatz. diff --git a/test-suite/success/TacticNotation1.v b/test-suite/success/TacticNotation1.v new file mode 100644 index 00000000..289f2816 --- /dev/null +++ b/test-suite/success/TacticNotation1.v @@ -0,0 +1,20 @@ +Module Type S. +End S. + +Module F (E : S). + + Tactic Notation "foo" := idtac. + + Ltac bar := foo. + +End F. + +Module G (E : S). + Module M := F E. + + Lemma Foo : True. + Proof. + M.bar. + Abort. + +End G. diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v index 21b829aa..a4ed76c5 100644 --- a/test-suite/success/apply.v +++ b/test-suite/success/apply.v @@ -536,3 +536,13 @@ Goal forall f:nat->nat, (forall P x, P (f x)) -> let x:=f 0 in x = 0. intros f H x. apply H. Qed. + +(* Test that occur-check is not too restrictive (see comments of #3141) *) +Lemma bar (X: nat -> nat -> Prop) (foo:forall x, X x x) (a: unit) (H: tt = a): + exists x, exists y, X x y. +Proof. +intros; eexists; eexists; case H. +apply (foo ?y). +Grab Existential Variables. +exact 0. +Qed. diff --git a/test-suite/success/coindprim.v b/test-suite/success/coindprim.v new file mode 100644 index 00000000..4e0b7bf5 --- /dev/null +++ b/test-suite/success/coindprim.v @@ -0,0 +1,52 @@ +Set Primitive Projections. + +CoInductive stream A := { hd : A; tl : stream A }. + +CoFixpoint ticks : stream unit := + {| hd := tt; tl := ticks |}. + +Arguments hd [ A ] s. +Arguments tl [ A ] s. + +CoInductive bisim {A} : stream A -> stream A -> Prop := + | bisims s s' : hd s = hd s' -> bisim (tl s) (tl s') -> bisim s s'. + +Lemma bisim_refl {A} (s : stream A) : bisim s s. +Proof. + revert s. + cofix aux. intros. constructor. reflexivity. apply aux. +Defined. + +Lemma constr : forall (A : Type) (s : stream A), + bisim s (Build_stream _ s.(hd) s.(tl)). +Proof. + intros. constructor. reflexivity. simpl. apply bisim_refl. +Defined. + +Lemma constr' : forall (A : Type) (s : stream A), + s = Build_stream _ s.(hd) s.(tl). +Proof. + intros. + Fail destruct s. +Abort. + +Eval compute in constr _ ticks. + +Notation convertible x y := (eq_refl x : x = y). + +Fail Check convertible ticks {| hd := hd ticks; tl := tl ticks |}. + +CoInductive U := inU + { outU : U }. + +CoFixpoint u : U := + inU u. + +CoFixpoint force (u : U) : U := + inU (outU u). + +Lemma eq (x : U) : x = force x. +Proof. + Fail destruct x. +Abort. + (* Impossible *)
\ No newline at end of file diff --git a/test-suite/success/proof_using.v b/test-suite/success/proof_using.v index dbbd57ae..61e73f85 100644 --- a/test-suite/success/proof_using.v +++ b/test-suite/success/proof_using.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Section Foo. Variable a : nat. diff --git a/test-suite/success/qed_export.v b/test-suite/success/qed_export.v new file mode 100644 index 00000000..b3e41ab1 --- /dev/null +++ b/test-suite/success/qed_export.v @@ -0,0 +1,18 @@ +Lemma a : True. +Proof. +assert True as H. + abstract (trivial) using exported_seff. +exact H. +Fail Qed exporting a_subproof. +Qed exporting exported_seff. +Check ( exported_seff : True ). + +Lemma b : True. +Proof. +assert True as H. + abstract (trivial) using exported_seff2. +exact H. +Qed. + +Fail Check ( exported_seff2 : True ). + diff --git a/test-suite/success/rewrite.v b/test-suite/success/rewrite.v index 6dcd6592..62249666 100644 --- a/test-suite/success/rewrite.v +++ b/test-suite/success/rewrite.v @@ -148,3 +148,13 @@ eexists. intro H. rewrite H. reflexivity. Abort. + +(* Check that rewriting within evars still work (was broken in 8.5beta1) *) + + +Goal forall (a: unit) (H: a = tt), exists x y:nat, x = y. +intros; eexists; eexists. +rewrite H. +Undo. +subst. +Abort. diff --git a/test-suite/success/rewrite_dep.v b/test-suite/success/rewrite_dep.v index fe250ae8..d0aafd38 100644 --- a/test-suite/success/rewrite_dep.v +++ b/test-suite/success/rewrite_dep.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Require Import Setoid. Require Import Morphisms. Require Vector. diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v index be0d49e0..0465c4b3 100644 --- a/test-suite/success/setoid_test.v +++ b/test-suite/success/setoid_test.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. Require Import Setoid. Parameter A : Set. diff --git a/test-suite/success/simpl.v b/test-suite/success/simpl.v index b5330779..e540ae5f 100644 --- a/test-suite/success/simpl.v +++ b/test-suite/success/simpl.v @@ -1,3 +1,4 @@ +Require Import TestSuite.admit. (* Check that inversion of names of mutual inductive fixpoints works *) (* (cf bug #1031) *) diff --git a/test-suite/success/tryif.v b/test-suite/success/tryif.v new file mode 100644 index 00000000..4394bddb --- /dev/null +++ b/test-suite/success/tryif.v @@ -0,0 +1,50 @@ +Require Import TestSuite.admit. + +(** [not tac] is equivalent to [fail tac "succeeds"] if [tac] succeeds, and is equivalent to [idtac] if [tac] fails *) +Tactic Notation "not" tactic3(tac) := + (tryif tac then fail 0 tac "succeeds" else idtac); (* error if the tactic solved all goals *) []. + +(** Test if a tactic succeeds, but always roll-back the results *) +Tactic Notation "test" tactic3(tac) := tryif not tac then fail 0 tac "fails" else idtac. + +Goal Set. +Proof. + not fail. + not not idtac. + not fail 0. + (** Would be nice if we could get [not fail 1] to pass, maybe *) + not not admit. + not not test admit. + not progress test admit. + (* test grouping *) + not (not idtac; fail). + assert True. + all:not fail. + 2:not fail. + all:admit. +Defined. + +Goal Set. +Proof. + test idtac. + test try fail. + test admit. + test match goal with |- Set => idtac end. + test (idtac; match goal with |- Set => idtac end). + (* test grouping *) + first [ (test idtac; fail); fail 1 | idtac ]. + try test fail. + try test test fail. + test test idtac. + test test admit. + Fail test fail. + test (idtac; []). + test (assert True; [|]). + (* would be nice, perhaps, if we could catch [fail 1] and not just [fail 0] this *) + try ((test fail); fail 1). + assert True. + all:test idtac. + all:test admit. + 2:test admit. + all:admit. +Defined. diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index 073cd5e9..048faa91 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -31,7 +31,7 @@ Set Universe Polymorphism. The relation [R] will be instantiated by [respectful] and [A] by an arrow type for usual morphisms. *) Section Proper. - Context {A B : Type}. + Context {A : Type}. Class Proper (R : crelation A) (m : A) := proper_prf : R m m. @@ -71,7 +71,7 @@ Section Proper. (** The non-dependent version is an instance where we forget dependencies. *) - Definition respectful (R : crelation A) (R' : crelation B) : crelation (A -> B) := + Definition respectful {B} (R : crelation A) (R' : crelation B) : crelation (A -> B) := Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R'). End Proper. @@ -143,7 +143,7 @@ Ltac f_equiv := end. Section Relations. - Context {A B : Type}. + Context {A : Type}. (** [forall_def] reifies the dependent product as a definition. *) @@ -156,10 +156,10 @@ Section Relations. fun f g => forall a, sig a (f a) (g a). (** Non-dependent pointwise lifting *) - Definition pointwise_relation (R : crelation B) : crelation (A -> B) := + Definition pointwise_relation {B} (R : crelation B) : crelation (A -> B) := fun f g => forall a, R (f a) (g a). - Lemma pointwise_pointwise (R : crelation B) : + Lemma pointwise_pointwise {B} (R : crelation B) : relation_equivalence (pointwise_relation R) (@eq A ==> R). Proof. intros. split. simpl_crelation. firstorder. Qed. @@ -252,7 +252,7 @@ Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S) Section GenericInstances. (* Share universes *) - Context {A B C : Type}. + Implicit Types A B C : Type. (** We can build a PER on the Coq function space if we have PERs on the domain and codomain. *) @@ -379,7 +379,7 @@ Section GenericInstances. Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R). Proof. firstorder. Qed. - Global Program Instance compose_proper RA RB RC : + Global Program Instance compose_proper A B C RA RB RC : Proper ((RB ==> RC) ==> (RA ==> RB) ==> (RA ==> RC)) (@compose A B C). Next Obligation. @@ -396,12 +396,12 @@ Section GenericInstances. Proof. simpl_crelation. Qed. (** [respectful] is a morphism for crelation equivalence . *) - Set Printing All. Set Printing Universes. + Global Instance respectful_morphism : Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) (@respectful A B). Proof. - intros R R' HRR' S S' HSS' f g. + intros A B R R' HRR' S S' HSS' f g. unfold respectful , relation_equivalence in *; simpl in *. split ; intros H x y Hxy. apply (fst (HSS' _ _)). apply H. now apply (snd (HRR' _ _)). @@ -414,9 +414,9 @@ Section GenericInstances. Proper R' (m x). Proof. simpl_crelation. Qed. - Class Params (of : A) (arity : nat). + Class Params {A} (of : A) (arity : nat). - Lemma flip_respectful (R : crelation A) (R' : crelation B) : + Lemma flip_respectful {A B} (R : crelation A) (R' : crelation B) : relation_equivalence (flip (R ==> R')) (flip R ==> flip R'). Proof. intros. @@ -449,7 +449,7 @@ Section GenericInstances. Lemma reflexive_proper `{Reflexive A R} (x : A) : Proper R x. Proof. firstorder. Qed. - Lemma proper_eq (x : A) : Proper (@eq A) x. + Lemma proper_eq {A} (x : A) : Proper (@eq A) x. Proof. intros. apply reflexive_proper. Qed. End GenericInstances. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index d2971552..50f853f0 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -22,9 +22,6 @@ Inductive True : Prop := (** [False] is the always false proposition *) Inductive False : Prop :=. -(** [proof_admitted] is used to implement the admit tactic *) -Axiom proof_admitted : False. - (** [not A], written [~A], is the negation of [A] *) Definition not (A:Prop) := A -> False. diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index 424ca0c8..a7bdba90 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -59,7 +59,7 @@ Reserved Notation "( x , y , .. , z )" (at level 0). (** Notation "{ x }" is reserved and has a special status as component of other notations such as "{ A } + { B }" and "A + { B }" (which - are at the same level than "x + y"); + are at the same level as "x + y"); "{ x }" is at level 0 to factor with "{ x : A | P }" *) Reserved Notation "{ x }" (at level 0, x at level 99). diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 4894eba4..0efb8744 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -23,4 +23,4 @@ Declare ML Module "cc_plugin". Declare ML Module "ground_plugin". Declare ML Module "recdef_plugin". (* Default substrings not considered by queries like SearchAbout *) -Add Search Blacklist "_admitted" "_subproof" "Private_". +Add Search Blacklist "_subproof" "Private_". diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 9e828e6e..a7d3f806 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -180,12 +180,14 @@ Ltac easy := | H : _ |- _ => solve [inversion H] | _ => idtac end in - let rec do_atom := - solve [reflexivity | symmetry; trivial] || - contradiction || - (split; do_atom) - with do_ccl := trivial with eq_true; repeat do_intro; do_atom in - (use_hyps; do_ccl) || fail "Cannot solve this goal". + let do_atom := + solve [ trivial with eq_true | reflexivity | symmetry; trivial | contradiction ] in + let rec do_ccl := + try do_atom; + repeat (do_intro; try do_atom); + solve [ split; do_ccl ] in + solve [ do_atom | use_hyps; do_ccl ] || + fail "Cannot solve this goal". Tactic Notation "now" tactic(t) := t; easy. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 3cba090f..ea07a849 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -1014,11 +1014,17 @@ Proof. rewrite IHl; auto. Qed. +Lemma map_ext_in : + forall (A B : Type)(f g:A->B) l, (forall a, In a l -> f a = g a) -> map f l = map g l. +Proof. + induction l; simpl; auto. + intros; rewrite H by intuition; rewrite IHl; auto. +Qed. + Lemma map_ext : forall (A B : Type)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l. Proof. - induction l; simpl; auto. - rewrite H; rewrite IHl; auto. + intros; apply map_ext_in; auto. Qed. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index b57c3f04..c95fb4d5 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -613,18 +613,18 @@ induction s1; simpl; auto; intros. Qed. Lemma fold_right_equivlistA_restr2 : - forall s s' (i j:B) (heqij: eqB i j), + forall s s' i j, NoDupA s -> NoDupA s' -> ForallOrdPairs R s -> - eqB i j -> - equivlistA s s' -> eqB (fold_right f i s) (fold_right f j s'). + equivlistA s s' -> eqB i j -> + eqB (fold_right f i s) (fold_right f j s'). Proof. simple induction s. destruct s'; simpl. intros. assumption. unfold equivlistA; intros. - destruct (H3 a). + destruct (H2 a). assert (InA a nil) by auto; inv. - intros x l Hrec s' i j heqij N N' F eqij E; simpl in *. + intros x l Hrec s' i j N N' F E eqij; simpl in *. assert (InA x s') by (rewrite <- (E x); auto). destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). subst s'. @@ -649,7 +649,6 @@ Proof. red; intros; rewrite E; auto. Qed. - Lemma fold_right_add_restr2 : forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ForallOrdPairs R s' -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)). diff --git a/theories/Lists/SetoidPermutation.v b/theories/Lists/SetoidPermutation.v index afc7c25b..cea3e839 100644 --- a/theories/Lists/SetoidPermutation.v +++ b/theories/Lists/SetoidPermutation.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -Require Import SetoidList. +Require Import Permutation SetoidList. (* Set Universe Polymorphism. *) Set Implicit Arguments. @@ -123,4 +123,76 @@ Proof. apply equivlistA_NoDupA_split with x y; intuition. Qed. +Lemma Permutation_eqlistA_commute l₁ l₂ l₃ : + eqlistA eqA l₁ l₂ -> Permutation l₂ l₃ -> + exists l₂', Permutation l₁ l₂' /\ eqlistA eqA l₂' l₃. +Proof. + intros E P. revert l₁ E. + induction P; intros. + - inversion_clear E. now exists nil. + - inversion_clear E. + destruct (IHP l0) as (l0',(P',E')); trivial. clear IHP. + exists (x0::l0'). split; auto. + - inversion_clear E. inversion_clear H0. + exists (x1::x0::l1). now repeat constructor. + - clear P1 P2. + destruct (IHP1 _ E) as (l₁',(P₁,E₁)). + destruct (IHP2 _ E₁) as (l₂',(P₂,E₂)). + exists l₂'. split; trivial. econstructor; eauto. +Qed. + +Lemma PermutationA_decompose l₁ l₂ : + PermutationA l₁ l₂ -> + exists l, Permutation l₁ l /\ eqlistA eqA l l₂. +Proof. + induction 1. + - now exists nil. + - destruct IHPermutationA as (l,(P,E)). exists (x₁::l); auto. + - exists (x::y::l). split. constructor. reflexivity. + - destruct IHPermutationA1 as (l₁',(P,E)). + destruct IHPermutationA2 as (l₂',(P',E')). + destruct (@Permutation_eqlistA_commute l₁' l₂ l₂') as (l₁'',(P'',E'')); + trivial. + exists l₁''. split. now transitivity l₁'. now transitivity l₂'. +Qed. + +Lemma Permutation_PermutationA l₁ l₂ : + Permutation l₁ l₂ -> PermutationA l₁ l₂. +Proof. + induction 1. + - constructor. + - now constructor. + - apply permA_swap. + - econstructor; eauto. +Qed. + +Lemma eqlistA_PermutationA l₁ l₂ : + eqlistA eqA l₁ l₂ -> PermutationA l₁ l₂. +Proof. + induction 1; now constructor. +Qed. + +Lemma NoDupA_equivlistA_decompose l1 l2 : + NoDupA eqA l1 -> NoDupA eqA l2 -> equivlistA eqA l1 l2 -> + exists l, Permutation l1 l /\ eqlistA eqA l l2. +Proof. + intros. apply PermutationA_decompose. + now apply NoDupA_equivlistA_PermutationA. +Qed. + +Lemma PermutationA_preserves_NoDupA l₁ l₂ : + PermutationA l₁ l₂ -> NoDupA eqA l₁ -> NoDupA eqA l₂. +Proof. + induction 1; trivial. + - inversion_clear 1; constructor; auto. + apply PermutationA_equivlistA in H0. contradict H2. + now rewrite H, H0. + - inversion_clear 1. inversion_clear H1. constructor. + + contradict H. inversion_clear H; trivial. + elim H0. now constructor. + + constructor; trivial. + contradict H0. now apply InA_cons_tl. + - eauto. +Qed. + End Permutation. diff --git a/theories/MMaps/MMapAVL.v b/theories/MMaps/MMapAVL.v new file mode 100644 index 00000000..d840f1f3 --- /dev/null +++ b/theories/MMaps/MMapAVL.v @@ -0,0 +1,2158 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* Finite map library. *) + +(** * MMapAVL *) + +(** This module implements maps using AVL trees. + It follows the implementation from Ocaml's standard library. + + See the comments at the beginning of MSetAVL for more details. +*) + +Require Import Bool PeanoNat BinInt Int MMapInterface MMapList. +Require Import Orders OrdersFacts OrdersLists. + +Set Implicit Arguments. +Unset Strict Implicit. +(* For nicer extraction, we create inductive principles + only when needed *) +Local Unset Elimination Schemes. + +(** Notations and helper lemma about pairs *) + +Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. +Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. + +(** * The Raw functor + + Functor of pure functions + separate proofs of invariant + preservation *) + +Module Raw (Import I:Int)(X: OrderedType). +Local Open Scope pair_scope. +Local Open Scope lazy_bool_scope. +Local Open Scope Int_scope. +Local Notation int := I.t. + +Definition key := X.t. +Hint Transparent key. + +(** * Trees *) + +Section Elt. + +Variable elt : Type. + +(** * Trees + + The fifth field of [Node] is the height of the tree *) + +Inductive tree := + | Leaf : tree + | Node : tree -> key -> elt -> tree -> int -> tree. + +Notation t := tree. + +(** * Basic functions on trees: height and cardinal *) + +Definition height (m : t) : int := + match m with + | Leaf => 0 + | Node _ _ _ _ h => h + end. + +Fixpoint cardinal (m : t) : nat := + match m with + | Leaf => 0%nat + | Node l _ _ r _ => S (cardinal l + cardinal r) + end. + +(** * Empty Map *) + +Definition empty := Leaf. + +(** * Emptyness test *) + +Definition is_empty m := match m with Leaf => true | _ => false end. + +(** * Membership *) + +(** The [mem] function is deciding membership. It exploits the [Bst] property + to achieve logarithmic complexity. *) + +Fixpoint mem x m : bool := + match m with + | Leaf => false + | Node l y _ r _ => + match X.compare x y with + | Eq => true + | Lt => mem x l + | Gt => mem x r + end + end. + +Fixpoint find x m : option elt := + match m with + | Leaf => None + | Node l y d r _ => + match X.compare x y with + | Eq => Some d + | Lt => find x l + | Gt => find x r + end + end. + +(** * Helper functions *) + +(** [create l x r] creates a node, assuming [l] and [r] + to be balanced and [|height l - height r| <= 2]. *) + +Definition create l x e r := + Node l x e r (max (height l) (height r) + 1). + +(** [bal l x e r] acts as [create], but performs one step of + rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) + +Definition assert_false := create. + +Fixpoint bal l x d r := + let hl := height l in + let hr := height r in + if (hr+2) <? hl then + match l with + | Leaf => assert_false l x d r + | Node ll lx ld lr _ => + if (height lr) <=? (height ll) then + create ll lx ld (create lr x d r) + else + match lr with + | Leaf => assert_false l x d r + | Node lrl lrx lrd lrr _ => + create (create ll lx ld lrl) lrx lrd (create lrr x d r) + end + end + else + if (hl+2) <? hr then + match r with + | Leaf => assert_false l x d r + | Node rl rx rd rr _ => + if (height rl) <=? (height rr) then + create (create l x d rl) rx rd rr + else + match rl with + | Leaf => assert_false l x d r + | Node rll rlx rld rlr _ => + create (create l x d rll) rlx rld (create rlr rx rd rr) + end + end + else + create l x d r. + +(** * Insertion *) + +Fixpoint add x d m := + match m with + | Leaf => Node Leaf x d Leaf 1 + | Node l y d' r h => + match X.compare x y with + | Eq => Node l y d r h + | Lt => bal (add x d l) y d' r + | Gt => bal l y d' (add x d r) + end + end. + +(** * Extraction of minimum binding + + Morally, [remove_min] is to be applied to a non-empty tree + [t = Node l x e r h]. Since we can't deal here with [assert false] + for [t=Leaf], we pre-unpack [t] (and forget about [h]). +*) + +Fixpoint remove_min l x d r : t*(key*elt) := + match l with + | Leaf => (r,(x,d)) + | Node ll lx ld lr lh => + let (l',m) := remove_min ll lx ld lr in + (bal l' x d r, m) + end. + +(** * Merging two trees + + [merge0 t1 t2] builds the union of [t1] and [t2] assuming all elements + of [t1] to be smaller than all elements of [t2], and + [|height t1 - height t2| <= 2]. +*) + +Definition merge0 s1 s2 := + match s1,s2 with + | Leaf, _ => s2 + | _, Leaf => s1 + | _, Node l2 x2 d2 r2 h2 => + let '(s2',(x,d)) := remove_min l2 x2 d2 r2 in + bal s1 x d s2' + end. + +(** * Deletion *) + +Fixpoint remove x m := match m with + | Leaf => Leaf + | Node l y d r h => + match X.compare x y with + | Eq => merge0 l r + | Lt => bal (remove x l) y d r + | Gt => bal l y d (remove x r) + end + end. + +(** * join + + Same as [bal] but does not assume anything regarding heights of [l] + and [r]. +*) + +Fixpoint join l : key -> elt -> t -> t := + match l with + | Leaf => add + | Node ll lx ld lr lh => fun x d => + fix join_aux (r:t) : t := match r with + | Leaf => add x d l + | Node rl rx rd rr rh => + if rh+2 <? lh then bal ll lx ld (join lr x d r) + else if lh+2 <? rh then bal (join_aux rl) rx rd rr + else create l x d r + end + end. + +(** * Splitting + + [split x m] returns a triple [(l, o, r)] where + - [l] is the set of elements of [m] that are [< x] + - [r] is the set of elements of [m] that are [> x] + - [o] is the result of [find x m]. +*) + +Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }. +Notation "〚 l , b , r 〛" := (mktriple l b r) (at level 9). + +Fixpoint split x m : triple := match m with + | Leaf => 〚 Leaf, None, Leaf 〛 + | Node l y d r h => + match X.compare x y with + | Lt => let (ll,o,rl) := split x l in 〚 ll, o, join rl y d r 〛 + | Eq => 〚 l, Some d, r 〛 + | Gt => let (rl,o,rr) := split x r in 〚 join l y d rl, o, rr 〛 + end + end. + +(** * Concatenation + + Same as [merge] but does not assume anything about heights. +*) + +Definition concat m1 m2 := + match m1, m2 with + | Leaf, _ => m2 + | _ , Leaf => m1 + | _, Node l2 x2 d2 r2 _ => + let (m2',xd) := remove_min l2 x2 d2 r2 in + join m1 xd#1 xd#2 m2' + end. + +(** * Bindings *) + +(** [bindings_aux acc t] catenates the bindings of [t] in infix + order to the list [acc] *) + +Fixpoint bindings_aux (acc : list (key*elt)) m : list (key*elt) := + match m with + | Leaf => acc + | Node l x d r _ => bindings_aux ((x,d) :: bindings_aux acc r) l + end. + +(** then [bindings] is an instantiation with an empty [acc] *) + +Definition bindings := bindings_aux nil. + +(** * Fold *) + +Fixpoint fold {A} (f : key -> elt -> A -> A) (m : t) : A -> A := + fun a => match m with + | Leaf => a + | Node l x d r _ => fold f r (f x d (fold f l a)) + end. + +(** * Comparison *) + +Variable cmp : elt->elt->bool. + +(** ** Enumeration of the elements of a tree *) + +Inductive enumeration := + | End : enumeration + | More : key -> elt -> t -> enumeration -> enumeration. + +(** [cons m e] adds the elements of tree [m] on the head of + enumeration [e]. *) + +Fixpoint cons m e : enumeration := + match m with + | Leaf => e + | Node l x d r h => cons l (More x d r e) + end. + +(** One step of comparison of elements *) + +Definition equal_more x1 d1 (cont:enumeration->bool) e2 := + match e2 with + | End => false + | More x2 d2 r2 e2 => + match X.compare x1 x2 with + | Eq => cmp d1 d2 &&& cont (cons r2 e2) + | _ => false + end + end. + +(** Comparison of left tree, middle element, then right tree *) + +Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := + match m1 with + | Leaf => cont e2 + | Node l1 x1 d1 r1 _ => + equal_cont l1 (equal_more x1 d1 (equal_cont r1 cont)) e2 + end. + +(** Initial continuation *) + +Definition equal_end e2 := match e2 with End => true | _ => false end. + +(** The complete comparison *) + +Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End). + +End Elt. +Notation t := tree. +Notation "〚 l , b , r 〛" := (mktriple l b r) (at level 9). +Notation "t #l" := (t_left t) (at level 9, format "t '#l'"). +Notation "t #o" := (t_opt t) (at level 9, format "t '#o'"). +Notation "t #r" := (t_right t) (at level 9, format "t '#r'"). + + +(** * Map *) + +Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := + match m with + | Leaf _ => Leaf _ + | Node l x d r h => Node (map f l) x (f d) (map f r) h + end. + +(* * Mapi *) + +Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := + match m with + | Leaf _ => Leaf _ + | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h + end. + +(** * Map with removal *) + +Fixpoint mapo (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt) + : t elt' := + match m with + | Leaf _ => Leaf _ + | Node l x d r h => + match f x d with + | Some d' => join (mapo f l) x d' (mapo f r) + | None => concat (mapo f l) (mapo f r) + end + end. + +(** * Generalized merge + + Suggestion by B. Gregoire: a [merge] function with specialized + arguments that allows bypassing some tree traversal. Instead of one + [f0] of type [key -> option elt -> option elt' -> option elt''], + we ask here for: + - [f] which is a specialisation of [f0] when first option isn't [None] + - [mapl] treats a [tree elt] with [f0] when second option is [None] + - [mapr] treats a [tree elt'] with [f0] when first option is [None] + + The idea is that [mapl] and [mapr] can be instantaneous (e.g. + the identity or some constant function). +*) + +Section GMerge. +Variable elt elt' elt'' : Type. +Variable f : key -> elt -> option elt' -> option elt''. +Variable mapl : t elt -> t elt''. +Variable mapr : t elt' -> t elt''. + +Fixpoint gmerge m1 m2 := + match m1, m2 with + | Leaf _, _ => mapr m2 + | _, Leaf _ => mapl m1 + | Node l1 x1 d1 r1 h1, _ => + let (l2',o2,r2') := split x1 m2 in + match f x1 d1 o2 with + | Some e => join (gmerge l1 l2') x1 e (gmerge r1 r2') + | None => concat (gmerge l1 l2') (gmerge r1 r2') + end + end. + +End GMerge. + +(** * Merge + + The [merge] function of the Map interface can be implemented + via [gmerge] and [mapo]. +*) + +Section Merge. +Variable elt elt' elt'' : Type. +Variable f : key -> option elt -> option elt' -> option elt''. + +Definition merge : t elt -> t elt' -> t elt'' := + gmerge + (fun k d o => f k (Some d) o) + (mapo (fun k d => f k (Some d) None)) + (mapo (fun k d' => f k None (Some d'))). + +End Merge. + + + +(** * Invariants *) + +Section Invariants. +Variable elt : Type. + +(** ** Occurrence in a tree *) + +Inductive MapsTo (x : key)(e : elt) : t elt -> Prop := + | MapsRoot : forall l r h y, + X.eq x y -> MapsTo x e (Node l y e r h) + | MapsLeft : forall l r h y e', + MapsTo x e l -> MapsTo x e (Node l y e' r h) + | MapsRight : forall l r h y e', + MapsTo x e r -> MapsTo x e (Node l y e' r h). + +Inductive In (x : key) : t elt -> Prop := + | InRoot : forall l r h y e, + X.eq x y -> In x (Node l y e r h) + | InLeft : forall l r h y e', + In x l -> In x (Node l y e' r h) + | InRight : forall l r h y e', + In x r -> In x (Node l y e' r h). + +Definition In0 k m := exists e:elt, MapsTo k e m. + +(** ** Binary search trees *) + +(** [Above x m] : [x] is strictly greater than any key in [m]. + [Below x m] : [x] is strictly smaller than any key in [m]. *) + +Inductive Above (x:key) : t elt -> Prop := + | AbLeaf : Above x (Leaf _) + | AbNode l r h y e : Above x l -> X.lt y x -> Above x r -> + Above x (Node l y e r h). + +Inductive Below (x:key) : t elt -> Prop := + | BeLeaf : Below x (Leaf _) + | BeNode l r h y e : Below x l -> X.lt x y -> Below x r -> + Below x (Node l y e r h). + +Definition Apart (m1 m2 : t elt) : Prop := + forall x1 x2, In x1 m1 -> In x2 m2 -> X.lt x1 x2. + +(** Alternative statements, equivalent with [LtTree] and [GtTree] *) + +Definition lt_tree x m := forall y, In y m -> X.lt y x. +Definition gt_tree x m := forall y, In y m -> X.lt x y. + +(** [Bst t] : [t] is a binary search tree *) + +Inductive Bst : t elt -> Prop := + | BSLeaf : Bst (Leaf _) + | BSNode : forall x e l r h, Bst l -> Bst r -> + Above x l -> Below x r -> Bst (Node l x e r h). + +End Invariants. + + +(** * Correctness proofs, isolated in a sub-module *) + +Module Proofs. + Module MX := OrderedTypeFacts X. + Module PX := KeyOrderedType X. + Module L := MMapList.Raw X. + +Local Infix "∈" := In (at level 70). +Local Infix "==" := X.eq (at level 70). +Local Infix "<" := X.lt (at level 70). +Local Infix "<<" := Below (at level 70). +Local Infix ">>" := Above (at level 70). +Local Infix "<<<" := Apart (at level 70). + +Scheme tree_ind := Induction for tree Sort Prop. +Scheme Bst_ind := Induction for Bst Sort Prop. +Scheme MapsTo_ind := Induction for MapsTo Sort Prop. +Scheme In_ind := Induction for In Sort Prop. +Scheme Above_ind := Induction for Above Sort Prop. +Scheme Below_ind := Induction for Below Sort Prop. + +Functional Scheme mem_ind := Induction for mem Sort Prop. +Functional Scheme find_ind := Induction for find Sort Prop. +Functional Scheme bal_ind := Induction for bal Sort Prop. +Functional Scheme add_ind := Induction for add Sort Prop. +Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. +Functional Scheme merge0_ind := Induction for merge0 Sort Prop. +Functional Scheme remove_ind := Induction for remove Sort Prop. +Functional Scheme concat_ind := Induction for concat Sort Prop. +Functional Scheme split_ind := Induction for split Sort Prop. +Functional Scheme mapo_ind := Induction for mapo Sort Prop. +Functional Scheme gmerge_ind := Induction for gmerge Sort Prop. + +(** * Automation and dedicated tactics. *) + +Local Hint Constructors tree MapsTo In Bst Above Below. +Local Hint Unfold lt_tree gt_tree Apart. +Local Hint Immediate MX.eq_sym. +Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans. + +Tactic Notation "factornode" ident(s) := + try clear s; + match goal with + | |- context [Node ?l ?x ?e ?r ?h] => + set (s:=Node l x e r h) in *; clearbody s; clear l x e r h + | _ : context [Node ?l ?x ?e ?r ?h] |- _ => + set (s:=Node l x e r h) in *; clearbody s; clear l x e r h + end. + +(** A tactic for cleaning hypothesis after use of functional induction. *) + +Ltac cleanf := + match goal with + | H : X.compare _ _ = Eq |- _ => + rewrite ?H; apply MX.compare_eq in H; cleanf + | H : X.compare _ _ = Lt |- _ => + rewrite ?H; apply MX.compare_lt_iff in H; cleanf + | H : X.compare _ _ = Gt |- _ => + rewrite ?H; apply MX.compare_gt_iff in H; cleanf + | _ => idtac + end. + + +(** A tactic to repeat [inversion_clear] on all hyps of the + form [(f (Node ...))] *) + +Ltac inv f := + match goal with + | H:f (Leaf _) |- _ => inversion_clear H; inv f + | H:f _ (Leaf _) |- _ => inversion_clear H; inv f + | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f + | H:f _ _ _ (Leaf _) |- _ => inversion_clear H; inv f + | H:f (Node _ _ _ _ _) |- _ => inversion_clear H; inv f + | H:f _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f + | H:f _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f + | H:f _ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f + | _ => idtac + end. + +Ltac inv_all f := + match goal with + | H: f _ |- _ => inversion_clear H; inv f + | H: f _ _ |- _ => inversion_clear H; inv f + | H: f _ _ _ |- _ => inversion_clear H; inv f + | H: f _ _ _ _ |- _ => inversion_clear H; inv f + | _ => idtac + end. + +Ltac intuition_in := repeat (intuition; inv In; inv MapsTo). + +(* Function/Functional Scheme can't deal with internal fix. + Let's do its job by hand: *) + +Ltac join_tac l x d r := + revert x d r; + induction l as [| ll _ lx ld lr Hlr lh]; + [ | intros x d r; induction r as [| rl Hrl rx rd rr _ rh]; unfold join; + [ | destruct (rh+2 <? lh) eqn:LT; + [ match goal with |- context [ bal ?u ?v ?w ?z ] => + replace (bal u v w z) + with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto] + end + | destruct (lh+2 <? rh) eqn:LT'; + [ match goal with |- context [ bal ?u ?v ?w ?z ] => + replace (bal u v w z) + with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] + end + | ] ] ] ]; intros. + +Ltac cleansplit := + simpl; cleanf; inv Bst; + match goal with + | E:split _ _ = 〚 ?l, ?o, ?r 〛 |- _ => + change l with (〚l,o,r〛#l); rewrite <- ?E; + change o with (〚l,o,r〛#o); rewrite <- ?E; + change r with (〚l,o,r〛#r); rewrite <- ?E + | _ => idtac + end. + +(** * Basic results about [MapsTo], [In], [lt_tree], [gt_tree], [height] *) + +(** Facts about [MapsTo] and [In]. *) + +Lemma MapsTo_In {elt} k (e:elt) m : MapsTo k e m -> k ∈ m. +Proof. + induction 1; auto. +Qed. +Local Hint Resolve MapsTo_In. + +Lemma In_MapsTo {elt} k m : k ∈ m -> exists (e:elt), MapsTo k e m. +Proof. + induction 1; try destruct IHIn as (e,He); exists e; auto. +Qed. + +Lemma In_alt {elt} k (m:t elt) : In0 k m <-> k ∈ m. +Proof. + split. + intros (e,H); eauto. + unfold In0; apply In_MapsTo; auto. +Qed. + +Lemma MapsTo_1 {elt} m x y (e:elt) : + x == y -> MapsTo x e m -> MapsTo y e m. +Proof. + induction m; simpl; intuition_in; eauto. +Qed. +Hint Immediate MapsTo_1. + +Instance MapsTo_compat {elt} : + Proper (X.eq==>Logic.eq==>Logic.eq==>iff) (@MapsTo elt). +Proof. + intros x x' Hx e e' He m m' Hm. subst. + split; now apply MapsTo_1. +Qed. + +Instance In_compat {elt} : + Proper (X.eq==>Logic.eq==>iff) (@In elt). +Proof. + intros x x' H m m' <-. + induction m; simpl; intuition_in; eauto. +Qed. + +Lemma In_node_iff {elt} l x (e:elt) r h y : + y ∈ (Node l x e r h) <-> y ∈ l \/ y == x \/ y ∈ r. +Proof. + intuition_in. +Qed. + +(** Results about [Above] and [Below] *) + +Lemma above {elt} (m:t elt) x : + x >> m <-> forall y, y ∈ m -> y < x. +Proof. + split. + - induction 1; intuition_in; MX.order. + - induction m; constructor; auto. +Qed. + +Lemma below {elt} (m:t elt) x : + x << m <-> forall y, y ∈ m -> x < y. +Proof. + split. + - induction 1; intuition_in; MX.order. + - induction m; constructor; auto. +Qed. + +Lemma AboveLt {elt} (m:t elt) x y : x >> m -> y ∈ m -> y < x. +Proof. + rewrite above; intuition. +Qed. + +Lemma BelowGt {elt} (m:t elt) x y : x << m -> y ∈ m -> x < y. +Proof. + rewrite below; intuition. +Qed. + +Lemma Above_not_In {elt} (m:t elt) x : x >> m -> ~ x ∈ m. +Proof. + induction 1; intuition_in; MX.order. +Qed. + +Lemma Below_not_In {elt} (m:t elt) x : x << m -> ~ x ∈ m. +Proof. + induction 1; intuition_in; MX.order. +Qed. + +Lemma Above_trans {elt} (m:t elt) x y : x < y -> x >> m -> y >> m. +Proof. + induction 2; constructor; trivial; MX.order. +Qed. + +Lemma Below_trans {elt} (m:t elt) x y : y < x -> x << m -> y << m. +Proof. + induction 2; constructor; trivial; MX.order. +Qed. + +Local Hint Resolve + AboveLt Above_not_In Above_trans + BelowGt Below_not_In Below_trans. + +(** Helper tactic concerning order of elements. *) + +Ltac order := match goal with + | U: _ >> ?m, V: _ ∈ ?m |- _ => + generalize (AboveLt U V); clear U; order + | U: _ << ?m, V: _ ∈ ?m |- _ => + generalize (BelowGt U V); clear U; order + | U: _ >> ?m, V: MapsTo _ _ ?m |- _ => + generalize (AboveLt U (MapsTo_In V)); clear U; order + | U: _ << ?m, V: MapsTo _ _ ?m |- _ => + generalize (BelowGt U (MapsTo_In V)); clear U; order + | _ => MX.order +end. + +Lemma between {elt} (m m':t elt) x : + x >> m -> x << m' -> m <<< m'. +Proof. + intros H H' y y' Hy Hy'. order. +Qed. + +Section Elt. +Variable elt:Type. +Implicit Types m r : t elt. + +(** * Membership *) + +Lemma find_1 m x e : Bst m -> MapsTo x e m -> find x m = Some e. +Proof. + functional induction (find x m); cleanf; + intros; inv Bst; intuition_in; order. +Qed. + +Lemma find_2 m x e : find x m = Some e -> MapsTo x e m. +Proof. + functional induction (find x m); cleanf; subst; intros; auto. + - discriminate. + - injection H as ->. auto. +Qed. + +Lemma find_spec m x e : Bst m -> + (find x m = Some e <-> MapsTo x e m). +Proof. + split; auto using find_1, find_2. +Qed. + +Lemma find_in m x : find x m <> None -> x ∈ m. +Proof. + destruct (find x m) eqn:F; intros H. + - apply MapsTo_In with e. now apply find_2. + - now elim H. +Qed. + +Lemma in_find m x : Bst m -> x ∈ m -> find x m <> None. +Proof. + intros H H'. + destruct (In_MapsTo H') as (d,Hd). + now rewrite (find_1 H Hd). +Qed. + +Lemma find_in_iff m x : Bst m -> + (find x m <> None <-> x ∈ m). +Proof. + split; auto using find_in, in_find. +Qed. + +Lemma not_find_iff m x : Bst m -> + (find x m = None <-> ~ x ∈ m). +Proof. + intros H. rewrite <- find_in_iff; trivial. + destruct (find x m); split; try easy. now destruct 1. +Qed. + +Lemma eq_option_alt (o o':option elt) : + o=o' <-> (forall e, o=Some e <-> o'=Some e). +Proof. +split; intros. +- now subst. +- destruct o, o'; rewrite ?H; auto. symmetry; now apply H. +Qed. + +Lemma find_mapsto_equiv : forall m m' x, Bst m -> Bst m' -> + (find x m = find x m' <-> + (forall d, MapsTo x d m <-> MapsTo x d m')). +Proof. + intros m m' x Hm Hm'. rewrite eq_option_alt. + split; intros H d. now rewrite <- 2 find_spec. now rewrite 2 find_spec. +Qed. + +Lemma find_in_equiv : forall m m' x, Bst m -> Bst m' -> + find x m = find x m' -> + (x ∈ m <-> x ∈ m'). +Proof. + split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ]; + apply in_find; auto. +Qed. + +Lemma find_compat m x x' : Bst m -> X.eq x x' -> find x m = find x' m. +Proof. + intros B E. + destruct (find x' m) eqn:H. + - apply find_1; trivial. rewrite E. now apply find_2. + - rewrite not_find_iff in *; trivial. now rewrite E. +Qed. + +Lemma mem_spec m x : Bst m -> mem x m = true <-> x ∈ m. +Proof. + functional induction (mem x m); auto; intros; cleanf; + inv Bst; intuition_in; try discriminate; order. +Qed. + +(** * Empty map *) + +Lemma empty_bst : Bst (empty elt). +Proof. + constructor. +Qed. + +Lemma empty_spec x : find x (empty elt) = None. +Proof. + reflexivity. +Qed. + +(** * Emptyness test *) + +Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None. +Proof. + destruct m as [|r x e l h]; simpl; split; try easy. + intros H. specialize (H x). now rewrite MX.compare_refl in H. +Qed. + +(** * Helper functions *) + +Lemma create_bst l x e r : + Bst l -> Bst r -> x >> l -> x << r -> Bst (create l x e r). +Proof. + unfold create; auto. +Qed. +Hint Resolve create_bst. + +Lemma create_in l x e r y : + y ∈ (create l x e r) <-> y == x \/ y ∈ l \/ y ∈ r. +Proof. + unfold create; split; [ inversion_clear 1 | ]; intuition. +Qed. + +Lemma bal_bst l x e r : Bst l -> Bst r -> + x >> l -> x << r -> Bst (bal l x e r). +Proof. + functional induction (bal l x e r); intros; cleanf; + inv Bst; inv Above; inv Below; + repeat apply create_bst; auto; unfold create; constructor; eauto. +Qed. +Hint Resolve bal_bst. + +Lemma bal_in l x e r y : + y ∈ (bal l x e r) <-> y == x \/ y ∈ l \/ y ∈ r. +Proof. + functional induction (bal l x e r); intros; cleanf; + rewrite !create_in; intuition_in. +Qed. + +Lemma bal_mapsto l x e r y e' : + MapsTo y e' (bal l x e r) <-> MapsTo y e' (create l x e r). +Proof. + functional induction (bal l x e r); intros; cleanf; + unfold assert_false, create; intuition_in. +Qed. + +Lemma bal_find l x e r y : + Bst l -> Bst r -> x >> l -> x << r -> + find y (bal l x e r) = find y (create l x e r). +Proof. + functional induction (bal l x e r); intros; cleanf; trivial; + inv Bst; inv Above; inv Below; + simpl; repeat case X.compare_spec; intuition; order. +Qed. + +(** * Insertion *) + +Lemma add_in m x y e : + y ∈ (add x e m) <-> y == x \/ y ∈ m. +Proof. + functional induction (add x e m); auto; intros; cleanf; + rewrite ?bal_in; intuition_in. setoid_replace y with x; auto. +Qed. + +Lemma add_lt m x e y : y >> m -> x < y -> y >> add x e m. +Proof. + intros. apply above. intros z. rewrite add_in. destruct 1; order. +Qed. + +Lemma add_gt m x e y : y << m -> y < x -> y << add x e m. +Proof. + intros. apply below. intros z. rewrite add_in. destruct 1; order. +Qed. + +Lemma add_bst m x e : Bst m -> Bst (add x e m). +Proof. + functional induction (add x e m); intros; cleanf; + inv Bst; try apply bal_bst; auto using add_lt, add_gt. +Qed. +Hint Resolve add_lt add_gt add_bst. + +Lemma add_spec1 m x e : Bst m -> find x (add x e m) = Some e. +Proof. + functional induction (add x e m); simpl; intros; cleanf; trivial. + - now rewrite MX.compare_refl. + - inv Bst. rewrite bal_find; auto. + simpl. case X.compare_spec; try order; auto. + - inv Bst. rewrite bal_find; auto. + simpl. case X.compare_spec; try order; auto. +Qed. + +Lemma add_spec2 m x y e : Bst m -> ~ x == y -> + find y (add x e m) = find y m. +Proof. + functional induction (add x e m); simpl; intros; cleanf; trivial. + - case X.compare_spec; trivial; order. + - case X.compare_spec; trivial; order. + - inv Bst. rewrite bal_find by auto. simpl. now rewrite IHt. + - inv Bst. rewrite bal_find by auto. simpl. now rewrite IHt. +Qed. + +Lemma add_find m x y e : Bst m -> + find y (add x e m) = + match X.compare y x with Eq => Some e | _ => find y m end. +Proof. + intros. + case X.compare_spec; intros. + - apply find_spec; auto. rewrite H0. apply find_spec; auto. + now apply add_spec1. + - apply add_spec2; trivial; order. + - apply add_spec2; trivial; order. +Qed. + +(** * Extraction of minimum binding *) + +Definition RemoveMin m res := + match m with + | Leaf _ => False + | Node l x e r h => remove_min l x e r = res + end. + +Lemma RemoveMin_step l x e r h m' p : + RemoveMin (Node l x e r h) (m',p) -> + (l = Leaf _ /\ m' = r /\ p = (x,e) \/ + exists m0, RemoveMin l (m0,p) /\ m' = bal m0 x e r). +Proof. + simpl. destruct l as [|ll lx le lr lh]; simpl. + - intros [= -> ->]. now left. + - destruct (remove_min ll lx le lr) as (l',p'). + intros [= <- <-]. right. now exists l'. +Qed. + +Lemma remove_min_mapsto m m' p : RemoveMin m (m',p) -> + forall y e, + MapsTo y e m <-> (y == p#1 /\ e = p#2) \/ MapsTo y e m'. +Proof. + revert m'. + induction m as [|l IH x d r _ h]; [destruct 1|]. + intros m' R. apply RemoveMin_step in R. + destruct R as [(->,(->,->))|[m0 (R,->)]]; intros y e; simpl. + - intuition_in. subst. now constructor. + - rewrite bal_mapsto. unfold create. specialize (IH _ R y e). + intuition_in. +Qed. + +Lemma remove_min_in m m' p : RemoveMin m (m',p) -> + forall y, y ∈ m <-> y == p#1 \/ y ∈ m'. +Proof. + revert m'. + induction m as [|l IH x e r _ h]; [destruct 1|]. + intros m' R y. apply RemoveMin_step in R. + destruct R as [(->,(->,->))|[m0 (R,->)]]. + + intuition_in. + + rewrite bal_in, In_node_iff, (IH _ R); intuition. +Qed. + +Lemma remove_min_lt m m' p : RemoveMin m (m',p) -> + forall y, y >> m -> y >> m'. +Proof. + intros R y L. apply above. intros z Hz. + apply (AboveLt L). + apply (remove_min_in R). now right. +Qed. + +Lemma remove_min_gt m m' p : RemoveMin m (m',p) -> + Bst m -> p#1 << m'. +Proof. + revert m'. + induction m as [|l IH x e r _ h]; [destruct 1|]. + intros m' R H. inv Bst. apply RemoveMin_step in R. + destruct R as [(_,(->,->))|[m0 (R,->)]]; auto. + assert (p#1 << m0) by now apply IH. + assert (In p#1 l) by (apply (remove_min_in R); now left). + apply below. intros z. rewrite bal_in. + intuition_in; order. +Qed. + +Lemma remove_min_bst m m' p : RemoveMin m (m',p) -> + Bst m -> Bst m'. +Proof. + revert m'. + induction m as [|l IH x e r _ h]; [destruct 1|]. + intros m' R H. inv Bst. apply RemoveMin_step in R. + destruct R as [(_,(->,->))|[m0 (R,->)]]; auto. + apply bal_bst; eauto using remove_min_lt. +Qed. + +Lemma remove_min_find m m' p : RemoveMin m (m',p) -> + Bst m -> + forall y, + find y m = + match X.compare y p#1 with + | Eq => Some p#2 + | Lt => None + | Gt => find y m' + end. +Proof. + revert m'. + induction m as [|l IH x e r _ h]; [destruct 1|]. + intros m' R B y. inv Bst. apply RemoveMin_step in R. + destruct R as [(->,(->,->))|[m0 (R,->)]]; auto. + assert (Bst m0) by now apply (remove_min_bst R). + assert (p#1 << m0) by now apply (remove_min_gt R). + assert (x >> m0) by now apply (remove_min_lt R). + assert (In p#1 l) by (apply (remove_min_in R); now left). + simpl in *. + rewrite (IH _ R), bal_find by trivial. clear IH. simpl. + do 2 case X.compare_spec; trivial; try order. +Qed. + +(** * Merging two trees *) + +Ltac factor_remove_min m R := match goal with + | h:int, H:remove_min ?l ?x ?e ?r = ?p |- _ => + assert (R:RemoveMin (Node l x e r h) p) by exact H; + set (m:=Node l x e r h) in *; clearbody m; clear H l x e r +end. + +Lemma merge0_in m1 m2 y : + y ∈ (merge0 m1 m2) <-> y ∈ m1 \/ y ∈ m2. +Proof. + functional induction (merge0 m1 m2); intros; try factornode m1. + - intuition_in. + - intuition_in. + - factor_remove_min l R. rewrite bal_in, (remove_min_in R). + simpl; intuition. +Qed. + +Lemma merge0_mapsto m1 m2 y e : + MapsTo y e (merge0 m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2. +Proof. + functional induction (merge0 m1 m2); intros; try factornode m1. + - intuition_in. + - intuition_in. + - factor_remove_min l R. rewrite bal_mapsto, (remove_min_mapsto R). + simpl. unfold create; intuition_in. subst. now constructor. +Qed. + +Lemma merge0_bst m1 m2 : Bst m1 -> Bst m2 -> m1 <<< m2 -> + Bst (merge0 m1 m2). +Proof. + functional induction (merge0 m1 m2); intros B1 B2 B12; trivial. + factornode m1. factor_remove_min l R. + apply bal_bst; auto. + - eapply remove_min_bst; eauto. + - apply above. intros z Hz. apply B12; trivial. + rewrite (remove_min_in R). now left. + - now apply (remove_min_gt R). +Qed. +Hint Resolve merge0_bst. + +(** * Deletion *) + +Lemma remove_in m x y : Bst m -> + (y ∈ remove x m <-> ~ y == x /\ y ∈ m). +Proof. + functional induction (remove x m); simpl; intros; cleanf; inv Bst; + rewrite ?merge0_in, ?bal_in, ?IHt; intuition_in; order. +Qed. + +Lemma remove_lt m x y : Bst m -> y >> m -> y >> remove x m. +Proof. + intros. apply above. intro. rewrite remove_in by trivial. + destruct 1; order. +Qed. + +Lemma remove_gt m x y : Bst m -> y << m -> y << remove x m. +Proof. + intros. apply below. intro. rewrite remove_in by trivial. + destruct 1; order. +Qed. + +Lemma remove_bst m x : Bst m -> Bst (remove x m). +Proof. + functional induction (remove x m); simpl; intros; cleanf; inv Bst. + - trivial. + - apply merge0_bst; eauto. + - apply bal_bst; auto using remove_lt. + - apply bal_bst; auto using remove_gt. +Qed. +Hint Resolve remove_bst remove_gt remove_lt. + +Lemma remove_spec1 m x : Bst m -> find x (remove x m) = None. +Proof. + intros. apply not_find_iff; auto. rewrite remove_in; intuition. +Qed. + +Lemma remove_spec2 m x y : Bst m -> ~ x == y -> + find y (remove x m) = find y m. +Proof. + functional induction (remove x m); simpl; intros; cleanf; inv Bst. + - trivial. + - case X.compare_spec; intros; try order; + rewrite find_mapsto_equiv; auto. + + intros. rewrite merge0_mapsto; intuition; order. + + apply merge0_bst; auto. red; intros; transitivity y0; order. + + intros. rewrite merge0_mapsto; intuition; order. + + apply merge0_bst; auto. now apply between with y0. + - rewrite bal_find by auto. simpl. case X.compare_spec; auto. + - rewrite bal_find by auto. simpl. case X.compare_spec; auto. +Qed. + +(** * join *) + +Lemma join_in l x d r y : + y ∈ (join l x d r) <-> y == x \/ y ∈ l \/ y ∈ r. +Proof. + join_tac l x d r. + - simpl join. rewrite add_in. intuition_in. + - rewrite add_in. intuition_in. + - rewrite bal_in, Hlr. clear Hlr Hrl. intuition_in. + - rewrite bal_in, Hrl; clear Hlr Hrl; intuition_in. + - apply create_in. +Qed. + +Lemma join_bst l x d r : + Bst (create l x d r) -> Bst (join l x d r). +Proof. + join_tac l x d r; unfold create in *; + inv Bst; inv Above; inv Below; auto. + - simpl. auto. + - apply bal_bst; auto. + apply below. intro. rewrite join_in. intuition_in; order. + - apply bal_bst; auto. + apply above. intro. rewrite join_in. intuition_in; order. +Qed. +Hint Resolve join_bst. + +Lemma join_find l x d r y : + Bst (create l x d r) -> + find y (join l x d r) = find y (create l x d r). +Proof. + unfold create at 1. + join_tac l x d r; trivial. + - simpl in *. inv Bst. + rewrite add_find; trivial. + case X.compare_spec; intros; trivial. + apply not_find_iff; auto. intro. order. + - clear Hlr. factornode l. simpl. inv Bst. + rewrite add_find by auto. + case X.compare_spec; intros; trivial. + apply not_find_iff; auto. intro. order. + - clear Hrl LT. factornode r. inv Bst; inv Above; inv Below. + rewrite bal_find; auto; simpl. + + rewrite Hlr; auto; simpl. + repeat (case X.compare_spec; trivial; try order). + + apply below. intro. rewrite join_in. intuition_in; order. + - clear Hlr LT LT'. factornode l. inv Bst; inv Above; inv Below. + rewrite bal_find; auto; simpl. + + rewrite Hrl; auto; simpl. + repeat (case X.compare_spec; trivial; try order). + + apply above. intro. rewrite join_in. intuition_in; order. +Qed. + +(** * split *) + +Lemma split_in_l0 m x y : y ∈ (split x m)#l -> y ∈ m. +Proof. + functional induction (split x m); cleansplit; + rewrite ?join_in; intuition. +Qed. + +Lemma split_in_r0 m x y : y ∈ (split x m)#r -> y ∈ m. +Proof. + functional induction (split x m); cleansplit; + rewrite ?join_in; intuition. +Qed. + +Lemma split_in_l m x y : Bst m -> + (y ∈ (split x m)#l <-> y ∈ m /\ y < x). +Proof. + functional induction (split x m); intros; cleansplit; + rewrite ?join_in, ?IHt; intuition_in; order. +Qed. + +Lemma split_in_r m x y : Bst m -> + (y ∈ (split x m)#r <-> y ∈ m /\ x < y). +Proof. + functional induction (split x m); intros; cleansplit; + rewrite ?join_in, ?IHt; intuition_in; order. +Qed. + +Lemma split_in_o m x : (split x m)#o = find x m. +Proof. + functional induction (split x m); intros; cleansplit; auto. +Qed. + +Lemma split_lt_l m x : Bst m -> x >> (split x m)#l. +Proof. + intro. apply above. intro. rewrite split_in_l; intuition; order. +Qed. + +Lemma split_lt_r m x y : y >> m -> y >> (split x m)#r. +Proof. + intro. apply above. intros z Hz. apply split_in_r0 in Hz. order. +Qed. + +Lemma split_gt_r m x : Bst m -> x << (split x m)#r. +Proof. + intro. apply below. intro. rewrite split_in_r; intuition; order. +Qed. + +Lemma split_gt_l m x y : y << m -> y << (split x m)#l. +Proof. + intro. apply below. intros z Hz. apply split_in_l0 in Hz. order. +Qed. +Hint Resolve split_lt_l split_lt_r split_gt_l split_gt_r. + +Lemma split_bst_l m x : Bst m -> Bst (split x m)#l. +Proof. + functional induction (split x m); intros; cleansplit; intuition; + auto using join_bst. +Qed. + +Lemma split_bst_r m x : Bst m -> Bst (split x m)#r. +Proof. + functional induction (split x m); intros; cleansplit; intuition; + auto using join_bst. +Qed. +Hint Resolve split_bst_l split_bst_r. + +Lemma split_find m x y : Bst m -> + find y m = match X.compare y x with + | Eq => (split x m)#o + | Lt => find y (split x m)#l + | Gt => find y (split x m)#r + end. +Proof. + functional induction (split x m); intros; cleansplit. + - now case X.compare. + - repeat case X.compare_spec; trivial; order. + - simpl in *. rewrite join_find, IHt; auto. + simpl. repeat case X.compare_spec; trivial; order. + - rewrite join_find, IHt; auto. + simpl; repeat case X.compare_spec; trivial; order. +Qed. + +(** * Concatenation *) + +Lemma concat_in m1 m2 y : + y ∈ (concat m1 m2) <-> y ∈ m1 \/ y ∈ m2. +Proof. + functional induction (concat m1 m2); intros; try factornode m1. + - intuition_in. + - intuition_in. + - factor_remove_min m2 R. + rewrite join_in, (remove_min_in R); simpl; intuition. +Qed. + +Lemma concat_bst m1 m2 : Bst m1 -> Bst m2 -> m1 <<< m2 -> + Bst (concat m1 m2). +Proof. + functional induction (concat m1 m2); intros B1 B2 LT; auto; + try factornode m1. + factor_remove_min m2 R. + apply join_bst, create_bst; auto. + - now apply (remove_min_bst R). + - apply above. intros y Hy. apply LT; trivial. + rewrite (remove_min_in R); now left. + - now apply (remove_min_gt R). +Qed. +Hint Resolve concat_bst. + +Definition oelse {A} (o1 o2:option A) := + match o1 with + | Some x => Some x + | None => o2 + end. + +Lemma concat_find m1 m2 y : Bst m1 -> Bst m2 -> m1 <<< m2 -> + find y (concat m1 m2) = oelse (find y m2) (find y m1). +Proof. + functional induction (concat m1 m2); intros B1 B2 B; auto; try factornode m1. + - destruct (find y m2); auto. + - factor_remove_min m2 R. + assert (xd#1 >> m1). + { apply above. intros z Hz. apply B; trivial. + rewrite (remove_min_in R). now left. } + rewrite join_find; simpl; auto. + + rewrite (remove_min_find R B2 y). + case X.compare_spec; intros; auto. + destruct (find y m2'); trivial. + simpl. symmetry. apply not_find_iff; eauto. + + apply create_bst; auto. + * now apply (remove_min_bst R). + * now apply (remove_min_gt R). +Qed. + + +(** * Elements *) + +Notation eqk := (PX.eqk (elt:= elt)). +Notation eqke := (PX.eqke (elt:= elt)). +Notation ltk := (PX.ltk (elt:= elt)). + +Lemma bindings_aux_mapsto : forall (s:t elt) acc x e, + InA eqke (x,e) (bindings_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc. +Proof. + induction s as [ | l Hl x e r Hr h ]; simpl; auto. + intuition. + inversion H0. + intros. + rewrite Hl. + destruct (Hr acc x0 e0); clear Hl Hr. + intuition; inversion_clear H3; intuition. + compute in H0. destruct H0; simpl in *; subst; intuition. +Qed. + +Lemma bindings_mapsto : forall (s:t elt) x e, + InA eqke (x,e) (bindings s) <-> MapsTo x e s. +Proof. + intros; generalize (bindings_aux_mapsto s nil x e); intuition. + inversion_clear H0. +Qed. + +Lemma bindings_in : forall (s:t elt) x, L.PX.In x (bindings s) <-> x ∈ s. +Proof. + intros. + unfold L.PX.In. + rewrite <- In_alt; unfold In0. + split; intros (y,H); exists y. + - now rewrite <- bindings_mapsto. + - unfold L.PX.MapsTo; now rewrite bindings_mapsto. +Qed. + +Lemma bindings_aux_sort : forall (s:t elt) acc, + Bst s -> sort ltk acc -> + (forall x e y, InA eqke (x,e) acc -> y ∈ s -> y < x) -> + sort ltk (bindings_aux acc s). +Proof. + induction s as [ | l Hl y e r Hr h]; simpl; intuition. + inv Bst. + apply Hl; auto. + - constructor. + + apply Hr; eauto. + + clear Hl Hr. + apply InA_InfA with (eqA:=eqke); auto with *. + intros (y',e') Hy'. + apply bindings_aux_mapsto in Hy'. compute. intuition; eauto. + - clear Hl Hr. intros x e' y' Hx Hy'. + inversion_clear Hx. + + compute in H. destruct H; simpl in *. order. + + apply bindings_aux_mapsto in H. intuition eauto. +Qed. + +Lemma bindings_sort : forall s : t elt, Bst s -> sort ltk (bindings s). +Proof. + intros; unfold bindings; apply bindings_aux_sort; auto. + intros; inversion H0. +Qed. +Hint Resolve bindings_sort. + +Lemma bindings_nodup : forall s : t elt, Bst s -> NoDupA eqk (bindings s). +Proof. + intros; apply PX.Sort_NoDupA; auto. +Qed. + +Lemma bindings_aux_cardinal m acc : + (length acc + cardinal m)%nat = length (bindings_aux acc m). +Proof. + revert acc. induction m; simpl; intuition. + rewrite <- IHm1; simpl. + rewrite <- IHm2. rewrite Nat.add_succ_r, <- Nat.add_assoc. + f_equal. f_equal. apply Nat.add_comm. +Qed. + +Lemma bindings_cardinal m : cardinal m = length (bindings m). +Proof. + exact (bindings_aux_cardinal m nil). +Qed. + +Lemma bindings_app : + forall (s:t elt) acc, bindings_aux acc s = bindings s ++ acc. +Proof. + induction s; simpl; intros; auto. + rewrite IHs1, IHs2. + unfold bindings; simpl. + rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto. +Qed. + +Lemma bindings_node : + forall (t1 t2:t elt) x e z l, + bindings t1 ++ (x,e) :: bindings t2 ++ l = + bindings (Node t1 x e t2 z) ++ l. +Proof. + unfold bindings; simpl; intros. + rewrite !bindings_app, !app_nil_r, !app_ass; auto. +Qed. + +(** * Fold *) + +Definition fold' {A} (f : key -> elt -> A -> A)(s : t elt) := + L.fold f (bindings s). + +Lemma fold_equiv_aux {A} (s : t elt) (f : key -> elt -> A -> A) (a : A) acc : + L.fold f (bindings_aux acc s) a = L.fold f acc (fold f s a). +Proof. + revert a acc. + induction s; simpl; trivial. + intros. rewrite IHs1. simpl. apply IHs2. +Qed. + +Lemma fold_equiv {A} (s : t elt) (f : key -> elt -> A -> A) (a : A) : + fold f s a = fold' f s a. +Proof. + unfold fold', bindings. now rewrite fold_equiv_aux. +Qed. + +Lemma fold_spec (s:t elt)(Hs:Bst s){A}(i:A)(f : key -> elt -> A -> A) : + fold f s i = fold_left (fun a p => f p#1 p#2 a) (bindings s) i. +Proof. + rewrite fold_equiv. unfold fold'. now rewrite L.fold_spec. +Qed. + +(** * Comparison *) + +(** [flatten_e e] returns the list of bindings of the enumeration [e] + i.e. the list of bindings actually compared *) + +Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with + | End _ => nil + | More x e t r => (x,e) :: bindings t ++ flatten_e r + end. + +Lemma flatten_e_bindings : + forall (l:t elt) r x d z e, + bindings l ++ flatten_e (More x d r e) = + bindings (Node l x d r z) ++ flatten_e e. +Proof. + intros; apply bindings_node. +Qed. + +Lemma cons_1 : forall (s:t elt) e, + flatten_e (cons s e) = bindings s ++ flatten_e e. +Proof. + induction s; auto; intros. + simpl flatten_e; rewrite IHs1; apply flatten_e_bindings; auto. +Qed. + +(** Proof of correction for the comparison *) + +Variable cmp : elt->elt->bool. + +Definition IfEq b l1 l2 := L.equal cmp l1 l2 = b. + +Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2, + X.eq x1 x2 -> cmp d1 d2 = true -> + IfEq b l1 l2 -> + IfEq b ((x1,d1)::l1) ((x2,d2)::l2). +Proof. + unfold IfEq; destruct b; simpl; intros; case X.compare_spec; simpl; + try rewrite H0; auto; order. +Qed. + +Lemma equal_end_IfEq : forall e2, + IfEq (equal_end e2) nil (flatten_e e2). +Proof. + destruct e2; red; auto. +Qed. + +Lemma equal_more_IfEq : + forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, + IfEq (cont (cons r2 e2)) l (bindings r2 ++ flatten_e e2) -> + IfEq (equal_more cmp x1 d1 cont (More x2 d2 r2 e2)) ((x1,d1)::l) + (flatten_e (More x2 d2 r2 e2)). +Proof. + unfold IfEq; simpl; intros; destruct X.compare; simpl; auto. + rewrite <-andb_lazy_alt; f_equal; auto. +Qed. + +Lemma equal_cont_IfEq : forall m1 cont e2 l, + (forall e, IfEq (cont e) l (flatten_e e)) -> + IfEq (equal_cont cmp m1 cont e2) (bindings m1 ++ l) (flatten_e e2). +Proof. + induction m1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; intros; auto. + rewrite <- bindings_node; simpl. + apply Hl1; auto. + clear e2; intros [|x2 d2 r2 e2]. + simpl; red; auto. + apply equal_more_IfEq. + rewrite <- cons_1; auto. +Qed. + +Lemma equal_IfEq : forall (m1 m2:t elt), + IfEq (equal cmp m1 m2) (bindings m1) (bindings m2). +Proof. + intros; unfold equal. + rewrite <- (app_nil_r (bindings m1)). + replace (bindings m2) with (flatten_e (cons m2 (End _))) + by (rewrite cons_1; simpl; rewrite app_nil_r; auto). + apply equal_cont_IfEq. + intros. + apply equal_end_IfEq; auto. +Qed. + +Definition Equivb m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). + +Lemma Equivb_bindings : forall s s', + Equivb s s' <-> L.Equivb cmp (bindings s) (bindings s'). +Proof. +unfold Equivb, L.Equivb; split; split; intros. +do 2 rewrite bindings_in; firstorder. +destruct H. +apply (H2 k); rewrite <- bindings_mapsto; auto. +do 2 rewrite <- bindings_in; firstorder. +destruct H. +apply (H2 k); unfold L.PX.MapsTo; rewrite bindings_mapsto; auto. +Qed. + +Lemma equal_Equivb : forall (s s': t elt), Bst s -> Bst s' -> + (equal cmp s s' = true <-> Equivb s s'). +Proof. + intros s s' B B'. + rewrite Equivb_bindings, <- equal_IfEq. + split; [apply L.equal_2|apply L.equal_1]; auto. +Qed. + +End Elt. + +Section Map. +Variable elt elt' : Type. +Variable f : elt -> elt'. + +Lemma map_spec m x : + find x (map f m) = option_map f (find x m). +Proof. +induction m; simpl; trivial. case X.compare_spec; auto. +Qed. + +Lemma map_in m x : x ∈ (map f m) <-> x ∈ m. +Proof. +induction m; simpl; intuition_in. +Qed. + +Lemma map_bst m : Bst m -> Bst (map f m). +Proof. +induction m; simpl; auto. intros; inv Bst; constructor; auto. +- apply above. intro. rewrite map_in. intros. order. +- apply below. intro. rewrite map_in. intros. order. +Qed. + +End Map. +Section Mapi. +Variable elt elt' : Type. +Variable f : key -> elt -> elt'. + +Lemma mapi_spec m x : + exists y:key, + X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). +Proof. + induction m; simpl. + - now exists x. + - case X.compare_spec; simpl; auto. intros. now exists k. +Qed. + +Lemma mapi_in m x : x ∈ (mapi f m) <-> x ∈ m. +Proof. +induction m; simpl; intuition_in. +Qed. + +Lemma mapi_bst m : Bst m -> Bst (mapi f m). +Proof. +induction m; simpl; auto. intros; inv Bst; constructor; auto. +- apply above. intro. rewrite mapi_in. intros. order. +- apply below. intro. rewrite mapi_in. intros. order. +Qed. + +End Mapi. + +Section Mapo. +Variable elt elt' : Type. +Variable f : key -> elt -> option elt'. + +Lemma mapo_in m x : + x ∈ (mapo f m) -> + exists y d, X.eq y x /\ MapsTo x d m /\ f y d <> None. +Proof. +functional induction (mapo f m); simpl; auto; intro H. +- inv In. +- rewrite join_in in H; destruct H as [H|[H|H]]. + + exists x0, d. do 2 (split; auto). congruence. + + destruct (IHt H) as (y & e & ? & ? & ?). exists y, e. auto. + + destruct (IHt0 H) as (y & e & ? & ? & ?). exists y, e. auto. +- rewrite concat_in in H; destruct H as [H|H]. + + destruct (IHt H) as (y & e & ? & ? & ?). exists y, e. auto. + + destruct (IHt0 H) as (y & e & ? & ? & ?). exists y, e. auto. +Qed. + +Lemma mapo_lt m x : x >> m -> x >> mapo f m. +Proof. + intros H. apply above. intros y Hy. + destruct (mapo_in Hy) as (y' & e & ? & ? & ?). order. +Qed. + +Lemma mapo_gt m x : x << m -> x << mapo f m. +Proof. + intros H. apply below. intros y Hy. + destruct (mapo_in Hy) as (y' & e & ? & ? & ?). order. +Qed. +Hint Resolve mapo_lt mapo_gt. + +Lemma mapo_bst m : Bst m -> Bst (mapo f m). +Proof. +functional induction (mapo f m); simpl; auto; intro H; inv Bst. +- apply join_bst, create_bst; auto. +- apply concat_bst; auto. apply between with x; auto. +Qed. +Hint Resolve mapo_bst. + +Ltac nonify e := + replace e with (@None elt) by + (symmetry; rewrite not_find_iff; auto; intro; order). + +Definition obind {A B} (o:option A) (f:A->option B) := + match o with Some a => f a | None => None end. + +Lemma mapo_find m x : + Bst m -> + exists y, X.eq y x /\ + find x (mapo f m) = obind (find x m) (f y). +Proof. +functional induction (mapo f m); simpl; auto; intros B; + inv Bst. +- now exists x. +- rewrite join_find; auto. + + simpl. case X.compare_spec; simpl; intros. + * now exists x0. + * destruct IHt as (y' & ? & ?); auto. + exists y'; split; trivial. + * destruct IHt0 as (y' & ? & ?); auto. + exists y'; split; trivial. + + constructor; auto using mapo_lt, mapo_gt. +- rewrite concat_find; auto. + + destruct IHt0 as (y' & ? & ->); auto. + destruct IHt as (y'' & ? & ->); auto. + case X.compare_spec; simpl; intros. + * nonify (find x r). nonify (find x l). simpl. now exists x0. + * nonify (find x r). now exists y''. + * nonify (find x l). exists y'. split; trivial. + destruct (find x r); simpl; trivial. + now destruct (f y' e). + + apply between with x0; auto. +Qed. + +End Mapo. + +Section Gmerge. +Variable elt elt' elt'' : Type. +Variable f0 : key -> option elt -> option elt' -> option elt''. +Variable f : key -> elt -> option elt' -> option elt''. +Variable mapl : t elt -> t elt''. +Variable mapr : t elt' -> t elt''. +Hypothesis f0_f : forall x d o, f x d o = f0 x (Some d) o. +Hypothesis mapl_bst : forall m, Bst m -> Bst (mapl m). +Hypothesis mapr_bst : forall m', Bst m' -> Bst (mapr m'). +Hypothesis mapl_f0 : forall x m, Bst m -> + exists y, X.eq y x /\ + find x (mapl m) = obind (find x m) (fun d => f0 y (Some d) None). +Hypothesis mapr_f0 : forall x m, Bst m -> + exists y, X.eq y x /\ + find x (mapr m) = obind (find x m) (fun d => f0 y None (Some d)). + +Notation gmerge := (gmerge f mapl mapr). + +Lemma gmerge_in m m' y : Bst m -> Bst m' -> + y ∈ (gmerge m m') -> y ∈ m \/ y ∈ m'. +Proof. + functional induction (gmerge m m'); intros B1 B2 H; + try factornode m2; inv Bst. + - right. apply find_in. + generalize (in_find (mapr_bst B2) H). + destruct (@mapr_f0 y m2) as (y' & ? & ->); trivial. + intros A B. rewrite B in A. now elim A. + - left. apply find_in. + generalize (in_find (mapl_bst B1) H). + destruct (@mapl_f0 y m2) as (y' & ? & ->); trivial. + intros A B. rewrite B in A. now elim A. + - rewrite join_in in *. revert IHt1 IHt0 H. cleansplit. + generalize (split_bst_l x1 B2) (split_bst_r x1 B2). + rewrite split_in_r, split_in_l; intuition_in. + - rewrite concat_in in *. revert IHt1 IHt0 H; cleansplit. + generalize (split_bst_l x1 B2) (split_bst_r x1 B2). + rewrite split_in_r, split_in_l; intuition_in. +Qed. + +Lemma gmerge_lt m m' x : Bst m -> Bst m' -> + x >> m -> x >> m' -> x >> gmerge m m'. +Proof. + intros. apply above. intros y Hy. + apply gmerge_in in Hy; intuition_in; order. +Qed. + +Lemma gmerge_gt m m' x : Bst m -> Bst m' -> + x << m -> x << m' -> x << gmerge m m'. +Proof. + intros. apply below. intros y Hy. + apply gmerge_in in Hy; intuition_in; order. +Qed. +Hint Resolve gmerge_lt gmerge_gt. +Hint Resolve split_bst_l split_bst_r split_lt_l split_gt_r. + +Lemma gmerge_bst m m' : Bst m -> Bst m' -> Bst (gmerge m m'). +Proof. + functional induction (gmerge m m'); intros B1 B2; auto; + factornode m2; inv Bst; + (apply join_bst, create_bst || apply concat_bst); + revert IHt1 IHt0; cleansplit; intuition. + apply between with x1; auto. +Qed. +Hint Resolve gmerge_bst. + +Lemma oelse_none_r {A} (o:option A) : oelse o None = o. +Proof. now destruct o. Qed. + +Ltac nonify e := + let E := fresh "E" in + assert (E : e = None); + [ rewrite not_find_iff; auto; intro U; + try apply gmerge_in in U; intuition_in; order + | rewrite E; clear E ]. + +Lemma gmerge_find m m' x : Bst m -> Bst m' -> + In x m \/ In x m' -> + exists y, X.eq y x /\ + find x (gmerge m m') = f0 y (find x m) (find x m'). +Proof. + functional induction (gmerge m m'); intros B1 B2 H; + try factornode m2; inv Bst. + - destruct H; [ intuition_in | ]. + destruct (@mapr_f0 x m2) as (y,(Hy,E)); trivial. + exists y; split; trivial. + rewrite E. simpl. apply in_find in H; trivial. + destruct (find x m2); simpl; intuition. + - destruct H; [ | intuition_in ]. + destruct (@mapl_f0 x m2) as (y,(Hy,E)); trivial. + exists y; split; trivial. + rewrite E. simpl. apply in_find in H; trivial. + destruct (find x m2); simpl; intuition. + - generalize (split_bst_l x1 B2) (split_bst_r x1 B2). + rewrite (split_find x1 x B2). + rewrite e1 in *; simpl in *. intros. + rewrite join_find by (cleansplit; constructor; auto). + simpl. case X.compare_spec; intros. + + exists x1. split; auto. now rewrite <- e3, f0_f. + + apply IHt1; auto. clear IHt1 IHt0. + cleansplit; rewrite split_in_l; trivial. + intuition_in; order. + + apply IHt0; auto. clear IHt1 IHt0. + cleansplit; rewrite split_in_r; trivial. + intuition_in; order. + - generalize (split_bst_l x1 B2) (split_bst_r x1 B2). + rewrite (split_find x1 x B2). + pose proof (split_lt_l x1 B2). + pose proof (split_gt_r x1 B2). + rewrite e1 in *; simpl in *. intros. + rewrite concat_find by (try apply between with x1; auto). + case X.compare_spec; intros. + + clear IHt0 IHt1. + exists x1. split; auto. rewrite <- f0_f, e2. + nonify (find x (gmerge r1 r2')). + nonify (find x (gmerge l1 l2')). trivial. + + nonify (find x (gmerge r1 r2')). + simpl. apply IHt1; auto. clear IHt1 IHt0. + intuition_in; try order. + right. cleansplit. now apply split_in_l. + + nonify (find x (gmerge l1 l2')). simpl. + rewrite oelse_none_r. + apply IHt0; auto. clear IHt1 IHt0. + intuition_in; try order. + right. cleansplit. now apply split_in_r. +Qed. + +End Gmerge. + +Section Merge. +Variable elt elt' elt'' : Type. +Variable f : key -> option elt -> option elt' -> option elt''. + +Lemma merge_bst m m' : Bst m -> Bst m' -> Bst (merge f m m'). +Proof. +unfold merge; intros. +apply gmerge_bst with f; + auto using mapo_bst, mapo_find. +Qed. + +Lemma merge_spec1 m m' x : Bst m -> Bst m' -> + In x m \/ In x m' -> + exists y, X.eq y x /\ + find x (merge f m m') = f y (find x m) (find x m'). +Proof. + unfold merge; intros. + edestruct (gmerge_find (f0:=f)) as (y,(Hy,E)); + eauto using mapo_bst. + - reflexivity. + - intros. now apply mapo_find. + - intros. now apply mapo_find. +Qed. + +Lemma merge_spec2 m m' x : Bst m -> Bst m' -> + In x (merge f m m') -> In x m \/ In x m'. +Proof. +unfold merge; intros. +eapply gmerge_in with (f0:=f); try eassumption; + auto using mapo_bst, mapo_find. +Qed. + +End Merge. +End Proofs. +End Raw. + +(** * Encapsulation + + Now, in order to really provide a functor implementing [S], we + need to encapsulate everything into a type of balanced binary search trees. *) + +Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. + + Module E := X. + Module Raw := Raw I X. + Import Raw.Proofs. + + Record tree (elt:Type) := + Mk {this :> Raw.tree elt; is_bst : Raw.Bst this}. + + Definition t := tree. + Definition key := E.t. + + Section Elt. + Variable elt elt' elt'': Type. + + Implicit Types m : t elt. + Implicit Types x y : key. + Implicit Types e : elt. + + Definition empty : t elt := Mk (empty_bst elt). + Definition is_empty m : bool := Raw.is_empty m.(this). + Definition add x e m : t elt := Mk (add_bst x e m.(is_bst)). + Definition remove x m : t elt := Mk (remove_bst x m.(is_bst)). + Definition mem x m : bool := Raw.mem x m.(this). + Definition find x m : option elt := Raw.find x m.(this). + Definition map f m : t elt' := Mk (map_bst f m.(is_bst)). + Definition mapi (f:key->elt->elt') m : t elt' := + Mk (mapi_bst f m.(is_bst)). + Definition merge f m (m':t elt') : t elt'' := + Mk (merge_bst f m.(is_bst) m'.(is_bst)). + Definition bindings m : list (key*elt) := Raw.bindings m.(this). + Definition cardinal m := Raw.cardinal m.(this). + Definition fold {A} (f:key->elt->A->A) m i := Raw.fold (A:=A) f m.(this) i. + Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). + + Definition MapsTo x e m : Prop := Raw.MapsTo x e m.(this). + Definition In x m : Prop := Raw.In0 x m.(this). + + Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt. + Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt. + Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt. + + Instance MapsTo_compat : + Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. + Proof. + intros k k' Hk e e' He m m' Hm. unfold MapsTo; simpl. + now rewrite Hk, He, Hm. + Qed. + + Lemma find_spec m x e : find x m = Some e <-> MapsTo x e m. + Proof. apply find_spec. apply is_bst. Qed. + + Lemma mem_spec m x : mem x m = true <-> In x m. + Proof. + unfold In, mem; rewrite In_alt. apply mem_spec. apply is_bst. + Qed. + + Lemma empty_spec x : find x empty = None. + Proof. apply empty_spec. Qed. + + Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None. + Proof. apply is_empty_spec. Qed. + + Lemma add_spec1 m x e : find x (add x e m) = Some e. + Proof. apply add_spec1. apply is_bst. Qed. + Lemma add_spec2 m x y e : ~ E.eq x y -> find y (add x e m) = find y m. + Proof. apply add_spec2. apply is_bst. Qed. + + Lemma remove_spec1 m x : find x (remove x m) = None. + Proof. apply remove_spec1. apply is_bst. Qed. + Lemma remove_spec2 m x y : ~E.eq x y -> find y (remove x m) = find y m. + Proof. apply remove_spec2. apply is_bst. Qed. + + Lemma bindings_spec1 m x e : + InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. + Proof. apply bindings_mapsto. Qed. + + Lemma bindings_spec2 m : sort lt_key (bindings m). + Proof. apply bindings_sort. apply is_bst. Qed. + + Lemma bindings_spec2w m : NoDupA eq_key (bindings m). + Proof. apply bindings_nodup. apply is_bst. Qed. + + Lemma fold_spec m {A} (i : A) (f : key -> elt -> A -> A) : + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. + Proof. apply fold_spec. apply is_bst. Qed. + + Lemma cardinal_spec m : cardinal m = length (bindings m). + Proof. apply bindings_cardinal. Qed. + + Definition Equal m m' := forall y, find y m = find y m'. + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equivb cmp := Equiv (Cmp cmp). + + Lemma Equivb_Equivb cmp m m' : + Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. + Proof. + unfold Equivb, Equiv, Raw.Proofs.Equivb, In. intuition. + generalize (H0 k); do 2 rewrite In_alt; intuition. + generalize (H0 k); do 2 rewrite In_alt; intuition. + generalize (H0 k); do 2 rewrite <- In_alt; intuition. + generalize (H0 k); do 2 rewrite <- In_alt; intuition. + Qed. + + Lemma equal_spec m m' cmp : + equal cmp m m' = true <-> Equivb cmp m m'. + Proof. rewrite Equivb_Equivb. apply equal_Equivb; apply is_bst. Qed. + + End Elt. + + Lemma map_spec {elt elt'} (f:elt->elt') m x : + find x (map f m) = option_map f (find x m). + Proof. apply map_spec. Qed. + + Lemma mapi_spec {elt elt'} (f:key->elt->elt') m x : + exists y:key, E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). + Proof. apply mapi_spec. Qed. + + Lemma merge_spec1 {elt elt' elt''} + (f:key->option elt->option elt'->option elt'') m m' x : + In x m \/ In x m' -> + exists y:key, E.eq y x /\ + find x (merge f m m') = f y (find x m) (find x m'). + Proof. + unfold In. rewrite !In_alt. apply merge_spec1; apply is_bst. + Qed. + + Lemma merge_spec2 {elt elt' elt''} + (f:key -> option elt->option elt'->option elt'') m m' x : + In x (merge f m m') -> In x m \/ In x m'. + Proof. + unfold In. rewrite !In_alt. apply merge_spec2; apply is_bst. + Qed. + +End IntMake. + + +Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: + Sord with Module Data := D + with Module MapS.E := X. + + Module Data := D. + Module Import MapS := IntMake(I)(X). + Module LO := MMapList.Make_ord(X)(D). + Module R := Raw. + Module P := Raw.Proofs. + + Definition t := MapS.t D.t. + + Definition cmp e e' := + match D.compare e e' with Eq => true | _ => false end. + + (** One step of comparison of bindings *) + + Definition compare_more x1 d1 (cont:R.enumeration D.t -> comparison) e2 := + match e2 with + | R.End _ => Gt + | R.More x2 d2 r2 e2 => + match X.compare x1 x2 with + | Eq => match D.compare d1 d2 with + | Eq => cont (R.cons r2 e2) + | Lt => Lt + | Gt => Gt + end + | Lt => Lt + | Gt => Gt + end + end. + + (** Comparison of left tree, middle element, then right tree *) + + Fixpoint compare_cont s1 (cont:R.enumeration D.t -> comparison) e2 := + match s1 with + | R.Leaf _ => cont e2 + | R.Node l1 x1 d1 r1 _ => + compare_cont l1 (compare_more x1 d1 (compare_cont r1 cont)) e2 + end. + + (** Initial continuation *) + + Definition compare_end (e2:R.enumeration D.t) := + match e2 with R.End _ => Eq | _ => Lt end. + + (** The complete comparison *) + + Definition compare m1 m2 := + compare_cont m1.(this) compare_end (R.cons m2 .(this) (Raw.End _)). + + (** Correctness of this comparison *) + + Definition Cmp c := + match c with + | Eq => LO.eq_list + | Lt => LO.lt_list + | Gt => (fun l1 l2 => LO.lt_list l2 l1) + end. + + Lemma cons_Cmp c x1 x2 d1 d2 l1 l2 : + X.eq x1 x2 -> D.eq d1 d2 -> + Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). + Proof. + destruct c; simpl; intros; case X.compare_spec; auto; try P.MX.order. + intros. right. split; auto. now symmetry. + Qed. + Hint Resolve cons_Cmp. + + Lemma compare_end_Cmp e2 : + Cmp (compare_end e2) nil (P.flatten_e e2). + Proof. + destruct e2; simpl; auto. + Qed. + + Lemma compare_more_Cmp x1 d1 cont x2 d2 r2 e2 l : + Cmp (cont (R.cons r2 e2)) l (R.bindings r2 ++ P.flatten_e e2) -> + Cmp (compare_more x1 d1 cont (R.More x2 d2 r2 e2)) ((x1,d1)::l) + (P.flatten_e (R.More x2 d2 r2 e2)). + Proof. + simpl; case X.compare_spec; simpl; + try case D.compare_spec; simpl; auto; + case X.compare_spec; try P.MX.order; auto. + Qed. + + Lemma compare_cont_Cmp : forall s1 cont e2 l, + (forall e, Cmp (cont e) l (P.flatten_e e)) -> + Cmp (compare_cont s1 cont e2) (R.bindings s1 ++ l) (P.flatten_e e2). + Proof. + induction s1 as [|l1 Hl1 x1 d1 r1 Hr1 h1] using P.tree_ind; + intros; auto. + rewrite <- P.bindings_node; simpl. + apply Hl1; auto. clear e2. intros [|x2 d2 r2 e2]. + simpl; auto. + apply compare_more_Cmp. + rewrite <- P.cons_1; auto. + Qed. + + Lemma compare_Cmp m1 m2 : + Cmp (compare m1 m2) (bindings m1) (bindings m2). + Proof. + destruct m1 as (s1,H1), m2 as (s2,H2). + unfold compare, bindings; simpl. + rewrite <- (app_nil_r (R.bindings s1)). + replace (R.bindings s2) with (P.flatten_e (R.cons s2 (R.End _))) by + (rewrite P.cons_1; simpl; rewrite app_nil_r; auto). + auto using compare_cont_Cmp, compare_end_Cmp. + Qed. + + Definition eq (m1 m2 : t) := LO.eq_list (bindings m1) (bindings m2). + Definition lt (m1 m2 : t) := LO.lt_list (bindings m1) (bindings m2). + + Lemma compare_spec m1 m2 : CompSpec eq lt m1 m2 (compare m1 m2). + Proof. + assert (H := compare_Cmp m1 m2). + unfold Cmp in H. + destruct (compare m1 m2); auto. + Qed. + + (* Proofs about [eq] and [lt] *) + + Definition sbindings (m1 : t) := + LO.MapS.Mk (P.bindings_sort m1.(is_bst)). + + Definition seq (m1 m2 : t) := LO.eq (sbindings m1) (sbindings m2). + Definition slt (m1 m2 : t) := LO.lt (sbindings m1) (sbindings m2). + + Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2. + Proof. + unfold eq, seq, sbindings, bindings, LO.eq; intuition. + Qed. + + Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2. + Proof. + unfold lt, slt, sbindings, bindings, LO.lt; intuition. + Qed. + + Lemma eq_spec m m' : eq m m' <-> Equivb cmp m m'. + Proof. + rewrite eq_seq; unfold seq. + rewrite Equivb_Equivb. + rewrite P.Equivb_bindings. apply LO.eq_spec. + Qed. + + Instance eq_equiv : Equivalence eq. + Proof. + constructor; red; [intros x|intros x y| intros x y z]; + rewrite !eq_seq; apply LO.eq_equiv. + Qed. + + Instance lt_compat : Proper (eq ==> eq ==> iff) lt. + Proof. + intros m1 m2 H1 m1' m2' H2. rewrite !lt_slt. rewrite eq_seq in *. + now apply LO.lt_compat. + Qed. + + Instance lt_strorder : StrictOrder lt. + Proof. + constructor; red; [intros x; red|intros x y z]; + rewrite !lt_slt; apply LO.lt_strorder. + Qed. + +End IntMake_ord. + +(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) + +Module Make (X: OrderedType) <: S with Module E := X + :=IntMake(Z_as_Int)(X). + +Module Make_ord (X: OrderedType)(D: OrderedType) + <: Sord with Module Data := D + with Module MapS.E := X + :=IntMake_ord(Z_as_Int)(X)(D). diff --git a/theories/MMaps/MMapFacts.v b/theories/MMaps/MMapFacts.v new file mode 100644 index 00000000..69066a7b --- /dev/null +++ b/theories/MMaps/MMapFacts.v @@ -0,0 +1,2434 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(** * Finite maps library *) + +(** This functor derives additional facts from [MMapInterface.S]. These + facts are mainly the specifications of [MMapInterface.S] written using + different styles: equivalence and boolean equalities. +*) + +Require Import Bool Equalities Orders OrdersFacts OrdersLists. +Require Import Morphisms Permutation SetoidPermutation. +Require Export MMapInterface. +Set Implicit Arguments. +Unset Strict Implicit. + +Lemma eq_bool_alt b b' : b=b' <-> (b=true <-> b'=true). +Proof. + destruct b, b'; intuition. +Qed. + +Lemma eq_option_alt {elt}(o o':option elt) : + o=o' <-> (forall e, o=Some e <-> o'=Some e). +Proof. +split; intros. +- now subst. +- destruct o, o'; rewrite ?H; auto. + symmetry; now apply H. +Qed. + +Lemma option_map_some {A B}(f:A->B) o : + option_map f o <> None <-> o <> None. +Proof. + destruct o; simpl. now split. split; now destruct 1. +Qed. + +(** * Properties about weak maps *) + +Module WProperties_fun (E:DecidableType)(Import M:WSfun E). + +Definition Empty {elt}(m : t elt) := forall x e, ~MapsTo x e m. + +(** A few things about E.eq *) + +Lemma eq_refl x : E.eq x x. Proof. apply E.eq_equiv. Qed. +Lemma eq_sym x y : E.eq x y -> E.eq y x. Proof. apply E.eq_equiv. Qed. +Lemma eq_trans x y z : E.eq x y -> E.eq y z -> E.eq x z. +Proof. apply E.eq_equiv. Qed. +Hint Immediate eq_refl eq_sym : map. +Hint Resolve eq_trans eq_equivalence E.eq_equiv : map. + +Definition eqb x y := if E.eq_dec x y then true else false. + +Lemma eqb_eq x y : eqb x y = true <-> E.eq x y. +Proof. + unfold eqb; case E.eq_dec; now intuition. +Qed. + +Lemma eqb_sym x y : eqb x y = eqb y x. +Proof. + apply eq_bool_alt. rewrite !eqb_eq. split; apply E.eq_equiv. +Qed. + +(** Initial results about MapsTo and In *) + +Lemma mapsto_fun {elt} m x (e e':elt) : + MapsTo x e m -> MapsTo x e' m -> e=e'. +Proof. +rewrite <- !find_spec. congruence. +Qed. + +Lemma in_find {elt} (m : t elt) x : In x m <-> find x m <> None. +Proof. + unfold In. split. + - intros (e,H). rewrite <-find_spec in H. congruence. + - destruct (find x m) as [e|] eqn:H. + + exists e. now apply find_spec. + + now destruct 1. +Qed. + +Lemma not_in_find {elt} (m : t elt) x : ~In x m <-> find x m = None. +Proof. + rewrite in_find. split; auto. + intros; destruct (find x m); trivial. now destruct H. +Qed. + +Notation in_find_iff := in_find (only parsing). +Notation not_find_in_iff := not_in_find (only parsing). + +(** * [Equal] is a setoid equality. *) + +Infix "==" := Equal (at level 30). + +Lemma Equal_refl {elt} (m : t elt) : m == m. +Proof. red; reflexivity. Qed. + +Lemma Equal_sym {elt} (m m' : t elt) : m == m' -> m' == m. +Proof. unfold Equal; auto. Qed. + +Lemma Equal_trans {elt} (m m' m'' : t elt) : + m == m' -> m' == m'' -> m == m''. +Proof. unfold Equal; congruence. Qed. + +Instance Equal_equiv {elt} : Equivalence (@Equal elt). +Proof. +constructor; [exact Equal_refl | exact Equal_sym | exact Equal_trans]. +Qed. + +Arguments Equal {elt} m m'. + +Instance MapsTo_m {elt} : + Proper (E.eq==>Logic.eq==>Equal==>iff) (@MapsTo elt). +Proof. +intros k k' Hk e e' <- m m' Hm. rewrite <- Hk. +now rewrite <- !find_spec, Hm. +Qed. + +Instance In_m {elt} : + Proper (E.eq==>Equal==>iff) (@In elt). +Proof. +intros k k' Hk m m' Hm. unfold In. +split; intros (e,H); exists e; revert H; + now rewrite Hk, <- !find_spec, Hm. +Qed. + +Instance find_m {elt} : Proper (E.eq==>Equal==>Logic.eq) (@find elt). +Proof. +intros k k' Hk m m' <-. +rewrite eq_option_alt. intros. now rewrite !find_spec, Hk. +Qed. + +Instance mem_m {elt} : Proper (E.eq==>Equal==>Logic.eq) (@mem elt). +Proof. +intros k k' Hk m m' Hm. now rewrite eq_bool_alt, !mem_spec, Hk, Hm. +Qed. + +Instance Empty_m {elt} : Proper (Equal==>iff) (@Empty elt). +Proof. +intros m m' Hm. unfold Empty. now setoid_rewrite Hm. +Qed. + +Instance is_empty_m {elt} : Proper (Equal ==> Logic.eq) (@is_empty elt). +Proof. +intros m m' Hm. rewrite eq_bool_alt, !is_empty_spec. + now setoid_rewrite Hm. +Qed. + +Instance add_m {elt} : Proper (E.eq==>Logic.eq==>Equal==>Equal) (@add elt). +Proof. +intros k k' Hk e e' <- m m' Hm y. +destruct (E.eq_dec k y) as [H|H]. +- rewrite <-H, add_spec1. now rewrite Hk, add_spec1. +- rewrite !add_spec2; trivial. now rewrite <- Hk. +Qed. + +Instance remove_m {elt} : Proper (E.eq==>Equal==>Equal) (@remove elt). +Proof. +intros k k' Hk m m' Hm y. +destruct (E.eq_dec k y) as [H|H]. +- rewrite <-H, remove_spec1. now rewrite Hk, remove_spec1. +- rewrite !remove_spec2; trivial. now rewrite <- Hk. +Qed. + +Instance map_m {elt elt'} : + Proper ((Logic.eq==>Logic.eq)==>Equal==>Equal) (@map elt elt'). +Proof. +intros f f' Hf m m' Hm y. rewrite !map_spec, Hm. +destruct (find y m'); simpl; trivial. f_equal. now apply Hf. +Qed. + +Instance mapi_m {elt elt'} : + Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal) (@mapi elt elt'). +Proof. +intros f f' Hf m m' Hm y. +destruct (mapi_spec f m y) as (x,(Hx,->)). +destruct (mapi_spec f' m' y) as (x',(Hx',->)). +rewrite <- Hm. destruct (find y m); trivial. simpl. +f_equal. apply Hf; trivial. now rewrite Hx, Hx'. +Qed. + +Instance merge_m {elt elt' elt''} : + Proper ((E.eq==>Logic.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal==>Equal) + (@merge elt elt' elt''). +Proof. +intros f f' Hf m1 m1' Hm1 m2 m2' Hm2 y. +destruct (find y m1) as [e1|] eqn:H1. +- apply find_spec in H1. + assert (H : In y m1 \/ In y m2) by (left; now exists e1). + destruct (merge_spec1 f H) as (y1,(Hy1,->)). + rewrite Hm1,Hm2 in H. + destruct (merge_spec1 f' H) as (y2,(Hy2,->)). + rewrite <- Hm1, <- Hm2. apply Hf; trivial. now transitivity y. +- destruct (find y m2) as [e2|] eqn:H2. + + apply find_spec in H2. + assert (H : In y m1 \/ In y m2) by (right; now exists e2). + destruct (merge_spec1 f H) as (y1,(Hy1,->)). + rewrite Hm1,Hm2 in H. + destruct (merge_spec1 f' H) as (y2,(Hy2,->)). + rewrite <- Hm1, <- Hm2. apply Hf; trivial. now transitivity y. + + apply not_in_find in H1. apply not_in_find in H2. + assert (H : ~In y (merge f m1 m2)). + { intro H. apply merge_spec2 in H. intuition. } + apply not_in_find in H. rewrite H. + symmetry. apply not_in_find. intro H'. + apply merge_spec2 in H'. rewrite <- Hm1, <- Hm2 in H'. + intuition. +Qed. + +(* Later: compatibility for cardinal, fold, ... *) + +(** ** Earlier specifications (cf. FMaps) *) + +Section OldSpecs. +Variable elt: Type. +Implicit Type m: t elt. +Implicit Type x y z: key. +Implicit Type e: elt. + +Lemma MapsTo_1 m x y e : E.eq x y -> MapsTo x e m -> MapsTo y e m. +Proof. + now intros ->. +Qed. + +Lemma find_1 m x e : MapsTo x e m -> find x m = Some e. +Proof. apply find_spec. Qed. + +Lemma find_2 m x e : find x m = Some e -> MapsTo x e m. +Proof. apply find_spec. Qed. + +Lemma mem_1 m x : In x m -> mem x m = true. +Proof. apply mem_spec. Qed. + +Lemma mem_2 m x : mem x m = true -> In x m. +Proof. apply mem_spec. Qed. + +Lemma empty_1 : Empty (@empty elt). +Proof. + intros x e. now rewrite <- find_spec, empty_spec. +Qed. + +Lemma is_empty_1 m : Empty m -> is_empty m = true. +Proof. + unfold Empty; rewrite is_empty_spec. setoid_rewrite <- find_spec. + intros H x. specialize (H x). + destruct (find x m) as [e|]; trivial. + now destruct (H e). +Qed. + +Lemma is_empty_2 m : is_empty m = true -> Empty m. +Proof. + rewrite is_empty_spec. intros H x e. now rewrite <- find_spec, H. +Qed. + +Lemma add_1 m x y e : E.eq x y -> MapsTo y e (add x e m). +Proof. + intros <-. rewrite <-find_spec. apply add_spec1. +Qed. + +Lemma add_2 m x y e e' : + ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). +Proof. + intro. now rewrite <- !find_spec, add_spec2. +Qed. + +Lemma add_3 m x y e e' : + ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. +Proof. + intro. rewrite <- !find_spec, add_spec2; trivial. +Qed. + +Lemma remove_1 m x y : E.eq x y -> ~ In y (remove x m). +Proof. + intros <-. apply not_in_find. apply remove_spec1. +Qed. + +Lemma remove_2 m x y e : + ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). +Proof. + intro. now rewrite <- !find_spec, remove_spec2. +Qed. + +Lemma remove_3bis m x y e : + find y (remove x m) = Some e -> find y m = Some e. +Proof. + destruct (E.eq_dec x y) as [<-|H]. + - now rewrite remove_spec1. + - now rewrite remove_spec2. +Qed. + +Lemma remove_3 m x y e : MapsTo y e (remove x m) -> MapsTo y e m. +Proof. + rewrite <-!find_spec. apply remove_3bis. +Qed. + +Lemma bindings_1 m x e : + MapsTo x e m -> InA eq_key_elt (x,e) (bindings m). +Proof. apply bindings_spec1. Qed. + +Lemma bindings_2 m x e : + InA eq_key_elt (x,e) (bindings m) -> MapsTo x e m. +Proof. apply bindings_spec1. Qed. + +Lemma bindings_3w m : NoDupA eq_key (bindings m). +Proof. apply bindings_spec2w. Qed. + +Lemma cardinal_1 m : cardinal m = length (bindings m). +Proof. apply cardinal_spec. Qed. + +Lemma fold_1 m (A : Type) (i : A) (f : key -> elt -> A -> A) : + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. +Proof. apply fold_spec. Qed. + +Lemma equal_1 m m' cmp : Equivb cmp m m' -> equal cmp m m' = true. +Proof. apply equal_spec. Qed. + +Lemma equal_2 m m' cmp : equal cmp m m' = true -> Equivb cmp m m'. +Proof. apply equal_spec. Qed. + +End OldSpecs. + +Lemma map_1 {elt elt'}(m: t elt)(x:key)(e:elt)(f:elt->elt') : + MapsTo x e m -> MapsTo x (f e) (map f m). +Proof. + rewrite <- !find_spec, map_spec. now intros ->. +Qed. + +Lemma map_2 {elt elt'}(m: t elt)(x:key)(f:elt->elt') : + In x (map f m) -> In x m. +Proof. + rewrite !in_find, map_spec. apply option_map_some. +Qed. + +Lemma mapi_1 {elt elt'}(m: t elt)(x:key)(e:elt)(f:key->elt->elt') : + MapsTo x e m -> + exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). +Proof. + destruct (mapi_spec f m x) as (y,(Hy,Eq)). + intro H. exists y; split; trivial. + rewrite <-find_spec in *. now rewrite Eq, H. +Qed. + +Lemma mapi_2 {elt elt'}(m: t elt)(x:key)(f:key->elt->elt') : + In x (mapi f m) -> In x m. +Proof. + destruct (mapi_spec f m x) as (y,(Hy,Eq)). + rewrite !in_find. intro H; contradict H. now rewrite Eq, H. +Qed. + +(** The ancestor [map2] of the current [merge] was dealing with functions + on datas only, not on keys. *) + +Definition map2 {elt elt' elt''} (f:option elt->option elt'->option elt'') + := merge (fun _ => f). + +Lemma map2_1 {elt elt' elt''}(m: t elt)(m': t elt') + (x:key)(f:option elt->option elt'->option elt'') : + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). +Proof. + intros. unfold map2. + now destruct (merge_spec1 (fun _ => f) H) as (y,(_,->)). +Qed. + +Lemma map2_2 {elt elt' elt''}(m: t elt)(m': t elt') + (x:key)(f:option elt->option elt'->option elt'') : + In x (map2 f m m') -> In x m \/ In x m'. +Proof. apply merge_spec2. Qed. + +Hint Immediate MapsTo_1 mem_2 is_empty_2 + map_2 mapi_2 add_3 remove_3 find_2 : map. +Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1 + remove_2 find_1 fold_1 map_1 mapi_1 mapi_2 : map. + +(** ** Specifications written using equivalences *) + +Section IffSpec. +Variable elt: Type. +Implicit Type m: t elt. +Implicit Type x y z: key. +Implicit Type e: elt. + +Lemma in_iff m x y : E.eq x y -> (In x m <-> In y m). +Proof. now intros ->. Qed. + +Lemma mapsto_iff m x y e : E.eq x y -> (MapsTo x e m <-> MapsTo y e m). +Proof. now intros ->. Qed. + +Lemma mem_in_iff m x : In x m <-> mem x m = true. +Proof. symmetry. apply mem_spec. Qed. + +Lemma not_mem_in_iff m x : ~In x m <-> mem x m = false. +Proof. +rewrite mem_in_iff; destruct (mem x m); intuition. +Qed. + +Lemma mem_find m x : mem x m = true <-> find x m <> None. +Proof. + rewrite <- mem_in_iff. apply in_find. +Qed. + +Lemma not_mem_find m x : mem x m = false <-> find x m = None. +Proof. + rewrite <- not_mem_in_iff. apply not_in_find. +Qed. + +Lemma In_dec m x : { In x m } + { ~ In x m }. +Proof. + generalize (mem_in_iff m x). + destruct (mem x m); [left|right]; intuition. +Qed. + +Lemma find_mapsto_iff m x e : MapsTo x e m <-> find x m = Some e. +Proof. symmetry. apply find_spec. Qed. + +Lemma equal_iff m m' cmp : Equivb cmp m m' <-> equal cmp m m' = true. +Proof. symmetry. apply equal_spec. Qed. + +Lemma empty_mapsto_iff x e : MapsTo x e empty <-> False. +Proof. +rewrite <- find_spec, empty_spec. now split. +Qed. + +Lemma not_in_empty x : ~In x (@empty elt). +Proof. +intros (e,H). revert H. apply empty_mapsto_iff. +Qed. + +Lemma empty_in_iff x : In x (@empty elt) <-> False. +Proof. +split; [ apply not_in_empty | destruct 1 ]. +Qed. + +Lemma is_empty_iff m : Empty m <-> is_empty m = true. +Proof. split; [apply is_empty_1 | apply is_empty_2 ]. Qed. + +Lemma add_mapsto_iff m x y e e' : + MapsTo y e' (add x e m) <-> + (E.eq x y /\ e=e') \/ + (~E.eq x y /\ MapsTo y e' m). +Proof. +split. +- intros H. destruct (E.eq_dec x y); [left|right]; split; trivial. + + symmetry. apply (mapsto_fun H); auto with map. + + now apply add_3 with x e. +- destruct 1 as [(H,H')|(H,H')]; subst; auto with map. +Qed. + +Lemma add_mapsto_new m x y e e' : ~In x m -> + MapsTo y e' (add x e m) <-> (E.eq x y /\ e=e') \/ MapsTo y e' m. +Proof. + intros. + rewrite add_mapsto_iff. intuition. + right; split; trivial. contradict H. exists e'. now rewrite H. +Qed. + +Lemma in_add m x y e : In y m -> In y (add x e m). +Proof. + destruct (E.eq_dec x y) as [<-|H']. + - now rewrite !in_find, add_spec1. + - now rewrite !in_find, add_spec2. +Qed. + +Lemma add_in_iff m x y e : In y (add x e m) <-> E.eq x y \/ In y m. +Proof. +split. +- intros H. destruct (E.eq_dec x y); [now left|right]. + rewrite in_find, add_spec2 in H; trivial. now apply in_find. +- intros [<-|H]. + + exists e. now apply add_1. + + now apply in_add. +Qed. + +Lemma add_neq_mapsto_iff m x y e e' : + ~ E.eq x y -> (MapsTo y e' (add x e m) <-> MapsTo y e' m). +Proof. +split; [apply add_3|apply add_2]; auto. +Qed. + +Lemma add_neq_in_iff m x y e : + ~ E.eq x y -> (In y (add x e m) <-> In y m). +Proof. +split; intros (e',H0); exists e'. +- now apply add_3 with x e. +- now apply add_2. +Qed. + +Lemma remove_mapsto_iff m x y e : + MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m. +Proof. +split; [split|destruct 1]. +- intro E. revert H. now rewrite <-E, <- find_spec, remove_spec1. +- now apply remove_3 with x. +- now apply remove_2. +Qed. + +Lemma remove_in_iff m x y : In y (remove x m) <-> ~E.eq x y /\ In y m. +Proof. +unfold In; split; [ intros (e,H) | intros (E,(e,H)) ]. +- apply remove_mapsto_iff in H. destruct H; split; trivial. + now exists e. +- exists e. now apply remove_2. +Qed. + +Lemma remove_neq_mapsto_iff : forall m x y e, + ~ E.eq x y -> (MapsTo y e (remove x m) <-> MapsTo y e m). +Proof. +split; [apply remove_3|apply remove_2]; auto. +Qed. + +Lemma remove_neq_in_iff : forall m x y, + ~ E.eq x y -> (In y (remove x m) <-> In y m). +Proof. +split; intros (e',H0); exists e'. +- now apply remove_3 with x. +- now apply remove_2. +Qed. + +Lemma bindings_mapsto_iff m x e : + MapsTo x e m <-> InA eq_key_elt (x,e) (bindings m). +Proof. symmetry. apply bindings_spec1. Qed. + +Lemma bindings_in_iff m x : + In x m <-> exists e, InA eq_key_elt (x,e) (bindings m). +Proof. +unfold In; split; intros (e,H); exists e; now apply bindings_spec1. +Qed. + +End IffSpec. + +Lemma map_mapsto_iff {elt elt'} m x b (f : elt -> elt') : + MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m. +Proof. +rewrite <-find_spec, map_spec. setoid_rewrite <- find_spec. +destruct (find x m); simpl; split. +- injection 1. now exists e. +- intros (a,(->,H)). now injection H as ->. +- discriminate. +- intros (a,(_,H)); discriminate. +Qed. + +Lemma map_in_iff {elt elt'} m x (f : elt -> elt') : + In x (map f m) <-> In x m. +Proof. +rewrite !in_find, map_spec. apply option_map_some. +Qed. + +Lemma mapi_in_iff {elt elt'} m x (f:key->elt->elt') : + In x (mapi f m) <-> In x m. +Proof. +rewrite !in_find. destruct (mapi_spec f m x) as (y,(_,->)). +apply option_map_some. +Qed. + +(** Unfortunately, we don't have simple equivalences for [mapi] + and [MapsTo]. The only correct one needs compatibility of [f]. *) + +Lemma mapi_inv {elt elt'} m x b (f : key -> elt -> elt') : + MapsTo x b (mapi f m) -> + exists a y, E.eq y x /\ b = f y a /\ MapsTo x a m. +Proof. +rewrite <- find_spec. setoid_rewrite <- find_spec. +destruct (mapi_spec f m x) as (y,(E,->)). +destruct (find x m); simpl. +- injection 1 as <-. now exists e, y. +- discriminate. +Qed. + +Lemma mapi_spec' {elt elt'} (f:key->elt->elt') : + Proper (E.eq==>Logic.eq==>Logic.eq) f -> + forall m x, + find x (mapi f m) = option_map (f x) (find x m). +Proof. + intros. destruct (mapi_spec f m x) as (y,(Hy,->)). + destruct (find x m); simpl; trivial. + now rewrite Hy. +Qed. + +Lemma mapi_1bis {elt elt'} m x e (f:key->elt->elt') : + Proper (E.eq==>Logic.eq==>Logic.eq) f -> + MapsTo x e m -> MapsTo x (f x e) (mapi f m). +Proof. +intros. destruct (mapi_1 f H0) as (y,(->,H2)). trivial. +Qed. + +Lemma mapi_mapsto_iff {elt elt'} m x b (f:key->elt->elt') : + Proper (E.eq==>Logic.eq==>Logic.eq) f -> + (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m). +Proof. +rewrite <-find_spec. setoid_rewrite <-find_spec. +intros Pr. rewrite mapi_spec' by trivial. +destruct (find x m); simpl; split. +- injection 1 as <-. now exists e. +- intros (a,(->,H)). now injection H as <-. +- discriminate. +- intros (a,(_,H)). discriminate. +Qed. + +(** Things are even worse for [merge] : we don't try to state any + equivalence, see instead boolean results below. *) + +(** Useful tactic for simplifying expressions like + [In y (add x e (remove z m))] *) + +Ltac map_iff := + repeat (progress ( + rewrite add_mapsto_iff || rewrite add_in_iff || + rewrite remove_mapsto_iff || rewrite remove_in_iff || + rewrite empty_mapsto_iff || rewrite empty_in_iff || + rewrite map_mapsto_iff || rewrite map_in_iff || + rewrite mapi_in_iff)). + +(** ** Specifications written using boolean predicates *) + +Section BoolSpec. + +Lemma mem_find_b {elt}(m:t elt)(x:key) : + mem x m = if find x m then true else false. +Proof. +apply eq_bool_alt. rewrite mem_find. destruct (find x m). +- now split. +- split; (discriminate || now destruct 1). +Qed. + +Variable elt elt' elt'' : Type. +Implicit Types m : t elt. +Implicit Types x y z : key. +Implicit Types e : elt. + +Lemma mem_b m x y : E.eq x y -> mem x m = mem y m. +Proof. now intros ->. Qed. + +Lemma find_o m x y : E.eq x y -> find x m = find y m. +Proof. now intros ->. Qed. + +Lemma empty_o x : find x (@empty elt) = None. +Proof. apply empty_spec. Qed. + +Lemma empty_a x : mem x (@empty elt) = false. +Proof. apply not_mem_find. apply empty_spec. Qed. + +Lemma add_eq_o m x y e : + E.eq x y -> find y (add x e m) = Some e. +Proof. + intros <-. apply add_spec1. +Qed. + +Lemma add_neq_o m x y e : + ~ E.eq x y -> find y (add x e m) = find y m. +Proof. apply add_spec2. Qed. +Hint Resolve add_neq_o : map. + +Lemma add_o m x y e : + find y (add x e m) = if E.eq_dec x y then Some e else find y m. +Proof. +destruct (E.eq_dec x y); auto with map. +Qed. + +Lemma add_eq_b m x y e : + E.eq x y -> mem y (add x e m) = true. +Proof. +intros <-. apply mem_spec, add_in_iff. now left. +Qed. + +Lemma add_neq_b m x y e : + ~E.eq x y -> mem y (add x e m) = mem y m. +Proof. +intros. now rewrite !mem_find_b, add_neq_o. +Qed. + +Lemma add_b m x y e : + mem y (add x e m) = eqb x y || mem y m. +Proof. +rewrite !mem_find_b, add_o. unfold eqb. +now destruct (E.eq_dec x y). +Qed. + +Lemma remove_eq_o m x y : + E.eq x y -> find y (remove x m) = None. +Proof. intros ->. apply remove_spec1. Qed. + +Lemma remove_neq_o m x y : + ~ E.eq x y -> find y (remove x m) = find y m. +Proof. apply remove_spec2. Qed. + +Hint Resolve remove_eq_o remove_neq_o : map. + +Lemma remove_o m x y : + find y (remove x m) = if E.eq_dec x y then None else find y m. +Proof. +destruct (E.eq_dec x y); auto with map. +Qed. + +Lemma remove_eq_b m x y : + E.eq x y -> mem y (remove x m) = false. +Proof. +intros <-. now rewrite mem_find_b, remove_eq_o. +Qed. + +Lemma remove_neq_b m x y : + ~ E.eq x y -> mem y (remove x m) = mem y m. +Proof. +intros. now rewrite !mem_find_b, remove_neq_o. +Qed. + +Lemma remove_b m x y : + mem y (remove x m) = negb (eqb x y) && mem y m. +Proof. +rewrite !mem_find_b, remove_o; unfold eqb. +now destruct (E.eq_dec x y). +Qed. + +Lemma map_o m x (f:elt->elt') : + find x (map f m) = option_map f (find x m). +Proof. apply map_spec. Qed. + +Lemma map_b m x (f:elt->elt') : + mem x (map f m) = mem x m. +Proof. +rewrite !mem_find_b, map_o. now destruct (find x m). +Qed. + +Lemma mapi_b m x (f:key->elt->elt') : + mem x (mapi f m) = mem x m. +Proof. +apply eq_bool_alt; rewrite !mem_spec. apply mapi_in_iff. +Qed. + +Lemma mapi_o m x (f:key->elt->elt') : + Proper (E.eq==>Logic.eq==>Logic.eq) f -> + find x (mapi f m) = option_map (f x) (find x m). +Proof. intros; now apply mapi_spec'. Qed. + +Lemma merge_spec1' (f:key->option elt->option elt'->option elt'') : + Proper (E.eq==>Logic.eq==>Logic.eq==>Logic.eq) f -> + forall (m:t elt)(m':t elt') x, + In x m \/ In x m' -> + find x (merge f m m') = f x (find x m) (find x m'). +Proof. + intros Hf m m' x H. + now destruct (merge_spec1 f H) as (y,(->,->)). +Qed. + +Lemma merge_spec1_none (f:key->option elt->option elt'->option elt'') : + (forall x, f x None None = None) -> + forall (m: t elt)(m': t elt') x, + exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m'). +Proof. +intros Hf m m' x. +destruct (find x m) as [e|] eqn:Hm. +- assert (H : In x m \/ In x m') by (left; exists e; now apply find_spec). + destruct (merge_spec1 f H) as (y,(Hy,->)). + exists y; split; trivial. now rewrite Hm. +- destruct (find x m') as [e|] eqn:Hm'. + + assert (H : In x m \/ In x m') by (right; exists e; now apply find_spec). + destruct (merge_spec1 f H) as (y,(Hy,->)). + exists y; split; trivial. now rewrite Hm, Hm'. + + exists x. split. reflexivity. rewrite Hf. + apply not_in_find. intro H. + apply merge_spec2 in H. apply not_in_find in Hm. apply not_in_find in Hm'. + intuition. +Qed. + +Lemma merge_spec1'_none (f:key->option elt->option elt'->option elt'') : + Proper (E.eq==>Logic.eq==>Logic.eq==>Logic.eq) f -> + (forall x, f x None None = None) -> + forall (m: t elt)(m': t elt') x, + find x (merge f m m') = f x (find x m) (find x m'). +Proof. + intros Hf Hf' m m' x. + now destruct (merge_spec1_none Hf' m m' x) as (y,(->,->)). +Qed. + +Lemma bindings_o : forall m x, + find x m = findA (eqb x) (bindings m). +Proof. +intros. rewrite eq_option_alt. intro e. +rewrite <- find_mapsto_iff, bindings_mapsto_iff. +unfold eqb. +rewrite <- findA_NoDupA; dintuition; try apply bindings_3w; eauto. +Qed. + +Lemma bindings_b : forall m x, + mem x m = existsb (fun p => eqb x (fst p)) (bindings m). +Proof. +intros. +apply eq_bool_alt. +rewrite mem_spec, bindings_in_iff, existsb_exists. +split. +- intros (e,H). + rewrite InA_alt in H. + destruct H as ((k,e'),((H1,H2),H')); simpl in *; subst e'. + exists (k, e); split; trivial. simpl. now apply eqb_eq. +- intros ((k,e),(H,H')); simpl in *. apply eqb_eq in H'. + exists e. rewrite InA_alt. exists (k,e). now repeat split. +Qed. + +End BoolSpec. + +Section Equalities. +Variable elt:Type. + +(** A few basic equalities *) + +Lemma eq_empty (m: t elt) : m == empty <-> is_empty m = true. +Proof. + unfold Equal. rewrite is_empty_spec. now setoid_rewrite empty_spec. +Qed. + +Lemma add_id (m: t elt) x e : add x e m == m <-> find x m = Some e. +Proof. + split. + - intros H. rewrite <- (H x). apply add_spec1. + - intros H y. rewrite !add_o. now destruct E.eq_dec as [<-|E]. +Qed. + +Lemma add_add_1 (m: t elt) x e : + add x e (add x e m) == add x e m. +Proof. + intros y. rewrite !add_o. destruct E.eq_dec; auto. +Qed. + +Lemma add_add_2 (m: t elt) x x' e e' : + ~E.eq x x' -> add x e (add x' e' m) == add x' e' (add x e m). +Proof. + intros H y. rewrite !add_o. + do 2 destruct E.eq_dec; auto. + elim H. now transitivity y. +Qed. + +Lemma remove_id (m: t elt) x : remove x m == m <-> ~In x m. +Proof. + rewrite not_in_find. split. + - intros H. rewrite <- (H x). apply remove_spec1. + - intros H y. rewrite !remove_o. now destruct E.eq_dec as [<-|E]. +Qed. + +Lemma remove_remove_1 (m: t elt) x : + remove x (remove x m) == remove x m. +Proof. + intros y. rewrite !remove_o. destruct E.eq_dec; auto. +Qed. + +Lemma remove_remove_2 (m: t elt) x x' : + remove x (remove x' m) == remove x' (remove x m). +Proof. + intros y. rewrite !remove_o. do 2 destruct E.eq_dec; auto. +Qed. + +Lemma remove_add_1 (m: t elt) x e : + remove x (add x e m) == remove x m. +Proof. + intro y. rewrite !remove_o, !add_o. now destruct E.eq_dec. +Qed. + +Lemma remove_add_2 (m: t elt) x x' e : + ~E.eq x x' -> remove x' (add x e m) == add x e (remove x' m). +Proof. + intros H y. rewrite !remove_o, !add_o. + do 2 destruct E.eq_dec; auto. + - elim H; now transitivity y. + - symmetry. now apply remove_eq_o. + - symmetry. now apply remove_neq_o. +Qed. + +Lemma add_remove_1 (m: t elt) x e : + add x e (remove x m) == add x e m. +Proof. + intro y. rewrite !add_o, !remove_o. now destruct E.eq_dec. +Qed. + +(** Another characterisation of [Equal] *) + +Lemma Equal_mapsto_iff : forall m1 m2 : t elt, + m1 == m2 <-> (forall k e, MapsTo k e m1 <-> MapsTo k e m2). +Proof. +intros m1 m2. split; [intros Heq k e|intros Hiff]. +rewrite 2 find_mapsto_iff, Heq. split; auto. +intro k. rewrite eq_option_alt. intro e. +rewrite <- 2 find_mapsto_iff; auto. +Qed. + +(** * Relations between [Equal], [Equiv] and [Equivb]. *) + +(** First, [Equal] is [Equiv] with Leibniz on elements. *) + +Lemma Equal_Equiv : forall (m m' : t elt), + m == m' <-> Equiv Logic.eq m m'. +Proof. +intros. rewrite Equal_mapsto_iff. split; intros. +- split. + + split; intros (e,Hin); exists e; [rewrite <- H|rewrite H]; auto. + + intros; apply mapsto_fun with m k; auto; rewrite H; auto. +- split; intros H'. + + destruct H. + assert (Hin : In k m') by (rewrite <- H; exists e; auto). + destruct Hin as (e',He'). + rewrite (H0 k e e'); auto. + + destruct H. + assert (Hin : In k m) by (rewrite H; exists e; auto). + destruct Hin as (e',He'). + rewrite <- (H0 k e' e); auto. +Qed. + +(** [Equivb] and [Equiv] and equivalent when [eq_elt] and [cmp] + are related. *) + +Section Cmp. +Variable eq_elt : elt->elt->Prop. +Variable cmp : elt->elt->bool. + +Definition compat_cmp := + forall e e', cmp e e' = true <-> eq_elt e e'. + +Lemma Equiv_Equivb : compat_cmp -> + forall m m', Equiv eq_elt m m' <-> Equivb cmp m m'. +Proof. + unfold Equivb, Equiv, Cmp; intuition. + red in H; rewrite H; eauto. + red in H; rewrite <-H; eauto. +Qed. +End Cmp. + +(** Composition of the two last results: relation between [Equal] + and [Equivb]. *) + +Lemma Equal_Equivb : forall cmp, + (forall e e', cmp e e' = true <-> e = e') -> + forall (m m':t elt), m == m' <-> Equivb cmp m m'. +Proof. + intros; rewrite Equal_Equiv. + apply Equiv_Equivb; auto. +Qed. + +Lemma Equal_Equivb_eqdec : + forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }), + let cmp := fun e e' => if eq_elt_dec e e' then true else false in + forall (m m':t elt), m == m' <-> Equivb cmp m m'. +Proof. +intros; apply Equal_Equivb. +unfold cmp; clear cmp; intros. +destruct eq_elt_dec; now intuition. +Qed. + +End Equalities. + +(** * Results about [fold], [bindings], induction principles... *) + +Section Elt. + Variable elt:Type. + + Definition Add x (e:elt) m m' := m' == (add x e m). + + Notation eqke := (@eq_key_elt elt). + Notation eqk := (@eq_key elt). + + Instance eqk_equiv : Equivalence eqk. + Proof. unfold eq_key. destruct E.eq_equiv. constructor; eauto. Qed. + + Instance eqke_equiv : Equivalence eqke. + Proof. + unfold eq_key_elt; split; repeat red; intuition; simpl in *; + etransitivity; eauto. + Qed. + + (** Complements about InA, NoDupA and findA *) + + Lemma InA_eqke_eqk k k' e e' l : + E.eq k k' -> InA eqke (k,e) l -> InA eqk (k',e') l. + Proof. + intros Hk. rewrite 2 InA_alt. + intros ((k'',e'') & (Hk'',He'') & H); simpl in *; subst e''. + exists (k'',e); split; auto. red; simpl. now transitivity k. + Qed. + + Lemma NoDupA_incl {A} (R R':relation A) : + (forall x y, R x y -> R' x y) -> + forall l, NoDupA R' l -> NoDupA R l. + Proof. + intros Incl. + induction 1 as [ | a l E _ IH ]; constructor; auto. + contradict E. revert E. rewrite 2 InA_alt. firstorder. + Qed. + + Lemma NoDupA_eqk_eqke l : NoDupA eqk l -> NoDupA eqke l. + Proof. + apply NoDupA_incl. now destruct 1. + Qed. + + Lemma findA_rev l k : NoDupA eqk l -> + findA (eqb k) l = findA (eqb k) (rev l). + Proof. + intros H. apply eq_option_alt. intros e. unfold eqb. + rewrite <- !findA_NoDupA, InA_rev; eauto with map. reflexivity. + change (NoDupA eqk (rev l)). apply NoDupA_rev; auto using eqk_equiv. + Qed. + + (** * Bindings *) + + Lemma bindings_Empty (m:t elt) : Empty m <-> bindings m = nil. + Proof. + unfold Empty. split; intros H. + - assert (H' : forall a, ~ List.In a (bindings m)). + { intros (k,e) H'. apply (H k e). + rewrite bindings_mapsto_iff, InA_alt. + exists (k,e); repeat split; auto with map. } + destruct (bindings m) as [|p l]; trivial. + destruct (H' p); simpl; auto. + - intros x e. rewrite bindings_mapsto_iff, InA_alt. + rewrite H. now intros (y,(E,H')). + Qed. + + Lemma bindings_empty : bindings (@empty elt) = nil. + Proof. + rewrite <-bindings_Empty; apply empty_1. + Qed. + + (** * Conversions between maps and association lists. *) + + Definition uncurry {U V W : Type} (f : U -> V -> W) : U*V -> W := + fun p => f (fst p) (snd p). + + Definition of_list := + List.fold_right (uncurry (@add _)) (@empty elt). + + Definition to_list := bindings. + + Lemma of_list_1 : forall l k e, + NoDupA eqk l -> + (MapsTo k e (of_list l) <-> InA eqke (k,e) l). + Proof. + induction l as [|(k',e') l IH]; simpl; intros k e Hnodup. + - rewrite empty_mapsto_iff, InA_nil; intuition. + - unfold uncurry; simpl. + inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. + specialize (IH k e Hnodup'); clear Hnodup'. + rewrite add_mapsto_iff, InA_cons, <- IH. + unfold eq_key_elt at 1; simpl. + split; destruct 1 as [H|H]; try (intuition;fail). + destruct (E.eq_dec k k'); [left|right]; split; auto with map. + contradict Hnotin. + apply InA_eqke_eqk with k e; intuition. + Qed. + + Lemma of_list_1b : forall l k, + NoDupA eqk l -> + find k (of_list l) = findA (eqb k) l. + Proof. + induction l as [|(k',e') l IH]; simpl; intros k Hnodup. + apply empty_o. + unfold uncurry; simpl. + inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. + specialize (IH k Hnodup'); clear Hnodup'. + rewrite add_o, IH, eqb_sym. unfold eqb; now destruct E.eq_dec. + Qed. + + Lemma of_list_2 : forall l, NoDupA eqk l -> + equivlistA eqke l (to_list (of_list l)). + Proof. + intros l Hnodup (k,e). + rewrite <- bindings_mapsto_iff, of_list_1; intuition. + Qed. + + Lemma of_list_3 : forall s, Equal (of_list (to_list s)) s. + Proof. + intros s k. + rewrite of_list_1b, bindings_o; auto. + apply bindings_3w. + Qed. + + (** * Fold *) + + (** Alternative specification via [fold_right] *) + + Lemma fold_spec_right m (A:Type)(i:A)(f : key -> elt -> A -> A) : + fold f m i = List.fold_right (uncurry f) i (rev (bindings m)). + Proof. + rewrite fold_1. symmetry. apply fold_left_rev_right. + Qed. + + (** ** Induction principles about fold contributed by S. Lescuyer *) + + (** In the following lemma, the step hypothesis is deliberately restricted + to the precise map m we are considering. *) + + Lemma fold_rec : + forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), + forall (i:A)(m:t elt), + (forall m, Empty m -> P m i) -> + (forall k e a m' m'', MapsTo k e m -> ~In k m' -> + Add k e m' m'' -> P m' a -> P m'' (f k e a)) -> + P m (fold f m i). + Proof. + intros A P f i m Hempty Hstep. + rewrite fold_spec_right. + set (F:=uncurry f). + set (l:=rev (bindings m)). + assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' -> + Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)). + { + intros k e a m' m'' H ? ? ?; eapply Hstep; eauto. + revert H; unfold l; rewrite InA_rev, bindings_mapsto_iff; auto with *. } + assert (Hdup : NoDupA eqk l). + { unfold l. apply NoDupA_rev; try red; unfold eq_key ; eauto with *. + apply bindings_3w. } + assert (Hsame : forall k, find k m = findA (eqb k) l). + { intros k. unfold l. rewrite bindings_o, findA_rev; auto. + apply bindings_3w. } + clearbody l. clearbody F. clear Hstep f. revert m Hsame. induction l. + - (* empty *) + intros m Hsame; simpl. + apply Hempty. intros k e. + rewrite find_mapsto_iff, Hsame; simpl; discriminate. + - (* step *) + intros m Hsame; destruct a as (k,e); simpl. + apply Hstep' with (of_list l); auto. + + rewrite InA_cons; left; red; auto with map. + + inversion_clear Hdup. contradict H. destruct H as (e',He'). + apply InA_eqke_eqk with k e'; auto with map. + rewrite <- of_list_1; auto. + + intro k'. rewrite Hsame, add_o, of_list_1b. simpl. + rewrite eqb_sym. unfold eqb. now destruct E.eq_dec. + inversion_clear Hdup; auto with map. + + apply IHl. + * intros; eapply Hstep'; eauto. + * inversion_clear Hdup; auto. + * intros; apply of_list_1b. inversion_clear Hdup; auto. + Qed. + + (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this + case, [P] must be compatible with equality of sets *) + + Theorem fold_rec_bis : + forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), + forall (i:A)(m:t elt), + (forall m m' a, Equal m m' -> P m a -> P m' a) -> + (P empty i) -> + (forall k e a m', MapsTo k e m -> ~In k m' -> + P m' a -> P (add k e m') (f k e a)) -> + P m (fold f m i). + Proof. + intros A P f i m Pmorphism Pempty Pstep. + apply fold_rec; intros. + apply Pmorphism with empty; auto. intro k. rewrite empty_o. + case_eq (find k m0); auto; intros e'; rewrite <- find_mapsto_iff. + intro H'; elim (H k e'); auto. + apply Pmorphism with (add k e m'); try intro; auto. + Qed. + + Lemma fold_rec_nodep : + forall (A:Type)(P : A -> Type)(f : key -> elt -> A -> A)(i:A)(m:t elt), + P i -> (forall k e a, MapsTo k e m -> P a -> P (f k e a)) -> + P (fold f m i). + Proof. + intros; apply fold_rec_bis with (P:=fun _ => P); auto. + Qed. + + (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : + the step hypothesis must here be applicable anywhere. + At the same time, it looks more like an induction principle, + and hence can be easier to use. *) + + Lemma fold_rec_weak : + forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A)(i:A), + (forall m m' a, Equal m m' -> P m a -> P m' a) -> + P empty i -> + (forall k e a m, ~In k m -> P m a -> P (add k e m) (f k e a)) -> + forall m, P m (fold f m i). + Proof. + intros; apply fold_rec_bis; auto. + Qed. + + Lemma fold_rel : + forall (A B:Type)(R : A -> B -> Type) + (f : key -> elt -> A -> A)(g : key -> elt -> B -> B)(i : A)(j : B) + (m : t elt), + R i j -> + (forall k e a b, MapsTo k e m -> R a b -> R (f k e a) (g k e b)) -> + R (fold f m i) (fold g m j). + Proof. + intros A B R f g i j m Rempty Rstep. + rewrite 2 fold_spec_right. set (l:=rev (bindings m)). + assert (Rstep' : forall k e a b, InA eqke (k,e) l -> + R a b -> R (f k e a) (g k e b)). + { intros; apply Rstep; auto. + rewrite bindings_mapsto_iff, <- InA_rev; auto with map. } + clearbody l; clear Rstep m. + induction l; simpl; auto. + apply Rstep'; auto. + destruct a; simpl; rewrite InA_cons; left; red; auto with map. + Qed. + + (** From the induction principle on [fold], we can deduce some general + induction principles on maps. *) + + Lemma map_induction : + forall P : t elt -> Type, + (forall m, Empty m -> P m) -> + (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') -> + forall m, P m. + Proof. + intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. + Qed. + + Lemma map_induction_bis : + forall P : t elt -> Type, + (forall m m', Equal m m' -> P m -> P m') -> + P empty -> + (forall x e m, ~In x m -> P m -> P (add x e m)) -> + forall m, P m. + Proof. + intros. + apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. + Qed. + + (** [fold] can be used to reconstruct the same initial set. *) + + Lemma fold_identity : forall m : t elt, Equal (fold (@add _) m empty) m. + Proof. + intros. + apply fold_rec with (P:=fun m acc => Equal acc m); auto with map. + intros m' Heq k'. + rewrite empty_o. + case_eq (find k' m'); auto; intros e'; rewrite <- find_mapsto_iff. + intro; elim (Heq k' e'); auto. + intros k e a m' m'' _ _ Hadd Heq k'. + red in Heq. rewrite Hadd, 2 add_o, Heq; auto. + Qed. + + Section Fold_More. + + (** ** Additional properties of fold *) + + (** When a function [f] is compatible and allows transpositions, we can + compute [fold f] in any order. *) + + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). + + Lemma fold_Empty (f:key->elt->A->A) : + forall m i, Empty m -> eqA (fold f m i) i. + Proof. + intros. apply fold_rec_nodep with (P:=fun a => eqA a i). + reflexivity. + intros. elim (H k e); auto. + Qed. + + Lemma fold_init (f:key->elt->A->A) : + Proper (E.eq==>eq==>eqA==>eqA) f -> + forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i'). + Proof. + intros Hf m i i' Hi. apply fold_rel with (R:=eqA); auto. + intros. now apply Hf. + Qed. + + (** Transpositions of f (a.k.a diamond property). + Could we swap two sequential calls to f, i.e. do we have: + + f k e (f k' e' a) == f k' e' (f k e a) + + First, we do no need this equation for all keys, but only + when k and k' aren't equal, as suggested by Pierre Castéran. + Think for instance of [f] being [M.add] : in general, we don't have + [M.add k e (M.add k e' m) == M.add k e' (M.add k e m)]. + Fortunately, we will never encounter this situation during a real + [fold], since the keys received by this [fold] are unique. + NB: without this condition, this condition would be + [SetoidList.transpose2]. + + Secondly, instead of the equation above, we now use a statement + with more basic equalities, allowing to prove [fold_commutes] even + when [f] isn't a morphism. + NB: When [f] is a morphism, [Diamond f] gives back the equation above. +*) + + Definition Diamond (f:key->elt->A->A) := + forall k k' e e' a b b', ~E.eq k k' -> + eqA (f k e a) b -> eqA (f k' e' a) b' -> eqA (f k e b') (f k' e' b). + + Lemma fold_commutes (f:key->elt->A->A) : + Diamond f -> + forall i m k e, ~In k m -> + eqA (fold f m (f k e i)) (f k e (fold f m i)). + Proof. + intros Hf i m k e H. + apply fold_rel with (R:= fun a b => eqA a (f k e b)); auto. + - reflexivity. + - intros k' e' b a Hm E. + apply Hf with a; try easy. + contradict H; rewrite <- H. now exists e'. + Qed. + + Hint Resolve NoDupA_eqk_eqke NoDupA_rev bindings_3w : map. + + Lemma fold_Proper (f:key->elt->A->A) : + Proper (E.eq==>eq==>eqA==>eqA) f -> + Diamond f -> + Proper (Equal==>eqA==>eqA) (fold f). + Proof. + intros Hf Hf' m1 m2 Hm i j Hi. + rewrite 2 fold_spec_right. + assert (NoDupA eqk (rev (bindings m1))) by (auto with * ). + assert (NoDupA eqk (rev (bindings m2))) by (auto with * ). + apply fold_right_equivlistA_restr2 with (R:=complement eqk)(eqA:=eqke) + ; auto with *. + - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *. now apply Hf. + - unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto with map. + - intros (k,e) (k',e') z z' h h'; unfold eq_key, uncurry;simpl; auto. + rewrite h'. eapply Hf'; now eauto. + - rewrite <- NoDupA_altdef; auto. + - intros (k,e). + rewrite 2 InA_rev, <- 2 bindings_mapsto_iff, 2 find_mapsto_iff, Hm; + auto with *. + Qed. + + Lemma fold_Equal (f:key->elt->A->A) : + Proper (E.eq==>eq==>eqA==>eqA) f -> + Diamond f -> + forall m1 m2 i, + Equal m1 m2 -> + eqA (fold f m1 i) (fold f m2 i). + Proof. + intros. now apply fold_Proper. + Qed. + + Lemma fold_Add (f:key->elt->A->A) : + Proper (E.eq==>eq==>eqA==>eqA) f -> + Diamond f -> + forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 -> + eqA (fold f m2 i) (f k e (fold f m1 i)). + Proof. + intros Hf Hf' m1 m2 k e i Hm1 Hm2. + rewrite 2 fold_spec_right. + set (f':=uncurry f). + change (f k e (fold_right f' i (rev (bindings m1)))) + with (f' (k,e) (fold_right f' i (rev (bindings m1)))). + assert (NoDupA eqk (rev (bindings m1))) by (auto with * ). + assert (NoDupA eqk (rev (bindings m2))) by (auto with * ). + apply fold_right_add_restr with + (R:=complement eqk)(eqA:=eqke); auto with *. + - intros (k1,e1) (k2,e2) (Hk,He) a a' Ha; unfold f'; simpl in *. now apply Hf. + - unfold complement, eq_key_elt, eq_key; repeat red; intuition eauto with map. + - intros (k1,e1) (k2,e2) z1 z2; unfold eq_key, f', uncurry; simpl. + eapply Hf'; now eauto. + - rewrite <- NoDupA_altdef; auto. + - rewrite InA_rev, <- bindings_mapsto_iff by (auto with * ). firstorder. + - intros (a,b). + rewrite InA_cons, 2 InA_rev, <- 2 bindings_mapsto_iff, + 2 find_mapsto_iff by (auto with * ). + unfold eq_key_elt; simpl. + rewrite Hm2, !find_spec, add_mapsto_new; intuition. + Qed. + + Lemma fold_add (f:key->elt->A->A) : + Proper (E.eq==>eq==>eqA==>eqA) f -> + Diamond f -> + forall m k e i, ~In k m -> + eqA (fold f (add k e m) i) (f k e (fold f m i)). + Proof. + intros. now apply fold_Add. + Qed. + + End Fold_More. + + (** * Cardinal *) + + Lemma cardinal_fold (m : t elt) : + cardinal m = fold (fun _ _ => S) m 0. + Proof. + rewrite cardinal_1, fold_1. + symmetry; apply fold_left_length; auto. + Qed. + + Lemma cardinal_Empty : forall m : t elt, + Empty m <-> cardinal m = 0. + Proof. + intros. + rewrite cardinal_1, bindings_Empty. + destruct (bindings m); intuition; discriminate. + Qed. + + Lemma Equal_cardinal (m m' : t elt) : + Equal m m' -> cardinal m = cardinal m'. + Proof. + intro. rewrite 2 cardinal_fold. + apply fold_Equal with (eqA:=eq); try congruence; auto with map. + Qed. + + Lemma cardinal_0 (m : t elt) : Empty m -> cardinal m = 0. + Proof. + intros; rewrite <- cardinal_Empty; auto. + Qed. + + Lemma cardinal_S m m' x e : + ~ In x m -> Add x e m m' -> cardinal m' = S (cardinal m). + Proof. + intros. rewrite 2 cardinal_fold. + change S with ((fun _ _ => S) x e). + apply fold_Add with (eqA:=eq); try congruence; auto with map. + Qed. + + Lemma cardinal_inv_1 : forall m : t elt, + cardinal m = 0 -> Empty m. + Proof. + intros; rewrite cardinal_Empty; auto. + Qed. + Hint Resolve cardinal_inv_1 : map. + + Lemma cardinal_inv_2 : + forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }. + Proof. + intros; rewrite M.cardinal_spec in *. + generalize (bindings_mapsto_iff m). + destruct (bindings m); try discriminate. + exists p; auto. + rewrite H0; destruct p; simpl; auto. + constructor; red; auto with map. + Qed. + + Lemma cardinal_inv_2b : + forall m, cardinal m <> 0 -> { p : key*elt | MapsTo (fst p) (snd p) m }. + Proof. + intros. + generalize (@cardinal_inv_2 m); destruct cardinal. + elim H;auto. + eauto. + Qed. + + Lemma not_empty_mapsto (m : t elt) : + ~Empty m -> exists k e, MapsTo k e m. + Proof. + intro. + destruct (@cardinal_inv_2b m) as ((k,e),H'). + contradict H. now apply cardinal_inv_1. + exists k; now exists e. + Qed. + + Lemma not_empty_in (m:t elt) : + ~Empty m -> exists k, In k m. + Proof. + intro. destruct (not_empty_mapsto H) as (k,Hk). + now exists k. + Qed. + + (** * Additional notions over maps *) + + Definition Disjoint (m m' : t elt) := + forall k, ~(In k m /\ In k m'). + + Definition Partition (m m1 m2 : t elt) := + Disjoint m1 m2 /\ + (forall k e, MapsTo k e m <-> MapsTo k e m1 \/ MapsTo k e m2). + + (** * Emulation of some functions lacking in the interface *) + + Definition filter (f : key -> elt -> bool)(m : t elt) := + fold (fun k e m => if f k e then add k e m else m) m empty. + + Definition for_all (f : key -> elt -> bool)(m : t elt) := + fold (fun k e b => if f k e then b else false) m true. + + Definition exists_ (f : key -> elt -> bool)(m : t elt) := + fold (fun k e b => if f k e then true else b) m false. + + Definition partition (f : key -> elt -> bool)(m : t elt) := + (filter f m, filter (fun k e => negb (f k e)) m). + + (** [update] adds to [m1] all the bindings of [m2]. It can be seen as + an [union] operator which gives priority to its 2nd argument + in case of binding conflit. *) + + Definition update (m1 m2 : t elt) := fold (@add _) m2 m1. + + (** [restrict] keeps from [m1] only the bindings whose key is in [m2]. + It can be seen as an [inter] operator, with priority to its 1st argument + in case of binding conflit. *) + + Definition restrict (m1 m2 : t elt) := filter (fun k _ => mem k m2) m1. + + (** [diff] erases from [m1] all bindings whose key is in [m2]. *) + + Definition diff (m1 m2 : t elt) := filter (fun k _ => negb (mem k m2)) m1. + + (** Properties of these abbreviations *) + + Lemma filter_iff (f : key -> elt -> bool) : + Proper (E.eq==>eq==>eq) f -> + forall m k e, + MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true. + Proof. + unfold filter. + set (f':=fun k e m => if f k e then add k e m else m). + intros Hf m. pattern m, (fold f' m empty). apply fold_rec. + + - intros m' Hm' k e. rewrite empty_mapsto_iff. intuition. + elim (Hm' k e); auto. + + - intros k e acc m1 m2 Hke Hn Hadd IH k' e'. + change (Equal m2 (add k e m1)) in Hadd; rewrite Hadd. + unfold f'; simpl. + rewrite add_mapsto_new by trivial. + case_eq (f k e); intros Hfke; simpl; + rewrite ?add_mapsto_iff, IH; clear IH; intuition. + + rewrite <- Hfke; apply Hf; auto with map. + + right. repeat split; trivial. contradict Hn. rewrite Hn. now exists e'. + + assert (f k e = f k' e') by (apply Hf; auto). congruence. + Qed. + + Lemma for_all_filter f m : + for_all f m = is_empty (filter (fun k e => negb (f k e)) m). + Proof. + unfold for_all, filter. + eapply fold_rel with (R:=fun x y => x = is_empty y). + - symmetry. apply is_empty_iff. apply empty_1. + - intros; subst. destruct (f k e); simpl; trivial. + symmetry. apply not_true_is_false. rewrite is_empty_spec. + intros H'. specialize (H' k). now rewrite add_spec1 in H'. + Qed. + + Lemma exists_filter f m : + exists_ f m = negb (is_empty (filter f m)). + Proof. + unfold for_all, filter. + eapply fold_rel with (R:=fun x y => x = negb (is_empty y)). + - symmetry. rewrite negb_false_iff. apply is_empty_iff. apply empty_1. + - intros; subst. destruct (f k e); simpl; trivial. + symmetry. rewrite negb_true_iff. apply not_true_is_false. + rewrite is_empty_spec. + intros H'. specialize (H' k). now rewrite add_spec1 in H'. + Qed. + + Lemma for_all_iff f m : + Proper (E.eq==>eq==>eq) f -> + (for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true)). + Proof. + intros Hf. + rewrite for_all_filter. + rewrite <- is_empty_iff. unfold Empty. + split; intros H k e; specialize (H k e); + rewrite filter_iff in * by solve_proper; intuition. + - destruct (f k e); auto. + - now rewrite H0 in H2. + Qed. + + Lemma exists_iff f m : + Proper (E.eq==>eq==>eq) f -> + (exists_ f m = true <-> + (exists k e, MapsTo k e m /\ f k e = true)). + Proof. + intros Hf. + rewrite exists_filter. rewrite negb_true_iff. + rewrite <- not_true_iff_false, <- is_empty_iff. + split. + - intros H. apply not_empty_mapsto in H. now setoid_rewrite filter_iff in H. + - unfold Empty. setoid_rewrite filter_iff; trivial. firstorder. + Qed. + + Lemma Disjoint_alt : forall m m', + Disjoint m m' <-> + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> False). + Proof. + unfold Disjoint; split. + intros H k v v' H1 H2. + apply H with k; split. + exists v; trivial. + exists v'; trivial. + intros H k ((v,Hv),(v',Hv')). + eapply H; eauto. + Qed. + + Section Partition. + Variable f : key -> elt -> bool. + Hypothesis Hf : Proper (E.eq==>eq==>eq) f. + + Lemma partition_iff_1 : forall m m1 k e, + m1 = fst (partition f m) -> + (MapsTo k e m1 <-> MapsTo k e m /\ f k e = true). + Proof. + unfold partition; simpl; intros. subst m1. + apply filter_iff; auto. + Qed. + + Lemma partition_iff_2 : forall m m2 k e, + m2 = snd (partition f m) -> + (MapsTo k e m2 <-> MapsTo k e m /\ f k e = false). + Proof. + unfold partition; simpl; intros. subst m2. + rewrite filter_iff. + split; intros (H,H'); split; auto. + destruct (f k e); simpl in *; auto. + rewrite H'; auto. + repeat red; intros. f_equal. apply Hf; auto. + Qed. + + Lemma partition_Partition : forall m m1 m2, + partition f m = (m1,m2) -> Partition m m1 m2. + Proof. + intros. split. + rewrite Disjoint_alt. intros k e e'. + rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) + by (rewrite H; auto). + intros (U,V) (W,Z). rewrite <- (mapsto_fun U W) in Z; congruence. + intros k e. + rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) + by (rewrite H; auto). + destruct (f k e); intuition. + Qed. + + End Partition. + + Lemma Partition_In : forall m m1 m2 k, + Partition m m1 m2 -> In k m -> {In k m1}+{In k m2}. + Proof. + intros m m1 m2 k Hm Hk. + destruct (In_dec m1 k) as [H|H]; [left|right]; auto. + destruct Hm as (Hm,Hm'). + destruct Hk as (e,He); rewrite Hm' in He; destruct He. + elim H; exists e; auto. + exists e; auto. + Defined. + + Lemma Disjoint_sym : forall m1 m2, Disjoint m1 m2 -> Disjoint m2 m1. + Proof. + intros m1 m2 H k (H1,H2). elim (H k); auto. + Qed. + + Lemma Partition_sym : forall m m1 m2, + Partition m m1 m2 -> Partition m m2 m1. + Proof. + intros m m1 m2 (H,H'); split. + apply Disjoint_sym; auto. + intros; rewrite H'; intuition. + Qed. + + Lemma Partition_Empty : forall m m1 m2, Partition m m1 m2 -> + (Empty m <-> (Empty m1 /\ Empty m2)). + Proof. + intros m m1 m2 (Hdisj,Heq). split. + intro He. + split; intros k e Hke; elim (He k e); rewrite Heq; auto. + intros (He1,He2) k e Hke. rewrite Heq in Hke. destruct Hke. + elim (He1 k e); auto. + elim (He2 k e); auto. + Qed. + + Lemma Partition_Add : + forall m m' x e , ~In x m -> Add x e m m' -> + forall m1 m2, Partition m' m1 m2 -> + exists m3, (Add x e m3 m1 /\ Partition m m3 m2 \/ + Add x e m3 m2 /\ Partition m m1 m3). + Proof. + unfold Partition. intros m m' x e Hn Hadd m1 m2 (Hdisj,Hor). + assert (Heq : Equal m (remove x m')). + { change (Equal m' (add x e m)) in Hadd. rewrite Hadd. + intro k. rewrite remove_o, add_o. + destruct E.eq_dec as [He|Hne]; auto. + rewrite <- He, <- not_find_in_iff; auto. } + assert (H : MapsTo x e m'). + { change (Equal m' (add x e m)) in Hadd; rewrite Hadd. + apply add_1; auto with map. } + rewrite Hor in H; destruct H. + + - (* first case : x in m1 *) + exists (remove x m1); left. split; [|split]. + + (* add *) + change (Equal m1 (add x e (remove x m1))). + intro k. + rewrite add_o, remove_o. + destruct E.eq_dec as [He|Hne]; auto. + rewrite <- He; apply find_1; auto. + + (* disjoint *) + intros k (H1,H2). elim (Hdisj k). split; auto. + rewrite remove_in_iff in H1; destruct H1; auto. + + (* mapsto *) + intros k' e'. + rewrite Heq, 2 remove_mapsto_iff, Hor. + intuition. + elim (Hdisj x); split; [exists e|exists e']; auto. + apply MapsTo_1 with k'; auto with map. + + - (* second case : x in m2 *) + exists (remove x m2); right. split; [|split]. + + (* add *) + change (Equal m2 (add x e (remove x m2))). + intro k. + rewrite add_o, remove_o. + destruct E.eq_dec as [He|Hne]; auto. + rewrite <- He; apply find_1; auto. + + (* disjoint *) + intros k (H1,H2). elim (Hdisj k). split; auto. + rewrite remove_in_iff in H2; destruct H2; auto. + + (* mapsto *) + intros k' e'. + rewrite Heq, 2 remove_mapsto_iff, Hor. + intuition. + elim (Hdisj x); split; [exists e'|exists e]; auto. + apply MapsTo_1 with k'; auto with map. + Qed. + + Lemma Partition_fold : + forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A), + Proper (E.eq==>eq==>eqA==>eqA) f -> + Diamond eqA f -> + forall m m1 m2 i, + Partition m m1 m2 -> + eqA (fold f m i) (fold f m1 (fold f m2 i)). + Proof. + intros A eqA st f Comp Tra. + induction m as [m Hm|m m' IH k e Hn Hadd] using map_induction. + + - intros m1 m2 i Hp. rewrite (fold_Empty (eqA:=eqA)); auto. + rewrite (Partition_Empty Hp) in Hm. destruct Hm. + rewrite 2 (fold_Empty (eqA:=eqA)); auto. reflexivity. + + - intros m1 m2 i Hp. + destruct (Partition_Add Hn Hadd Hp) as (m3,[(Hadd',Hp')|(Hadd',Hp')]). + + (* fst case: m3 is (k,e)::m1 *) + assert (~In k m3). + { contradict Hn. destruct Hn as (e',He'). + destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. } + transitivity (f k e (fold f m i)). + apply fold_Add with (eqA:=eqA); auto. + symmetry. + transitivity (f k e (fold f m3 (fold f m2 i))). + apply fold_Add with (eqA:=eqA); auto. + apply Comp; auto with map. + symmetry; apply IH; auto. + + (* snd case: m3 is (k,e)::m2 *) + assert (~In k m3). + { contradict Hn. destruct Hn as (e',He'). + destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. } + assert (~In k m1). + { contradict Hn. destruct Hn as (e',He'). + destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. } + transitivity (f k e (fold f m i)). + apply fold_Add with (eqA:=eqA); auto. + transitivity (f k e (fold f m1 (fold f m3 i))). + apply Comp; auto using IH with map. + transitivity (fold f m1 (f k e (fold f m3 i))). + symmetry. + apply fold_commutes with (eqA:=eqA); auto. + apply fold_init with (eqA:=eqA); auto. + symmetry. + apply fold_Add with (eqA:=eqA); auto. + Qed. + + Lemma Partition_cardinal : forall m m1 m2, Partition m m1 m2 -> + cardinal m = cardinal m1 + cardinal m2. + Proof. + intros. + rewrite (cardinal_fold m), (cardinal_fold m1). + set (f:=fun (_:key)(_:elt)=>S). + setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)). + rewrite <- cardinal_fold. + apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto. + apply Partition_fold with (eqA:=eq); compute; auto with map. congruence. + Qed. + + Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 -> + let f := fun k (_:elt) => mem k m1 in + Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)). + Proof. + intros m m1 m2 Hm f. + assert (Hf : Proper (E.eq==>eq==>eq) f). + intros k k' Hk e e' _; unfold f; rewrite Hk; auto. + set (m1':= fst (partition f m)). + set (m2':= snd (partition f m)). + split; rewrite Equal_mapsto_iff; intros k e. + rewrite (@partition_iff_1 f Hf m m1') by auto. + unfold f. + rewrite <- mem_in_iff. + destruct Hm as (Hm,Hm'). + rewrite Hm'. + intuition. + exists e; auto. + elim (Hm k); split; auto; exists e; auto. + rewrite (@partition_iff_2 f Hf m m2') by auto. + unfold f. + rewrite <- not_mem_in_iff. + destruct Hm as (Hm,Hm'). + rewrite Hm'. + intuition. + elim (Hm k); split; auto; exists e; auto. + elim H1; exists e; auto. + Qed. + + Lemma update_mapsto_iff : forall m m' k e, + MapsTo k e (update m m') <-> + (MapsTo k e m' \/ (MapsTo k e m /\ ~In k m')). + Proof. + unfold update. + intros m m'. + pattern m', (fold (@add _) m' m). apply fold_rec. + + - intros m0 Hm0 k e. + assert (~In k m0) by (intros (e0,He0); apply (Hm0 k e0); auto). + intuition. + elim (Hm0 k e); auto. + + - intros k e m0 m1 m2 _ Hn Hadd IH k' e'. + change (Equal m2 (add k e m1)) in Hadd. + rewrite Hadd, 2 add_mapsto_iff, IH, add_in_iff. clear IH. intuition. + Qed. + + Lemma update_dec : forall m m' k e, MapsTo k e (update m m') -> + { MapsTo k e m' } + { MapsTo k e m /\ ~In k m'}. + Proof. + intros m m' k e H. rewrite update_mapsto_iff in H. + destruct (In_dec m' k) as [H'|H']; [left|right]; intuition. + elim H'; exists e; auto. + Defined. + + Lemma update_in_iff : forall m m' k, + In k (update m m') <-> In k m \/ In k m'. + Proof. + intros m m' k. split. + intros (e,H); rewrite update_mapsto_iff in H. + destruct H; [right|left]; exists e; intuition. + destruct (In_dec m' k) as [H|H]. + destruct H as (e,H). intros _; exists e. + rewrite update_mapsto_iff; left; auto. + destruct 1 as [H'|H']; [|elim H; auto]. + destruct H' as (e,H'). exists e. + rewrite update_mapsto_iff; right; auto. + Qed. + + Lemma diff_mapsto_iff : forall m m' k e, + MapsTo k e (diff m m') <-> MapsTo k e m /\ ~In k m'. + Proof. + intros m m' k e. + unfold diff. + rewrite filter_iff. + intuition. + rewrite mem_1 in *; auto; discriminate. + intros ? ? Hk _ _ _; rewrite Hk; auto. + Qed. + + Lemma diff_in_iff : forall m m' k, + In k (diff m m') <-> In k m /\ ~In k m'. + Proof. + intros m m' k. split. + intros (e,H); rewrite diff_mapsto_iff in H. + destruct H; split; auto. exists e; auto. + intros ((e,H),H'); exists e; rewrite diff_mapsto_iff; auto. + Qed. + + Lemma restrict_mapsto_iff : forall m m' k e, + MapsTo k e (restrict m m') <-> MapsTo k e m /\ In k m'. + Proof. + intros m m' k e. + unfold restrict. + rewrite filter_iff. + intuition. + intros ? ? Hk _ _ _; rewrite Hk; auto. + Qed. + + Lemma restrict_in_iff : forall m m' k, + In k (restrict m m') <-> In k m /\ In k m'. + Proof. + intros m m' k. split. + intros (e,H); rewrite restrict_mapsto_iff in H. + destruct H; split; auto. exists e; auto. + intros ((e,H),H'); exists e; rewrite restrict_mapsto_iff; auto. + Qed. + + (** specialized versions analyzing only keys (resp. bindings) *) + + Definition filter_dom (f : key -> bool) := filter (fun k _ => f k). + Definition filter_range (f : elt -> bool) := filter (fun _ => f). + Definition for_all_dom (f : key -> bool) := for_all (fun k _ => f k). + Definition for_all_range (f : elt -> bool) := for_all (fun _ => f). + Definition exists_dom (f : key -> bool) := exists_ (fun k _ => f k). + Definition exists_range (f : elt -> bool) := exists_ (fun _ => f). + Definition partition_dom (f : key -> bool) := partition (fun k _ => f k). + Definition partition_range (f : elt -> bool) := partition (fun _ => f). + + End Elt. + + Instance cardinal_m {elt} : Proper (Equal ==> Logic.eq) (@cardinal elt). + Proof. intros m m'. apply Equal_cardinal. Qed. + + Instance Disjoint_m {elt} : Proper (Equal ==> Equal ==> iff) (@Disjoint elt). + Proof. + intros m1 m1' Hm1 m2 m2' Hm2. unfold Disjoint. split; intros. + rewrite <- Hm1, <- Hm2; auto. + rewrite Hm1, Hm2; auto. + Qed. + + Instance Partition_m {elt} : + Proper (Equal ==> Equal ==> Equal ==> iff) (@Partition elt). + Proof. + intros m1 m1' Hm1 m2 m2' Hm2 m3 m3' Hm3. unfold Partition. + rewrite <- Hm2, <- Hm3. + split; intros (H,H'); split; auto; intros. + rewrite <- Hm1, <- Hm2, <- Hm3; auto. + rewrite Hm1, Hm2, Hm3; auto. + Qed. + +(* + Instance filter_m0 {elt} (f:key->elt->bool) : + Proper (E.eq==>Logic.eq==>Logic.eq) f -> + Proper (Equal==>Equal) (filter f). + Proof. + intros Hf m m' Hm. apply Equal_mapsto_iff. intros. + now rewrite !filter_iff, Hm. + Qed. +*) + + Instance filter_m {elt} : + Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal) (@filter elt). + Proof. + intros f f' Hf m m' Hm. unfold filter. + rewrite 2 fold_spec_right. + set (l := rev (bindings m)). + set (l' := rev (bindings m')). + set (op := fun (f:key->elt->bool) => + uncurry (fun k e acc => if f k e then add k e acc else acc)). + change (Equal (fold_right (op f) empty l) (fold_right (op f') empty l')). + assert (Hl : NoDupA eq_key l). + { apply NoDupA_rev. apply eqk_equiv. apply bindings_spec2w. } + assert (Hl' : NoDupA eq_key l'). + { apply NoDupA_rev. apply eqk_equiv. apply bindings_spec2w. } + assert (H : PermutationA eq_key_elt l l'). + { apply NoDupA_equivlistA_PermutationA. + - apply eqke_equiv. + - now apply NoDupA_eqk_eqke. + - now apply NoDupA_eqk_eqke. + - intros (k,e); unfold l, l'. rewrite 2 InA_rev, 2 bindings_spec1. + rewrite Equal_mapsto_iff in Hm. apply Hm. } + destruct (PermutationA_decompose (eqke_equiv _) H) as (l0,(P,E)). + transitivity (fold_right (op f) empty l0). + - apply fold_right_equivlistA_restr2 + with (eqA:=Logic.eq)(R:=complement eq_key); auto with *. + + intros p p' <- acc acc' Hacc. + destruct p as (k,e); unfold op, uncurry; simpl. + destruct (f k e); now rewrite Hacc. + + intros (k,e) (k',e') z z'. + unfold op, complement, uncurry, eq_key; simpl. + intros Hk Hz. + destruct (f k e), (f k' e'); rewrite <- Hz; try reflexivity. + now apply add_add_2. + + apply NoDupA_incl with eq_key; trivial. intros; subst; now red. + + apply PermutationA_preserves_NoDupA with l; auto with *. + apply Permutation_PermutationA; auto with *. + apply NoDupA_incl with eq_key; trivial. intros; subst; now red. + + apply NoDupA_altdef. apply NoDupA_rev. apply eqk_equiv. + apply bindings_spec2w. + + apply PermutationA_equivlistA; auto with *. + apply Permutation_PermutationA; auto with *. + - clearbody l'. clear l Hl Hl' H P m m' Hm. + induction E. + + reflexivity. + + simpl. destruct x as (k,e), x' as (k',e'). + unfold op, uncurry at 1 3; simpl. + destruct H; simpl in *. rewrite <- (Hf _ _ H _ _ H0). + destruct (f k e); trivial. now f_equiv. + Qed. + + Instance for_all_m {elt} : + Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Logic.eq) (@for_all elt). + Proof. + intros f f' Hf m m' Hm. rewrite 2 for_all_filter. + (* Strange: we cannot rewrite Hm here... *) + f_equiv. f_equiv; trivial. + intros k k' Hk e e' He. f_equal. now apply Hf. + Qed. + + Instance exists_m {elt} : + Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Logic.eq) (@exists_ elt). + Proof. + intros f f' Hf m m' Hm. rewrite 2 exists_filter. + f_equal. now apply is_empty_m, filter_m. + Qed. + + Fact diamond_add {elt} : Diamond Equal (@add elt). + Proof. + intros k k' e e' a b b' Hk <- <-. now apply add_add_2. + Qed. + + Instance update_m {elt} : Proper (Equal ==> Equal ==> Equal) (@update elt). + Proof. + intros m1 m1' Hm1 m2 m2' Hm2. + unfold update. + apply fold_Proper; auto using diamond_add with *. + Qed. + + Instance restrict_m {elt} : Proper (Equal==>Equal==>Equal) (@restrict elt). + Proof. + intros m1 m1' Hm1 m2 m2' Hm2 y. + unfold restrict. + apply eq_option_alt. intros e. + rewrite !find_spec, !filter_iff, Hm1, Hm2. reflexivity. + clear. intros x x' Hx e e' He. now rewrite Hx. + clear. intros x x' Hx e e' He. now rewrite Hx. + Qed. + + Instance diff_m {elt} : Proper (Equal==>Equal==>Equal) (@diff elt). + Proof. + intros m1 m1' Hm1 m2 m2' Hm2 y. + unfold diff. + apply eq_option_alt. intros e. + rewrite !find_spec, !filter_iff, Hm1, Hm2. reflexivity. + clear. intros x x' Hx e e' He. now rewrite Hx. + clear. intros x x' Hx e e' He. now rewrite Hx. + Qed. + +End WProperties_fun. + +(** * Same Properties for self-contained weak maps and for full maps *) + +Module WProperties (M:WS) := WProperties_fun M.E M. +Module Properties := WProperties. + +(** * Properties specific to maps with ordered keys *) + +Module OrdProperties (M:S). + Module Import ME := OrderedTypeFacts M.E. + Module Import O:=KeyOrderedType M.E. + Module Import P:=Properties M. + Import M. + + Section Elt. + Variable elt:Type. + + Definition Above x (m:t elt) := forall y, In y m -> E.lt y x. + Definition Below x (m:t elt) := forall y, In y m -> E.lt x y. + + Section Bindings. + + Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt), + sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'. + Proof. + apply SortA_equivlistA_eqlistA; eauto with *. + Qed. + + Ltac klean := unfold O.eqke, O.ltk, RelCompFun in *; simpl in *. + Ltac keauto := klean; intuition; eauto. + + Definition gtb (p p':key*elt) := + match E.compare (fst p) (fst p') with Gt => true | _ => false end. + Definition leb p := fun p' => negb (gtb p p'). + + Definition bindings_lt p m := List.filter (gtb p) (bindings m). + Definition bindings_ge p m := List.filter (leb p) (bindings m). + + Lemma gtb_1 : forall p p', gtb p p' = true <-> ltk p' p. + Proof. + intros (x,e) (y,e'); unfold gtb; klean. + case E.compare_spec; intuition; try discriminate; ME.order. + Qed. + + Lemma leb_1 : forall p p', leb p p' = true <-> ~ltk p' p. + Proof. + intros (x,e) (y,e'); unfold leb, gtb; klean. + case E.compare_spec; intuition; try discriminate; ME.order. + Qed. + + Instance gtb_compat : forall p, Proper (eqke==>eq) (gtb p). + Proof. + red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H. + generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); + destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); klean; auto. + - intros. symmetry; rewrite H2. rewrite <-H, <-H1; auto. + - intros. rewrite H1. rewrite H, <- H2; auto. + Qed. + + Instance leb_compat : forall p, Proper (eqke==>eq) (leb p). + Proof. + intros x a b H. unfold leb; f_equal; apply gtb_compat; auto. + Qed. + + Hint Resolve gtb_compat leb_compat bindings_spec2 : map. + + Lemma bindings_split : forall p m, + bindings m = bindings_lt p m ++ bindings_ge p m. + Proof. + unfold bindings_lt, bindings_ge, leb; intros. + apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with *. + intros; destruct x; destruct y; destruct p. + rewrite gtb_1 in H; klean. + apply not_true_iff_false in H0. rewrite gtb_1 in H0. klean. ME.order. + Qed. + + Lemma bindings_Add : forall m m' x e, ~In x m -> Add x e m m' -> + eqlistA eqke (bindings m') + (bindings_lt (x,e) m ++ (x,e):: bindings_ge (x,e) m). + Proof. + intros; unfold bindings_lt, bindings_ge. + apply sort_equivlistA_eqlistA; auto with *. + - apply (@SortA_app _ eqke); auto with *. + + apply (@filter_sort _ eqke); auto with *; keauto. + + constructor; auto with map. + * apply (@filter_sort _ eqke); auto with *; keauto. + * rewrite (@InfA_alt _ eqke); auto with *; try (keauto; fail). + { intros. + rewrite filter_InA in H1; auto with *; destruct H1. + rewrite leb_1 in H2. + destruct y; klean. + rewrite <- bindings_mapsto_iff in H1. + assert (~E.eq x t0). + { contradict H. + exists e0; apply MapsTo_1 with t0; auto. + ME.order. } + ME.order. } + { apply (@filter_sort _ eqke); auto with *; keauto. } + + intros. + rewrite filter_InA in H1; auto with *; destruct H1. + rewrite gtb_1 in H3. + destruct y; destruct x0; klean. + inversion_clear H2. + * red in H4; klean; destruct H4; simpl in *. ME.order. + * rewrite filter_InA in H4; auto with *; destruct H4. + rewrite leb_1 in H4. klean; ME.order. + - intros (k,e'). + rewrite InA_app_iff, InA_cons, 2 filter_InA, + <-2 bindings_mapsto_iff, leb_1, gtb_1, + find_mapsto_iff, (H0 k), <- find_mapsto_iff, + add_mapsto_iff by (auto with * ). + change (eqke (k,e') (x,e)) with (E.eq k x /\ e' = e). + klean. + split. + + intros [(->,->)|(Hk,Hm)]. + * right; now left. + * destruct (lt_dec k x); intuition. + + intros [(Hm,LT)|[(->,->)|(Hm,EQ)]]. + * right; split; trivial; ME.order. + * now left. + * destruct (eq_dec x k) as [Hk|Hk]. + elim H. exists e'. now rewrite Hk. + right; auto. + Qed. + + Lemma bindings_Add_Above : forall m m' x e, + Above x m -> Add x e m m' -> + eqlistA eqke (bindings m') (bindings m ++ (x,e)::nil). + Proof. + intros. + apply sort_equivlistA_eqlistA; auto with *. + apply (@SortA_app _ eqke); auto with *. + intros. + inversion_clear H2. + destruct x0; destruct y. + rewrite <- bindings_mapsto_iff in H1. + destruct H3; klean. + rewrite H2. + apply H; firstorder. + inversion H3. + red; intros a; destruct a. + rewrite InA_app_iff, InA_cons, InA_nil, <- 2 bindings_mapsto_iff, + find_mapsto_iff, (H0 t0), <- find_mapsto_iff, + add_mapsto_iff by (auto with *). + change (eqke (t0,e0) (x,e)) with (E.eq t0 x /\ e0 = e). + intuition. + destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. + exfalso. + assert (In t0 m) by (exists e0; auto). + generalize (H t0 H1). + ME.order. + Qed. + + Lemma bindings_Add_Below : forall m m' x e, + Below x m -> Add x e m m' -> + eqlistA eqke (bindings m') ((x,e)::bindings m). + Proof. + intros. + apply sort_equivlistA_eqlistA; auto with *. + change (sort ltk (((x,e)::nil) ++ bindings m)). + apply (@SortA_app _ eqke); auto with *. + intros. + inversion_clear H1. + destruct y; destruct x0. + rewrite <- bindings_mapsto_iff in H2. + destruct H3; klean. + rewrite H1. + apply H; firstorder. + inversion H3. + red; intros a; destruct a. + rewrite InA_cons, <- 2 bindings_mapsto_iff, + find_mapsto_iff, (H0 t0), <- find_mapsto_iff, + add_mapsto_iff by (auto with * ). + change (eqke (t0,e0) (x,e)) with (E.eq t0 x /\ e0 = e). + intuition. + destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. + exfalso. + assert (In t0 m) by (exists e0; auto). + generalize (H t0 H1). + ME.order. + Qed. + + Lemma bindings_Equal_eqlistA : forall (m m': t elt), + Equal m m' -> eqlistA eqke (bindings m) (bindings m'). + Proof. + intros. + apply sort_equivlistA_eqlistA; auto with *. + red; intros. + destruct x; do 2 rewrite <- bindings_mapsto_iff. + do 2 rewrite find_mapsto_iff; rewrite H; split; auto. + Qed. + + End Bindings. + + Section Min_Max_Elt. + + (** We emulate two [max_elt] and [min_elt] functions. *) + + Fixpoint max_elt_aux (l:list (key*elt)) := match l with + | nil => None + | (x,e)::nil => Some (x,e) + | (x,e)::l => max_elt_aux l + end. + Definition max_elt m := max_elt_aux (bindings m). + + Lemma max_elt_Above : + forall m x e, max_elt m = Some (x,e) -> Above x (remove x m). + Proof. + red; intros. + rewrite remove_in_iff in H0. + destruct H0. + rewrite bindings_in_iff in H1. + destruct H1. + unfold max_elt in *. + generalize (bindings_spec2 m). + revert x e H y x0 H0 H1. + induction (bindings m). + simpl; intros; try discriminate. + intros. + destruct a; destruct l; simpl in *. + injection H; clear H; intros; subst. + inversion_clear H1. + red in H; simpl in *; intuition. + now elim H0. + inversion H. + change (max_elt_aux (p::l) = Some (x,e)) in H. + generalize (IHl x e H); clear IHl; intros IHl. + inversion_clear H1; [ | inversion_clear H2; eauto ]. + red in H3; simpl in H3; destruct H3. + destruct p as (p1,p2). + destruct (E.eq_dec p1 x) as [Heq|Hneq]. + rewrite <- Heq; auto. + inversion_clear H2. + inversion_clear H5. + red in H2; simpl in H2; ME.order. + transitivity p1; auto. + inversion_clear H2. + inversion_clear H5. + red in H2; simpl in H2; ME.order. + eapply IHl; eauto with *. + econstructor; eauto. + red; eauto with *. + inversion H2; auto. + Qed. + + Lemma max_elt_MapsTo : + forall m x e, max_elt m = Some (x,e) -> MapsTo x e m. + Proof. + intros. + unfold max_elt in *. + rewrite bindings_mapsto_iff. + induction (bindings m). + simpl; try discriminate. + destruct a; destruct l; simpl in *. + injection H; intros; subst; constructor; red; auto with *. + constructor 2; auto. + Qed. + + Lemma max_elt_Empty : + forall m, max_elt m = None -> Empty m. + Proof. + intros. + unfold max_elt in *. + rewrite bindings_Empty. + induction (bindings m); auto. + destruct a; destruct l; simpl in *; try discriminate. + assert (H':=IHl H); discriminate. + Qed. + + Definition min_elt m : option (key*elt) := match bindings m with + | nil => None + | (x,e)::_ => Some (x,e) + end. + + Lemma min_elt_Below : + forall m x e, min_elt m = Some (x,e) -> Below x (remove x m). + Proof. + unfold min_elt, Below; intros. + rewrite remove_in_iff in H0; destruct H0. + rewrite bindings_in_iff in H1. + destruct H1. + generalize (bindings_spec2 m). + destruct (bindings m). + try discriminate. + destruct p; injection H; intros; subst. + inversion_clear H1. + red in H2; destruct H2; simpl in *; ME.order. + inversion_clear H4. + rewrite (@InfA_alt _ eqke) in H3; eauto with *. + apply (H3 (y,x0)); auto. + Qed. + + Lemma min_elt_MapsTo : + forall m x e, min_elt m = Some (x,e) -> MapsTo x e m. + Proof. + intros. + unfold min_elt in *. + rewrite bindings_mapsto_iff. + destruct (bindings m). + simpl; try discriminate. + destruct p; simpl in *. + injection H; intros; subst; constructor; red; auto with *. + Qed. + + Lemma min_elt_Empty : + forall m, min_elt m = None -> Empty m. + Proof. + intros. + unfold min_elt in *. + rewrite bindings_Empty. + destruct (bindings m); auto. + destruct p; simpl in *; discriminate. + Qed. + + End Min_Max_Elt. + + Section Induction_Principles. + + Lemma map_induction_max : + forall P : t elt -> Type, + (forall m, Empty m -> P m) -> + (forall m m', P m -> forall x e, Above x m -> Add x e m m' -> P m') -> + forall m, P m. + Proof. + intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. + apply X; apply cardinal_inv_1; auto. + + case_eq (max_elt m); intros. + destruct p. + assert (Add k e (remove k m) m). + { apply max_elt_MapsTo, find_spec, add_id in H. + unfold Add. symmetry. now rewrite add_remove_1. } + apply X0 with (remove k m) k e; auto with map. + apply IHn. + assert (S n = S (cardinal (remove k m))). + { rewrite Heqn. + eapply cardinal_S; eauto with map. } + inversion H1; auto. + eapply max_elt_Above; eauto. + + apply X; apply max_elt_Empty; auto. + Qed. + + Lemma map_induction_min : + forall P : t elt -> Type, + (forall m, Empty m -> P m) -> + (forall m m', P m -> forall x e, Below x m -> Add x e m m' -> P m') -> + forall m, P m. + Proof. + intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. + apply X; apply cardinal_inv_1; auto. + + case_eq (min_elt m); intros. + destruct p. + assert (Add k e (remove k m) m). + { apply min_elt_MapsTo, find_spec, add_id in H. + unfold Add. symmetry. now rewrite add_remove_1. } + apply X0 with (remove k m) k e; auto. + apply IHn. + assert (S n = S (cardinal (remove k m))). + { rewrite Heqn. + eapply cardinal_S; eauto with map. } + inversion H1; auto. + eapply min_elt_Below; eauto. + + apply X; apply min_elt_Empty; auto. + Qed. + + End Induction_Principles. + + Section Fold_properties. + + (** The following lemma has already been proved on Weak Maps, + but with one additionnal hypothesis (some [transpose] fact). *) + + Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f:key->elt->A->A)(i:A), + Proper (E.eq==>eq==>eqA==>eqA) f -> + Equal m1 m2 -> + eqA (fold f m1 i) (fold f m2 i). + Proof. + intros m1 m2 A eqA st f i Hf Heq. + rewrite 2 fold_spec_right. + apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. + intros (k,e) (k',e') (Hk,He) a a' Ha; simpl in *; apply Hf; auto. + apply eqlistA_rev. apply bindings_Equal_eqlistA. auto. + Qed. + + Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), + Above x m1 -> Add x e m1 m2 -> + eqA (fold f m2 i) (f x e (fold f m1 i)). + Proof. + intros. rewrite 2 fold_spec_right. set (f':=uncurry f). + transitivity (fold_right f' i (rev (bindings m1 ++ (x,e)::nil))). + apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. + intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *. apply P; auto. + apply eqlistA_rev. + apply bindings_Add_Above; auto. + rewrite distr_rev; simpl. + reflexivity. + Qed. + + Lemma fold_Add_Below : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), + Below x m1 -> Add x e m1 m2 -> + eqA (fold f m2 i) (fold f m1 (f x e i)). + Proof. + intros. rewrite 2 fold_spec_right. set (f':=uncurry f). + transitivity (fold_right f' i (rev (((x,e)::nil)++bindings m1))). + apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. + intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *; apply P; auto. + apply eqlistA_rev. + simpl; apply bindings_Add_Below; auto. + rewrite distr_rev; simpl. + rewrite fold_right_app. + reflexivity. + Qed. + + End Fold_properties. + + End Elt. + +End OrdProperties. diff --git a/theories/MMaps/MMapInterface.v b/theories/MMaps/MMapInterface.v new file mode 100644 index 00000000..05c5e5d8 --- /dev/null +++ b/theories/MMaps/MMapInterface.v @@ -0,0 +1,292 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(** * Finite map library *) + +(** This file proposes interfaces for finite maps *) + +Require Export Bool Equalities Orders SetoidList. +Set Implicit Arguments. +Unset Strict Implicit. + +(** When compared with Ocaml Map, this signature has been split in + several parts : + + - The first parts [WSfun] and [WS] propose signatures for weak + maps, which are maps with no ordering on the key type nor the + data type. [WSfun] and [WS] are almost identical, apart from the + fact that [WSfun] is expressed in a functorial way whereas [WS] + is self-contained. For obtaining an instance of such signatures, + a decidable equality on keys in enough (see for example + [FMapWeakList]). These signatures contain the usual operators + (add, find, ...). The only function that asks for more is + [equal], whose first argument should be a comparison on data. + + - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the + case where the key type is ordered. The main novelty is that + [bindings] is required to produce sorted lists. + + - Finally, [Sord] extends [S] with a complete comparison function. For + that, the data type should have a decidable total ordering as well. + + If unsure, what you're looking for is probably [S]: apart from [Sord], + all other signatures are subsets of [S]. + + Some additional differences with Ocaml: + + - no [iter] function, useless since Coq is purely functional + - [option] types are used instead of [Not_found] exceptions + +*) + + +Definition Cmp {elt:Type}(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. + +(** ** Weak signature for maps + + No requirements for an ordering on keys nor elements, only decidability + of equality on keys. First, a functorial signature: *) + +Module Type WSfun (E : DecidableType). + + Definition key := E.t. + Hint Transparent key. + + Definition eq_key {elt} (p p':key*elt) := E.eq (fst p) (fst p'). + + Definition eq_key_elt {elt} (p p':key*elt) := + E.eq (fst p) (fst p') /\ (snd p) = (snd p'). + + Parameter t : Type -> Type. + (** the abstract type of maps *) + + Section Ops. + + Parameter empty : forall {elt}, t elt. + (** The empty map. *) + + Variable elt:Type. + + Parameter is_empty : t elt -> bool. + (** Test whether a map is empty or not. *) + + Parameter add : key -> elt -> t elt -> t elt. + (** [add x y m] returns a map containing the same bindings as [m], + plus a binding of [x] to [y]. If [x] was already bound in [m], + its previous binding disappears. *) + + Parameter find : key -> t elt -> option elt. + (** [find x m] returns the current binding of [x] in [m], + or [None] if no such binding exists. *) + + Parameter remove : key -> t elt -> t elt. + (** [remove x m] returns a map containing the same bindings as [m], + except for [x] which is unbound in the returned map. *) + + Parameter mem : key -> t elt -> bool. + (** [mem x m] returns [true] if [m] contains a binding for [x], + and [false] otherwise. *) + + Parameter bindings : t elt -> list (key*elt). + (** [bindings m] returns an assoc list corresponding to the bindings + of [m], in any order. *) + + Parameter cardinal : t elt -> nat. + (** [cardinal m] returns the number of bindings in [m]. *) + + Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A. + (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1] ... [kN] are the keys of all bindings in [m] + (in any order), and [d1] ... [dN] are the associated data. *) + + Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool. + (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, + that is, contain equal keys and associate them with equal data. + [cmp] is the equality predicate used to compare the data associated + with the keys. *) + + Variable elt' elt'' : Type. + + Parameter map : (elt -> elt') -> t elt -> t elt'. + (** [map f m] returns a map with same domain as [m], where the associated + value a of all bindings of [m] has been replaced by the result of the + application of [f] to [a]. Since Coq is purely functional, the order + in which the bindings are passed to [f] is irrelevant. *) + + Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'. + (** Same as [map], but the function receives as arguments both the + key and the associated value for each binding of the map. *) + + Parameter merge : (key -> option elt -> option elt' -> option elt'') -> + t elt -> t elt' -> t elt''. + (** [merge f m m'] creates a new map whose bindings belong to the ones + of either [m] or [m']. The presence and value for a key [k] is + determined by [f k e e'] where [e] and [e'] are the (optional) + bindings of [k] in [m] and [m']. *) + + End Ops. + Section Specs. + + Variable elt:Type. + + Parameter MapsTo : key -> elt -> t elt -> Prop. + + Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m. + + Global Declare Instance MapsTo_compat : + Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. + + Variable m m' : t elt. + Variable x y : key. + Variable e : elt. + + Parameter find_spec : find x m = Some e <-> MapsTo x e m. + Parameter mem_spec : mem x m = true <-> In x m. + Parameter empty_spec : find x (@empty elt) = None. + Parameter is_empty_spec : is_empty m = true <-> forall x, find x m = None. + Parameter add_spec1 : find x (add x e m) = Some e. + Parameter add_spec2 : ~E.eq x y -> find y (add x e m) = find y m. + Parameter remove_spec1 : find x (remove x m) = None. + Parameter remove_spec2 : ~E.eq x y -> find y (remove x m) = find y m. + + (** Specification of [bindings] *) + Parameter bindings_spec1 : + InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. + (** When compared with ordered maps, here comes the only + property that is really weaker: *) + Parameter bindings_spec2w : NoDupA eq_key (bindings m). + + (** Specification of [cardinal] *) + Parameter cardinal_spec : cardinal m = length (bindings m). + + (** Specification of [fold] *) + Parameter fold_spec : + forall {A} (i : A) (f : key -> elt -> A -> A), + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. + + (** Equality of maps *) + + (** Caveat: there are at least three distinct equality predicates on maps. + - The simpliest (and maybe most natural) way is to consider keys up to + their equivalence [E.eq], but elements up to Leibniz equality, in + the spirit of [eq_key_elt] above. This leads to predicate [Equal]. + - Unfortunately, this [Equal] predicate can't be used to describe + the [equal] function, since this function (for compatibility with + ocaml) expects a boolean comparison [cmp] that may identify more + elements than Leibniz. So logical specification of [equal] is done + via another predicate [Equivb] + - This predicate [Equivb] is quite ad-hoc with its boolean [cmp], + it can be generalized in a [Equiv] expecting a more general + (possibly non-decidable) equality predicate on elements *) + + Definition Equal (m m':t elt) := forall y, find y m = find y m'. + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp). + + (** Specification of [equal] *) + Parameter equal_spec : forall cmp : elt -> elt -> bool, + equal cmp m m' = true <-> Equivb cmp m m'. + + End Specs. + Section SpecMaps. + + Variables elt elt' elt'' : Type. + + Parameter map_spec : forall (f:elt->elt') m x, + find x (map f m) = option_map f (find x m). + + Parameter mapi_spec : forall (f:key->elt->elt') m x, + exists y:key, E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). + + Parameter merge_spec1 : + forall (f:key->option elt->option elt'->option elt'') m m' x, + In x m \/ In x m' -> + exists y:key, E.eq y x /\ + find x (merge f m m') = f y (find x m) (find x m'). + + Parameter merge_spec2 : + forall (f:key -> option elt->option elt'->option elt'') m m' x, + In x (merge f m m') -> In x m \/ In x m'. + + End SpecMaps. +End WSfun. + +(** ** Static signature for Weak Maps + + Similar to [WSfun] but expressed in a self-contained way. *) + +Module Type WS. + Declare Module E : DecidableType. + Include WSfun E. +End WS. + + + +(** ** Maps on ordered keys, functorial signature *) + +Module Type Sfun (E : OrderedType). + Include WSfun E. + + Definition lt_key {elt} (p p':key*elt) := E.lt (fst p) (fst p'). + + (** Additional specification of [bindings] *) + + Parameter bindings_spec2 : forall {elt}(m : t elt), sort lt_key (bindings m). + + (** Remark: since [fold] is specified via [bindings], this stronger + specification of [bindings] has an indirect impact on [fold], + which can now be proved to receive bindings in increasing order. *) + +End Sfun. + + +(** ** Maps on ordered keys, self-contained signature *) + +Module Type S. + Declare Module E : OrderedType. + Include Sfun E. +End S. + + + +(** ** Maps with ordering both on keys and datas *) + +Module Type Sord. + + Declare Module Data : OrderedType. + Declare Module MapS : S. + Import MapS. + + Definition t := MapS.t Data.t. + + Include HasEq <+ HasLt <+ IsEq <+ IsStrOrder. + + Definition cmp e e' := + match Data.compare e e' with Eq => true | _ => false end. + + Parameter eq_spec : forall m m', eq m m' <-> Equivb cmp m m'. + + Parameter compare : t -> t -> comparison. + + Parameter compare_spec : forall m1 m2, CompSpec eq lt m1 m2 (compare m1 m2). + +End Sord. + + +(* TODO: provides filter + partition *) + +(* TODO: provide split + Parameter split : key -> t elt -> t elt * option elt * t elt. + + Parameter split_spec k m : + split k m = (filter (fun x -> E.compare x k) m, find k m, filter ...) + + min_binding, max_binding, choose ? +*) diff --git a/theories/MMaps/MMapList.v b/theories/MMaps/MMapList.v new file mode 100644 index 00000000..c521178c --- /dev/null +++ b/theories/MMaps/MMapList.v @@ -0,0 +1,1144 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(** * Finite map library *) + +(** This file proposes an implementation of the non-dependant interface + [MMapInterface.S] using lists of pairs ordered (increasing) with respect to + left projection. *) + +Require Import MMapInterface OrdersFacts OrdersLists. + +Set Implicit Arguments. +Unset Strict Implicit. + +Module Raw (X:OrderedType). + +Module Import MX := OrderedTypeFacts X. +Module Import PX := KeyOrderedType X. + +Definition key := X.t. +Definition t (elt:Type) := list (X.t * elt). + +Local Notation Sort := (sort ltk). +Local Notation Inf := (lelistA (ltk)). + +Section Elt. +Variable elt : Type. + +Ltac SortLt := + match goal with + | H1 : Sort ?m, H2:Inf (?k',?e') ?m, H3:In ?k ?m |- _ => + assert (X.lt k' k); + [let e := fresh "e" in destruct H3 as (e,H3); + change (ltk (k',e') (k,e)); + apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ] + | H1:Sort ?m, H2:Inf (?k',?e') ?m, H3:MapsTo ?k ?e ?m |- _ => + assert (X.lt k' k); + [change (ltk (k',e') (k,e)); + apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ] + | H1:Sort ?m, H2:Inf (?k',?e') ?m, H3:InA eqke (?k,?e) ?m |- _ => + assert (X.lt k' k); + [change (ltk (k',e') (k,e)); + apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ] + end. + +(** * [find] *) + +Fixpoint find (k:key) (m: t elt) : option elt := + match m with + | nil => None + | (k',x)::m' => + match X.compare k k' with + | Lt => None + | Eq => Some x + | Gt => find k m' + end + end. + +Lemma find_spec m (Hm:Sort m) x e : + find x m = Some e <-> MapsTo x e m. +Proof. + induction m as [|(k,e') m IH]; simpl. + - split. discriminate. inversion 1. + - inversion_clear Hm. + unfold MapsTo in *. rewrite InA_cons, eqke_def. + case X.compare_spec; intros. + + split. injection 1 as ->; auto. + intros [(_,<-)|IN]; trivial. SortLt. MX.order. + + split. discriminate. + intros [(E,<-)|IN]; trivial; try SortLt; MX.order. + + rewrite IH; trivial. split; auto. + intros [(E,<-)|IN]; trivial. MX.order. +Qed. + +(** * [mem] *) + +Fixpoint mem (k : key) (m : t elt) : bool := + match m with + | nil => false + | (k',_) :: l => + match X.compare k k' with + | Lt => false + | Eq => true + | Gt => mem k l + end + end. + +Lemma mem_spec m (Hm:Sort m) x : mem x m = true <-> In x m. +Proof. + induction m as [|(k,e') m IH]; simpl. + - split. discriminate. inversion 1. inversion_clear H0. + - inversion_clear Hm. + rewrite In_cons; simpl. + case X.compare_spec; intros. + + intuition. + + split. discriminate. intros [E|(e,IN)]. MX.order. + SortLt. MX.order. + + rewrite IH; trivial. split; auto. intros [E|IN]; trivial. + MX.order. +Qed. + +(** * [empty] *) + +Definition empty : t elt := nil. + +Lemma empty_spec x : find x empty = None. +Proof. + reflexivity. +Qed. + +Lemma empty_sorted : Sort empty. +Proof. + unfold empty; auto. +Qed. + +(** * [is_empty] *) + +Definition is_empty (l : t elt) : bool := if l then true else false. + +Lemma is_empty_spec m : + is_empty m = true <-> forall x, find x m = None. +Proof. + destruct m as [|(k,e) m]; simpl; split; trivial; try discriminate. + intros H. specialize (H k). now rewrite compare_refl in H. +Qed. + +(** * [add] *) + +Fixpoint add (k : key) (x : elt) (s : t elt) : t elt := + match s with + | nil => (k,x) :: nil + | (k',y) :: l => + match X.compare k k' with + | Lt => (k,x)::s + | Eq => (k,x)::l + | Gt => (k',y) :: add k x l + end + end. + +Lemma add_spec1 m x e : find x (add x e m) = Some e. +Proof. + induction m as [|(k,e') m IH]; simpl. + - now rewrite compare_refl. + - case X.compare_spec; simpl; rewrite ?compare_refl; trivial. + rewrite <- compare_gt_iff. now intros ->. +Qed. + +Lemma add_spec2 m x y e : ~X.eq x y -> find y (add x e m) = find y m. +Proof. + induction m as [|(k,e') m IH]; simpl. + - case X.compare_spec; trivial; MX.order. + - case X.compare_spec; simpl; intros; trivial. + + rewrite <-H. case X.compare_spec; trivial; MX.order. + + do 2 (case X.compare_spec; trivial; try MX.order). + + now rewrite IH. +Qed. + +Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), + Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m). +Proof. + induction m. + simpl; intuition. + intros. + destruct a as (x'',e''). + inversion_clear H. + compute in H0,H1. + simpl; case X.compare; intuition. +Qed. +Hint Resolve add_Inf. + +Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). +Proof. + induction m. + simpl; intuition. + intros. + destruct a as (x',e'). + simpl; case (X.compare_spec x x'); intuition; inversion_clear Hm; auto. + constructor; auto. + apply Inf_eq with (x',e'); auto. +Qed. + +(** * [remove] *) + +Fixpoint remove (k : key) (s : t elt) : t elt := + match s with + | nil => nil + | (k',x) :: l => + match X.compare k k' with + | Lt => s + | Eq => l + | Gt => (k',x) :: remove k l + end + end. + +Lemma remove_spec1 m (Hm:Sort m) x : find x (remove x m) = None. +Proof. + induction m as [|(k,e') m IH]; simpl; trivial. + inversion_clear Hm. + case X.compare_spec; simpl. + - intros E. rewrite <- E in H0. + apply Sort_Inf_NotIn in H0; trivial. unfold In in H0. + setoid_rewrite <- find_spec in H0; trivial. + destruct (find x m); trivial. + elim H0; now exists e. + - rewrite <- compare_lt_iff. now intros ->. + - rewrite <- compare_gt_iff. intros ->; auto. +Qed. + +Lemma remove_spec2 m (Hm:Sort m) x y : + ~X.eq x y -> find y (remove x m) = find y m. +Proof. + induction m as [|(k,e') m IH]; simpl; trivial. + inversion_clear Hm. + case X.compare_spec; simpl; intros E E'; try rewrite IH; auto. + case X.compare_spec; simpl; trivial; try MX.order. + intros. rewrite <- E in H0,H1. clear E E'. + destruct (find y m) eqn:F; trivial. + apply find_spec in F; trivial. + SortLt. MX.order. +Qed. + +Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), + Inf (x',e') m -> Inf (x',e') (remove x m). +Proof. + induction m. + simpl; intuition. + intros. + destruct a as (x'',e''). + inversion_clear H. + compute in H0. + simpl; case X.compare; intuition. + inversion_clear Hm. + apply Inf_lt with (x'',e''); auto. +Qed. +Hint Resolve remove_Inf. + +Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). +Proof. + induction m. + simpl; intuition. + intros. + destruct a as (x',e'). + simpl; case X.compare_spec; intuition; inversion_clear Hm; auto. +Qed. + +(** * [bindings] *) + +Definition bindings (m: t elt) := m. + +Lemma bindings_spec1 m x e : + InA eqke (x,e) (bindings m) <-> MapsTo x e m. +Proof. + reflexivity. +Qed. + +Lemma bindings_spec2 m (Hm:Sort m) : sort ltk (bindings m). +Proof. + auto. +Qed. + +Lemma bindings_spec2w m (Hm:Sort m) : NoDupA eqk (bindings m). +Proof. + now apply Sort_NoDupA. +Qed. + +(** * [fold] *) + +Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) : A := + match m with + | nil => acc + | (k,e)::m' => fold f m' (f k e acc) + end. + +Lemma fold_spec m : forall (A:Type)(i:A)(f:key->elt->A->A), + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. +Proof. + induction m as [|(k,e) m IH]; simpl; auto. +Qed. + +(** * [equal] *) + +Fixpoint equal (cmp:elt->elt->bool)(m m' : t elt) : bool := + match m, m' with + | nil, nil => true + | (x,e)::l, (x',e')::l' => + match X.compare x x' with + | Eq => cmp e e' && equal cmp l l' + | _ => false + end + | _, _ => false + end. + +Definition Equivb (cmp:elt->elt->bool) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). + +Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, + Equivb cmp m m' -> equal cmp m m' = true. +Proof. + induction m as [|(k,e) m IH]; destruct m' as [|(k',e') m']; simpl. + - trivial. + - intros _ cmp (H,_). + exfalso. apply (@In_nil elt k'). rewrite H, In_cons. now left. + - intros _ cmp (H,_). + exfalso. apply (@In_nil elt k). rewrite <- H, In_cons. now left. + - intros Hm' cmp E. + inversion_clear Hm; inversion_clear Hm'. + case X.compare_spec; intros E'. + + apply andb_true_intro; split. + * eapply E; eauto. apply InA_cons; now left. + * apply IH; clear IH; trivial. + destruct E as (E1,E2). split. + { intros x. clear E2. + split; intros; SortLt. + specialize (E1 x); rewrite 2 In_cons in E1; simpl in E1. + destruct E1 as ([E1|E1],_); eauto. MX.order. + specialize (E1 x); rewrite 2 In_cons in E1; simpl in E1. + destruct E1 as (_,[E1|E1]); eauto. MX.order. } + { intros x xe xe' Hx HX'. eapply E2; eauto. } + + assert (IN : In k ((k',e')::m')). + { apply E. apply In_cons; now left. } + apply In_cons in IN. simpl in IN. destruct IN as [?|IN]. MX.order. + SortLt. MX.order. + + assert (IN : In k' ((k,e)::m)). + { apply E. apply In_cons; now left. } + apply In_cons in IN. simpl in IN. destruct IN as [?|IN]. MX.order. + SortLt. MX.order. +Qed. + +Lemma equal_2 m (Hm:Sort m) m' (Hm':Sort m') cmp : + equal cmp m m' = true -> Equivb cmp m m'. +Proof. + revert m' Hm'. + induction m as [|(k,e) m IH]; destruct m' as [|(k',e') m']; simpl; + try discriminate. + - split. reflexivity. inversion 1. + - intros Hm'. case X.compare_spec; try discriminate. + rewrite andb_true_iff. intros E (C,EQ). + inversion_clear Hm; inversion_clear Hm'. + apply IH in EQ; trivial. + destruct EQ as (E1,E2). + split. + + intros x. rewrite 2 In_cons; simpl. rewrite <- E1. + intuition; now left; MX.order. + + intros x ex ex'. unfold MapsTo in *. rewrite 2 InA_cons, 2 eqke_def. + intuition; subst. + * trivial. + * SortLt. MX.order. + * SortLt. MX.order. + * eapply E2; eauto. +Qed. + +Lemma equal_spec m (Hm:Sort m) m' (Hm':Sort m') cmp : + equal cmp m m' = true <-> Equivb cmp m m'. +Proof. + split. now apply equal_2. now apply equal_1. +Qed. + +(** This lemma isn't part of the spec of [Equivb], but is used in [MMapAVL] *) + +Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) -> + eqk x y -> cmp (snd x) (snd y) = true -> + (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)). +Proof. + intros. + inversion H; subst. + inversion H0; subst. + destruct x; destruct y; compute in H1, H2. + split; intros. + apply equal_2; auto. + simpl. + case X.compare_spec; intros; try MX.order. + rewrite H2; simpl. + apply equal_1; auto. + apply equal_2; auto. + generalize (equal_1 H H0 H3). + simpl. + case X.compare_spec; try discriminate. + rewrite andb_true_iff. intuition. +Qed. + +Variable elt':Type. + +(** * [map] and [mapi] *) + +Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := + match m with + | nil => nil + | (k,e)::m' => (k,f e) :: map f m' + end. + +Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := + match m with + | nil => nil + | (k,e)::m' => (k,f k e) :: mapi f m' + end. + +End Elt. +Arguments find {elt} k m. +Section Elt2. +Variable elt elt' : Type. + +(** Specification of [map] *) + +Lemma map_spec (f:elt->elt') m x : + find x (map f m) = option_map f (find x m). +Proof. + induction m as [|(k,e) m IH]; simpl; trivial. + now case X.compare_spec. +Qed. + +Lemma map_Inf (f:elt->elt') m x e e' : + Inf (x,e) m -> Inf (x,e') (map f m). +Proof. + induction m as [|(x0,e0) m IH]; simpl; auto. + inversion_clear 1; auto. +Qed. +Hint Resolve map_Inf. + +Lemma map_sorted (f:elt->elt')(m: t elt)(Hm : Sort m) : + Sort (map f m). +Proof. + induction m as [|(x,e) m IH]; simpl; auto. + inversion_clear Hm. constructor; eauto. +Qed. + +(** Specification of [mapi] *) + +Lemma mapi_spec (f:key->elt->elt') m x : + exists y, X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). +Proof. + induction m as [|(k,e) m IH]; simpl. + - now exists x. + - elim X.compare_spec; intros; simpl. + + now exists k. + + now exists x. + + apply IH. +Qed. + +Lemma mapi_Inf (f:key->elt->elt') m x e : + Inf (x,e) m -> Inf (x,f x e) (mapi f m). +Proof. + induction m as [|(x0,e0) m IH]; simpl; auto. + inversion_clear 1; auto. +Qed. +Hint Resolve mapi_Inf. + +Lemma mapi_sorted (f:key->elt->elt') m (Hm : Sort m) : + Sort (mapi f m). +Proof. + induction m as [|(x,e) m IH]; simpl; auto. + inversion_clear Hm; auto. +Qed. + +End Elt2. +Section Elt3. + +(** * [merge] *) + +Variable elt elt' elt'' : Type. +Variable f : key -> option elt -> option elt' -> option elt''. + +Definition option_cons {A}(k:key)(o:option A)(l:list (key*A)) := + match o with + | Some e => (k,e)::l + | None => l + end. + +Fixpoint merge_l (m : t elt) : t elt'' := + match m with + | nil => nil + | (k,e)::l => option_cons k (f k (Some e) None) (merge_l l) + end. + +Fixpoint merge_r (m' : t elt') : t elt'' := + match m' with + | nil => nil + | (k,e')::l' => option_cons k (f k None (Some e')) (merge_r l') + end. + +Fixpoint merge (m : t elt) : t elt' -> t elt'' := + match m with + | nil => merge_r + | (k,e) :: l => + fix merge_aux (m' : t elt') : t elt'' := + match m' with + | nil => merge_l m + | (k',e') :: l' => + match X.compare k k' with + | Lt => option_cons k (f k (Some e) None) (merge l m') + | Eq => option_cons k (f k (Some e) (Some e')) (merge l l') + | Gt => option_cons k' (f k' None (Some e')) (merge_aux l') + end + end + end. + +Notation oee' := (option elt * option elt')%type. + +Fixpoint combine (m : t elt) : t elt' -> t oee' := + match m with + | nil => map (fun e' => (None,Some e')) + | (k,e) :: l => + fix combine_aux (m':t elt') : list (key * oee') := + match m' with + | nil => map (fun e => (Some e,None)) m + | (k',e') :: l' => + match X.compare k k' with + | Lt => (k,(Some e, None))::combine l m' + | Eq => (k,(Some e, Some e'))::combine l l' + | Gt => (k',(None,Some e'))::combine_aux l' + end + end + end. + +Definition fold_right_pair {A B C}(f: A->B->C->C)(l:list (A*B))(i:C) := + List.fold_right (fun p => f (fst p) (snd p)) i l. + +Definition merge' m m' := + let m0 : t oee' := combine m m' in + let m1 : t (option elt'') := mapi (fun k p => f k (fst p) (snd p)) m0 in + fold_right_pair (option_cons (A:=elt'')) m1 nil. + +Lemma merge_equiv : forall m m', merge' m m' = merge m m'. +Proof. + unfold merge'. + induction m as [|(k,e) m IHm]; intros. + - (* merge_r *) + simpl. + induction m' as [|(k',e') m' IHm']; simpl; rewrite ?IHm'; auto. + - induction m' as [|(k',e') m' IHm']; simpl. + + f_equal. + (* merge_l *) + clear k e IHm. + induction m as [|(k,e) m IHm]; simpl; rewrite ?IHm; auto. + + elim X.compare_spec; intros; simpl; f_equal. + * apply IHm. + * apply IHm. + * apply IHm'. +Qed. + +Lemma combine_Inf : + forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), + Inf (x,e) m -> + Inf (x,e') m' -> + Inf (x,e'') (combine m m'). +Proof. + induction m. + - intros. simpl. eapply map_Inf; eauto. + - induction m'; intros. + + destruct a. + replace (combine ((t0, e0) :: m) nil) with + (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto. + eapply map_Inf; eauto. + + simpl. + destruct a as (k,e0); destruct a0 as (k',e0'). + elim X.compare_spec. + * inversion_clear H; auto. + * inversion_clear H; auto. + * inversion_clear H0; auto. +Qed. +Hint Resolve combine_Inf. + +Lemma combine_sorted m (Hm : Sort m) m' (Hm' : Sort m') : + Sort (combine m m'). +Proof. + revert m' Hm'. + induction m. + - intros; clear Hm. simpl. apply map_sorted; auto. + - induction m'; intros. + + clear Hm'. + destruct a. + replace (combine ((t0, e) :: m) nil) with + (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto. + apply map_sorted; auto. + + simpl. + destruct a as (k,e); destruct a0 as (k',e'). + inversion_clear Hm; inversion_clear Hm'. + case X.compare_spec; [intros Heq| intros Hlt| intros Hlt]; + constructor; auto. + * assert (Inf (k, e') m') by (apply Inf_eq with (k',e'); auto). + exact (combine_Inf _ H0 H3). + * assert (Inf (k, e') ((k',e')::m')) by auto. + exact (combine_Inf _ H0 H3). + * assert (Inf (k', e) ((k,e)::m)) by auto. + exact (combine_Inf _ H3 H2). +Qed. + +Lemma merge_sorted m (Hm : Sort m) m' (Hm' : Sort m') : + Sort (merge m m'). +Proof. + intros. + rewrite <- merge_equiv. + unfold merge'. + assert (Hmm':=combine_sorted Hm Hm'). + set (l0:=combine m m') in *; clearbody l0. + set (f':= fun k p => f k (fst p) (snd p)). + assert (H1:=mapi_sorted f' Hmm'). + set (l1:=mapi f' l0) in *; clearbody l1. + clear f' f Hmm' l0 Hm Hm' m m'. + (* Sort fold_right_pair *) + induction l1. + - simpl; auto. + - inversion_clear H1. + destruct a; destruct o; auto. + simpl. + constructor; auto. + clear IHl1. + (* Inf fold_right_pair *) + induction l1. + + simpl; auto. + + destruct a; destruct o; simpl; auto. + * inversion_clear H0; auto. + * inversion_clear H0. inversion_clear H. + compute in H1. + apply IHl1; auto. + apply Inf_lt with (t1, None); auto. +Qed. + +Definition at_least_one (o:option elt)(o':option elt') := + match o, o' with + | None, None => None + | _, _ => Some (o,o') + end. + +Lemma combine_spec m (Hm : Sort m) m' (Hm' : Sort m') (x:key) : + find x (combine m m') = at_least_one (find x m) (find x m'). +Proof. + revert m' Hm'. + induction m. + intros. + simpl. + induction m'. + intros; simpl; auto. + simpl; destruct a. + simpl; destruct (X.compare x t0); simpl; auto. + inversion_clear Hm'; auto. + induction m'. + (* m' = nil *) + intros; destruct a; simpl. + destruct (X.compare_spec x t0) as [ |Hlt|Hlt]; simpl; auto. + inversion_clear Hm; clear H0 Hlt Hm' IHm t0. + induction m; simpl; auto. + inversion_clear H. + destruct a. + simpl; destruct (X.compare x t0); simpl; auto. + (* m' <> nil *) + intros. + destruct a as (k,e); destruct a0 as (k',e'); simpl. + inversion Hm; inversion Hm'; subst. + destruct (X.compare_spec k k'); simpl; + destruct (X.compare_spec x k); + MX.order || destruct (X.compare_spec x k'); + simpl; try MX.order; auto. + - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order. + - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order. + - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order. + - change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')). + rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order. + - change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')). + rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order. + - change (find x (combine ((k, e) :: m) m') = + at_least_one (find x m) (find x m')). + rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order. +Qed. + +Definition at_least_one_then_f k (o:option elt)(o':option elt') := + match o, o' with + | None, None => None + | _, _ => f k o o' + end. + +Lemma merge_spec0 m (Hm : Sort m) m' (Hm' : Sort m') (x:key) : + exists y, X.eq y x /\ + find x (merge m m') = at_least_one_then_f y (find x m) (find x m'). +Proof. + intros. + rewrite <- merge_equiv. + unfold merge'. + assert (H:=combine_spec Hm Hm' x). + assert (H2:=combine_sorted Hm Hm'). + set (f':= fun k p => f k (fst p) (snd p)). + set (m0 := combine m m') in *; clearbody m0. + set (o:=find x m) in *; clearbody o. + set (o':=find x m') in *; clearbody o'. + clear Hm Hm' m m'. revert H. + match goal with |- ?G => + assert (G/\(find x m0 = None -> + find x (fold_right_pair option_cons (mapi f' m0) nil) = None)); + [|intuition] end. + induction m0; simpl in *; intuition. + - exists x; split; [easy|]. + destruct o; destruct o'; simpl in *; try discriminate; auto. + - destruct a as (k,(oo,oo')); simpl in *. + inversion_clear H2. + destruct (X.compare_spec x k) as [Heq|Hlt|Hlt]; simpl in *. + + (* x = k *) + exists k; split; [easy|]. + assert (at_least_one_then_f k o o' = f k oo oo'). + { destruct o; destruct o'; simpl in *; inversion_clear H; auto. } + rewrite H2. + unfold f'; simpl. + destruct (f k oo oo'); simpl. + * elim X.compare_spec; trivial; try MX.order. + * destruct (IHm0 H0) as (_,H4); apply H4; auto. + case_eq (find x m0); intros; auto. + assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))). + now compute. + symmetry in H5. + destruct (Sort_Inf_NotIn H0 (Inf_eq H5 H1)). + exists p; apply find_spec; auto. + + (* x < k *) + destruct (f' k (oo,oo')); simpl. + * elim X.compare_spec; trivial; try MX.order. + destruct o; destruct o'; simpl in *; try discriminate; auto. + now exists x. + * apply IHm0; trivial. + rewrite <- H. + case_eq (find x m0); intros; auto. + assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). + red; auto. + destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)). + exists p; apply find_spec; auto. + + (* k < x *) + unfold f'; simpl. + destruct (f k oo oo'); simpl. + * elim X.compare_spec; trivial; try MX.order. + intros. apply IHm0; auto. + * apply IHm0; auto. + + - (* None -> None *) + destruct a as (k,(oo,oo')). + simpl. + inversion_clear H2. + destruct (X.compare_spec x k) as [Hlt|Heq|Hlt]; try discriminate. + + (* x < k *) + unfold f'; simpl. + destruct (f k oo oo'); simpl. + elim X.compare_spec; trivial; try MX.order. intros. + apply IHm0; auto. + case_eq (find x m0); intros; auto. + assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). + now compute. + destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)). + exists p; apply find_spec; auto. + + (* k < x *) + unfold f'; simpl. + destruct (f k oo oo'); simpl. + elim X.compare_spec; trivial; try MX.order. intros. + apply IHm0; auto. + apply IHm0; auto. +Qed. + +(** Specification of [merge] *) + +Lemma merge_spec1 m (Hm : Sort m) m' (Hm' : Sort m')(x:key) : + In x m \/ In x m' -> + exists y, X.eq y x /\ + find x (merge m m') = f y (find x m) (find x m'). +Proof. + intros. + destruct (merge_spec0 Hm Hm' x) as (y,(Hy,H')). + exists y; split; [easy|]. rewrite H'. + destruct H as [(e,H)|(e,H)]; + apply find_spec in H; trivial; rewrite H; simpl; auto. + now destruct (find x m). +Qed. + +Lemma merge_spec2 m (Hm : Sort m) m' (Hm' : Sort m')(x:key) : + In x (merge m m') -> In x m \/ In x m'. +Proof. + intros. + destruct H as (e,H). + apply find_spec in H; auto using merge_sorted. + destruct (merge_spec0 Hm Hm' x) as (y,(Hy,H')). + rewrite H in H'. + destruct (find x m) eqn:F. + - apply find_spec in F; eauto. + - destruct (find x m') eqn:F'. + + apply find_spec in F'; eauto. + + simpl in H'. discriminate. +Qed. + +End Elt3. +End Raw. + +Module Make (X: OrderedType) <: S with Module E := X. +Module Raw := Raw X. +Module E := X. + +Definition key := E.t. +Definition eq_key {elt} := @Raw.PX.eqk elt. +Definition eq_key_elt {elt} := @Raw.PX.eqke elt. +Definition lt_key {elt} := @Raw.PX.ltk elt. + +Record t_ (elt:Type) := Mk + {this :> Raw.t elt; + sorted : sort Raw.PX.ltk this}. +Definition t := t_. + +Definition empty {elt} := Mk (Raw.empty_sorted elt). + +Section Elt. + Variable elt elt' elt'':Type. + + Implicit Types m : t elt. + Implicit Types x y : key. + Implicit Types e : elt. + + Definition is_empty m : bool := Raw.is_empty m.(this). + Definition add x e m : t elt := Mk (Raw.add_sorted m.(sorted) x e). + Definition find x m : option elt := Raw.find x m.(this). + Definition remove x m : t elt := Mk (Raw.remove_sorted m.(sorted) x). + Definition mem x m : bool := Raw.mem x m.(this). + Definition map f m : t elt' := Mk (Raw.map_sorted f m.(sorted)). + Definition mapi (f:key->elt->elt') m : t elt' := + Mk (Raw.mapi_sorted f m.(sorted)). + Definition merge f m (m':t elt') : t elt'' := + Mk (Raw.merge_sorted f m.(sorted) m'.(sorted)). + Definition bindings m : list (key*elt) := Raw.bindings m.(this). + Definition cardinal m := length m.(this). + Definition fold {A:Type}(f:key->elt->A->A) m (i:A) : A := + Raw.fold f m.(this) i. + Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). + + Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). + Definition In x m : Prop := Raw.PX.In x m.(this). + + Definition Equal m m' := forall y, find y m = find y m'. + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). + + Instance MapsTo_compat : + Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. + Proof. + intros x x' Hx e e' <- m m' <-. unfold MapsTo. now rewrite Hx. + Qed. + + Lemma find_spec m : forall x e, find x m = Some e <-> MapsTo x e m. + Proof. exact (Raw.find_spec m.(sorted)). Qed. + + Lemma mem_spec m : forall x, mem x m = true <-> In x m. + Proof. exact (Raw.mem_spec m.(sorted)). Qed. + + Lemma empty_spec : forall x, find x empty = None. + Proof. exact (Raw.empty_spec _). Qed. + + Lemma is_empty_spec m : is_empty m = true <-> (forall x, find x m = None). + Proof. exact (Raw.is_empty_spec m.(this)). Qed. + + Lemma add_spec1 m : forall x e, find x (add x e m) = Some e. + Proof. exact (Raw.add_spec1 m.(this)). Qed. + Lemma add_spec2 m : forall x y e, ~E.eq x y -> find y (add x e m) = find y m. + Proof. exact (Raw.add_spec2 m.(this)). Qed. + + Lemma remove_spec1 m : forall x, find x (remove x m) = None. + Proof. exact (Raw.remove_spec1 m.(sorted)). Qed. + Lemma remove_spec2 m : forall x y, ~E.eq x y -> find y (remove x m) = find y m. + Proof. exact (Raw.remove_spec2 m.(sorted)). Qed. + + Lemma bindings_spec1 m : forall x e, + InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. + Proof. exact (Raw.bindings_spec1 m.(this)). Qed. + Lemma bindings_spec2w m : NoDupA eq_key (bindings m). + Proof. exact (Raw.bindings_spec2w m.(sorted)). Qed. + Lemma bindings_spec2 m : sort lt_key (bindings m). + Proof. exact (Raw.bindings_spec2 m.(sorted)). Qed. + + Lemma cardinal_spec m : cardinal m = length (bindings m). + Proof. reflexivity. Qed. + + Lemma fold_spec m : forall (A : Type) (i : A) (f : key -> elt -> A -> A), + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. + Proof. exact (Raw.fold_spec m.(this)). Qed. + + Lemma equal_spec m m' : forall cmp, equal cmp m m' = true <-> Equivb cmp m m'. + Proof. exact (Raw.equal_spec m.(sorted) m'.(sorted)). Qed. + +End Elt. + + Lemma map_spec {elt elt'} (f:elt->elt') m : + forall x, find x (map f m) = option_map f (find x m). + Proof. exact (Raw.map_spec f m.(this)). Qed. + + Lemma mapi_spec {elt elt'} (f:key->elt->elt') m : + forall x, exists y, + E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). + Proof. exact (Raw.mapi_spec f m.(this)). Qed. + + Lemma merge_spec1 {elt elt' elt''} + (f:key->option elt->option elt'->option elt'') m m' : + forall x, + In x m \/ In x m' -> + exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m'). + Proof. exact (Raw.merge_spec1 f m.(sorted) m'.(sorted)). Qed. + + Lemma merge_spec2 {elt elt' elt''} + (f:key->option elt->option elt'->option elt'') m m' : + forall x, + In x (merge f m m') -> In x m \/ In x m'. + Proof. exact (Raw.merge_spec2 m.(sorted) m'.(sorted)). Qed. + +End Make. + +Module Make_ord (X: OrderedType)(D : OrderedType) <: +Sord with Module Data := D + with Module MapS.E := X. + +Module Data := D. +Module MapS := Make(X). +Import MapS. + +Module MD := OrderedTypeFacts(D). +Import MD. + +Definition t := MapS.t D.t. + +Definition cmp e e' := + match D.compare e e' with Eq => true | _ => false end. + +Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop := + match m, m' with + | nil, nil => True + | (x,e)::l, (x',e')::l' => + match X.compare x x' with + | Eq => D.eq e e' /\ eq_list l l' + | _ => False + end + | _, _ => False + end. + +Definition eq m m' := eq_list m.(this) m'.(this). + +Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop := + match m, m' with + | nil, nil => False + | nil, _ => True + | _, nil => False + | (x,e)::l, (x',e')::l' => + match X.compare x x' with + | Lt => True + | Gt => False + | Eq => D.lt e e' \/ (D.eq e e' /\ lt_list l l') + end + end. + +Definition lt m m' := lt_list m.(this) m'.(this). + +Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true. +Proof. + intros (l,Hl); induction l. + intros (l',Hl'); unfold eq; simpl. + destruct l'; unfold equal; simpl; intuition. + intros (l',Hl'); unfold eq. + destruct l'. + destruct a; unfold equal; simpl; intuition. + destruct a as (x,e). + destruct p as (x',e'). + unfold equal; simpl. + destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; simpl; intuition. + unfold cmp at 1. + elim D.compare_spec; try MD.order; simpl. + inversion_clear Hl. + inversion_clear Hl'. + destruct (IHl H (Mk H3)). + unfold equal, eq in H5; simpl in H5; auto. + destruct (andb_prop _ _ H); clear H. + generalize H0; unfold cmp. + elim D.compare_spec; try MD.order; simpl; try discriminate. + destruct (andb_prop _ _ H); clear H. + inversion_clear Hl. + inversion_clear Hl'. + destruct (IHl H (Mk H3)). + unfold equal, eq in H6; simpl in H6; auto. +Qed. + +Lemma eq_spec m m' : eq m m' <-> Equivb cmp m m'. +Proof. + now rewrite eq_equal, equal_spec. +Qed. + +Lemma eq_refl : forall m : t, eq m m. +Proof. + intros (m,Hm); induction m; unfold eq; simpl; auto. + destruct a. + destruct (X.compare_spec t0 t0) as [Hlt|Heq|Hlt]; auto. + - split. reflexivity. inversion_clear Hm. apply (IHm H). + - MapS.Raw.MX.order. + - MapS.Raw.MX.order. +Qed. + +Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. +Proof. + intros (m,Hm); induction m; + intros (m', Hm'); destruct m'; unfold eq; simpl; + try destruct a as (x,e); try destruct p as (x',e'); auto. + destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; + elim X.compare_spec; try MapS.Raw.MX.order; intuition. + inversion_clear Hm; inversion_clear Hm'. + apply (IHm H0 (Mk H4)); auto. +Qed. + +Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. +Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + intros (m3, Hm3); destruct m3; unfold eq; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); + try destruct p0 as (x'',e''); try contradiction; auto. + destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; + destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; + elim X.compare_spec; try MapS.Raw.MX.order; intuition. + now transitivity e'. + inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. + apply (IHm1 H1 (Mk H6) (Mk H8)); intuition. +Qed. + +Instance eq_equiv : Equivalence eq. +Proof. split; [exact eq_refl|exact eq_sym|exact eq_trans]. Qed. + +Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. +Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + intros (m3, Hm3); destruct m3; unfold lt; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); + try destruct p0 as (x'',e''); try contradiction; auto. + destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; + destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; + elim X.compare_spec; try MapS.Raw.MX.order; intuition. + left; transitivity e'; auto. + left; MD.order. + left; MD.order. + right. + split. + transitivity e'; auto. + inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. + apply (IHm1 H2 (Mk H6) (Mk H8)); intuition. +Qed. + +Lemma lt_irrefl : forall m, ~ lt m m. +Proof. + intros (m,Hm); induction m; unfold lt; simpl; auto. + destruct a. + destruct (X.compare_spec t0 t0) as [Hlt|Heq|Hlt]; auto. + - intuition. MD.order. inversion_clear Hm. now apply (IHm H0). + - MapS.Raw.MX.order. +Qed. + +Instance lt_strorder : StrictOrder lt. +Proof. split; [exact lt_irrefl|exact lt_trans]. Qed. + +Lemma lt_compat1 : forall m1 m1' m2, eq m1 m1' -> lt m1 m2 -> lt m1' m2. +Proof. + intros (m1,Hm1); induction m1; + intros (m1',Hm1'); destruct m1'; + intros (m2,Hm2); destruct m2; unfold eq, lt; + try destruct a as (x,e); + try destruct p as (x',e'); + try destruct p0 as (x'',e''); try contradiction; simpl; auto. + destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; + destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; + elim X.compare_spec; try MapS.Raw.MX.order; intuition. + left; MD.order. + right. + split. + MD.order. + inversion_clear Hm1; inversion_clear Hm1'; inversion_clear Hm2. + apply (IHm1 H0 (Mk H6) (Mk H8)); intuition. +Qed. + +Lemma lt_compat2 : forall m1 m2 m2', eq m2 m2' -> lt m1 m2 -> lt m1 m2'. +Proof. + intros (m1,Hm1); induction m1; + intros (m2,Hm2); destruct m2; + intros (m2',Hm2'); destruct m2'; unfold eq, lt; + try destruct a as (x,e); + try destruct p as (x',e'); + try destruct p0 as (x'',e''); try contradiction; simpl; auto. + destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; + destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; + elim X.compare_spec; try MapS.Raw.MX.order; intuition. + left; MD.order. + right. + split. + MD.order. + inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm2'. + apply (IHm1 H0 (Mk H6) (Mk H8)); intuition. +Qed. + +Instance lt_compat : Proper (eq==>eq==>iff) lt. +Proof. + intros m1 m1' H1 m2 m2' H2. split; intros. + now apply (lt_compat2 H2), (lt_compat1 H1). + symmetry in H1, H2. + now apply (lt_compat2 H2), (lt_compat1 H1). +Qed. + +Ltac cmp_solve := + unfold eq, lt; simpl; elim X.compare_spec; try Raw.MX.order; auto. + +Fixpoint compare_list m1 m2 := match m1, m2 with +| nil, nil => Eq +| nil, _ => Lt +| _, nil => Gt +| (k1,e1)::m1, (k2,e2)::m2 => + match X.compare k1 k2 with + | Lt => Lt + | Gt => Gt + | Eq => match D.compare e1 e2 with + | Lt => Lt + | Gt => Gt + | Eq => compare_list m1 m2 + end + end +end. + +Definition compare m1 m2 := compare_list m1.(this) m2.(this). + +Lemma compare_spec : forall m1 m2, CompSpec eq lt m1 m2 (compare m1 m2). +Proof. + unfold CompSpec. + intros (m1,Hm1)(m2,Hm2). unfold compare, eq, lt; simpl. + revert m2 Hm2. + induction m1 as [|(k1,e1) m1 IH1]; destruct m2 as [|(k2,e2) m2]; + try constructor; simpl; intros; auto. + elim X.compare_spec; simpl; try constructor; auto; intros. + elim D.compare_spec; simpl; try constructor; auto; intros. + inversion_clear Hm1; inversion_clear Hm2. + destruct (IH1 H1 _ H3); simpl; try constructor; auto. + elim X.compare_spec; try Raw.MX.order. right. now split. + elim X.compare_spec; try Raw.MX.order. now left. + elim X.compare_spec; try Raw.MX.order; auto. +Qed. + +End Make_ord. diff --git a/theories/MMaps/MMapPositive.v b/theories/MMaps/MMapPositive.v new file mode 100644 index 00000000..d3aab238 --- /dev/null +++ b/theories/MMaps/MMapPositive.v @@ -0,0 +1,698 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(** * MMapPositive : an implementation of MMapInterface for [positive] keys. *) + +Require Import Bool PeanoNat BinPos Orders OrdersEx OrdersLists MMapInterface. + +Set Implicit Arguments. +Local Open Scope lazy_bool_scope. +Local Open Scope positive_scope. +Local Unset Elimination Schemes. + +(** This file is an adaptation to the [MMap] framework of a work by + Xavier Leroy and Sandrine Blazy (used for building certified compilers). + Keys are of type [positive], and maps are binary trees: the sequence + of binary digits of a positive number corresponds to a path in such a tree. + This is quite similar to the [IntMap] library, except that no path + compression is implemented, and that the current file is simple enough to be + self-contained. *) + +(** Reverses the positive [y] and concatenate it with [x] *) + +Fixpoint rev_append (y x : positive) : positive := + match y with + | 1 => x + | y~1 => rev_append y x~1 + | y~0 => rev_append y x~0 + end. +Local Infix "@" := rev_append (at level 60). +Definition rev x := x@1. + +(** The module of maps over positive keys *) + +Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. + + Module E:=PositiveOrderedTypeBits. + Module ME:=KeyOrderedType E. + + Definition key := positive : Type. + + Definition eq_key {A} (p p':key*A) := E.eq (fst p) (fst p'). + + Definition eq_key_elt {A} (p p':key*A) := + E.eq (fst p) (fst p') /\ (snd p) = (snd p'). + + Definition lt_key {A} (p p':key*A) := E.lt (fst p) (fst p'). + + Instance eqk_equiv {A} : Equivalence (@eq_key A) := _. + Instance eqke_equiv {A} : Equivalence (@eq_key_elt A) := _. + Instance ltk_strorder {A} : StrictOrder (@lt_key A) := _. + + Inductive tree (A : Type) := + | Leaf : tree A + | Node : tree A -> option A -> tree A -> tree A. + + Arguments Leaf {A}. + + Scheme tree_ind := Induction for tree Sort Prop. + + Definition t := tree. + + Definition empty {A} : t A := Leaf. + + Section A. + Variable A:Type. + + Fixpoint is_empty (m : t A) : bool := + match m with + | Leaf => true + | Node l None r => (is_empty l) &&& (is_empty r) + | _ => false + end. + + Fixpoint find (i : key) (m : t A) : option A := + match m with + | Leaf => None + | Node l o r => + match i with + | xH => o + | xO ii => find ii l + | xI ii => find ii r + end + end. + + Fixpoint mem (i : key) (m : t A) : bool := + match m with + | Leaf => false + | Node l o r => + match i with + | xH => match o with None => false | _ => true end + | xO ii => mem ii l + | xI ii => mem ii r + end + end. + + Fixpoint add (i : key) (v : A) (m : t A) : t A := + match m with + | Leaf => + match i with + | xH => Node Leaf (Some v) Leaf + | xO ii => Node (add ii v Leaf) None Leaf + | xI ii => Node Leaf None (add ii v Leaf) + end + | Node l o r => + match i with + | xH => Node l (Some v) r + | xO ii => Node (add ii v l) o r + | xI ii => Node l o (add ii v r) + end + end. + + (** helper function to avoid creating empty trees that are not leaves *) + + Definition node (l : t A) (o: option A) (r : t A) : t A := + match o,l,r with + | None,Leaf,Leaf => Leaf + | _,_,_ => Node l o r + end. + + Fixpoint remove (i : key) (m : t A) : t A := + match m with + | Leaf => Leaf + | Node l o r => + match i with + | xH => node l None r + | xO ii => node (remove ii l) o r + | xI ii => node l o (remove ii r) + end + end. + + (** [bindings] *) + + Fixpoint xbindings (m : t A) (i : positive) (a: list (key*A)) := + match m with + | Leaf => a + | Node l None r => xbindings l i~0 (xbindings r i~1 a) + | Node l (Some e) r => xbindings l i~0 ((rev i,e) :: xbindings r i~1 a) + end. + + Definition bindings (m : t A) := xbindings m 1 nil. + + (** [cardinal] *) + + Fixpoint cardinal (m : t A) : nat := + match m with + | Leaf => 0%nat + | Node l None r => (cardinal l + cardinal r)%nat + | Node l (Some _) r => S (cardinal l + cardinal r) + end. + + (** Specification proofs *) + + Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v. + Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m. + + Lemma MapsTo_compat : Proper (E.eq==>eq==>eq==>iff) MapsTo. + Proof. + intros k k' Hk e e' He m m' Hm. red in Hk. now subst. + Qed. + + Lemma find_spec m x e : find x m = Some e <-> MapsTo x e m. + Proof. reflexivity. Qed. + + Lemma mem_find : + forall m x, mem x m = match find x m with None => false | _ => true end. + Proof. + induction m; destruct x; simpl; auto. + Qed. + + Lemma mem_spec : forall m x, mem x m = true <-> In x m. + Proof. + unfold In, MapsTo; intros m x; rewrite mem_find. + split. + - destruct (find x m). + exists a; auto. + intros; discriminate. + - destruct 1 as (e0,H0); rewrite H0; auto. + Qed. + + Lemma gleaf : forall (i : key), find i Leaf = None. + Proof. destruct i; simpl; auto. Qed. + + Theorem empty_spec: + forall (i: key), find i empty = None. + Proof. exact gleaf. Qed. + + Lemma is_empty_spec m : + is_empty m = true <-> forall k, find k m = None. + Proof. + induction m; simpl. + - intuition. apply empty_spec. + - destruct o. split; try discriminate. + intros H. now specialize (H xH). + rewrite <- andb_lazy_alt, andb_true_iff, IHm1, IHm2. + clear IHm1 IHm2. + split. + + intros (H1,H2) k. destruct k; simpl; auto. + + intros H; split; intros k. apply (H (xO k)). apply (H (xI k)). + Qed. + + Theorem add_spec1: + forall (m: t A) (i: key) (x: A), find i (add i x m) = Some x. + Proof. + intros m i; revert m. + induction i; destruct m; simpl; auto. + Qed. + + Theorem add_spec2: + forall (m: t A) (i j: key) (x: A), + i <> j -> find j (add i x m) = find j m. + Proof. + intros m i j; revert m i. + induction j; destruct i, m; simpl; intros; + rewrite ?IHj, ?gleaf; auto; try congruence. + Qed. + + Lemma rleaf : forall (i : key), remove i Leaf = Leaf. + Proof. destruct i; simpl; auto. Qed. + + Lemma gnode l o r i : find i (node l o r) = find i (Node l o r). + Proof. + destruct o,l,r; simpl; trivial. + destruct i; simpl; now rewrite ?gleaf. + Qed. + + Opaque node. + + Theorem remove_spec1: + forall (m: t A)(i: key), find i (remove i m) = None. + Proof. + induction m; simpl. + - intros; rewrite rleaf. apply gleaf. + - destruct i; simpl remove; rewrite gnode; simpl; auto. + Qed. + + Theorem remove_spec2: + forall (m: t A)(i j: key), + i <> j -> find j (remove i m) = find j m. + Proof. + induction m; simpl; intros. + - now rewrite rleaf. + - destruct i; simpl; rewrite gnode; destruct j; simpl; trivial; + try apply IHm1; try apply IHm2; congruence. + Qed. + + Local Notation InL := (InA eq_key_elt). + + Lemma xbindings_spec: forall m j acc k e, + InL (k,e) (xbindings m j acc) <-> + InL (k,e) acc \/ exists x, k=(j@x) /\ find x m = Some e. + Proof. + induction m as [|l IHl o r IHr]; simpl. + - intros. split; intro H. + + now left. + + destruct H as [H|[x [_ H]]]. assumption. + now rewrite gleaf in H. + - intros j acc k e. case o as [e'|]; + rewrite IHl, ?InA_cons, IHr; clear IHl IHr; split. + + intros [[H|[H|H]]|H]; auto. + * unfold eq_key_elt, E.eq, fst, snd in H. destruct H as (->,<-). + right. now exists 1. + * destruct H as (x,(->,H)). right. now exists x~1. + * destruct H as (x,(->,H)). right. now exists x~0. + + intros [H|H]; auto. + destruct H as (x,(->,H)). + destruct x; simpl in *. + * left. right. right. now exists x. + * right. now exists x. + * left. left. injection H as ->. reflexivity. + + intros [[H|H]|H]; auto. + * destruct H as (x,(->,H)). right. now exists x~1. + * destruct H as (x,(->,H)). right. now exists x~0. + + intros [H|H]; auto. + destruct H as (x,(->,H)). + destruct x; simpl in *. + * left. right. now exists x. + * right. now exists x. + * discriminate. + Qed. + + Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y). + Proof. induction j; intros; simpl; auto. Qed. + + Lemma xbindings_sort m j acc : + sort lt_key acc -> + (forall x p, In x m -> InL p acc -> E.lt (j@x) (fst p)) -> + sort lt_key (xbindings m j acc). + Proof. + revert j acc. + induction m as [|l IHl o r IHr]; simpl; trivial. + intros j acc Hacc Hsacc. destruct o as [e|]. + - apply IHl;[constructor;[apply IHr; [apply Hacc|]|]|]. + + intros. now apply Hsacc. + + case_eq (xbindings r j~1 acc); [constructor|]. + intros (z,e') q H. constructor. + assert (H': InL (z,e') (xbindings r j~1 acc)). + { rewrite H. now constructor. } + clear H q. rewrite xbindings_spec in H'. + destruct H' as [H'|H']. + * apply (Hsacc 1 (z,e')); trivial. now exists e. + * destruct H' as (x,(->,H)). + red. simpl. now apply lt_rev_append. + + intros x (y,e') Hx Hy. inversion_clear Hy. + rewrite H. simpl. now apply lt_rev_append. + rewrite xbindings_spec in H. + destruct H as [H|H]. + * now apply Hsacc. + * destruct H as (z,(->,H)). simpl. + now apply lt_rev_append. + - apply IHl; [apply IHr; [apply Hacc|]|]. + + intros. now apply Hsacc. + + intros x (y,e') Hx H. rewrite xbindings_spec in H. + destruct H as [H|H]. + * now apply Hsacc. + * destruct H as (z,(->,H)). simpl. + now apply lt_rev_append. + Qed. + + Lemma bindings_spec1 m k e : + InA eq_key_elt (k,e) (bindings m) <-> MapsTo k e m. + Proof. + unfold bindings, MapsTo. rewrite xbindings_spec. + split; [ intros [H|(y & H & H')] | intros IN ]. + - inversion H. + - simpl in *. now subst. + - right. now exists k. + Qed. + + Lemma bindings_spec2 m : sort lt_key (bindings m). + Proof. + unfold bindings. + apply xbindings_sort. constructor. inversion 2. + Qed. + + Lemma bindings_spec2w m : NoDupA eq_key (bindings m). + Proof. + apply ME.Sort_NoDupA. + apply bindings_spec2. + Qed. + + Lemma xbindings_length m j acc : + length (xbindings m j acc) = (cardinal m + length acc)%nat. + Proof. + revert j acc. + induction m; simpl; trivial; intros. + destruct o; simpl; rewrite IHm1; simpl; rewrite IHm2; + now rewrite ?Nat.add_succ_r, Nat.add_assoc. + Qed. + + Lemma cardinal_spec m : cardinal m = length (bindings m). + Proof. + unfold bindings. rewrite xbindings_length. simpl. + symmetry. apply Nat.add_0_r. + Qed. + + (** [map] and [mapi] *) + + Variable B : Type. + + Section Mapi. + + Variable f : key -> option A -> option B. + + Fixpoint xmapi (m : t A) (i : key) : t B := + match m with + | Leaf => Leaf + | Node l o r => Node (xmapi l (i~0)) + (f (rev i) o) + (xmapi r (i~1)) + end. + + End Mapi. + + Definition mapi (f : key -> A -> B) m := + xmapi (fun k => option_map (f k)) m 1. + + Definition map (f : A -> B) m := mapi (fun _ => f) m. + + End A. + + Lemma xgmapi: + forall (A B: Type) (f: key -> option A -> option B) (i j : key) (m: t A), + (forall k, f k None = None) -> + find i (xmapi f m j) = f (j@i) (find i m). + Proof. + induction i; intros; destruct m; simpl; rewrite ?IHi; auto. + Qed. + + Theorem mapi_spec0 : + forall (A B: Type) (f: key -> A -> B) (i: key) (m: t A), + find i (mapi f m) = option_map (f i) (find i m). + Proof. + intros. unfold mapi. rewrite xgmapi; simpl; auto. + Qed. + + Lemma mapi_spec : + forall (A B: Type) (f: key -> A -> B) (m: t A) (i:key), + exists j, E.eq j i /\ + find i (mapi f m) = option_map (f j) (find i m). + Proof. + intros. + exists i. split. reflexivity. apply mapi_spec0. + Qed. + + Lemma map_spec : + forall (elt elt':Type)(f:elt->elt')(m: t elt)(x:key), + find x (map f m) = option_map f (find x m). + Proof. + intros; unfold map. apply mapi_spec0. + Qed. + + Section merge. + Variable A B C : Type. + Variable f : key -> option A -> option B -> option C. + + Fixpoint xmerge (m1 : t A)(m2 : t B)(i:positive) : t C := + match m1 with + | Leaf => xmapi (fun k => f k None) m2 i + | Node l1 o1 r1 => + match m2 with + | Leaf => xmapi (fun k o => f k o None) m1 i + | Node l2 o2 r2 => + Node (xmerge l1 l2 (i~0)) + (f (rev i) o1 o2) + (xmerge r1 r2 (i~1)) + end + end. + + Lemma xgmerge: forall (i j: key)(m1:t A)(m2: t B), + (forall i, f i None None = None) -> + find i (xmerge m1 m2 j) = f (j@i) (find i m1) (find i m2). + Proof. + induction i; intros; destruct m1; destruct m2; simpl; auto; + rewrite ?xgmapi, ?IHi; simpl; auto. + Qed. + + End merge. + + Definition merge {A B C}(f:key->option A->option B->option C) m1 m2 := + xmerge + (fun k o1 o2 => match o1,o2 with + | None,None => None + | _, _ => f k o1 o2 + end) + m1 m2 xH. + + Lemma merge_spec1 {A B C}(f:key->option A->option B->option C) : + forall m m' x, + In x m \/ In x m' -> + exists y, E.eq y x /\ + find x (merge f m m') = f y (find x m) (find x m'). + Proof. + intros. exists x. split. reflexivity. + unfold merge. + rewrite xgmerge; simpl; auto. + rewrite <- 2 mem_spec, 2 mem_find in H. + destruct (find x m); simpl; auto. + destruct (find x m'); simpl; auto. intuition discriminate. + Qed. + + Lemma merge_spec2 {A B C}(f:key->option A->option B->option C) : + forall m m' x, In x (merge f m m') -> In x m \/ In x m'. + Proof. + intros. + rewrite <-mem_spec, mem_find in H. + unfold merge in H. + rewrite xgmerge in H; simpl; auto. + rewrite <- 2 mem_spec, 2 mem_find. + destruct (find x m); simpl in *; auto. + destruct (find x m'); simpl in *; auto. + Qed. + + Section Fold. + + Variables A B : Type. + Variable f : key -> A -> B -> B. + + (** the additional argument, [i], records the current path, in + reverse order (this should be more efficient: we reverse this argument + only at present nodes only, rather than at each node of the tree). + we also use this convention in all functions below + *) + + Fixpoint xfold (m : t A) (v : B) (i : key) := + match m with + | Leaf => v + | Node l (Some x) r => + xfold r (f (rev i) x (xfold l v i~0)) i~1 + | Node l None r => + xfold r (xfold l v i~0) i~1 + end. + Definition fold m i := xfold m i 1. + + End Fold. + + Lemma fold_spec : + forall {A}(m:t A){B}(i : B) (f : key -> A -> B -> B), + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. + Proof. + unfold fold, bindings. intros A m B i f. revert m i. + set (f' := fun a p => f (fst p) (snd p) a). + assert (H: forall m i j acc, + fold_left f' acc (xfold f m i j) = + fold_left f' (xbindings m j acc) i). + { induction m as [|l IHl o r IHr]; intros; trivial. + destruct o; simpl; now rewrite IHr, <- IHl. } + intros. exact (H m i 1 nil). + Qed. + + Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) : bool := + match m1, m2 with + | Leaf, _ => is_empty m2 + | _, Leaf => is_empty m1 + | Node l1 o1 r1, Node l2 o2 r2 => + (match o1, o2 with + | None, None => true + | Some v1, Some v2 => cmp v1 v2 + | _, _ => false + end) + &&& equal cmp l1 l2 &&& equal cmp r1 r2 + end. + + Definition Equal (A:Type)(m m':t A) := + forall y, find y m = find y m'. + Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp). + + Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool), + Equivb cmp m m' -> equal cmp m m' = true. + Proof. + induction m. + - (* m = Leaf *) + destruct 1 as (E,_); simpl. + apply is_empty_spec; intros k. + destruct (find k m') eqn:F; trivial. + assert (H : In k m') by now exists a. + rewrite <- E in H. + destruct H as (x,H). red in H. now rewrite gleaf in H. + - (* m = Node *) + destruct m'. + + (* m' = Leaf *) + destruct 1 as (E,_); simpl. + destruct o. + * assert (H : In xH (@Leaf A)). + { rewrite <- E. now exists a. } + destruct H as (e,H). now red in H. + * apply andb_true_intro; split; apply is_empty_spec; intros k. + destruct (find k m1) eqn:F; trivial. + assert (H : In (xO k) (@Leaf A)). + { rewrite <- E. exists a; auto. } + destruct H as (x,H). red in H. now rewrite gleaf in H. + destruct (find k m2) eqn:F; trivial. + assert (H : In (xI k) (@Leaf A)). + { rewrite <- E. exists a; auto. } + destruct H as (x,H). red in H. now rewrite gleaf in H. + + (* m' = Node *) + destruct 1. + assert (Equivb cmp m1 m'1). + { split. + intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto. + intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto. } + assert (Equivb cmp m2 m'2). + { split. + intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto. + intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto. } + simpl. + destruct o; destruct o0; simpl. + repeat (apply andb_true_intro; split); auto. + apply (H0 xH); red; auto. + generalize (H xH); unfold In, MapsTo; simpl; intuition. + destruct H4; try discriminate; eauto. + generalize (H xH); unfold In, MapsTo; simpl; intuition. + destruct H5; try discriminate; eauto. + apply andb_true_intro; split; auto. + Qed. + + Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool), + equal cmp m m' = true -> Equivb cmp m m'. + Proof. + induction m. + (* m = Leaf *) + simpl. + split; intros. + split. + destruct 1; red in H0; destruct k; discriminate. + rewrite is_empty_spec in H. + intros (e,H'). red in H'. now rewrite H in H'. + red in H0; destruct k; discriminate. + (* m = Node *) + destruct m'. + (* m' = Leaf *) + simpl. + destruct o; intros; try discriminate. + destruct (andb_prop _ _ H); clear H. + split; intros. + split; unfold In, MapsTo; destruct 1. + destruct k; simpl in *; try discriminate. + rewrite is_empty_spec in H1. + now rewrite H1 in H. + rewrite is_empty_spec in H0. + now rewrite H0 in H. + destruct k; simpl in *; discriminate. + unfold In, MapsTo; destruct k; simpl in *; discriminate. + (* m' = Node *) + destruct o; destruct o0; simpl; intros; try discriminate. + destruct (andb_prop _ _ H); clear H. + destruct (andb_prop _ _ H0); clear H0. + destruct (IHm1 _ _ H2); clear H2 IHm1. + destruct (IHm2 _ _ H1); clear H1 IHm2. + split; intros. + destruct k; unfold In, MapsTo in *; simpl; auto. + split; eauto. + destruct k; unfold In, MapsTo in *; simpl in *. + eapply H4; eauto. + eapply H3; eauto. + congruence. + destruct (andb_prop _ _ H); clear H. + destruct (IHm1 _ _ H0); clear H0 IHm1. + destruct (IHm2 _ _ H1); clear H1 IHm2. + split; intros. + destruct k; unfold In, MapsTo in *; simpl; auto. + split; eauto. + destruct k; unfold In, MapsTo in *; simpl in *. + eapply H3; eauto. + eapply H2; eauto. + try discriminate. + Qed. + + Lemma equal_spec : forall (A:Type)(m m':t A)(cmp:A->A->bool), + equal cmp m m' = true <-> Equivb cmp m m'. + Proof. + split. apply equal_2. apply equal_1. + Qed. + +End PositiveMap. + +(** Here come some additionnal facts about this implementation. + Most are facts that cannot be derivable from the general interface. *) + +Module PositiveMapAdditionalFacts. + Import PositiveMap. + + (* Derivable from the Map interface *) + Theorem gsspec {A} i j x (m: t A) : + find i (add j x m) = if E.eq_dec i j then Some x else find i m. + Proof. + destruct (E.eq_dec i j) as [->|]; + [ apply add_spec1 | apply add_spec2; auto ]. + Qed. + + (* Not derivable from the Map interface *) + Theorem gsident {A} i (m:t A) v : + find i m = Some v -> add i v m = m. + Proof. + revert m. + induction i; destruct m; simpl in *; try congruence. + - intro H; now rewrite (IHi m2 H). + - intro H; now rewrite (IHi m1 H). + Qed. + + Lemma xmapi_ext {A B}(f g: key -> option A -> option B) : + (forall k (o : option A), f k o = g k o) -> + forall m i, xmapi f m i = xmapi g m i. + Proof. + induction m; intros; simpl; auto. now f_equal. + Qed. + + Theorem xmerge_commut{A B C} + (f: key -> option A -> option B -> option C) + (g: key -> option B -> option A -> option C) : + (forall k o1 o2, f k o1 o2 = g k o2 o1) -> + forall m1 m2 i, xmerge f m1 m2 i = xmerge g m2 m1 i. + Proof. + intros E. + induction m1; destruct m2; intros i; simpl; trivial; f_equal; + try apply IHm1_1; try apply IHm1_2; try apply xmapi_ext; + intros; apply E. + Qed. + + Theorem merge_commut{A B C} + (f: key -> option A -> option B -> option C) + (g: key -> option B -> option A -> option C) : + (forall k o1 o2, f k o1 o2 = g k o2 o1) -> + forall m1 m2, merge f m1 m2 = merge g m2 m1. + Proof. + intros E m1 m2. + unfold merge. apply xmerge_commut. + intros k [x1|] [x2|]; trivial. + Qed. + +End PositiveMapAdditionalFacts. diff --git a/theories/MMaps/MMapWeakList.v b/theories/MMaps/MMapWeakList.v new file mode 100644 index 00000000..656c61e1 --- /dev/null +++ b/theories/MMaps/MMapWeakList.v @@ -0,0 +1,687 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(** * Finite map library *) + +(** This file proposes an implementation of the non-dependant interface + [MMapInterface.WS] using lists of pairs, unordered but without redundancy. *) + +Require Import MMapInterface EqualitiesFacts. + +Set Implicit Arguments. +Unset Strict Implicit. + +Lemma Some_iff {A} (a a' : A) : Some a = Some a' <-> a = a'. +Proof. split; congruence. Qed. + +Module Raw (X:DecidableType). + +Module Import PX := KeyDecidableType X. + +Definition key := X.t. +Definition t (elt:Type) := list (X.t * elt). + +Ltac dec := match goal with + | |- context [ X.eq_dec ?x ?x ] => + let E := fresh "E" in destruct (X.eq_dec x x) as [E|E]; [ | now elim E] + | H : X.eq ?x ?y |- context [ X.eq_dec ?x ?y ] => + let E := fresh "E" in destruct (X.eq_dec x y) as [_|E]; [ | now elim E] + | H : ~X.eq ?x ?y |- context [ X.eq_dec ?x ?y ] => + let E := fresh "E" in destruct (X.eq_dec x y) as [E|_]; [ now elim H | ] + | |- context [ X.eq_dec ?x ?y ] => + let E := fresh "E" in destruct (X.eq_dec x y) as [E|E] +end. + +Section Elt. + +Variable elt : Type. +Notation NoDupA := (@NoDupA _ eqk). + +(** * [find] *) + +Fixpoint find (k:key) (s: t elt) : option elt := + match s with + | nil => None + | (k',x)::s' => if X.eq_dec k k' then Some x else find k s' + end. + +Lemma find_spec : forall m (Hm:NoDupA m) x e, + find x m = Some e <-> MapsTo x e m. +Proof. + unfold PX.MapsTo. + induction m as [ | (k,e) m IH]; simpl. + - split; inversion 1. + - intros Hm k' e'. rewrite InA_cons. + change (eqke (k',e') (k,e)) with (X.eq k' k /\ e' = e). + inversion_clear Hm. dec. + + rewrite Some_iff; intuition. + elim H. apply InA_eqk with (k',e'); auto. + + rewrite IH; intuition. +Qed. + +(** * [mem] *) + +Fixpoint mem (k : key) (s : t elt) : bool := + match s with + | nil => false + | (k',_) :: l => if X.eq_dec k k' then true else mem k l + end. + +Lemma mem_spec : forall m (Hm:NoDupA m) x, mem x m = true <-> In x m. +Proof. + induction m as [ | (k,e) m IH]; simpl; intros Hm x. + - split. discriminate. inversion_clear 1. inversion H0. + - inversion_clear Hm. rewrite PX.In_cons; simpl. + rewrite <- IH by trivial. + dec; intuition. +Qed. + +(** * [empty] *) + +Definition empty : t elt := nil. + +Lemma empty_spec x : find x empty = None. +Proof. + reflexivity. +Qed. + +Lemma empty_NoDup : NoDupA empty. +Proof. + unfold empty; auto. +Qed. + +(** * [is_empty] *) + +Definition is_empty (l : t elt) : bool := if l then true else false. + +Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None. +Proof. + destruct m; simpl; intuition; try discriminate. + specialize (H a). + revert H. now dec. +Qed. + +(* Not part of the exported specifications, used later for [merge]. *) + +Lemma find_eq : forall m (Hm:NoDupA m) x x', + X.eq x x' -> find x m = find x' m. +Proof. + induction m; simpl; auto; destruct a; intros. + inversion_clear Hm. + rewrite (IHm H1 x x'); auto. + dec; dec; trivial. + elim E0. now transitivity x. + elim E. now transitivity x'. +Qed. + +(** * [add] *) + +Fixpoint add (k : key) (x : elt) (s : t elt) : t elt := + match s with + | nil => (k,x) :: nil + | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l + end. + +Lemma add_spec1 m x e : find x (add x e m) = Some e. +Proof. + induction m as [ | (k,e') m IH]; simpl. + - now dec. + - dec; simpl; now dec. +Qed. + +Lemma add_spec2 m x y e : ~X.eq x y -> find y (add x e m) = find y m. +Proof. + intros N. + assert (N' : ~X.eq y x) by now contradict N. + induction m as [ | (k,e') m IH]; simpl. + - dec; trivial. + - repeat (dec; simpl); trivial. elim N. now transitivity k. +Qed. + +Lemma add_InA : forall m x y e e', + ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. +Proof. + induction m as [ | (k,e') m IH]; simpl; intros. + - inversion_clear H0. elim H. symmetry; apply H1. inversion_clear H1. + - revert H0; dec; rewrite !InA_cons. + + rewrite E. intuition. + + intuition. right; eapply IH; eauto. +Qed. + +Lemma add_NoDup : forall m (Hm:NoDupA m) x e, NoDupA (add x e m). +Proof. + induction m as [ | (k,e') m IH]; simpl; intros Hm x e. + - constructor; auto. now inversion 1. + - inversion_clear Hm. dec; constructor; auto. + + contradict H. apply InA_eqk with (x,e); auto. + + contradict H; apply add_InA with x e; auto. +Qed. + +(** * [remove] *) + +Fixpoint remove (k : key) (s : t elt) : t elt := + match s with + | nil => nil + | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l + end. + +Lemma remove_spec1 m (Hm: NoDupA m) x : find x (remove x m) = None. +Proof. + induction m as [ | (k,e') m IH]; simpl; trivial. + inversion_clear Hm. + repeat (dec; simpl); auto. + destruct (find x m) eqn:F; trivial. + apply find_spec in F; trivial. + elim H. apply InA_eqk with (x,e); auto. +Qed. + +Lemma remove_spec2 m (Hm: NoDupA m) x y : ~X.eq x y -> + find y (remove x m) = find y m. +Proof. + induction m as [ | (k,e') m IH]; simpl; trivial; intros E. + inversion_clear Hm. + repeat (dec; simpl); auto. + elim E. now transitivity k. +Qed. + +Lemma remove_InA : forall m (Hm:NoDupA m) x y e, + InA eqk (y,e) (remove x m) -> InA eqk (y,e) m. +Proof. + induction m as [ | (k,e') m IH]; simpl; trivial; intros. + inversion_clear Hm. + revert H; dec; rewrite !InA_cons; intuition. + right; eapply H; eauto. +Qed. + +Lemma remove_NoDup : forall m (Hm:NoDupA m) x, NoDupA (remove x m). +Proof. + induction m. + simpl; intuition. + intros. + inversion_clear Hm. + destruct a as (x',e'). + simpl; case (X.eq_dec x x'); auto. + constructor; auto. + contradict H; apply remove_InA with x; auto. +Qed. + +(** * [bindings] *) + +Definition bindings (m: t elt) := m. + +Lemma bindings_spec1 m x e : InA eqke (x,e) (bindings m) <-> MapsTo x e m. +Proof. + reflexivity. +Qed. + +Lemma bindings_spec2w m (Hm:NoDupA m) : NoDupA (bindings m). +Proof. + trivial. +Qed. + +(** * [fold] *) + +Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) : A := + match m with + | nil => acc + | (k,e)::m' => fold f m' (f k e acc) + end. + +Lemma fold_spec : forall m (A:Type)(i:A)(f:key->elt->A->A), + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. +Proof. + induction m as [ | (k,e) m IH]; simpl; auto. +Qed. + +(** * [equal] *) + +Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := + match find k m' with + | None => false + | Some e' => cmp e e' + end. + +Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := + fold (fun k e b => andb (check cmp k e m') b) m true. + +Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool := + andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m). + +Definition Submap (cmp:elt->elt->bool) m m' := + (forall k, In k m -> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). + +Definition Equivb (cmp:elt->elt->bool) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). + +Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + Submap cmp m m' -> submap cmp m m' = true. +Proof. + unfold Submap, submap. + induction m. + simpl; auto. + destruct a; simpl; intros. + destruct H. + inversion_clear Hm. + assert (H3 : In t0 m'). + { apply H; exists e; auto with *. } + destruct H3 as (e', H3). + assert (H4 : find t0 m' = Some e') by now apply find_spec. + unfold check at 2. rewrite H4. + rewrite (H0 t0); simpl; auto with *. + eapply IHm; auto. + split; intuition. + apply H. + destruct H6 as (e'',H6); exists e''; auto. + apply H0 with k; auto. +Qed. + +Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + submap cmp m m' = true -> Submap cmp m m'. +Proof. + unfold Submap, submap. + induction m. + simpl; auto. + intuition. + destruct H0; inversion H0. + inversion H0. + + destruct a; simpl; intros. + inversion_clear Hm. + rewrite andb_b_true in H. + assert (check cmp t0 e m' = true). + clear H1 H0 Hm' IHm. + set (b:=check cmp t0 e m') in *. + generalize H; clear H; generalize b; clear b. + induction m; simpl; auto; intros. + destruct a; simpl in *. + destruct (andb_prop _ _ (IHm _ H)); auto. + rewrite H2 in H. + destruct (IHm H1 m' Hm' cmp H); auto. + unfold check in H2. + case_eq (find t0 m'); [intros e' H5 | intros H5]; + rewrite H5 in H2; try discriminate. + split; intros. + destruct H6 as (e0,H6); inversion_clear H6. + compute in H7; destruct H7; subst. + exists e'. + apply PX.MapsTo_eq with t0; auto with *. + apply find_spec; auto. + apply H3. + exists e0; auto. + inversion_clear H6. + compute in H8; destruct H8; subst. + assert (H8 : MapsTo t0 e'0 m'). { eapply PX.MapsTo_eq; eauto. } + apply find_spec in H8; trivial. congruence. + apply H4 with k; auto. +Qed. + +(** Specification of [equal] *) + +Lemma equal_spec : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + equal cmp m m' = true <-> Equivb cmp m m'. +Proof. + unfold Equivb, equal. + split. + - intros. + destruct (andb_prop _ _ H); clear H. + generalize (submap_2 Hm Hm' H0). + generalize (submap_2 Hm' Hm H1). + firstorder. + - intuition. + apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder. +Qed. +End Elt. +Section Elt2. +Variable elt elt' : Type. + +(** * [map] and [mapi] *) + +Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := + match m with + | nil => nil + | (k,e)::m' => (k,f e) :: map f m' + end. + +Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := + match m with + | nil => nil + | (k,e)::m' => (k,f k e) :: mapi f m' + end. + +(** Specification of [map] *) + +Lemma map_spec (f:elt->elt')(m:t elt)(x:key) : + find x (map f m) = option_map f (find x m). +Proof. + induction m as [ | (k,e) m IH]; simpl; trivial. + dec; simpl; trivial. +Qed. + +Lemma map_NoDup m (Hm : NoDupA (@eqk elt) m)(f:elt->elt') : + NoDupA (@eqk elt') (map f m). +Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear Hm. + constructor; auto. + contradict H. + clear IHm H0. + induction m; simpl in *; auto. + inversion H. + destruct a; inversion H; auto. +Qed. + +(** Specification of [mapi] *) + +Lemma mapi_spec (f:key->elt->elt')(m:t elt)(x:key) : + exists y, X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). +Proof. + induction m as [ | (k,e) m IH]; simpl; trivial. + - now exists x. + - dec; simpl. + + now exists k. + + destruct IH as (y,(Hy,H)). now exists y. +Qed. + +Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), + NoDupA (@eqk elt') (mapi f m). +Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear Hm; auto. + constructor; auto. + contradict H. + clear IHm H0. + induction m; simpl in *; auto. + inversion_clear H. + destruct a; inversion_clear H; auto. +Qed. + +End Elt2. + +Lemma mapfst_InA {elt}(m:t elt) x : + InA X.eq x (List.map fst m) <-> In x m. +Proof. + induction m as [| (k,e) m IH]; simpl; auto. + - split; inversion 1. inversion H0. + - rewrite InA_cons, In_cons. simpl. now rewrite IH. +Qed. + +Lemma mapfst_NoDup {elt}(m:t elt) : + NoDupA X.eq (List.map fst m) <-> NoDupA eqk m. +Proof. + induction m as [| (k,e) m IH]; simpl. + - split; constructor. + - split; inversion_clear 1; constructor; try apply IH; trivial. + + contradict H0. rewrite mapfst_InA. eapply In_alt'; eauto. + + rewrite mapfst_InA. contradict H0. now apply In_alt'. +Qed. + +Lemma filter_NoDup f (m:list key) : + NoDupA X.eq m -> NoDupA X.eq (List.filter f m). +Proof. + induction 1; simpl. + - constructor. + - destruct (f x); trivial. constructor; trivial. + contradict H. rewrite InA_alt in *. destruct H as (y,(Hy,H)). + exists y; split; trivial. now rewrite filter_In in H. +Qed. + +Lemma NoDupA_unique_repr (l:list key) x y : + NoDupA X.eq l -> X.eq x y -> List.In x l -> List.In y l -> x = y. +Proof. + intros H E Hx Hy. + induction H; simpl in *. + - inversion Hx. + - intuition; subst; trivial. + elim H. apply InA_alt. now exists y. + elim H. apply InA_alt. now exists x. +Qed. + +Section Elt3. + +Variable elt elt' elt'' : Type. + +Definition restrict (m:t elt)(k:key) := + match find k m with + | None => true + | Some _ => false + end. + +Definition domains (m:t elt)(m':t elt') := + List.map fst m ++ List.filter (restrict m) (List.map fst m'). + +Lemma domains_InA m m' (Hm : NoDupA eqk m) x : + InA X.eq x (domains m m') <-> In x m \/ In x m'. +Proof. + unfold domains. + assert (Proper (X.eq==>eq) (restrict m)). + { intros k k' Hk. unfold restrict. now rewrite (find_eq Hm Hk). } + rewrite InA_app_iff, filter_InA, !mapfst_InA; intuition. + unfold restrict. + destruct (find x m) eqn:F. + - left. apply find_spec in F; trivial. now exists e. + - now right. +Qed. + +Lemma domains_NoDup m m' : NoDupA eqk m -> NoDupA eqk m' -> + NoDupA X.eq (domains m m'). +Proof. + intros Hm Hm'. unfold domains. + apply NoDupA_app; auto with *. + - now apply mapfst_NoDup. + - now apply filter_NoDup, mapfst_NoDup. + - intros x. + rewrite mapfst_InA. intros (e,H). + apply find_spec in H; trivial. + rewrite InA_alt. intros (y,(Hy,H')). + rewrite (find_eq Hm Hy) in H. + rewrite filter_In in H'. destruct H' as (_,H'). + unfold restrict in H'. now rewrite H in H'. +Qed. + +Fixpoint fold_keys (f:key->option elt'') l := + match l with + | nil => nil + | k::l => + match f k with + | Some e => (k,e)::fold_keys f l + | None => fold_keys f l + end + end. + +Lemma fold_keys_In f l x e : + List.In (x,e) (fold_keys f l) <-> List.In x l /\ f x = Some e. +Proof. + induction l as [|k l IH]; simpl. + - intuition. + - destruct (f k) eqn:F; simpl; rewrite IH; clear IH; intuition; + try left; congruence. +Qed. + +Lemma fold_keys_NoDup f l : + NoDupA X.eq l -> NoDupA eqk (fold_keys f l). +Proof. + induction 1; simpl. + - constructor. + - destruct (f x); trivial. + constructor; trivial. contradict H. + apply InA_alt in H. destruct H as ((k,e'),(E,H)). + rewrite fold_keys_In in H. + apply InA_alt. exists k. now split. +Qed. + +Variable f : key -> option elt -> option elt' -> option elt''. + +Definition merge m m' : t elt'' := + fold_keys (fun k => f k (find k m) (find k m')) (domains m m'). + +Lemma merge_NoDup m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m') : + NoDupA (@eqk elt'') (merge m m'). +Proof. + now apply fold_keys_NoDup, domains_NoDup. +Qed. + +Lemma merge_spec1 m (Hm:NoDupA eqk m) m' (Hm':NoDupA eqk m') x : + In x m \/ In x m' -> + exists y:key, X.eq y x /\ + find x (merge m m') = f y (find x m) (find x m'). +Proof. + assert (Hmm' : NoDupA eqk (merge m m')) by now apply merge_NoDup. + rewrite <- domains_InA; trivial. + rewrite InA_alt. intros (y,(Hy,H)). + exists y; split; [easy|]. + rewrite (find_eq Hm Hy), (find_eq Hm' Hy). + destruct (f y (find y m) (find y m')) eqn:F. + - apply find_spec; trivial. + red. apply InA_alt. exists (y,e). split. now split. + unfold merge. apply fold_keys_In. now split. + - destruct (find x (merge m m')) eqn:F'; trivial. + rewrite <- F; clear F. symmetry. + apply find_spec in F'; trivial. + red in F'. rewrite InA_alt in F'. + destruct F' as ((y',e'),(E,F')). + unfold merge in F'; rewrite fold_keys_In in F'. + destruct F' as (H',F'). + compute in E; destruct E as (Hy',<-). + replace y with y'; trivial. + apply (@NoDupA_unique_repr (domains m m')); auto. + now apply domains_NoDup. + now transitivity x. +Qed. + +Lemma merge_spec2 m (Hm:NoDupA eqk m) m' (Hm':NoDupA eqk m') x : + In x (merge m m') -> In x m \/ In x m'. +Proof. + rewrite <- domains_InA; trivial. + intros (e,H). red in H. rewrite InA_alt in H. destruct H as ((k,e'),(E,H)). + unfold merge in H; rewrite fold_keys_In in H. destruct H as (H,_). + apply InA_alt. exists k. split; trivial. now destruct E. +Qed. + +End Elt3. +End Raw. + + +Module Make (X: DecidableType) <: WS with Module E:=X. + Module Raw := Raw X. + + Module E := X. + Definition key := E.t. + Definition eq_key {elt} := @Raw.PX.eqk elt. + Definition eq_key_elt {elt} := @Raw.PX.eqke elt. + + Record t_ (elt:Type) := Mk + {this :> Raw.t elt; + nodup : NoDupA Raw.PX.eqk this}. + Definition t := t_. + + Definition empty {elt} : t elt := Mk (Raw.empty_NoDup elt). + +Section Elt. + Variable elt elt' elt'':Type. + Implicit Types m : t elt. + Implicit Types x y : key. + Implicit Types e : elt. + + Definition find x m : option elt := Raw.find x m.(this). + Definition mem x m : bool := Raw.mem x m.(this). + Definition is_empty m : bool := Raw.is_empty m.(this). + Definition add x e m : t elt := Mk (Raw.add_NoDup m.(nodup) x e). + Definition remove x m : t elt := Mk (Raw.remove_NoDup m.(nodup) x). + Definition map f m : t elt' := Mk (Raw.map_NoDup m.(nodup) f). + Definition mapi (f:key->elt->elt') m : t elt' := + Mk (Raw.mapi_NoDup m.(nodup) f). + Definition merge f m (m':t elt') : t elt'' := + Mk (Raw.merge_NoDup f m.(nodup) m'.(nodup)). + Definition bindings m : list (key*elt) := Raw.bindings m.(this). + Definition cardinal m := length m.(this). + Definition fold {A}(f:key->elt->A->A) m (i:A) : A := Raw.fold f m.(this) i. + Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). + Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). + Definition In x m : Prop := Raw.PX.In x m.(this). + + Definition Equal m m' := forall y, find y m = find y m'. + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equivb cmp m m' : Prop := Raw.Equivb cmp m.(this) m'.(this). + + Instance MapsTo_compat : + Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. + Proof. + intros x x' Hx e e' <- m m' <-. unfold MapsTo. now rewrite Hx. + Qed. + + Lemma find_spec m : forall x e, find x m = Some e <-> MapsTo x e m. + Proof. exact (Raw.find_spec m.(nodup)). Qed. + + Lemma mem_spec m : forall x, mem x m = true <-> In x m. + Proof. exact (Raw.mem_spec m.(nodup)). Qed. + + Lemma empty_spec : forall x, find x empty = None. + Proof. exact (Raw.empty_spec _). Qed. + + Lemma is_empty_spec m : is_empty m = true <-> (forall x, find x m = None). + Proof. exact (Raw.is_empty_spec m.(this)). Qed. + + Lemma add_spec1 m : forall x e, find x (add x e m) = Some e. + Proof. exact (Raw.add_spec1 m.(this)). Qed. + Lemma add_spec2 m : forall x y e, ~E.eq x y -> find y (add x e m) = find y m. + Proof. exact (Raw.add_spec2 m.(this)). Qed. + + Lemma remove_spec1 m : forall x, find x (remove x m) = None. + Proof. exact (Raw.remove_spec1 m.(nodup)). Qed. + Lemma remove_spec2 m : forall x y, ~E.eq x y -> find y (remove x m) = find y m. + Proof. exact (Raw.remove_spec2 m.(nodup)). Qed. + + Lemma bindings_spec1 m : forall x e, + InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. + Proof. exact (Raw.bindings_spec1 m.(this)). Qed. + Lemma bindings_spec2w m : NoDupA eq_key (bindings m). + Proof. exact (Raw.bindings_spec2w m.(nodup)). Qed. + + Lemma cardinal_spec m : cardinal m = length (bindings m). + Proof. reflexivity. Qed. + + Lemma fold_spec m : forall (A : Type) (i : A) (f : key -> elt -> A -> A), + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. + Proof. exact (Raw.fold_spec m.(this)). Qed. + + Lemma equal_spec m m' : forall cmp, equal cmp m m' = true <-> Equivb cmp m m'. + Proof. exact (Raw.equal_spec m.(nodup) m'.(nodup)). Qed. + +End Elt. + + Lemma map_spec {elt elt'} (f:elt->elt') m : + forall x, find x (map f m) = option_map f (find x m). + Proof. exact (Raw.map_spec f m.(this)). Qed. + + Lemma mapi_spec {elt elt'} (f:key->elt->elt') m : + forall x, exists y, + E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). + Proof. exact (Raw.mapi_spec f m.(this)). Qed. + + Lemma merge_spec1 {elt elt' elt''} + (f:key->option elt->option elt'->option elt'') m m' : + forall x, + In x m \/ In x m' -> + exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m'). + Proof. exact (Raw.merge_spec1 f m.(nodup) m'.(nodup)). Qed. + + Lemma merge_spec2 {elt elt' elt''} + (f:key->option elt->option elt'->option elt'') m m' : + forall x, + In x (merge f m m') -> In x m \/ In x m'. + Proof. exact (Raw.merge_spec2 m.(nodup) m'.(nodup)). Qed. + +End Make. diff --git a/theories/MMaps/MMaps.v b/theories/MMaps/MMaps.v new file mode 100644 index 00000000..054d0722 --- /dev/null +++ b/theories/MMaps/MMaps.v @@ -0,0 +1,16 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + + +Require Export Orders OrdersEx OrdersAlt. +Require Export Equalities. +Require Export MMapInterface. +Require Export MMapFacts. +Require Export MMapWeakList. +Require Export MMapList. +Require Export MMapPositive. diff --git a/theories/MMaps/vo.itarget b/theories/MMaps/vo.itarget new file mode 100644 index 00000000..a7bbd266 --- /dev/null +++ b/theories/MMaps/vo.itarget @@ -0,0 +1,7 @@ +MMapInterface.vo +MMapFacts.vo +MMapWeakList.vo +MMapList.vo +MMapPositive.vo +MMaps.vo +MMapAVL.vo
\ No newline at end of file diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index e1fc454a..cc023cc3 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -31,7 +31,7 @@ code after extraction. *) -Require Import MSetInterface MSetGenTree ZArith Int. +Require Import MSetInterface MSetGenTree BinInt Int. Set Implicit Arguments. Unset Strict Implicit. @@ -83,11 +83,11 @@ Definition assert_false := create. Definition bal l x r := let hl := height l in let hr := height r in - if gt_le_dec hl (hr+2) then + if (hr+2) <? hl then match l with | Leaf => assert_false l x r | Node _ ll lx lr => - if ge_lt_dec (height ll) (height lr) then + if (height lr) <=? (height ll) then create ll lx (create lr x r) else match lr with @@ -97,11 +97,11 @@ Definition bal l x r := end end else - if gt_le_dec hr (hl+2) then + if (hl+2) <? hr then match r with | Leaf => assert_false l x r | Node _ rl rx rr => - if ge_lt_dec (height rr) (height rl) then + if (height rl) <=? (height rr) then create (create l x rl) rx rr else match rl with @@ -138,8 +138,8 @@ Fixpoint join l : elt -> t -> t := fix join_aux (r:t) : t := match r with | Leaf => add x l | Node rh rl rx rr => - if gt_le_dec lh (rh+2) then bal ll lx (join lr x r) - else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr + if (rh+2) <? lh then bal ll lx (join lr x r) + else if (lh+2) <? rh then bal (join_aux rl) rx rr else create l x r end end. @@ -419,12 +419,12 @@ Local Open Scope Int_scope. Ltac join_tac := intro l; induction l as [| lh ll _ lx lr Hlr]; [ | intros x r; induction r as [| rh rl Hrl rx rr _]; unfold join; - [ | destruct (gt_le_dec lh (rh+2)) as [GT|LE]; + [ | destruct ((rh+2) <? lh) eqn:LT; [ match goal with |- context b [ bal ?a ?b ?c] => replace (bal a b c) with (bal ll lx (join lr x (Node rh rl rx rr))); [ | auto] end - | destruct (gt_le_dec rh (lh+2)) as [GT'|LE']; + | destruct ((lh+2) <? rh) eqn:LT'; [ match goal with |- context b [ bal ?a ?b ?c] => replace (bal a b c) with (bal (join (Node lh ll lx lr) x rl) rx rr); [ | auto] diff --git a/theories/MSets/MSetPositive.v b/theories/MSets/MSetPositive.v index 25a8c162..8dd240f4 100644 --- a/theories/MSets/MSetPositive.v +++ b/theories/MSets/MSetPositive.v @@ -16,79 +16,13 @@ Sandrine Blazy (used for building certified compilers). *) -Require Import Bool BinPos Orders MSetInterface. +Require Import Bool BinPos Orders OrdersEx MSetInterface. Set Implicit Arguments. Local Open Scope lazy_bool_scope. Local Open Scope positive_scope. Local Unset Elimination Schemes. -(** Even if [positive] can be seen as an ordered type with respect to the - usual order (see above), we can also use a lexicographic order over bits - (lower bits are considered first). This is more natural when using - [positive] as indexes for sets or maps (see FSetPositive and FMapPositive. *) - -Module PositiveOrderedTypeBits <: UsualOrderedType. - Definition t:=positive. - Include HasUsualEq <+ UsualIsEq. - Definition eqb := Pos.eqb. - Definition eqb_eq := Pos.eqb_eq. - Include HasEqBool2Dec. - - Fixpoint bits_lt (p q:positive) : Prop := - match p, q with - | xH, xI _ => True - | xH, _ => False - | xO p, xO q => bits_lt p q - | xO _, _ => True - | xI p, xI q => bits_lt p q - | xI _, _ => False - end. - - Definition lt:=bits_lt. - - Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x. - Proof. - induction x; simpl; auto. - Qed. - - Lemma bits_lt_trans : - forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z. - Proof. - induction x; destruct y,z; simpl; eauto; intuition. - Qed. - - Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. - intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition. - Qed. - - Instance lt_strorder : StrictOrder lt. - Proof. - split; [ exact bits_lt_antirefl | exact bits_lt_trans ]. - Qed. - - Fixpoint compare x y := - match x, y with - | x~1, y~1 => compare x y - | x~1, _ => Gt - | x~0, y~0 => compare x y - | x~0, _ => Lt - | 1, y~1 => Lt - | 1, 1 => Eq - | 1, y~0 => Gt - end. - - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). - Proof. - unfold eq, lt. - induction x; destruct y; try constructor; simpl; auto. - destruct (IHx y); subst; auto. - destruct (IHx y); subst; auto. - Qed. - -End PositiveOrderedTypeBits. - Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Module E:=PositiveOrderedTypeBits. @@ -303,12 +237,6 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. | Node l true r => S (cardinal l + cardinal r) end. - Definition omap (f: elt -> elt) x := - match x with - | None => None - | Some i => Some (f i) - end. - (** would it be more efficient to use a path like in the above functions ? *) Fixpoint choose (m: t) : option elt := @@ -316,7 +244,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. | Leaf => None | Node l o r => if o then Some 1 else match choose l with - | None => omap xI (choose r) + | None => option_map xI (choose r) | Some i => Some i~0 end end. @@ -326,7 +254,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. | Leaf => None | Node l o r => match min_elt l with - | None => if o then Some 1 else omap xI (min_elt r) + | None => if o then Some 1 else option_map xI (min_elt r) | Some i => Some i~0 end end. @@ -336,7 +264,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. | Leaf => None | Node l o r => match max_elt r with - | None => if o then Some 1 else omap xO (max_elt l) + | None => if o then Some 1 else option_map xO (max_elt l) | Some i => Some i~1 end end. @@ -967,7 +895,6 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Lemma elements_spec2w: forall s, NoDupA E.eq (elements s). Proof. intro. apply SortA_NoDupA with E.lt; auto with *. - apply E.eq_equiv. apply elements_spec2. Qed. diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index a9aa30df..ae6fe7dd 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -426,8 +426,9 @@ Ltac depind id := do_depind ltac:(fun hyp => do_ind hyp) id. (** A variant where generalized variables should be given by the user. *) Ltac do_depelim' rev tac H := - (try intros until H) ; block_goal ; rev H ; - (try revert_until H ; block_goal) ; generalize_eqs H ; tac H ; simpl_dep_elim. + (try intros until H) ; block_goal ; + (try revert_until H ; block_goal) ; + generalize_eqs H ; rev H ; tac H ; simpl_dep_elim. (** Calls [destruct] on the generalized hypothesis, results should be similar to inversion. By default, we don't try to generalize the hyp by its variable indices. *) @@ -463,3 +464,9 @@ Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) : Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => induction hyp using c) H. + +Tactic Notation "dependent" "induction" ident(H) "in" ne_hyp_list(l) := + do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => induction hyp in l) H. + +Tactic Notation "dependent" "induction" ident(H) "in" ne_hyp_list(l) "using" constr(c) := + do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => induction hyp in l using c) H. diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v index e39128cb..65fe8780 100644 --- a/theories/Program/Utils.v +++ b/theories/Program/Utils.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** Various syntaxic shortands that are useful with [Program]. *) +(** Various syntactic shorthands that are useful with [Program]. *) Require Export Coq.Program.Tactics. diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v index e848e4df..011328ec 100644 --- a/theories/Reals/Alembert.v +++ b/theories/Reals/Alembert.v @@ -572,6 +572,7 @@ Lemma Alembert_C6 : (forall n:nat, An n <> 0) -> Un_cv (fun n:nat => Rabs (An (S n) / An n)) k -> Rabs x < / k -> { l:R | Pser An x l }. +Proof. intros. cut { l:R | Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l }. intro X. diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v index f5b34de9..6d30319c 100644 --- a/theories/Reals/Cos_rel.v +++ b/theories/Reals/Cos_rel.v @@ -10,7 +10,7 @@ Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. Require Import Rtrigo_def. -Require Import Omega. +Require Import OmegaTactic. Local Open Scope R_scope. Definition A1 (x:R) (N:nat) : R := @@ -50,6 +50,7 @@ Theorem cos_plus_form : forall (x y:R) (n:nat), (0 < n)%nat -> A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n). +Proof. intros. unfold A1, B1. rewrite @@ -251,12 +252,14 @@ apply lt_O_Sn. Qed. Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i. +Proof. intros. assert (H := pow_Rsqr x i). unfold Rsqr in H; exact H. Qed. Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x). +Proof. intro. unfold cos; destruct (exist_cos (Rsqr x)) as (x0,p). unfold cos_in, cos_n, infinite_sum, R_dist in p. @@ -276,6 +279,7 @@ apply pow_sqr. Qed. Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)). +Proof. intros. unfold cos. destruct (exist_cos (Rsqr (x + y))) as (x0,p). @@ -298,6 +302,7 @@ apply pow_sqr. Qed. Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x). +Proof. intro. case (Req_dec x 0); intro. rewrite H. diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v index 30a26f77..94b881cc 100644 --- a/theories/Reals/PSeries_reg.v +++ b/theories/Reals/PSeries_reg.v @@ -24,6 +24,7 @@ Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r. Lemma Boule_convex : forall c d x y z, Boule c d x -> Boule c d y -> x <= z <= y -> Boule c d z. +Proof. intros c d x y z bx b_y intz. unfold Boule in bx, b_y; apply Rabs_def2 in bx; apply Rabs_def2 in b_y; apply Rabs_def1; @@ -33,6 +34,7 @@ Qed. Definition boule_of_interval x y (h : x < y) : {c :R & {r : posreal | c - r = x /\ c + r = y}}. +Proof. exists ((x + y)/2). assert (radius : 0 < (y - x)/2). unfold Rdiv; apply Rmult_lt_0_compat. @@ -71,6 +73,7 @@ Qed. Lemma Ball_in_inter : forall c1 c2 r1 r2 x, Boule c1 r1 x -> Boule c2 r2 x -> {r3 : posreal | forall y, Boule x r3 y -> Boule c1 r1 y /\ Boule c2 r2 y}. +Proof. intros c1 c2 [r1 r1p] [r2 r2p] x; unfold Boule; simpl; intros in1 in2. assert (Rmax (c1 - r1)(c2 - r2) < x). apply Rmax_lub_lt;[revert in1 | revert in2]; intros h; @@ -366,6 +369,7 @@ Qed. (* Uniform convergence implies pointwise simple convergence *) Lemma CVU_cv : forall f g c d, CVU f g c d -> forall x, Boule c d x -> Un_cv (fun n => f n x) (g x). +Proof. intros f g c d cvu x bx eps ep; destruct (cvu eps ep) as [N Pn]. exists N; intros n nN; rewrite R_dist_sym; apply Pn; assumption. Qed. @@ -374,6 +378,7 @@ Qed. Lemma CVU_ext_lim : forall f g1 g2 c d, CVU f g1 c d -> (forall x, Boule c d x -> g1 x = g2 x) -> CVU f g2 c d. +Proof. intros f g1 g2 c d cvu q eps ep; destruct (cvu _ ep) as [N Pn]. exists N; intros; rewrite <- q; auto. Qed. @@ -388,6 +393,7 @@ Lemma CVU_derivable : (forall x, Boule c d x -> Un_cv (fun n => f n x) (g x)) -> (forall n x, Boule c d x -> derivable_pt_lim (f n) x (f' n x)) -> forall x, Boule c d x -> derivable_pt_lim g x (g' x). +Proof. intros f f' g g' c d cvu cvp dff' x bx. set (rho_ := fun n y => diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v index 68718db0..cc45139d 100644 --- a/theories/Reals/Ratan.v +++ b/theories/Reals/Ratan.v @@ -450,6 +450,7 @@ fourier. Qed. Definition frame_tan y : {x | 0 < x < PI/2 /\ Rabs y < tan x}. +Proof. destruct (total_order_T (Rabs y) 1) as [Hs|Hgt]. assert (yle1 : Rabs y <= 1) by (destruct Hs; fourier). clear Hs; exists 1; split;[split; [exact Rlt_0_1 | exact PI2_1] | ]. @@ -567,10 +568,12 @@ Lemma pos_opp_lt : forall x, 0 < x -> -x < x. Proof. intros; fourier. Qed. Lemma tech_opp_tan : forall x y, -tan x < y -> tan (-x) < y. +Proof. intros; rewrite tan_neg; assumption. Qed. Definition pre_atan (y : R) : {x : R | -PI/2 < x < PI/2 /\ tan x = y}. +Proof. destruct (frame_tan y) as [ub [[ub0 ubpi2] Ptan_ub]]. set (pr := (conj (tech_opp_tan _ _ (proj2 (Rabs_def2 _ _ Ptan_ub))) (proj1 (Rabs_def2 _ _ Ptan_ub)))). @@ -649,6 +652,7 @@ exact df_neq. Qed. Lemma atan_increasing : forall x y, x < y -> atan x < atan y. +Proof. intros x y d. assert (t1 := atan_bound x). assert (t2 := atan_bound y). @@ -663,6 +667,7 @@ solve[rewrite yx; apply Rle_refl]. Qed. Lemma atan_0 : atan 0 = 0. +Proof. apply tan_is_inj; try (apply atan_bound). assert (t := PI_RGT_0); rewrite Ropp_div; split; fourier. rewrite atan_right_inv, tan_0. @@ -670,6 +675,7 @@ reflexivity. Qed. Lemma atan_1 : atan 1 = PI/4. +Proof. assert (ut := PI_RGT_0). assert (-PI/2 < PI/4 < PI/2) by (rewrite Ropp_div; split; fourier). assert (t := atan_bound 1). @@ -865,6 +871,7 @@ Qed. Definition ps_atan_exists_01 (x : R) (Hx:0 <= x <= 1) : {l : R | Un_cv (fun N : nat => sum_f_R0 (tg_alt (Ratan_seq x)) N) l}. +Proof. exact (alternated_series (Ratan_seq x) (Ratan_seq_decreasing _ Hx) (Ratan_seq_converging _ Hx)). Defined. @@ -888,6 +895,7 @@ Qed. Definition ps_atan_exists_1 (x : R) (Hx : -1 <= x <= 1) : {l : R | Un_cv (fun N : nat => sum_f_R0 (tg_alt (Ratan_seq x)) N) l}. +Proof. destruct (Rle_lt_dec 0 x). assert (pr : 0 <= x <= 1) by tauto. exact (ps_atan_exists_01 x pr). @@ -902,6 +910,7 @@ solve[intros; exists 0%nat; intros; rewrite R_dist_eq; auto]. Qed. Definition in_int (x : R) : {-1 <= x <= 1}+{~ -1 <= x <= 1}. +Proof. destruct (Rle_lt_dec x 1). destruct (Rle_lt_dec (-1) x). left;split; auto. @@ -1563,6 +1572,7 @@ Qed. Theorem Alt_PI_eq : Alt_PI = PI. +Proof. apply Rmult_eq_reg_r with (/4); fold (Alt_PI/4); fold (PI/4); [ | apply Rgt_not_eq; fourier]. assert (0 < PI/6) by (apply PI6_RGT_0). diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v index 11d94c11..8e2b2d08 100644 --- a/theories/Structures/EqualitiesFacts.v +++ b/theories/Structures/EqualitiesFacts.v @@ -8,132 +8,172 @@ Require Import Equalities Bool SetoidList RelationPairs. -(** * Keys and datas used in FMap *) +Set Implicit Arguments. -Module KeyDecidableType(Import D:DecidableType). +(** * Keys and datas used in MMap *) - Section Elt. - Variable elt : Type. - Notation key:=t. +Module KeyDecidableType(D:DecidableType). - Local Open Scope signature_scope. + Local Open Scope signature_scope. + Local Notation key := D.t. - Definition eqk : relation (key*elt) := eq @@1. - Definition eqke : relation (key*elt) := eq * Logic.eq. - Hint Unfold eqk eqke. + Definition eqk {elt} : relation (key*elt) := D.eq @@1. + Definition eqke {elt} : relation (key*elt) := D.eq * Logic.eq. - (* eqke is stricter than eqk *) + Hint Unfold eqk eqke. - Global Instance eqke_eqk : subrelation eqke eqk. - Proof. firstorder. Qed. + (** eqk, eqke are equalities *) - (* eqk, eqke are equalities, ltk is a strict order *) + Instance eqk_equiv {elt} : Equivalence (@eqk elt) := _. - Global Instance eqk_equiv : Equivalence eqk := _. + Instance eqke_equiv {elt} : Equivalence (@eqke elt) := _. - Global Instance eqke_equiv : Equivalence eqke := _. + (** eqke is stricter than eqk *) - (* Additionnal facts *) + Instance eqke_eqk {elt} : subrelation (@eqke elt) (@eqk elt). + Proof. firstorder. Qed. - Lemma InA_eqke_eqk : - forall x m, InA eqke x m -> InA eqk x m. - Proof. - unfold eqke, RelProd; induction 1; firstorder. - Qed. - Hint Resolve InA_eqke_eqk. + (** Alternative definitions of eqke and eqk *) - Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. - Proof. - intros. rewrite <- H; auto. - Qed. + Lemma eqke_def {elt} k k' (e e':elt) : + eqke (k,e) (k',e') = (D.eq k k' /\ e = e'). + Proof. reflexivity. Defined. - Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). - Definition In k m := exists e:elt, MapsTo k e m. + Lemma eqke_def' {elt} (p q:key*elt) : + eqke p q = (D.eq (fst p) (fst q) /\ snd p = snd q). + Proof. reflexivity. Defined. - Hint Unfold MapsTo In. + Lemma eqke_1 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> D.eq k k'. + Proof. now destruct 1. Qed. - (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) + Lemma eqke_2 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> e=e'. + Proof. now destruct 1. Qed. - Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. - Proof. - firstorder. - exists x; auto. - induction H. - destruct y; compute in H. - exists e; left; auto. - destruct IHInA as [e H0]. - exists e; auto. - Qed. - - Lemma In_alt2 : forall k l, In k l <-> Exists (fun p => eq k (fst p)) l. - Proof. + Lemma eqk_def {elt} k k' (e e':elt) : eqk (k,e) (k',e') = D.eq k k'. + Proof. reflexivity. Defined. + + Lemma eqk_def' {elt} (p q:key*elt) : eqk p q = D.eq (fst p) (fst q). + Proof. reflexivity. Qed. + + Lemma eqk_1 {elt} k k' (e e':elt) : eqk (k,e) (k',e') -> D.eq k k'. + Proof. trivial. Qed. + + Hint Resolve eqke_1 eqke_2 eqk_1. + + (* Additionnal facts *) + + Lemma InA_eqke_eqk {elt} p (m:list (key*elt)) : + InA eqke p m -> InA eqk p m. + Proof. + induction 1; firstorder. + Qed. + Hint Resolve InA_eqke_eqk. + + Lemma InA_eqk_eqke {elt} p (m:list (key*elt)) : + InA eqk p m -> exists q, eqk p q /\ InA eqke q m. + Proof. + induction 1; firstorder. + Qed. + + Lemma InA_eqk {elt} p q (m:list (key*elt)) : + eqk p q -> InA eqk p m -> InA eqk q m. + Proof. + now intros <-. + Qed. + + Definition MapsTo {elt} (k:key)(e:elt):= InA eqke (k,e). + Definition In {elt} k m := exists e:elt, MapsTo k e m. + + Hint Unfold MapsTo In. + + (* Alternative formulations for [In k l] *) + + Lemma In_alt {elt} k (l:list (key*elt)) : + In k l <-> exists e, InA eqk (k,e) l. + Proof. + unfold In, MapsTo. + split; intros (e,H). + - exists e; auto. + - apply InA_eqk_eqke in H. destruct H as ((k',e'),(E,H)). + compute in E. exists e'. now rewrite E. + Qed. + + Lemma In_alt' {elt} (l:list (key*elt)) k e : + In k l <-> InA eqk (k,e) l. + Proof. + rewrite In_alt. firstorder. eapply InA_eqk; eauto. now compute. + Qed. + + Lemma In_alt2 {elt} k (l:list (key*elt)) : + In k l <-> Exists (fun p => D.eq k (fst p)) l. + Proof. unfold In, MapsTo. setoid_rewrite Exists_exists; setoid_rewrite InA_alt. firstorder. exists (snd x), x; auto. - Qed. - - Lemma In_nil : forall k, In k nil <-> False. - Proof. - intros; rewrite In_alt2; apply Exists_nil. - Qed. - - Lemma In_cons : forall k p l, - In k (p::l) <-> eq k (fst p) \/ In k l. - Proof. - intros; rewrite !In_alt2, Exists_cons; intuition. - Qed. - - Global Instance MapsTo_compat : - Proper (eq==>Logic.eq==>equivlistA eqke==>iff) MapsTo. - Proof. + Qed. + + Lemma In_nil {elt} k : In k (@nil (key*elt)) <-> False. + Proof. + rewrite In_alt2; apply Exists_nil. + Qed. + + Lemma In_cons {elt} k p (l:list (key*elt)) : + In k (p::l) <-> D.eq k (fst p) \/ In k l. + Proof. + rewrite !In_alt2, Exists_cons; intuition. + Qed. + + Instance MapsTo_compat {elt} : + Proper (D.eq==>Logic.eq==>equivlistA eqke==>iff) (@MapsTo elt). + Proof. intros x x' Hx e e' He l l' Hl. unfold MapsTo. rewrite Hx, He, Hl; intuition. - Qed. + Qed. - Global Instance In_compat : Proper (eq==>equivlistA eqk==>iff) In. - Proof. + Instance In_compat {elt} : Proper (D.eq==>equivlistA eqk==>iff) (@In elt). + Proof. intros x x' Hx l l' Hl. rewrite !In_alt. setoid_rewrite Hl. setoid_rewrite Hx. intuition. - Qed. - - Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. - Proof. intros l x y e EQ. rewrite <- EQ; auto. Qed. + Qed. - Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. - Proof. intros l x y EQ. rewrite <- EQ; auto. Qed. + Lemma MapsTo_eq {elt} (l:list (key*elt)) x y e : + D.eq x y -> MapsTo x e l -> MapsTo y e l. + Proof. now intros <-. Qed. - Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. - Proof. - intros; invlist In; invlist MapsTo. compute in * |- ; intuition. - right; exists x; auto. - Qed. + Lemma In_eq {elt} (l:list (key*elt)) x y : + D.eq x y -> In x l -> In y l. + Proof. now intros <-. Qed. - Lemma In_inv_2 : forall k k' e e' l, - InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. - Proof. - intros; invlist InA; intuition. - Qed. + Lemma In_inv {elt} k k' e (l:list (key*elt)) : + In k ((k',e) :: l) -> D.eq k k' \/ In k l. + Proof. + intros (e',H). red in H. rewrite InA_cons, eqke_def in H. + intuition. right. now exists e'. + Qed. - Lemma In_inv_3 : forall x x' l, - InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. - Proof. - intros; invlist InA; compute in * |- ; intuition. - Qed. + Lemma In_inv_2 {elt} k k' e e' (l:list (key*elt)) : + InA eqk (k, e) ((k', e') :: l) -> ~ D.eq k k' -> InA eqk (k, e) l. + Proof. + rewrite InA_cons, eqk_def. intuition. + Qed. - End Elt. + Lemma In_inv_3 {elt} x x' (l:list (key*elt)) : + InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. + Proof. + rewrite InA_cons. destruct 1 as [H|H]; trivial. destruct 1. + eauto with *. + Qed. - Hint Unfold eqk eqke. Hint Extern 2 (eqke ?a ?b) => split. Hint Resolve InA_eqke_eqk. - Hint Unfold MapsTo In. Hint Resolve In_inv_2 In_inv_3. End KeyDecidableType. -(** * PairDecidableType - +(** * PairDecidableType + From two decidable types, we can build a new DecidableType over their cartesian product. *) diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v index acc7c767..b484257b 100644 --- a/theories/Structures/OrdersEx.v +++ b/theories/Structures/OrdersEx.v @@ -84,3 +84,70 @@ Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. End PairOrderedType. +(** Even if [positive] can be seen as an ordered type with respect to the + usual order (see above), we can also use a lexicographic order over bits + (lower bits are considered first). This is more natural when using + [positive] as indexes for sets or maps (see MSetPositive and MMapPositive. *) + +Local Open Scope positive. + +Module PositiveOrderedTypeBits <: UsualOrderedType. + Definition t:=positive. + Include HasUsualEq <+ UsualIsEq. + Definition eqb := Pos.eqb. + Definition eqb_eq := Pos.eqb_eq. + Include HasEqBool2Dec. + + Fixpoint bits_lt (p q:positive) : Prop := + match p, q with + | xH, xI _ => True + | xH, _ => False + | xO p, xO q => bits_lt p q + | xO _, _ => True + | xI p, xI q => bits_lt p q + | xI _, _ => False + end. + + Definition lt:=bits_lt. + + Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x. + Proof. + induction x; simpl; auto. + Qed. + + Lemma bits_lt_trans : + forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z. + Proof. + induction x; destruct y,z; simpl; eauto; intuition. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition. + Qed. + + Instance lt_strorder : StrictOrder lt. + Proof. + split; [ exact bits_lt_antirefl | exact bits_lt_trans ]. + Qed. + + Fixpoint compare x y := + match x, y with + | x~1, y~1 => compare x y + | x~1, _ => Gt + | x~0, y~0 => compare x y + | x~0, _ => Lt + | 1, y~1 => Lt + | 1, 1 => Eq + | 1, y~0 => Gt + end. + + Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Proof. + unfold eq, lt. + induction x; destruct y; try constructor; simpl; auto. + destruct (IHx y); subst; auto. + destruct (IHx y); subst; auto. + Qed. + +End PositiveOrderedTypeBits. diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v index 059992f5..4d49ac84 100644 --- a/theories/Structures/OrdersLists.v +++ b/theories/Structures/OrdersLists.v @@ -6,51 +6,47 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -Require Export RelationPairs SetoidList Orders. +Require Export RelationPairs SetoidList Orders EqualitiesFacts. Set Implicit Arguments. Unset Strict Implicit. (** * Specialization of results about lists modulo. *) -Module OrderedTypeLists (Import O:OrderedType). +Module OrderedTypeLists (O:OrderedType). -Section ForNotations. - -Notation In:=(InA eq). -Notation Inf:=(lelistA lt). -Notation Sort:=(sort lt). -Notation NoDup:=(NoDupA eq). +Local Notation In:=(InA O.eq). +Local Notation Inf:=(lelistA O.lt). +Local Notation Sort:=(sort O.lt). +Local Notation NoDup:=(NoDupA O.eq). Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. Proof. intros. rewrite <- H; auto. Qed. Lemma ListIn_In : forall l x, List.In x l -> In x l. -Proof. exact (In_InA eq_equiv). Qed. +Proof. exact (In_InA O.eq_equiv). Qed. -Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l. -Proof. exact (InfA_ltA lt_strorder). Qed. +Lemma Inf_lt : forall l x y, O.lt x y -> Inf y l -> Inf x l. +Proof. exact (InfA_ltA O.lt_strorder). Qed. -Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l. -Proof. exact (InfA_eqA eq_equiv lt_compat). Qed. +Lemma Inf_eq : forall l x y, O.eq x y -> Inf y l -> Inf x l. +Proof. exact (InfA_eqA O.eq_equiv O.lt_compat). Qed. -Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x. -Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed. +Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> O.lt a x. +Proof. exact (SortA_InfA_InA O.eq_equiv O.lt_strorder O.lt_compat). Qed. -Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l. -Proof. exact (@In_InfA t lt). Qed. +Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> O.lt x y) -> Inf x l. +Proof. exact (@In_InfA O.t O.lt). Qed. -Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l. -Proof. exact (InA_InfA eq_equiv (ltA:=lt)). Qed. +Lemma In_Inf : forall l x, (forall y, In y l -> O.lt x y) -> Inf x l. +Proof. exact (InA_InfA O.eq_equiv (ltA:=O.lt)). Qed. Lemma Inf_alt : - forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)). -Proof. exact (InfA_alt eq_equiv lt_strorder lt_compat). Qed. + forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> O.lt x y)). +Proof. exact (InfA_alt O.eq_equiv O.lt_strorder O.lt_compat). Qed. Lemma Sort_NoDup : forall l, Sort l -> NoDup l. -Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat) . Qed. - -End ForNotations. +Proof. exact (SortA_NoDupA O.eq_equiv O.lt_strorder O.lt_compat) . Qed. Hint Resolve ListIn_In Sort_NoDup Inf_lt. Hint Immediate In_eq Inf_lt. @@ -58,140 +54,66 @@ Hint Immediate In_eq Inf_lt. End OrderedTypeLists. +(** * Results about keys and data as manipulated in MMaps. *) +Module KeyOrderedType(O:OrderedType). + Include KeyDecidableType(O). (* provides eqk, eqke *) + Local Notation key:=O.t. + Local Open Scope signature_scope. -(** * Results about keys and data as manipulated in FMaps. *) - - -Module KeyOrderedType(Import O:OrderedType). - Module Import MO:=OrderedTypeLists(O). - - Section Elt. - Variable elt : Type. - Notation key:=t. - - Local Open Scope signature_scope. - - Definition eqk : relation (key*elt) := eq @@1. - Definition eqke : relation (key*elt) := eq * Logic.eq. - Definition ltk : relation (key*elt) := lt @@1. - - Hint Unfold eqk eqke ltk. + Definition ltk {elt} : relation (key*elt) := O.lt @@1. - (* eqke is stricter than eqk *) + Hint Unfold ltk. - Global Instance eqke_eqk : subrelation eqke eqk. - Proof. firstorder. Qed. + (* ltk is a strict order *) - (* eqk, eqke are equalities, ltk is a strict order *) + Instance ltk_strorder {elt} : StrictOrder (@ltk elt) := _. - Global Instance eqk_equiv : Equivalence eqk := _. + Instance ltk_compat {elt} : Proper (eqk==>eqk==>iff) (@ltk elt). + Proof. unfold eqk, ltk; auto with *. Qed. - Global Instance eqke_equiv : Equivalence eqke := _. + Instance ltk_compat' {elt} : Proper (eqke==>eqke==>iff) (@ltk elt). + Proof. eapply subrelation_proper; eauto with *. Qed. - Global Instance ltk_strorder : StrictOrder ltk := _. + (* Additionnal facts *) - Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk. - Proof. unfold eqk, ltk; auto with *. Qed. + Instance pair_compat {elt} : Proper (O.eq==>Logic.eq==>eqke) (@pair key elt). + Proof. apply pair_compat. Qed. - (* Additionnal facts *) - - Global Instance pair_compat : Proper (eq==>Logic.eq==>eqke) (@pair key elt). - Proof. apply pair_compat. Qed. + Section Elt. + Variable elt : Type. + Implicit Type p q : key*elt. + Implicit Type l m : list (key*elt). - Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. + Lemma ltk_not_eqk p q : ltk p q -> ~ eqk p q. Proof. - intros e e' LT EQ; rewrite EQ in LT. + intros LT EQ; rewrite EQ in LT. elim (StrictOrder_Irreflexive _ LT). Qed. - Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. + Lemma ltk_not_eqke p q : ltk p q -> ~eqke p q. Proof. - intros e e' LT EQ; rewrite EQ in LT. + intros LT EQ; rewrite EQ in LT. elim (StrictOrder_Irreflexive _ LT). Qed. - Lemma InA_eqke_eqk : - forall x m, InA eqke x m -> InA eqk x m. - Proof. - unfold eqke, RelProd; induction 1; firstorder. - Qed. - Hint Resolve InA_eqke_eqk. - - Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). - Definition In k m := exists e:elt, MapsTo k e m. Notation Sort := (sort ltk). Notation Inf := (lelistA ltk). - Hint Unfold MapsTo In. - - (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) - - Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. - Proof. - firstorder. - exists x; auto. - induction H. - destruct y; compute in H. - exists e; left; auto. - destruct IHInA as [e H0]. - exists e; auto. - Qed. + Lemma Inf_eq l x x' : eqk x x' -> Inf x' l -> Inf x l. + Proof. now intros <-. Qed. - Lemma In_alt2 : forall k l, In k l <-> Exists (fun p => eq k (fst p)) l. - Proof. - unfold In, MapsTo. - setoid_rewrite Exists_exists; setoid_rewrite InA_alt. - firstorder. - exists (snd x), x; auto. - Qed. - - Lemma In_nil : forall k, In k nil <-> False. - Proof. - intros; rewrite In_alt2; apply Exists_nil. - Qed. - - Lemma In_cons : forall k p l, - In k (p::l) <-> eq k (fst p) \/ In k l. - Proof. - intros; rewrite !In_alt2, Exists_cons; intuition. - Qed. - - Global Instance MapsTo_compat : - Proper (eq==>Logic.eq==>equivlistA eqke==>iff) MapsTo. - Proof. - intros x x' Hx e e' He l l' Hl. unfold MapsTo. - rewrite Hx, He, Hl; intuition. - Qed. - - Global Instance In_compat : Proper (eq==>equivlistA eqk==>iff) In. - Proof. - intros x x' Hx l l' Hl. rewrite !In_alt. - setoid_rewrite Hl. setoid_rewrite Hx. intuition. - Qed. - - Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. - Proof. intros l x y e EQ. rewrite <- EQ; auto. Qed. - - Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. - Proof. intros l x y EQ. rewrite <- EQ; auto. Qed. - - Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. - Proof. intros l x x' H. rewrite H; auto. Qed. - - Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. + Lemma Inf_lt l x x' : ltk x x' -> Inf x' l -> Inf x l. Proof. apply InfA_ltA; auto with *. Qed. Hint Immediate Inf_eq. Hint Resolve Inf_lt. - Lemma Sort_Inf_In : - forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. + Lemma Sort_Inf_In l p q : Sort l -> Inf q l -> InA eqk p l -> ltk q p. Proof. apply SortA_InfA_InA; auto with *. Qed. - Lemma Sort_Inf_NotIn : - forall l k e, Sort l -> Inf (k,e) l -> ~In k l. + Lemma Sort_Inf_NotIn l k e : Sort l -> Inf (k,e) l -> ~In k l. Proof. intros; red; intros. destruct H1 as [e' H2]. @@ -200,57 +122,34 @@ Module KeyOrderedType(Import O:OrderedType). repeat red; reflexivity. Qed. - Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l. + Lemma Sort_NoDupA l : Sort l -> NoDupA eqk l. Proof. apply SortA_NoDupA; auto with *. Qed. - Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'. + Lemma Sort_In_cons_1 l p q : Sort (p::l) -> InA eqk q l -> ltk p q. Proof. intros; invlist sort; eapply Sort_Inf_In; eauto. Qed. - Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> - ltk e e' \/ eqk e e'. + Lemma Sort_In_cons_2 l p q : Sort (p::l) -> InA eqk q (p::l) -> + ltk p q \/ eqk p q. Proof. intros; invlist InA; auto with relations. left; apply Sort_In_cons_1 with l; auto with relations. Qed. - Lemma Sort_In_cons_3 : - forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k. + Lemma Sort_In_cons_3 x l k e : + Sort ((k,e)::l) -> In x l -> ~O.eq x k. Proof. intros; invlist sort; red; intros. eapply Sort_Inf_NotIn; eauto using In_eq. Qed. - Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. - Proof. - intros; invlist In; invlist MapsTo. compute in * |- ; intuition. - right; exists x; auto. - Qed. - - Lemma In_inv_2 : forall k k' e e' l, - InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. - Proof. - intros; invlist InA; intuition. - Qed. - - Lemma In_inv_3 : forall x x' l, - InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. - Proof. - intros; invlist InA; compute in * |- ; intuition. - Qed. - End Elt. - Hint Unfold eqk eqke ltk. - Hint Extern 2 (eqke ?a ?b) => split. Hint Resolve ltk_not_eqk ltk_not_eqke. - Hint Resolve InA_eqke_eqk. - Hint Unfold MapsTo In. Hint Immediate Inf_eq. Hint Resolve Inf_lt. Hint Resolve Sort_Inf_NotIn. - Hint Resolve In_inv_2 In_inv_3. End KeyOrderedType. diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index 99ecd150..d210792f 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(** * An light axiomatization of integers (used in FSetAVL). *) +(** * An light axiomatization of integers (used in MSetAVL). *) (** We define a signature for an integer datatype based on [Z]. The goal is to allow a switch after extraction to ocaml's @@ -14,11 +14,11 @@ (typically : when mesuring the height of an AVL tree). *) -Require Import ZArith. +Require Import BinInt. Delimit Scope Int_scope with I. Local Open Scope Int_scope. -(** * a specification of integers *) +(** * A specification of integers *) Module Type Int. @@ -31,19 +31,19 @@ Module Type Int. Parameter _1 : t. Parameter _2 : t. Parameter _3 : t. - Parameter plus : t -> t -> t. + Parameter add : t -> t -> t. Parameter opp : t -> t. - Parameter minus : t -> t -> t. - Parameter mult : t -> t -> t. + Parameter sub : t -> t -> t. + Parameter mul : t -> t -> t. Parameter max : t -> t -> t. Notation "0" := _0 : Int_scope. Notation "1" := _1 : Int_scope. Notation "2" := _2 : Int_scope. Notation "3" := _3 : Int_scope. - Infix "+" := plus : Int_scope. - Infix "-" := minus : Int_scope. - Infix "*" := mult : Int_scope. + Infix "+" := add : Int_scope. + Infix "-" := sub : Int_scope. + Infix "*" := mul : Int_scope. Notation "- x" := (opp x) : Int_scope. (** For logical relations, we can rely on their counterparts in Z, @@ -61,7 +61,17 @@ Module Type Int. Notation "x < y < z" := (x < y /\ y < z) : Int_scope. Notation "x < y <= z" := (x < y /\ y <= z) : Int_scope. - (** Some decidability fonctions (informative). *) + (** Informative comparisons. *) + + Axiom eqb : t -> t -> bool. + Axiom ltb : t -> t -> bool. + Axiom leb : t -> t -> bool. + + Infix "=?" := eqb. + Infix "<?" := ltb. + Infix "<=?" := leb. + + (** For compatibility, some decidability fonctions (informative). *) Axiom gt_le_dec : forall x y : t, {x > y} + {x <= y}. Axiom ge_lt_dec : forall x y : t, {x >= y} + {x < y}. @@ -83,11 +93,14 @@ Module Type Int. Axiom i2z_1 : i2z _1 = 1%Z. Axiom i2z_2 : i2z _2 = 2%Z. Axiom i2z_3 : i2z _3 = 3%Z. - Axiom i2z_plus : forall n p, i2z (n + p) = (i2z n + i2z p)%Z. + Axiom i2z_add : forall n p, i2z (n + p) = (i2z n + i2z p)%Z. Axiom i2z_opp : forall n, i2z (-n) = (-i2z n)%Z. - Axiom i2z_minus : forall n p, i2z (n - p) = (i2z n - i2z p)%Z. - Axiom i2z_mult : forall n p, i2z (n * p) = (i2z n * i2z p)%Z. + Axiom i2z_sub : forall n p, i2z (n - p) = (i2z n - i2z p)%Z. + Axiom i2z_mul : forall n p, i2z (n * p) = (i2z n * i2z p)%Z. Axiom i2z_max : forall n p, i2z (max n p) = Z.max (i2z n) (i2z p). + Axiom i2z_eqb : forall n p, eqb n p = Z.eqb (i2z n) (i2z p). + Axiom i2z_ltb : forall n p, ltb n p = Z.ltb (i2z n) (i2z p). + Axiom i2z_leb : forall n p, leb n p = Z.leb (i2z n) (i2z p). End Int. @@ -97,11 +110,42 @@ End Int. Module MoreInt (Import I:Int). Local Notation int := I.t. + Lemma eqb_eq n p : (n =? p) = true <-> n == p. + Proof. + now rewrite i2z_eqb, Z.eqb_eq. + Qed. + + Lemma eqb_neq n p : (n =? p) = false <-> ~(n == p). + Proof. + rewrite <- eqb_eq. destruct (n =? p); intuition. + Qed. + + Lemma ltb_lt n p : (n <? p) = true <-> n < p. + Proof. + now rewrite i2z_ltb, Z.ltb_lt. + Qed. + + Lemma ltb_nlt n p : (n <? p) = false <-> ~(n < p). + Proof. + rewrite <- ltb_lt. destruct (n <? p); intuition. + Qed. + + Lemma leb_le n p : (n <=? p) = true <-> n <= p. + Proof. + now rewrite i2z_leb, Z.leb_le. + Qed. + + Lemma leb_nle n p : (n <=? p) = false <-> ~(n <= p). + Proof. + rewrite <- leb_le. destruct (n <=? p); intuition. + Qed. + (** A magic (but costly) tactic that goes from [int] back to the [Z] friendly world ... *) Hint Rewrite -> - i2z_0 i2z_1 i2z_2 i2z_3 i2z_plus i2z_opp i2z_minus i2z_mult i2z_max : i2z. + i2z_0 i2z_1 i2z_2 i2z_3 i2z_add i2z_opp i2z_sub i2z_mul i2z_max + i2z_eqb i2z_ltb i2z_leb : i2z. Ltac i2z := match goal with | H : ?a = ?b |- _ => @@ -149,18 +193,18 @@ Module MoreInt (Import I:Int). | EI1 : ExprI | EI2 : ExprI | EI3 : ExprI - | EIplus : ExprI -> ExprI -> ExprI + | EIadd : ExprI -> ExprI -> ExprI | EIopp : ExprI -> ExprI - | EIminus : ExprI -> ExprI -> ExprI - | EImult : ExprI -> ExprI -> ExprI + | EIsub : ExprI -> ExprI -> ExprI + | EImul : ExprI -> ExprI -> ExprI | EImax : ExprI -> ExprI -> ExprI | EIraw : int -> ExprI. Inductive ExprZ : Set := - | EZplus : ExprZ -> ExprZ -> ExprZ + | EZadd : ExprZ -> ExprZ -> ExprZ | EZopp : ExprZ -> ExprZ - | EZminus : ExprZ -> ExprZ -> ExprZ - | EZmult : ExprZ -> ExprZ -> ExprZ + | EZsub : ExprZ -> ExprZ -> ExprZ + | EZmul : ExprZ -> ExprZ -> ExprZ | EZmax : ExprZ -> ExprZ -> ExprZ | EZofI : ExprI -> ExprZ | EZraw : Z -> ExprZ. @@ -186,9 +230,9 @@ Module MoreInt (Import I:Int). | 1 => constr:EI1 | 2 => constr:EI2 | 3 => constr:EI3 - | ?x + ?y => let ex := i2ei x with ey := i2ei y in constr:(EIplus ex ey) - | ?x - ?y => let ex := i2ei x with ey := i2ei y in constr:(EIminus ex ey) - | ?x * ?y => let ex := i2ei x with ey := i2ei y in constr:(EImult ex ey) + | ?x + ?y => let ex := i2ei x with ey := i2ei y in constr:(EIadd ex ey) + | ?x - ?y => let ex := i2ei x with ey := i2ei y in constr:(EIsub ex ey) + | ?x * ?y => let ex := i2ei x with ey := i2ei y in constr:(EImul ex ey) | max ?x ?y => let ex := i2ei x with ey := i2ei y in constr:(EImax ex ey) | - ?x => let ex := i2ei x in constr:(EIopp ex) | ?x => constr:(EIraw x) @@ -198,9 +242,9 @@ Module MoreInt (Import I:Int). with z2ez trm := match constr:trm with - | (?x + ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZplus ex ey) - | (?x - ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZminus ex ey) - | (?x * ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmult ex ey) + | (?x + ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZadd ex ey) + | (?x - ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZsub ex ey) + | (?x * ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmul ex ey) | (Z.max ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EZmax ex ey) | (- ?x)%Z => let ex := z2ez x in constr:(EZopp ex) | i2z ?x => let ex := i2ei x in constr:(EZofI ex) @@ -232,9 +276,9 @@ Module MoreInt (Import I:Int). | EI1 => 1 | EI2 => 2 | EI3 => 3 - | EIplus e1 e2 => (ei2i e1)+(ei2i e2) - | EIminus e1 e2 => (ei2i e1)-(ei2i e2) - | EImult e1 e2 => (ei2i e1)*(ei2i e2) + | EIadd e1 e2 => (ei2i e1)+(ei2i e2) + | EIsub e1 e2 => (ei2i e1)-(ei2i e2) + | EImul e1 e2 => (ei2i e1)*(ei2i e2) | EImax e1 e2 => max (ei2i e1) (ei2i e2) | EIopp e => -(ei2i e) | EIraw i => i @@ -244,9 +288,9 @@ Module MoreInt (Import I:Int). Fixpoint ez2z (e:ExprZ) : Z := match e with - | EZplus e1 e2 => ((ez2z e1)+(ez2z e2))%Z - | EZminus e1 e2 => ((ez2z e1)-(ez2z e2))%Z - | EZmult e1 e2 => ((ez2z e1)*(ez2z e2))%Z + | EZadd e1 e2 => ((ez2z e1)+(ez2z e2))%Z + | EZsub e1 e2 => ((ez2z e1)-(ez2z e2))%Z + | EZmul e1 e2 => ((ez2z e1)*(ez2z e2))%Z | EZmax e1 e2 => Z.max (ez2z e1) (ez2z e2) | EZopp e => (-(ez2z e))%Z | EZofI e => i2z (ei2i e) @@ -278,9 +322,9 @@ Module MoreInt (Import I:Int). | EI1 => EZraw (1%Z) | EI2 => EZraw (2%Z) | EI3 => EZraw (3%Z) - | EIplus e1 e2 => EZplus (norm_ei e1) (norm_ei e2) - | EIminus e1 e2 => EZminus (norm_ei e1) (norm_ei e2) - | EImult e1 e2 => EZmult (norm_ei e1) (norm_ei e2) + | EIadd e1 e2 => EZadd (norm_ei e1) (norm_ei e2) + | EIsub e1 e2 => EZsub (norm_ei e1) (norm_ei e2) + | EImul e1 e2 => EZmul (norm_ei e1) (norm_ei e2) | EImax e1 e2 => EZmax (norm_ei e1) (norm_ei e2) | EIopp e => EZopp (norm_ei e) | EIraw i => EZofI (EIraw i) @@ -290,9 +334,9 @@ Module MoreInt (Import I:Int). Fixpoint norm_ez (e:ExprZ) : ExprZ := match e with - | EZplus e1 e2 => EZplus (norm_ez e1) (norm_ez e2) - | EZminus e1 e2 => EZminus (norm_ez e1) (norm_ez e2) - | EZmult e1 e2 => EZmult (norm_ez e1) (norm_ez e2) + | EZadd e1 e2 => EZadd (norm_ez e1) (norm_ez e2) + | EZsub e1 e2 => EZsub (norm_ez e1) (norm_ez e2) + | EZmul e1 e2 => EZmul (norm_ez e1) (norm_ez e2) | EZmax e1 e2 => EZmax (norm_ez e1) (norm_ez e2) | EZopp e => EZopp (norm_ez e) | EZofI e => norm_ei e @@ -316,24 +360,22 @@ Module MoreInt (Import I:Int). | EPraw p => EPraw p end. - Lemma norm_ei_correct : forall e:ExprI, ez2z (norm_ei e) = i2z (ei2i e). + Lemma norm_ei_correct (e:ExprI) : ez2z (norm_ei e) = i2z (ei2i e). Proof. - induction e; simpl; intros; i2z; auto; try congruence. + induction e; simpl; i2z; auto; try congruence. Qed. - Lemma norm_ez_correct : forall e:ExprZ, ez2z (norm_ez e) = ez2z e. + Lemma norm_ez_correct (e:ExprZ) : ez2z (norm_ez e) = ez2z e. Proof. - induction e; simpl; intros; i2z; auto; try congruence; apply norm_ei_correct. + induction e; simpl; i2z; auto; try congruence; apply norm_ei_correct. Qed. - Lemma norm_ep_correct : - forall e:ExprP, ep2p (norm_ep e) <-> ep2p e. + Lemma norm_ep_correct (e:ExprP) : ep2p (norm_ep e) <-> ep2p e. Proof. - induction e; simpl; repeat (rewrite norm_ez_correct); intuition. + induction e; simpl; rewrite ?norm_ez_correct; intuition. Qed. - Lemma norm_ep_correct2 : - forall e:ExprP, ep2p (norm_ep e) -> ep2p e. + Lemma norm_ep_correct2 (e:ExprP) : ep2p (norm_ep e) -> ep2p e. Proof. intros; destruct (norm_ep_correct e); auto. Qed. @@ -363,23 +405,50 @@ Module Z_as_Int <: Int. Definition _1 := 1. Definition _2 := 2. Definition _3 := 3. - Definition plus := Z.add. + Definition add := Z.add. Definition opp := Z.opp. - Definition minus := Z.sub. - Definition mult := Z.mul. + Definition sub := Z.sub. + Definition mul := Z.mul. Definition max := Z.max. - Definition gt_le_dec := Z_gt_le_dec. - Definition ge_lt_dec := Z_ge_lt_dec. + Definition eqb := Z.eqb. + Definition ltb := Z.ltb. + Definition leb := Z.leb. + Definition eq_dec := Z.eq_dec. + Definition gt_le_dec i j : {i > j} + { i <= j }. + Proof. + generalize (Z.ltb_spec j i). + destruct (j <? i); [left|right]; inversion H; trivial. + now apply Z.lt_gt. + Defined. + Definition ge_lt_dec i j : {i >= j} + { i < j }. + Proof. + generalize (Z.ltb_spec i j). + destruct (i <? j); [right|left]; inversion H; trivial. + now apply Z.le_ge. + Defined. + Definition i2z : t -> Z := fun n => n. - Lemma i2z_eq : forall n p, i2z n=i2z p -> n = p. Proof. auto. Qed. - Lemma i2z_0 : i2z _0 = 0. Proof. auto. Qed. - Lemma i2z_1 : i2z _1 = 1. Proof. auto. Qed. - Lemma i2z_2 : i2z _2 = 2. Proof. auto. Qed. - Lemma i2z_3 : i2z _3 = 3. Proof. auto. Qed. - Lemma i2z_plus n p : i2z (n + p) = i2z n + i2z p. Proof. auto. Qed. - Lemma i2z_opp n : i2z (- n) = - i2z n. Proof. auto. Qed. - Lemma i2z_minus n p : i2z (n - p) = i2z n - i2z p. Proof. auto. Qed. - Lemma i2z_mult n p : i2z (n * p) = i2z n * i2z p. Proof. auto. Qed. - Lemma i2z_max n p : i2z (max n p) = Z.max (i2z n) (i2z p). Proof. auto. Qed. + Lemma i2z_eq n p : i2z n = i2z p -> n = p. Proof. trivial. Qed. + Lemma i2z_0 : i2z _0 = 0. Proof. reflexivity. Qed. + Lemma i2z_1 : i2z _1 = 1. Proof. reflexivity. Qed. + Lemma i2z_2 : i2z _2 = 2. Proof. reflexivity. Qed. + Lemma i2z_3 : i2z _3 = 3. Proof. reflexivity. Qed. + Lemma i2z_add n p : i2z (n + p) = i2z n + i2z p. + Proof. reflexivity. Qed. + Lemma i2z_opp n : i2z (- n) = - i2z n. + Proof. reflexivity. Qed. + Lemma i2z_sub n p : i2z (n - p) = i2z n - i2z p. + Proof. reflexivity. Qed. + Lemma i2z_mul n p : i2z (n * p) = i2z n * i2z p. + Proof. reflexivity. Qed. + Lemma i2z_max n p : i2z (max n p) = Z.max (i2z n) (i2z p). + Proof. reflexivity. Qed. + Lemma i2z_eqb n p : eqb n p = Z.eqb (i2z n) (i2z p). + Proof. reflexivity. Qed. + Lemma i2z_leb n p : leb n p = Z.leb (i2z n) (i2z p). + Proof. reflexivity. Qed. + Lemma i2z_ltb n p : ltb n p = Z.ltb (i2z n) (i2z p). + Proof. reflexivity. Qed. + End Z_as_Int. diff --git a/theories/theories.itarget b/theories/theories.itarget index 3a87d8cf..4519070e 100644 --- a/theories/theories.itarget +++ b/theories/theories.itarget @@ -3,6 +3,7 @@ Bool/vo.otarget Classes/vo.otarget FSets/vo.otarget MSets/vo.otarget +MMaps/vo.otarget Structures/vo.otarget Init/vo.otarget Lists/vo.otarget diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index d660f420..0931fd55 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -46,9 +46,10 @@ let section s = let usage () = output_string stderr "Usage summary: -coq_makefile [subdirectory] .... [file.v] ... [file.ml[i4]?] ... - [file.ml{lib,pack}] ... [-extra[-phony] result dependencies command] - ... [-I dir] ... [-R physicalpath logicalpath] ... [VARIABLE = value] +coq_makefile .... [file.v] ... [file.ml[i4]?] ... [file.ml{lib,pack}] + ... [any] ... [-extra[-phony] result dependencies command] + ... [-I dir] ... [-R physicalpath logicalpath] + ... [-Q physicalpath logicalpath] ... [VARIABLE = value] ... [-arg opt] ... [-opt|-byte] [-no-install] [-f file] [-o file] [-h] [--help] @@ -56,8 +57,8 @@ coq_makefile [subdirectory] .... [file.v] ... [file.ml[i4]?] ... [file.ml[i4]?]: Objective Caml file to be compiled [file.ml{lib,pack}]: ocamlbuild file that describes a Objective Caml library/module -[subdirectory] : subdirectory that should be \"made\" and has a - Makefile itself to do so. +[any] : subdirectory that should be \"made\" and has a Makefile itself + to do so. Very fragile and discouraged. [-extra result dependencies command]: add target \"result\" with command \"command\" and dependencies \"dependencies\". If \"result\" is not generic (do not contains a %), \"result\" is built by _make all_ and @@ -157,7 +158,7 @@ let vars_to_put_by_root var_x_files_l (inc_ml,inc_i,inc_r) = |l -> try let out = List.assoc "." (List.rev_map (fun (p,l,_) -> (p,l)) l) in - let () = prerr_string "Warning: install rule assumes that -R/-Q . _ is the only -R/-Q option" in + let () = prerr_string "Warning: install rule assumes that -R/-Q . _ is the only -R/-Q option\n" in (None,[".",physical_dir_of_logical_dir out,List.rev_map fst var_x_files_l]) with Not_found -> ( @@ -297,7 +298,7 @@ let install (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,sds) in print "\tprintf 'cd \"$${DSTROOT}\"$(COQDOCINSTALL) && "; printf "find %s/%s -maxdepth 0 -and -empty -exec rmdir -p \\{\\} \\;\\n' >> \"$@\"\n" dir kind in - print "uninstall_me.sh:\n"; + printf "uninstall_me.sh: %s\n" !makefile_name; print "\techo '#!/bin/sh' > $@ \n"; if (not_empty cmxsfiles) then uninstall_by_root where_what_cmxs; uninstall_by_root where_what_oth; @@ -320,7 +321,7 @@ let make_makefile sds = end let clean sds sps = - print "clean:\n"; + print "clean::\n"; if !some_mlfile || !some_mlifile || !some_ml4file || !some_mllibfile || !some_mlpackfile then begin print "\trm -f $(ALLCMOFILES) $(CMIFILES) $(CMAFILES)\n"; print "\trm -f $(ALLCMOFILES:.cmo=.cmx) $(CMXAFILES) $(CMXSFILES) $(ALLCMOFILES:.cmo=.o) $(CMXAFILES:.cmxa=.a)\n"; @@ -329,6 +330,7 @@ let clean sds sps = if !some_vfile then begin print "\trm -f $(OBJFILES) $(OBJFILES:.o=.native) $(NATIVEFILES)\n"; + print "\tfind . -name .coq-native -type d -empty -delete\n"; print "\trm -f $(VOFILES) $(VOFILES:.vo=.vio) $(GFILES) $(VFILES:.v=.v.d) $(VFILES:=.beautified) $(VFILES:=.old)\n" end; print "\trm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) all-mli.tex\n"; @@ -342,7 +344,11 @@ let clean sds sps = (fun x -> print "\t+cd "; print x; print " && $(MAKE) clean\n") sds; print "\n"; - print "archclean:\n"; + let () = + if !some_vfile then + let () = print "cleanall:: clean\n" in + print "\trm -f $(patsubst %.v,.%.aux,$(VFILES))\n\n" in + print "archclean::\n"; print "\trm -f *.cmx *.o\n"; List.iter (fun x -> print "\t+cd "; print x; print " && $(MAKE) archclean\n") @@ -365,7 +371,7 @@ let implicit () = print "$(filter-out $(addsuffix .cmx,$(foreach lib,$(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(ML4FILES:.ml4=.cmx)): %.cmx: %.ml4\n"; print "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n"; print "$(addsuffix .d,$(ML4FILES)): %.ml4.d: %.ml4\n"; - print "\t$(COQDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in + print "\t$(OCAMLDEP) -slash $(OCAMLLIBS) $(PP) -impl \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in let ml_rules () = print "$(MLFILES:.ml=.cmo): %.cmo: %.ml\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; print "$(filter-out $(addsuffix .cmx,$(foreach lib,$(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(MLFILES:.ml=.cmx)): %.cmx: %.ml\n"; @@ -457,7 +463,7 @@ let variables is_install opt (args,defs) = print "ifeq ($(CAMLP4),camlp5) CAMLP4EXTEND=pa_extend.cmo q_MLast.cmo pa_macro.cmo unix.cma threads.cma else -CAMLP4EXTEND= +CAMLP4EXTEND=threads.cma endif\n"; print "PP?=-pp '$(CAMLP4O) -I $(CAMLLIB) -I $(CAMLLIB)threads/ $(COQSRCLIBS) compat5.cmo \\ $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl'\n\n"; @@ -530,9 +536,13 @@ let include_dirs (inc_ml,inc_i,inc_r) = List.iter (fun x -> print "\\\n "; print x) str_r; print "\n\n"; end +let double_colon = ["clean"; "cleanall"; "archclean"] + let custom sps = let pr_path (file,dependencies,is_phony,com) = - print file; print ": "; print dependencies; print "\n"; + print file; + print (if List.mem file double_colon then ":: " else ": "); + print dependencies; print "\n"; if com <> "" then (print "\t"; print com; print "\n"); print "\n" in @@ -543,7 +553,12 @@ let subdirs sds = let pr_subdir s = print s; print ":\n\t+cd \""; print s; print "\" && $(MAKE) all\n\n" in - if sds <> [] then section "Subdirectories."; + if sds <> [] then + let () = + Format.eprintf "@[Warning: Targets for subdirectories are very fragile.@ " in + let () = + Format.eprintf "For example,@ nothing is done to handle dependencies@ with them.@]@." in + section "Subdirectories."; List.iter pr_subdir sds let forpacks l = @@ -695,22 +710,25 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other end let all_target (vfiles, (_,_,_,_,mlpackfiles as mlfiles), sps, sds) inc = - let other_targets = CList.map_filter - (fun (n,_,is_phony,_) -> if not (is_phony || is_genrule n) then Some n else None) - sps @ sds in + let other_targets = + CList.map_filter + (fun (n,_,is_phony,_) -> if not (is_phony || is_genrule n) then Some n else None) + sps @ sds in main_targets vfiles mlfiles other_targets inc; - print ".PHONY: "; - print_list " " - ("all" :: "opt" :: "byte" :: "archclean" :: "clean" :: "install" :: - "uninstall_me.sh" :: "uninstall" :: "userinstall" :: "depend" :: - "html" :: "validate" :: - (sds@(CList.map_filter - (fun (n,_,is_phony,_) -> - if is_phony then Some n else None) sps))); - print "\n\n"; - custom sps; - subdirs sds; - forpacks mlpackfiles + print ".PHONY: "; + print_list + " " + ("all" :: "archclean" :: "beautify" :: "byte" :: "clean" :: "cleanall" + :: "gallina" :: "gallinahtml" :: "html" :: "install" :: "install-doc" + :: "install-natdynlink" :: "install-toploop" :: "opt" :: "printenv" + :: "quick" :: "uninstall" :: "userinstall" :: "validate" :: "vio2vo" + :: (sds@(CList.map_filter + (fun (n,_,is_phony,_) -> + if is_phony then Some n else None) sps))); + print "\n\n"; + custom sps; + subdirs sds; + forpacks mlpackfiles let banner () = print (Printf.sprintf @@ -750,7 +768,7 @@ let ensure_root_dir (v,(mli,ml4,ml,mllib,mlpack),_,_) ((ml_inc,i_inc,r_inc) as l let warn_install_at_root_directory (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,_) (inc_ml,inc_i,inc_r) = - let inc_top = List.filter (fun (_,ldir,_) -> ldir = "") inc_r@inc_i in + let inc_top = List.filter (fun (_,ldir,_) -> ldir = "") (inc_r@inc_i) in let inc_top_p = List.map (fun (p,_,_) -> p) inc_top in let files = vfiles @ mlifiles @ ml4files @ mlfiles @ mllibfiles @ mlpackfiles in if List.exists (fun f -> List.mem (Filename.dirname f) inc_top_p) files @@ -764,10 +782,10 @@ let check_overlapping_include (_,inc_i,inc_r) = | [] -> () | (pdir,_,abspdir)::l -> if not (is_prefix pwd abspdir) then - Printf.eprintf "Warning: in option -R, %s is not a subdirectory of the current directory\n" pdir; + Printf.eprintf "Warning: in option -R/-Q, %s is not a subdirectory of the current directory\n" pdir; List.iter (fun (pdir',_,abspdir') -> if is_prefix abspdir abspdir' || is_prefix abspdir' abspdir then - Printf.eprintf "Warning: in options -R, %s and %s overlap\n" pdir pdir') l; + Printf.eprintf "Warning: in options -R/-Q, %s and %s overlap\n" pdir pdir') l; in aux (inc_i@inc_r) let do_makefile args = diff --git a/tools/coq_tex.ml b/tools/coq_tex.ml index 383a68df..a2cc8384 100644 --- a/tools/coq_tex.ml +++ b/tools/coq_tex.ml @@ -79,7 +79,7 @@ let expos = Str.regexp "^" let tex_escaped s = let dollar = "\\$" and backslash = "\\\\" and expon = "\\^" in - let delims = Str.regexp ("[_{}&%#" ^ dollar ^ backslash ^ expon ^"~ <>']") in + let delims = Str.regexp ("[_{}&%#" ^ dollar ^ backslash ^ expon ^"~ <>'`]") in let adapt_delim = function | "_" | "{" | "}" | "&" | "%" | "#" | "$" as c -> "\\"^c | "\\" -> "{\\char'134}" @@ -89,6 +89,7 @@ let tex_escaped s = | "<" -> "{<}" | ">" -> "{>}" | "'" -> "{\\textquotesingle}" + | "`" -> "\\`{}" | _ -> assert false in let adapt = function diff --git a/tools/coqc.ml b/tools/coqc.ml index f636ffd8..7e822dbe 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -111,7 +111,7 @@ let parse_args () = |"-dont-load-proofs"|"-load-proofs"|"-force-load-proofs" |"-impredicative-set"|"-vm"|"-no-native-compiler" |"-verbose-compat-notations"|"-no-compat-notations" - |"-indices-matter"|"-quick"|"-color" + |"-indices-matter"|"-quick"|"-color"|"-type-in-type" |"-async-proofs-always-delegate"|"-async-proofs-never-reopen-branch" as o) :: rem -> parse (cfiles,o::args) rem @@ -121,7 +121,7 @@ let parse_args () = | ("-outputstate"|"-inputstate"|"-is"|"-exclude-dir" |"-load-vernac-source"|"-l"|"-load-vernac-object" |"-load-ml-source"|"-require"|"-load-ml-object" - |"-init-file"|"-dump-glob"|"-compat"|"-coqlib" + |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top" |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" as o) :: rem -> begin diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index edf7ee8e..cb704146 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -405,7 +405,7 @@ let set_kw = let gallina_kw_to_hide = "Implicit" space+ "Arguments" - | "Ltac" + | ("Local" space+)? "Ltac" | "Require" | "Import" | "Export" @@ -456,13 +456,7 @@ rule coq_bol = parse { begin_show (); coq_bol lexbuf } | space* end_show { end_show (); coq_bol lexbuf } - | space* ("Local"|"Global") - { - in_proof := None; - let s = lexeme lexbuf in - output_indented_keyword s lexbuf; - coq_bol lexbuf } - | space* gallina_kw_to_hide + | space* (("Local"|"Global") space+)? gallina_kw_to_hide { let s = lexeme lexbuf in if !Cdglobals.light && section_or_end s then let eol = skip_to_dot lexbuf in @@ -596,7 +590,7 @@ and coq = parse end } | eof { () } - | gallina_kw_to_hide + | (("Local"|"Global") space+)? gallina_kw_to_hide { let s = lexeme lexbuf in if !Cdglobals.light && section_or_end s then begin diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index ae6e6388..06030c45 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -595,7 +595,6 @@ module Html = struct | '<' -> Buffer.add_string buff "<" | '>' -> Buffer.add_string buff ">" | '&' -> Buffer.add_string buff "&" - | '\'' -> Buffer.add_string buff "´" | '\"' -> Buffer.add_string buff """ | c -> Buffer.add_char buff c done; diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli index 5dbd5379..80787298 100644 --- a/toplevel/auto_ind_decl.mli +++ b/toplevel/auto_ind_decl.mli @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Term open Names open Ind_tables diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index 22ea09c5..b29ba1ef 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -6,7 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Util open Pp open Errors open Indtypes @@ -53,12 +52,15 @@ let _ = Errors.register_handler explain_exn_default (** Pre-explain a vernac interpretation error *) -let wrap_vernac_error (exn, info) strm = - let header = Pp.tag (Pp.Tag.inj Ppstyle.error_tag Ppstyle.tag) (str "Error:") in - let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in - (e, info) +let wrap_vernac_error with_header (exn, info) strm = + if with_header then + let header = Pp.tag (Pp.Tag.inj Ppstyle.error_tag Ppstyle.tag) (str "Error:") in + let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in + (e, info) + else + (EvaluatedError (strm, None), info) -let process_vernac_interp_error exn = match fst exn with +let process_vernac_interp_error with_header exn = match fst exn with | Univ.UniverseInconsistency i -> let msg = if !Constrextern.print_universes then @@ -66,40 +68,40 @@ let process_vernac_interp_error exn = match fst exn with Univ.explain_universe_inconsistency Universes.pr_with_global_universes i else mt() in - wrap_vernac_error exn (str "Universe inconsistency" ++ msg ++ str ".") + wrap_vernac_error with_header exn (str "Universe inconsistency" ++ msg ++ str ".") | TypeError(ctx,te) -> - wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te) + wrap_vernac_error with_header exn (Himsg.explain_type_error ctx Evd.empty te) | PretypeError(ctx,sigma,te) -> - wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te) + wrap_vernac_error with_header exn (Himsg.explain_pretype_error ctx sigma te) | Typeclasses_errors.TypeClassError(env, te) -> - wrap_vernac_error exn (Himsg.explain_typeclass_error env te) + wrap_vernac_error with_header exn (Himsg.explain_typeclass_error env te) | InductiveError e -> - wrap_vernac_error exn (Himsg.explain_inductive_error e) + wrap_vernac_error with_header exn (Himsg.explain_inductive_error e) | Modops.ModuleTypingError e -> - wrap_vernac_error exn (Himsg.explain_module_error e) + wrap_vernac_error with_header exn (Himsg.explain_module_error e) | Modintern.ModuleInternalizationError e -> - wrap_vernac_error exn (Himsg.explain_module_internalization_error e) + wrap_vernac_error with_header exn (Himsg.explain_module_internalization_error e) | RecursionSchemeError e -> - wrap_vernac_error exn (Himsg.explain_recursion_scheme_error e) + wrap_vernac_error with_header exn (Himsg.explain_recursion_scheme_error e) | Cases.PatternMatchingError (env,sigma,e) -> - wrap_vernac_error exn (Himsg.explain_pattern_matching_error env sigma e) + wrap_vernac_error with_header exn (Himsg.explain_pattern_matching_error env sigma e) | Tacred.ReductionTacticError e -> - wrap_vernac_error exn (Himsg.explain_reduction_tactic_error e) + wrap_vernac_error with_header exn (Himsg.explain_reduction_tactic_error e) | Logic.RefinerError e -> - wrap_vernac_error exn (Himsg.explain_refiner_error e) + wrap_vernac_error with_header exn (Himsg.explain_refiner_error e) | Nametab.GlobalizationError q -> - wrap_vernac_error exn + wrap_vernac_error with_header exn (str "The reference" ++ spc () ++ Libnames.pr_qualid q ++ spc () ++ str "was not found" ++ spc () ++ str "in the current" ++ spc () ++ str "environment.") | Refiner.FailError (i,s) -> let s = Lazy.force s in - wrap_vernac_error exn + wrap_vernac_error with_header exn (str "Tactic failure" ++ (if Pp.is_empty s then s else str ": " ++ s) ++ if Int.equal i 0 then str "." else str " (level " ++ int i ++ str").") | AlreadyDeclared msg -> - wrap_vernac_error exn (msg ++ str ".") + wrap_vernac_error with_header exn (msg ++ str ".") | _ -> exn @@ -108,9 +110,9 @@ let rec strip_wrapping_exceptions = function strip_wrapping_exceptions e | exc -> exc -let process_vernac_interp_error (exc, info) = +let process_vernac_interp_error ?(with_header=true) (exc, info) = let exc = strip_wrapping_exceptions exc in - let e = process_vernac_interp_error (exc, info) in + let e = process_vernac_interp_error with_header (exc, info) in let ltac_trace = Exninfo.get info Proof_type.ltac_trace_info in let loc = Option.default Loc.ghost (Loc.get_loc info) in match ltac_trace with diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli index 1768af11..100b3772 100644 --- a/toplevel/cerrors.mli +++ b/toplevel/cerrors.mli @@ -12,7 +12,7 @@ val print_loc : Loc.t -> Pp.std_ppcmds (** Pre-explain a vernac interpretation error *) -val process_vernac_interp_error : Util.iexn -> Util.iexn +val process_vernac_interp_error : ?with_header:bool -> Util.iexn -> Util.iexn (** General explain function. Should not be used directly now, see instead function [Errors.print] and variants *) diff --git a/toplevel/classes.ml b/toplevel/classes.ml index f44ac367..33891ad9 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -103,8 +103,13 @@ let instance_hook k pri global imps ?hook cst = let declare_instance_constant k pri global imps ?hook id poly uctx term termtype = let kind = IsDefinition Instance in + let uctx = + let levels = Univ.LSet.union (Universes.universes_of_constr termtype) + (Universes.universes_of_constr term) in + Universes.restrict_universe_context uctx levels + in let entry = - Declare.definition_entry ~types:termtype ~poly ~univs:uctx term + Declare.definition_entry ~types:termtype ~poly ~univs:(Univ.ContextSet.to_context uctx) term in let cdecl = (DefinitionEntry entry, kind) in let kn = Declare.declare_constant id cdecl in @@ -165,7 +170,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro in let env' = push_rel_context ctx env in evars := Evarutil.nf_evar_map !evars; - evars := resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env !evars; + evars := resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:true env !evars; let subst = List.map (Evarutil.nf_evar !evars) subst in if abstract then begin @@ -208,7 +213,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro let get_id = function | Ident id' -> id' - | _ -> errorlabstrm "new_instance" (Pp.str "Only local structures are handled") + | Qualid (loc,id') -> (loc, snd (repr_qualid id')) in let props, rest = List.fold_left @@ -232,7 +237,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro k.cl_projs; c :: props, rest' with Not_found -> - (CHole (Loc.ghost, Some Evar_kinds.GoalEvar, Misctypes.IntroAnonymous, None) :: props), rest + (CHole (Loc.ghost, None(* Some Evar_kinds.GoalEvar *), Misctypes.IntroAnonymous, None) :: props), rest else props, rest) ([], props) k.cl_props in @@ -277,7 +282,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro in let term = Option.map nf term in if not (Evd.has_undefined evm) && not (Option.is_empty term) then - let ctx = Evd.universe_context evm in + let ctx = Evd.universe_context_set evm in declare_instance_constant k pri global imps ?hook id poly ctx (Option.get term) termtype else if !refine_instance || Option.is_empty term then begin diff --git a/toplevel/classes.mli b/toplevel/classes.mli index 0a351d3c..2b7e9e4f 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -8,7 +8,6 @@ open Names open Context -open Evd open Environ open Constrexpr open Typeclasses @@ -33,7 +32,7 @@ val declare_instance_constant : ?hook:(Globnames.global_reference -> unit) -> Id.t -> (** name *) bool -> (* polymorphic *) - Univ.universe_context -> (* Universes *) + Univ.universe_context_set -> (* Universes *) Constr.t -> (** body *) Term.types -> (** type *) Names.Id.t diff --git a/toplevel/command.ml b/toplevel/command.ml index 9cb3bb86..754ad852 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -233,9 +233,9 @@ let declare_assumption is_coe (local,p,kind) (c,ctx) imps impl nl (_,ident) = ma in (gr,inst,Lib.is_modtype_strict ()) -let interp_assumption evdref env bl c = +let interp_assumption evdref env impls bl c = let c = prod_constr_expr c bl in - let ty, impls = interp_type_evars_impls env evdref c in + let ty, impls = interp_type_evars_impls env evdref ~impls c in let evd, nf = nf_evars_and_universes !evdref in let ctx = Evd.universe_context_set evd in ((nf ty, ctx), impls) @@ -259,12 +259,15 @@ let do_assumptions (_, poly, _ as kind) nl l = l [] else l in - let _,l = List.fold_map (fun env (is_coe,(idl,c)) -> - let (t,ctx),imps = interp_assumption evdref env [] c in + let _,l = List.fold_map (fun (env,ienv) (is_coe,(idl,c)) -> + let (t,ctx),imps = interp_assumption evdref env ienv [] c in let env = push_named_context (List.map (fun (_,id) -> (id,None,t)) idl) env in - (env,((is_coe,idl),t,(ctx,imps)))) - env l + let ienv = List.fold_right (fun (_,id) ienv -> + let impls = compute_internalization_data env Variable t imps in + Id.Map.add id impls ienv) idl ienv in + ((env,ienv),((is_coe,idl),t,(ctx,imps)))) + (env,empty_internalization_env) l in let evd = solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref) in let l = List.map (on_pi2 (nf_evar evd)) l in @@ -746,8 +749,8 @@ let interp_fix_body env_rec evdref impls (_,ctx) fix ccl = let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx -let declare_fix (_,poly,_ as kind) ctx f ((def,_),eff) t imps = - let ce = definition_entry ~types:t ~poly ~univs:ctx ~eff def in +let declare_fix ?(opaque = false) (_,poly,_ as kind) ctx f ((def,_),eff) t imps = + let ce = definition_entry ~opaque ~types:t ~poly ~univs:ctx ~eff def in declare_definition f kind ce imps (Lemmas.mk_hook (fun _ r -> r)) let _ = Obligations.declare_fix_ref := declare_fix diff --git a/toplevel/command.mli b/toplevel/command.mli index 894333ad..3a38e52c 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -11,7 +11,6 @@ open Term open Entries open Libnames open Globnames -open Tacexpr open Vernacexpr open Constrexpr open Decl_kinds @@ -167,5 +166,5 @@ val do_cofixpoint : val check_mutuality : Environ.env -> bool -> (Id.t * types) list -> unit -val declare_fix : definition_kind -> Univ.universe_context -> Id.t -> +val declare_fix : ?opaque:bool -> definition_kind -> Univ.universe_context -> Id.t -> Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 03074ced..f1d8a492 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -57,28 +57,20 @@ let load_rcfile() = else Flags.if_verbose msg_info (str"Skipping rcfile loading.") -(* Puts dir in the path of ML and in the LoadPath *) -let coq_add_path unix_path s = - Mltop.add_path ~unix_path ~coq_root:(Names.DirPath.make [Nameops.coq_root;Names.Id.of_string s]) ~implicit:true; - Mltop.add_ml_dir unix_path - (* Recursively puts dir in the LoadPath if -nois was not passed *) let add_stdlib_path ~unix_path ~coq_root ~with_ml = - if !Flags.load_init then - Mltop.add_rec_path ~unix_path ~coq_root ~implicit:true - else - Mltop.add_path ~unix_path ~coq_root ~implicit:false; + Mltop.add_rec_path ~unix_path ~coq_root ~implicit:(!Flags.load_init); if with_ml then Mltop.add_rec_ml_dir unix_path let add_userlib_path ~unix_path = - Mltop.add_path ~unix_path ~coq_root:Nameops.default_root_prefix ~implicit:false; + Mltop.add_rec_path ~unix_path ~coq_root:Nameops.default_root_prefix ~implicit:false; Mltop.add_rec_ml_dir unix_path (* Options -I, -I-as, and -R of the command line *) let includes = ref [] -let push_include s alias recursive implicit = - includes := (s,alias,recursive,implicit) :: !includes +let push_include s alias implicit = + includes := (s, alias, implicit) :: !includes let ml_includes = ref [] let push_ml_include s = ml_includes := s :: !ml_includes @@ -91,10 +83,11 @@ let init_load_path () = let coq_root = Names.DirPath.make [Nameops.coq_root] in (* NOTE: These directories are searched from last to first *) (* first, developer specific directory to open *) - if Coq_config.local then coq_add_path (coqlib/"dev") "dev"; + if Coq_config.local then + Mltop.add_ml_dir (coqlib/"dev"); (* main loops *) if Coq_config.local || !Flags.boot then begin - let () = Mltop.add_ml_dir (coqlib/"stm") in + Mltop.add_ml_dir (coqlib/"stm"); Mltop.add_ml_dir (coqlib/"ide") end; Mltop.add_ml_dir (coqlib/"toploop"); @@ -109,13 +102,13 @@ let init_load_path () = List.iter (fun s -> add_userlib_path ~unix_path:s) xdg_dirs; (* then directories in COQPATH *) List.iter (fun s -> add_userlib_path ~unix_path:s) coqpath; - (* then current directory *) - Mltop.add_path ~unix_path:"." ~coq_root:Nameops.default_root_prefix ~implicit:false; - (* additional loadpath, given with options -I-as, -Q, and -R *) + (* then current directory (not recursively!) *) + Mltop.add_ml_dir "."; + Loadpath.add_load_path "." Nameops.default_root_prefix ~implicit:false; + (* additional loadpath, given with options -Q and -R *) List.iter - (fun (unix_path, coq_root, reci, implicit) -> - (if reci then Mltop.add_rec_path else Mltop.add_path) - ~unix_path ~coq_root ~implicit) + (fun (unix_path, coq_root, implicit) -> + Mltop.add_rec_path ~unix_path ~coq_root ~implicit) (List.rev !includes); (* additional ml directories, given with option -I *) List.iter Mltop.add_ml_dir (List.rev !ml_includes) diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli index 5f7133c3..c019cc1c 100644 --- a/toplevel/coqinit.mli +++ b/toplevel/coqinit.mli @@ -15,8 +15,8 @@ val set_rcfile : string -> unit val no_load_rc : unit -> unit val load_rcfile : unit -> unit -val push_include : string -> Names.DirPath.t -> bool -> bool -> unit -(** [push_include phys_path log_path recursive implicit] *) +val push_include : string -> Names.DirPath.t -> bool -> unit +(** [push_include phys_path log_path implicit] *) val push_ml_include : string -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 142f3386..e9e86953 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -135,9 +135,9 @@ let set_outputstate s = outputstate:=s let outputstate () = if not (String.is_empty !outputstate) then extern_state !outputstate -let set_include d p recursive implicit = +let set_include d p implicit = let p = dirpath_of_string p in - push_include d p recursive implicit + push_include d p implicit let load_vernacular_list = ref ([] : (string * bool) list) let add_load_vernacular verb s = @@ -378,7 +378,7 @@ let schedule_vio_compilation () = let get_native_name s = (* We ignore even critical errors because this mode has to be super silent *) try - String.concat Filename.dir_sep [Filename.dirname s; + String.concat "/" [Filename.dirname s; Nativelib.output_dir; Library.native_name_from_filename s] with _ -> "" @@ -402,21 +402,21 @@ let parse_args arglist = (* Complex options with many args *) |"-I"|"-include" -> begin match rem with - | d :: "-as" :: p :: rem -> set_include d p false true; args := rem - | d :: "-as" :: [] -> error_missing_arg "-as" | d :: rem -> push_ml_include d; args := rem | [] -> error_missing_arg opt end |"-Q" -> begin match rem with - | d :: p :: rem -> set_include d p true false; args := rem + | d :: p :: rem -> set_include d p false; args := rem | _ -> error_missing_arg opt end |"-R" -> begin match rem with - | d :: "-as" :: [] -> error_missing_arg "-as" - | d :: "-as" :: p :: rem - | d :: p :: rem -> set_include d p true true; args := rem + | d :: "-as" :: [] -> error_missing_arg opt + | d :: "-as" :: p :: rem -> + warning "option -R * -as * deprecated, remove the -as"; + set_include d p true; args := rem + | d :: p :: rem -> set_include d p true; args := rem | _ -> error_missing_arg opt end diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 9341f2f7..5429e660 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -879,7 +879,9 @@ let explain_label_already_declared l = str ("The label "^Label.to_string l^" is already declared.") let explain_application_to_not_path _ = - str "Application of modules is restricted to paths." + strbrk "A module cannot be applied to another module application or " ++ + strbrk "with-expression; you must give a name to the intermediate result " ++ + strbrk "module first." let explain_not_a_functor () = str "Application of a non-functor." diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index e6b23828..fbc45b4a 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -85,7 +85,7 @@ let _ = { optsync = true; optdepr = false; optname = "automatic declaration of boolean equality"; - optkey = ["Equality";"Schemes"]; + optkey = ["Boolean";"Equality";"Schemes"]; optread = (fun () -> !eq_flag) ; optwrite = (fun b -> eq_flag := b) } let _ = (* compatibility *) diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 161cf824..639ec1e6 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -61,23 +61,42 @@ let rec make_tags = function | GramNonTerminal (loc, etyp, _, po) :: l -> etyp :: make_tags l | [] -> [] +let make_fresh_key = + let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in + fun () -> + let cur = incr id; !id in + let lbl = Id.of_string ("_" ^ string_of_int cur) in + let kn = Lib.make_kn lbl in + let (mp, dir, _) = KerName.repr kn in + (** We embed the full path of the kernel name in the label so that the + identifier should be unique. This ensures that including two modules + together won't confuse the corresponding labels. *) + let lbl = Id.of_string_soft (Printf.sprintf "%s#%s#%i" + (ModPath.to_string mp) (DirPath.to_string dir) cur) + in + KerName.make mp dir (Label.of_id lbl) + type tactic_grammar_obj = { + tacobj_key : KerName.t; tacobj_local : locality_flag; tacobj_tacgram : tactic_grammar; tacobj_tacpp : Pptactic.pp_tactic; tacobj_body : Tacexpr.glob_tactic_expr } -let cache_tactic_notation ((_, key), tobj) = +let cache_tactic_notation (_, tobj) = + let key = tobj.tacobj_key in Tacenv.register_alias key tobj.tacobj_body; Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram; Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp -let open_tactic_notation i ((_, key), tobj) = +let open_tactic_notation i (_, tobj) = + let key = tobj.tacobj_key in if Int.equal i 1 && not tobj.tacobj_local then Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram -let load_tactic_notation i ((_, key), tobj) = +let load_tactic_notation i (_, tobj) = + let key = tobj.tacobj_key in (** Only add the printing and interpretation rules. *) Tacenv.register_alias key tobj.tacobj_body; Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp; @@ -85,7 +104,10 @@ let load_tactic_notation i ((_, key), tobj) = Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram let subst_tactic_notation (subst, tobj) = - { tobj with tacobj_body = Tacsubst.subst_tactic subst tobj.tacobj_body; } + { tobj with + tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; + tacobj_body = Tacsubst.subst_tactic subst tobj.tacobj_body; + } let classify_tactic_notation tacobj = Substitute tacobj @@ -115,6 +137,7 @@ let add_tactic_notation (local,n,prods,e) = tacgram_prods = prods; } in let tacobj = { + tacobj_key = make_fresh_key (); tacobj_local = local; tacobj_tacgram = parule; tacobj_tacpp = pprule; @@ -1103,7 +1126,7 @@ let open_notation i (_, nobj) = let scope = nobj.notobj_scope in let (ntn, df) = nobj.notobj_notation in let pat = nobj.notobj_interp in - if Int.equal i 1 then begin + if Int.equal i 1 && not (Notation.exists_notation_in_scope scope ntn pat) then begin (* Declare the interpretation *) Notation.declare_notation_interpretation ntn scope pat df; (* Declare the uninterpretation *) diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml index 9dc1dd5b..0b6fc48c 100644 --- a/toplevel/mltop.ml +++ b/toplevel/mltop.ml @@ -161,17 +161,6 @@ let add_rec_ml_dir unix_path = (* Adding files to Coq and ML loadpath *) -let add_path ~unix_path:dir ~coq_root:coq_dirpath ~implicit = - if exists_dir dir then - begin - add_ml_dir dir; - Loadpath.add_load_path dir - (if implicit then Loadpath.ImplicitRootPath else Loadpath.RootPath) - coq_dirpath - end - else - msg_warning (str ("Cannot open " ^ dir)) - let convert_string d = try Names.Id.of_string d with UserError _ -> @@ -191,11 +180,9 @@ let add_rec_path ~unix_path ~coq_root ~implicit = let dirs = List.map_filter convert_dirs dirs in let () = add_ml_dir unix_path in let add (path, dir) = - Loadpath.add_load_path path Loadpath.ImplicitPath dir in - let () = if implicit then List.iter add dirs in - Loadpath.add_load_path unix_path - (if implicit then Loadpath.ImplicitRootPath else Loadpath.RootPath) - coq_root + Loadpath.add_load_path path ~implicit dir in + let () = List.iter add dirs in + Loadpath.add_load_path unix_path ~implicit coq_root else msg_warning (str ("Cannot open " ^ unix_path)) diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli index 2a91afd8..4f3f4ddd 100644 --- a/toplevel/mltop.mli +++ b/toplevel/mltop.mli @@ -47,7 +47,6 @@ val add_ml_dir : string -> unit val add_rec_ml_dir : string -> unit (** Adds a path to the Coq and ML paths *) -val add_path : unix_path:string -> coq_root:Names.DirPath.t -> implicit:bool -> unit val add_rec_path : unix_path:string -> coq_root:Names.DirPath.t -> implicit:bool -> unit (** List of modules linked to the toplevel *) diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index aa068586..523134b5 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -21,7 +21,7 @@ open Pp open Errors open Util -let declare_fix_ref = ref (fun _ _ _ _ _ _ -> assert false) +let declare_fix_ref = ref (fun ?opaque _ _ _ _ _ _ -> assert false) let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false) let trace s = @@ -319,6 +319,7 @@ type program_info = { prg_kind : definition_kind; prg_reduce : constr -> constr; prg_hook : unit Lemmas.declaration_hook; + prg_opaque : bool; } let assumption_message = Declare.assumption_message @@ -512,8 +513,9 @@ let declare_definition prg = let body, typ = subst_body true prg in let nf = Universes.nf_evars_and_universes_opt_subst (fun x -> None) (Evd.evar_universe_context_subst prg.prg_ctx) in + let opaque = prg.prg_opaque in let ce = - definition_entry ~types:(nf typ) ~poly:(pi2 prg.prg_kind) + definition_entry ~opaque ~types:(nf typ) ~poly:(pi2 prg.prg_kind) ~univs:(Evd.evar_context_universe_context prg.prg_ctx) (nf body) in progmap_remove prg; @@ -564,6 +566,7 @@ let declare_mutual_definition l = let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in let (local,poly,kind) = first.prg_kind in let fixnames = first.prg_deps in + let opaque = first.prg_opaque in let kind = if fixkind != IsCoFixpoint then Fixpoint else CoFixpoint in let indexes, fixdecls = match fixkind with @@ -584,7 +587,7 @@ let declare_mutual_definition l = in (* Declare the recursive definitions *) let ctx = Evd.evar_context_universe_context first.prg_ctx in - let kns = List.map4 (!declare_fix_ref (local, poly, kind) ctx) + let kns = List.map4 (!declare_fix_ref ~opaque (local, poly, kind) ctx) fixnames fixdecls fixtypes fiximps in (* Declare notations *) List.iter Metasyntax.add_notation_interpretation first.prg_notations; @@ -640,7 +643,7 @@ let declare_obligation prg obl body ty uctx = else Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) } -let init_prog_info n b t ctx deps fixkind notations obls impls kind reduce hook = +let init_prog_info ?(opaque = false) n b t ctx deps fixkind notations obls impls kind reduce hook = let obls', b = match b with | None -> @@ -655,7 +658,7 @@ let init_prog_info n b t ctx deps fixkind notations obls impls kind reduce hook Array.mapi (fun i (n, t, l, o, d, tac) -> { obl_name = n ; obl_body = None; - obl_location = l; obl_type = reduce t; obl_status = o; + obl_location = l; obl_type = t; obl_status = o; obl_deps = d; obl_tac = tac }) obls, b in @@ -664,7 +667,8 @@ let init_prog_info n b t ctx deps fixkind notations obls impls kind reduce hook prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; - prg_hook = hook; } + prg_hook = hook; + prg_opaque = opaque; } let get_prog name = let prg_infos = !from_prg in @@ -976,9 +980,9 @@ let show_term n = ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body) let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic - ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ -> ())) obls = + ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ -> ())) ?(opaque = false) obls = let info = str (Id.to_string n) ++ str " has type-checked" in - let prg = init_prog_info n term t ctx [] None [] obls implicits kind reduce hook in + let prg = init_prog_info ~opaque n term t ctx [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose msg_info (info ++ str "."); @@ -994,11 +998,11 @@ let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) | _ -> res) let add_mutual_definitions l ctx ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) - ?(hook=Lemmas.mk_hook (fun _ _ -> ())) notations fixkind = + ?(hook=Lemmas.mk_hook (fun _ _ -> ())) ?(opaque = false) notations fixkind = let deps = List.map (fun (n, b, t, imps, obls) -> n) l in List.iter (fun (n, b, t, imps, obls) -> - let prg = init_prog_info n (Some b) t ctx deps (Some fixkind) + let prg = init_prog_info ~opaque n (Some b) t ctx deps (Some fixkind) notations obls imps kind reduce hook in progmap_add n prg) l; let _defined = diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli index 582b4935..40f124ca 100644 --- a/toplevel/obligations.mli +++ b/toplevel/obligations.mli @@ -14,10 +14,9 @@ open Pp open Globnames open Vernacexpr open Decl_kinds -open Tacexpr (** Forward declaration. *) -val declare_fix_ref : (definition_kind -> Univ.universe_context -> Id.t -> +val declare_fix_ref : (?opaque:bool -> definition_kind -> Univ.universe_context -> Id.t -> Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference) ref val declare_definition_ref : @@ -69,7 +68,7 @@ val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types -> ?kind:Decl_kinds.definition_kind -> ?tactic:unit Proofview.tactic -> ?reduce:(Term.constr -> Term.constr) -> - ?hook:unit Lemmas.declaration_hook -> obligation_info -> progress + ?hook:unit Lemmas.declaration_hook -> ?opaque:bool -> obligation_info -> progress type notations = (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list @@ -85,7 +84,7 @@ val add_mutual_definitions : ?tactic:unit Proofview.tactic -> ?kind:Decl_kinds.definition_kind -> ?reduce:(Term.constr -> Term.constr) -> - ?hook:unit Lemmas.declaration_hook -> + ?hook:unit Lemmas.declaration_hook -> ?opaque:bool -> notations -> fixpoint_kind -> unit diff --git a/toplevel/record.ml b/toplevel/record.ml index 55f53351..737b7fb5 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -472,10 +472,15 @@ let add_inductive_class ind = let k = let ctx = oneind.mind_arity_ctxt in let inst = Univ.UContext.instance mind.mind_universes in + let map = function + | (_, Some _, _) -> None + | (_, None, t) -> Some (lazy t) + in + let args = List.map_filter map ctx in let ty = Inductive.type_of_inductive_knowing_parameters (push_rel_context ctx (Global.env ())) ((mind,oneind),inst) - (Array.map (fun x -> lazy x) (Termops.extended_rel_vect 0 ctx)) + (Array.of_list args) in { cl_impl = IndRef ind; cl_context = List.map (const None) ctx, ctx; diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib index d22524e5..bf0f305a 100644 --- a/toplevel/toplevel.mllib +++ b/toplevel/toplevel.mllib @@ -13,7 +13,6 @@ Record Vernacinterp Mltop Vernacentries -Whelp Vernac Usage Coqloop diff --git a/toplevel/usage.ml b/toplevel/usage.ml index d4d44569..f053839c 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -23,9 +23,7 @@ let print_usage_channel co command = output_string co " -I dir look for ML files in dir\ \n -include dir (idem)\ -\n -I dir -as coqdir implicitly map physical dir to logical coqdir\ -\n -R dir -as coqdir recursively map physical dir to logical coqdir\ -\n -R dir coqdir (idem)\ +\n -R dir coqdir recursively map physical dir to logical coqdir\ \n -Q dir coqdir map physical dir to logical coqdir\ \n -top coqdir set the toplevel name to be coqdir instead of Top\ \n -notop set the toplevel name to be the empty logical path\ @@ -47,6 +45,11 @@ let print_usage_channel co command = \n -require f load Coq object file f.vo and import it (Require f.)\ \n -compile f compile Coq file f.v (implies -batch)\ \n -compile-verbose f verbosely compile Coq file f.v (implies -batch)\ +\n -quick quickly compile .v files to .vio files (skip proofs)\ +\n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\ +\n into fi.vo\ +\n -schedule-vio-checking j f1..fn run up to j instances of Coq to check all\ +\n proofs in each fi.vio\ \n\ \n -where print Coq's standard library location and exit\ \n -config print Coq's configuration information and exit\ @@ -66,6 +69,7 @@ let print_usage_channel co command = \n -with-geoproof (yes|no) to (de)activate special functions for Geoproof within Coqide (default is yes)\ \n -impredicative-set set sort Set impredicative\ \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ +\n -type-in-type disable universe consistency checking\ \n -time display the time taken by each command\ \n -no-native-compiler disable the native_compute reduction machinery\ \n -h, -help print this list of options\ diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index fb12edfb..cfa9bddc 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -387,12 +387,13 @@ let err_unmapped_library loc qid = pr_dirpath dir ++ str".") let err_notfound_library loc qid = - msg_error - (hov 0 (strbrk "Unable to locate library " ++ pr_qualid qid ++ str".")) + user_err_loc + (loc,"locate_library", + strbrk "Unable to locate library " ++ pr_qualid qid ++ str".") let print_located_library r = let (loc,qid) = qualid_of_reference r in - try msg_found_library (Library.locate_qualified_library false qid) + try msg_found_library (Library.locate_qualified_library ~warn:false qid) with | Library.LibUnmappedDir -> err_unmapped_library loc qid | Library.LibNotFound -> err_notfound_library loc qid @@ -496,7 +497,7 @@ let vernac_exact_proof c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the begining of a proof. *) let status = by (Tactics.New.exact_proof c) in - save_proof (Vernacexpr.Proved(true,None)); + save_proof (Vernacexpr.(Proved(Opaque None,None))); if not status then Pp.feedback Feedback.AddedAxiom let vernac_assumption locality poly (local, kind) l nl = @@ -598,11 +599,8 @@ let vernac_constraint l = do_constraint l (* Modules *) let vernac_import export refl = - let import ref = - Library.import_module export (qualid_of_reference ref) - in - List.iter import refl; - Lib.add_frozen_state () + Library.import_module export (List.map qualid_of_reference refl); + Lib.add_frozen_state () let vernac_declare_module export (loc, id) binders_ast mty_ast = (* We check the state of the system (in section, in module type) @@ -752,9 +750,25 @@ let vernac_end_segment (_,id as lid) = (* Libraries *) -let vernac_require import qidl = +let vernac_require from import qidl = let qidl = List.map qualid_of_reference qidl in - let modrefl = List.map Library.try_locate_qualified_library qidl in + let root = match from with + | None -> None + | Some from -> + let (_, qid) = Libnames.qualid_of_reference from in + let (hd, tl) = Libnames.repr_qualid qid in + Some (Libnames.add_dirpath_suffix hd tl) + in + let locate (loc, qid) = + try + let warn = Flags.is_verbose () in + let (_, dir, f) = Library.locate_qualified_library ?root ~warn qid in + (dir, f) + with + | Library.LibUnmappedDir -> err_unmapped_library loc qid + | Library.LibNotFound -> err_notfound_library loc qid + in + let modrefl = List.map locate qidl in if Dumpglob.dump () then List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref loc dp "lib") qidl (List.map fst modrefl); Library.require_library_from_dirpath modrefl import @@ -878,11 +892,10 @@ let vernac_set_used_variables e = let expand filename = Envars.expand_path_macros ~warn:(fun x -> msg_warning (str x)) filename -let vernac_add_loadpath isrec pdir ldiropt = +let vernac_add_loadpath implicit pdir ldiropt = let pdir = expand pdir in let alias = Option.default Nameops.default_root_prefix ldiropt in - (if isrec then Mltop.add_rec_path else Mltop.add_path) - ~unix_path:pdir ~coq_root:alias ~implicit:true + Mltop.add_rec_path ~unix_path:pdir ~coq_root:alias ~implicit let vernac_remove_loadpath path = Loadpath.remove_load_path (expand path) @@ -963,20 +976,27 @@ let register_ltac local isrec tacl = (name, body) in let rfun = List.map map tacl in - let ltacrecvars = + let recvars = let fold accu (op, _) = match op with | UpdateTac _ -> accu - | NewTac id -> Id.Map.add id (Lib.make_kn id) accu + | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu in - if isrec then List.fold_left fold Id.Map.empty rfun - else Id.Map.empty + if isrec then List.fold_left fold [] rfun + else [] in - let ist = { (Tacintern.make_empty_glob_sign ()) with Genintern.ltacrecvars; } in + let ist = Tacintern.make_empty_glob_sign () in let map (name, body) = let body = Flags.with_option Tacintern.strict_check (Tacintern.intern_tactic_or_tacarg ist) body in (name, body) in - let defs = List.map map rfun in + let defs () = + (** Register locally the tactic to handle recursivity. This function affects + the whole environment, so that we transactify it afterwards. *) + let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in + let () = List.iter iter_rec recvars in + List.map map rfun + in + let defs = Future.transactify defs () in let iter (def, tac) = match def with | NewTac id -> Tacenv.register_ltac false local id tac; @@ -1124,6 +1144,7 @@ let vernac_declare_arguments locality r l nargs flags = vernac_declare_implicits locality r implicits; if nargs >= 0 && nargs < List.fold_left max 0 rargs then error "The \"/\" option must be placed after the last \"!\"."; + let no_flags = List.is_empty flags in let rec narrow = function | #Reductionops.ReductionBehaviour.flag as x :: tl -> x :: narrow tl | [] -> [] | _ :: tl -> narrow tl in @@ -1141,7 +1162,7 @@ let vernac_declare_arguments locality r l nargs flags = some_implicits_specified || some_scopes_specified || some_simpl_flags_specified) && - List.length flags = 0 then + no_flags then msg_warning (strbrk "This command is just asserting the number and names of arguments of " ++ pr_global sr ++ strbrk". If this is what you want add ': assert' to silence the warning. If you want to clear implicit arguments add ': clear implicits'. If you want to clear notation scopes add ': clear scopes'") @@ -1503,7 +1524,7 @@ let vernac_check_may_eval redexp glopt rc = Evarconv.check_problems_are_solved env sigma'; let sigma',nf = Evarutil.nf_evars_and_universes sigma' in let uctx = Evd.universe_context sigma' in - let env = Environ.push_context uctx env in + let env = Environ.push_context uctx (Evarutil.nf_env_evar sigma' env) in let c = nf c in let j = if Evarutil.has_undefined_evars sigma' c then @@ -1516,12 +1537,8 @@ let vernac_check_may_eval redexp glopt rc = let l = Evar.Set.union (Evd.evars_of_term j.Environ.uj_val) (Evd.evars_of_term j.Environ.uj_type) in let j = { j with Environ.uj_type = Reductionops.nf_betaiota sigma' j.Environ.uj_type } in msg_notice (print_judgment env sigma' j ++ - (if l != Evar.Set.empty then - let l = Evar.Set.fold (fun ev -> Evar.Map.add ev (Evarutil.nf_evar_info sigma' (Evd.find sigma' ev))) l Evar.Map.empty in - (fnl () ++ str "where" ++ fnl () ++ pr_evars sigma' l) - else - mt ()) ++ - Printer.pr_universe_ctx uctx) + pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma' l ++ + Printer.pr_universe_ctx uctx) | Some r -> Tacintern.dump_glob_red_expr r; let (sigma',r_interp) = interp_redexp env sigma' r in @@ -1883,7 +1900,7 @@ let interp ?proof locality poly c = | VernacNameSectionHypSet (lid, set) -> vernac_name_sec_hyp lid set - | VernacRequire (export, qidl) -> vernac_require export qidl + | VernacRequire (from, export, qidl) -> vernac_require from export qidl | VernacImport (export,qidl) -> vernac_import export qidl | VernacCanonical qid -> vernac_canonical qid | VernacCoercion (local,r,s,t) -> vernac_coercion locality poly local r s t @@ -1951,14 +1968,16 @@ let interp ?proof locality poly c = | VernacComments l -> if_verbose msg_info (str "Comments ok\n") | VernacNop -> () + (* The STM should handle that, but LOAD bypasses the STM... *) + | VernacAbort id -> msg_warning (str "VernacAbort not handled by Stm") + | VernacAbortAll -> msg_warning (str "VernacAbortAll not handled by Stm") + | VernacRestart -> msg_warning (str "VernacRestart not handled by Stm") + | VernacUndo _ -> msg_warning (str "VernacUndo not handled by Stm") + | VernacUndoTo _ -> msg_warning (str "VernacUndoTo not handled by Stm") + | VernacBacktrack _ -> msg_warning (str "VernacBacktrack not handled by Stm") + (* Proof management *) | VernacGoal t -> vernac_start_proof poly Theorem [None,([],t,None)] false - | VernacAbort id -> anomaly (str "VernacAbort not handled by Stm") - | VernacAbortAll -> anomaly (str "VernacAbortAll not handled by Stm") - | VernacRestart -> anomaly (str "VernacRestart not handled by Stm") - | VernacUndo _ -> anomaly (str "VernacUndo not handled by Stm") - | VernacUndoTo _ -> anomaly (str "VernacUndoTo not handled by Stm") - | VernacBacktrack _ -> anomaly (str "VernacBacktrack not handled by Stm") | VernacFocus n -> vernac_focus n | VernacUnfocus -> vernac_unfocus () | VernacUnfocused -> vernac_unfocused () @@ -2061,7 +2080,7 @@ let locate_if_not_already loc (e, info) = | Some l -> if Loc.is_ghost l then (e, Loc.add_loc info loc) else (e, info) exception HasNotFailed -exception HasFailed of string +exception HasFailed of std_ppcmds let with_fail b f = if not b then f () @@ -2076,8 +2095,8 @@ let with_fail b f = | HasNotFailed as e -> raise e | e -> let e = Errors.push e in - raise (HasFailed (Pp.string_of_ppcmds - (Errors.iprint (Cerrors.process_vernac_interp_error e))))) + raise (HasFailed (Errors.iprint + (Cerrors.process_vernac_interp_error ~with_header:false e)))) () with e when Errors.noncritical e -> let (e, _) = Errors.push e in @@ -2086,8 +2105,7 @@ let with_fail b f = errorlabstrm "Fail" (str "The command has not failed!") | HasFailed msg -> if is_verbose () || !Flags.ide_slave then msg_info - (str "The command has indeed failed with message:" ++ - fnl () ++ str "=> " ++ hov 0 (str msg)) + (str "The command has indeed failed with message:" ++ fnl () ++ msg) | _ -> assert false end diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml index 17f971fd..d3e48f75 100644 --- a/toplevel/vernacinterp.ml +++ b/toplevel/vernacinterp.ml @@ -10,14 +10,17 @@ open Util open Pp open Errors +type deprecation = bool +type vernac_command = Genarg.raw_generic_argument list -> unit -> unit + (* Table of vernac entries *) let vernac_tab = (Hashtbl.create 51 : - (Vernacexpr.extend_name, (Genarg.raw_generic_argument list -> unit -> unit)) Hashtbl.t) + (Vernacexpr.extend_name, deprecation * vernac_command) Hashtbl.t) -let vinterp_add s f = +let vinterp_add depr s f = try - Hashtbl.add vernac_tab s f + Hashtbl.add vernac_tab s (depr, f) with Failure _ -> errorlabstrm "vinterp_add" (str"Cannot add the vernac command " ++ str (fst s) ++ str" twice.") @@ -28,7 +31,7 @@ let overwriting_vinterp_add s f = let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s with Not_found -> () end; - Hashtbl.add vernac_tab s f + Hashtbl.add vernac_tab s (false, f) let vinterp_map s = try @@ -44,7 +47,16 @@ let vinterp_init () = Hashtbl.clear vernac_tab let call ?locality (opn,converted_args) = let loc = ref "Looking up command" in try - let callback = vinterp_map opn in + let depr, callback = vinterp_map opn in + let () = if depr then + let rules = Egramml.get_extend_vernac_rule opn in + let pr_gram = function + | Egramml.GramTerminal s -> str s + | Egramml.GramNonTerminal _ -> str "_" + in + let pr = pr_sequence pr_gram rules in + msg_warning (str "Deprecated vernacular command: " ++ pr) + in loc:= "Checking arguments"; let hunk = callback converted_args in loc:= "Executing command"; diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli index 38fce5d1..02820654 100644 --- a/toplevel/vernacinterp.mli +++ b/toplevel/vernacinterp.mli @@ -8,9 +8,13 @@ (** Interpretation of extended vernac phrases. *) -val vinterp_add : Vernacexpr.extend_name -> (Genarg.raw_generic_argument list -> unit -> unit) -> unit +type deprecation = bool +type vernac_command = Genarg.raw_generic_argument list -> unit -> unit + +val vinterp_add : deprecation -> Vernacexpr.extend_name -> + vernac_command -> unit val overwriting_vinterp_add : - Vernacexpr.extend_name -> (Genarg.raw_generic_argument list -> unit -> unit) -> unit + Vernacexpr.extend_name -> vernac_command -> unit val vinterp_init : unit -> unit val call : ?locality:bool -> Vernacexpr.extend_name * Genarg.raw_generic_argument list -> unit diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4 deleted file mode 100644 index daedc30f..00000000 --- a/toplevel/whelp.ml4 +++ /dev/null @@ -1,224 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "grammar/grammar.cma" i*) - -open Flags -open Pp -open Errors -open Names -open Term -open Glob_term -open Libnames -open Globnames -open Nametab -open Detyping -open Constrintern -open Dischargedhypsmap -open Pfedit -open Tacmach -open Misctypes - -(* Coq interface to the Whelp query engine developed at - the University of Bologna *) - -let whelp_server_name = ref "http://mowgli.cs.unibo.it:58080" -let getter_server_name = ref "http://mowgli.cs.unibo.it:58081" - -open Goptions - -let _ = - declare_string_option - { optsync = false; - optdepr = false; - optname = "Whelp server"; - optkey = ["Whelp";"Server"]; - optread = (fun () -> !whelp_server_name); - optwrite = (fun s -> whelp_server_name := s) } - -let _ = - declare_string_option - { optsync = false; - optdepr = false; - optname = "Whelp getter"; - optkey = ["Whelp";"Getter"]; - optread = (fun () -> !getter_server_name); - optwrite = (fun s -> getter_server_name := s) } - - -let make_whelp_request req c = - !whelp_server_name ^ "/apply?xmluri=" ^ !getter_server_name ^ "/getempty¶m.profile=firewall&profile=firewall¶m.keys=d_c%2CC1%2CHC2%2CL¶m.embedkeys=d_c%2CTC1%2CHC2%2CL¶m.thkeys=T1%2CT2%2CL%2CE¶m.prooftreekeys=HAT%2CG%2CHAO%2CL¶m.media-type=text%2Fhtml¶m.thmedia-type=&prooftreemedia-type=¶m.doctype-public=¶m.encoding=¶m.thencoding=¶m.prooftreeencoding=&advanced=no&keys=S%2CT1%2CT2%2CL%2CRT%2CE¶m.expression=" ^ c ^ "¶m.action=" ^ req - -let b = Buffer.create 16 - -let url_char c = - if 'A' <= c && c <= 'Z' || 'a' <= c && c <= 'z' || - '0' <= c && c <= '9' || c ='.' - then Buffer.add_char b c - else Buffer.add_string b (Printf.sprintf "%%%2X" (Char.code c)) - -let url_string s = String.iter url_char s - -let rec url_list_with_sep sep f = function - | [] -> () - | [a] -> f a - | a::l -> f a; url_string sep; url_list_with_sep sep f l - -let url_id id = url_string (Id.to_string id) - -let uri_of_dirpath dir = - url_string "cic:/"; url_list_with_sep "/" url_id (List.rev dir) - -let error_whelp_unknown_reference ref = - let qid = Nametab.shortest_qualid_of_global Id.Set.empty ref in - errorlabstrm "" - (strbrk "Definitions of the current session, like " ++ pr_qualid qid ++ - strbrk ", are not supported in Whelp.") - -let uri_of_repr_kn ref (mp,dir,l) = - match mp with - | MPfile sl -> - uri_of_dirpath (Label.to_id l :: DirPath.repr dir @ DirPath.repr sl) - | _ -> - error_whelp_unknown_reference ref - -let url_paren f l = url_char '('; f l; url_char ')' -let url_bracket f l = url_char '['; f l; url_char ']' - -let whelp_of_glob_sort = function - | GProp -> "Prop" - | GSet -> "Set" - | GType _ -> "Type" - -let uri_int n = Buffer.add_string b (string_of_int n) - -let uri_of_ind_pointer l = - url_string ".ind#xpointer"; url_paren (url_list_with_sep "/" uri_int) l - -let uri_of_global ref = - match ref with - | VarRef id -> error ("Unknown Whelp reference: "^(Id.to_string id)^".") - | ConstRef cst -> - uri_of_repr_kn ref (repr_con cst); url_string ".con" - | IndRef (kn,i) -> - uri_of_repr_kn ref (repr_mind kn); uri_of_ind_pointer [1;i+1] - | ConstructRef ((kn,i),j) -> - uri_of_repr_kn ref (repr_mind kn); uri_of_ind_pointer [1;i+1;j] - -let whelm_special = Id.of_string "WHELM_ANON_VAR" - -let url_of_name = function - | Name id -> url_id id - | Anonymous -> url_id whelm_special (* No anon id in Whelp *) - -let uri_of_binding f (id,c) = url_id id; url_string "\\Assign "; f c - -let uri_params f = function - | [] -> () - | l -> url_string "\\subst"; - url_bracket (url_list_with_sep ";" (uri_of_binding f)) l - -let get_discharged_hyp_names sp = List.map basename (get_discharged_hyps sp) - -let section_parameters = function - | GRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_)),_) -> - get_discharged_hyp_names (path_of_global (IndRef(induri,0))) - | GRef (_,(ConstRef cst as ref),_) -> - get_discharged_hyp_names (path_of_global ref) - | _ -> [] - -let merge vl al = - let rec aux acc = function - | ([],l) | (_,([] as l)) -> List.rev acc, l - | (v::vl,a::al) -> aux ((v,a)::acc) (vl,al) - in aux [] (vl,al) - -let rec uri_of_constr c = - match c with - | GVar (_,id) -> url_id id - | GRef (_,ref,_) -> uri_of_global ref - | GHole _ | GEvar _ -> url_string "?" - | GSort (_,s) -> url_string (whelp_of_glob_sort s) - | GApp (_,f,args) -> - let inst,rest = merge (section_parameters f) args in - uri_of_constr f; url_char ' '; uri_params uri_of_constr inst; - url_list_with_sep " " uri_of_constr rest - | GLambda (_,na,k,ty,c) -> - url_string "\\lambda "; url_of_name na; url_string ":"; - uri_of_constr ty; url_string "."; uri_of_constr c - | GProd (_,Anonymous,k,ty,c) -> - uri_of_constr ty; url_string "\\to "; uri_of_constr c - | GProd (_,Name id,k,ty,c) -> - url_string "\\forall "; url_id id; url_string ":"; - uri_of_constr ty; url_string "."; uri_of_constr c - | GLetIn (_,na,b,c) -> - url_string "let "; url_of_name na; url_string "\\def "; - uri_of_constr b; url_string " in "; uri_of_constr c - | GCast (_,c, (CastConv t|CastVM t|CastNative t)) -> - uri_of_constr c; url_string ":"; uri_of_constr t - | GRec _ | GIf _ | GLetTuple _ | GCases _ -> - error "Whelp does not support pattern-matching and (co-)fixpoint." - | GCast (_,_, CastCoerce) -> - anomaly (Pp.str "Written w/o parenthesis") - | GPatVar _ -> - anomaly (Pp.str "Found constructors not supported in constr") - -let make_string f x = Buffer.reset b; f x; Buffer.contents b - -let send_whelp req s = - let url = make_whelp_request req s in - let command = Util.subst_command_placeholder browser_cmd_fmt url in - let _ = CUnix.run_command ~hook:print_string command in () - -let whelp_constr env sigma req c = - let c = detype false [whelm_special] env sigma c in - send_whelp req (make_string uri_of_constr c) - -let whelp_constr_expr req c = - let (sigma,env)= Lemmas.get_current_context () in - let _,c = interp_open_constr env sigma c in - whelp_constr env sigma req c - -let whelp_locate s = - send_whelp "locate" s - -let whelp_elim ind = - send_whelp "elim" (make_string uri_of_global (IndRef ind)) - -let on_goal f = - let gls = Proof.V82.subgoals (get_pftreestate ()) in - let gls = { gls with Evd.it = List.hd gls.Evd.it } in - f (pf_env gls) (project gls) (Termops.it_mkNamedProd_or_LetIn (pf_concl gls) (pf_hyps gls)) - -type whelp_request = - | Locate of string - | Elim of inductive - | Constr of string * constr - -let whelp = function - | Locate s -> whelp_locate s - | Elim ind -> whelp_elim ind - | Constr (s,c) -> whelp_constr (Global.env()) (Evd.empty) s c - -VERNAC ARGUMENT EXTEND whelp_constr_request -| [ "Match" ] -> [ "match" ] -| [ "Instance" ] -> [ "instance" ] -END - -VERNAC COMMAND EXTEND Whelp CLASSIFIED AS QUERY -| [ "Whelp" "Locate" string(s) ] -> [ whelp_locate s ] -| [ "Whelp" "Locate" preident(s) ] -> [ whelp_locate s ] -| [ "Whelp" "Elim" global(r) ] -> [ whelp_elim (Smartlocate.global_inductive_with_alias r) ] -| [ "Whelp" whelp_constr_request(req) constr(c) ] -> [ whelp_constr_expr req c] -END - -VERNAC COMMAND EXTEND WhelpHint CLASSIFIED AS QUERY -| [ "Whelp" "Hint" constr(c) ] -> [ whelp_constr_expr "hint" c ] -| [ "Whelp" "Hint" ] => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ] -> - [ on_goal (fun env sigma -> whelp_constr env sigma "hint") ] -END |