diff options
| author |  Stephane Glondu <steph@glondu.net> | 2012-06-04 12:23:14 +0200 |
|---|---|---|
| committer | Stephane Glondu <steph@glondu.net> | 2012-06-04 12:23:14 +0200 |
| commit | 86535d84cc3cffeee1dcd8545343f234e7285530 (patch) | |
| tree | 9b221c283c2971f7ac151397231059e1d239e723 | |
| parent | 39efc41237ec906226a3a53d7396d51173495204 (diff) | |
| parent | 61dc740ed1c3780cccaec00d059a28f0d31d0052 (diff) | |
Remove non-DFSG contentsupstream/8.4_gamma0+really8.4beta2+dfsg
274 files changed, 9508 insertions, 7449 deletions
@@ -79,6 +79,9 @@ doc/stdlib/Library.out doc/stdlib/Library.pdf doc/stdlib/Library.ps doc/stdlib/Library.coqdoc.tex +doc/stdlib/FullLibrary.pdf +doc/stdlib/FullLibrary.ps +doc/stdlib/FullLibrary.coqdoc.tex doc/stdlib/html/ doc/stdlib/index-body.html doc/stdlib/index-list.html @@ -1,5 +1,54 @@ -Changes from V8.3 to V8.4 -========================= +Changes from V8.4beta to V8.4 +============================= + +Vernacular commands + +- Undo and UndoTo are now handling the proof states. They may + perform some extra steps of backtrack to avoid states where + the proof state is unavailable (typically a closed proof). +- The commands Suspend and Resume have been removed. +- A basic Show Script has been reintroduced (no indentation). +- New command "Set Parsing Explicit" for deactivating parsing (and printing) + of implicit arguments (useful for teaching). +- New command "Grab Existential Variables" to transform the unresolved evars at + the end of a proof into goals. + +Tactics + +- Still no general "info" tactical, but new specific tactics + info_auto, info_eauto, info_trivial which provides information + on the proofs found by auto/eauto/trivial. Display of these + details could also be activated by Set Info Auto/Eauto/Trivial. +- Details on everything tried by auto/eauto/trivial during + a proof search could be obtained by "debug auto", "debug eauto", + "debug trivial" or by a global "Set Debug Auto/Eauto/Trivial". +- New command "r string" that interprets "idtac string" as a breakpoint + and jumps to its next use in Ltac debugger. +- Tactics from the Dp plugin (simplify, ergo, yices, cvc3, z3, cvcl, + harvey, zenon, gwhy) have been removed, since Why2 has not been + maintained for the last few years. The Why3 plugin should be a suitable + replacement in most cases. + +Libraries + +- MSetRBT : a new implementation of MSets via Red-Black trees (initial + contribution by Andrew Appel). +- MSetAVL : for maximal sharing with the new MSetRBT, the argument order + of Node has changed (this should be transparent to regular MSets users). + +Module System + +- The names of modules (and module types) are now in a fully separated + namespace from ordinary definitions : "Definition E:=0. Module E. End E." + is now accepted. + +CoqIDE + +- Coqide now supports the Restart command, and Undo (with a warning). + Better support for Abort. + +Changes from V8.3 to V8.4beta +============================= Logic @@ -69,6 +118,8 @@ Tactics - When applying destruct or inversion on a fixpoint hiding an inductive type, recursive calls to the fixpoint now remain folded by default (rare source of incompatibility generally solvable by adding a call to simpl). +- The behavior of the simpl tactic can be tuned using the new "Arguments" + vernacular. Vernacular commands @@ -90,6 +141,7 @@ Vernacular commands to avoid conversion at Qed time to go into a very long computation. - New command "Show Goal ident" to display the statement of a goal, even a closed one (available from Proof General). +- New command "Arguments" subsuming "Implicit Arguments" and "Arguments Scope". Module System @@ -1,6 +1,6 @@ The Coq proof assistant -Copyright 1999-2010 The Coq development team, INRIA, CNRS, University +Copyright 1999-2012 The Coq development team, INRIA, CNRS, University Paris Sud, University Paris 7, Ecole Polytechnique. This product includes also software developed by @@ -106,6 +106,7 @@ The following people have contributed to the development of different versions of the Coq Proof assistant during the indicated time: Bruno Barras (INRIA, 1995-now) + Pierre Boutillier (INRIA-PPS, 2010-now) Jacek Chrzaszcz (LRI, 1998-2003) Thierry Coquand (INRIA, 1985-1989) Pierre Corbineau (LRI, 2003-2005, Nijmegen, 2005-2008, Grenoble 1, 2008-now) @@ -118,10 +119,12 @@ of the Coq Proof assistant during the indicated time: Amy Felty (INRIA, 1993) Jean-Christophe Filliâtre (ENS Lyon, 1994-1997, LRI, 1997-now) Eduardo Giménez (ENS Lyon, 1993-1996, INRIA, 1997-1998) + Stéphane Glondu (INRIA-PPS, 2007-now) Benjamin Grégoire (INRIA, 2003-now) Hugo Herbelin (INRIA, 1996-now) Gérard Huet (INRIA, 1985-1997) - Pierre Letouzey (LRI, 2000-2004 & PPS, 2005-now) + Pierre Letouzey (LRI, 2000-2004, PPS, 2005-2008, INRIA-PPS, 2009-now) + Patrick Loiseleur (Paris Sud, 1997-1999) Evgeny Makarov (INRIA, 2007) Pascal Manoury (INRIA, 1993) Micaela Mayero (INRIA, 1997-2002) @@ -132,9 +135,11 @@ of the Coq Proof assistant during the indicated time: Julien Narboux (INRIA, 2005-2006, Strasbourg, 2007-now) Jean-Marc Notin (CNRS, 2006-now) Catherine Parent-Vigouroux (ENS Lyon, 1992-1995) - Patrick Loiseleur (Paris Sud, 1997-1999) Christine Paulin-Mohring (INRIA, 1985-1989, ENS Lyon, 1989-1997, LRI, 1997-now) + Pierre-Marie Pédrot (INRIA-PPS, 2011-now) + Matthias Puech (INRIA-Bologna, 2008-now) + Yann Régis-Gianas (INRIA-PPS, 2009-now) Clément Renard (INRIA, 2001-2004) Claudio Sacerdoti Coen (INRIA, 2004-2005) Amokrane Saïbi (INRIA, 1993-1998) @@ -142,6 +147,7 @@ of the Coq Proof assistant during the indicated time: Élie Soubiran (INRIA, 2007-now) Matthieu Sozeau (INRIA, 2005-now) Arnaud Spiwack (INRIA, 2006-now) + Enrico Tassi (INRIA, 2011-now) Benjamin Werner (INRIA, 1989-1994) *************************************************************************** @@ -39,9 +39,9 @@ WHAT DO YOU NEED ? urpmi coq - Should you need or prefer to compile Coq V8.2 yourself, you need: + Should you need or prefer to compile Coq V8.4 yourself, you need: - - Objective Caml version 3.10.0 or later + - Objective Caml version 3.11.2 or later (available at http://caml.inria.fr/) - Camlp5 (version <= 4.08, or 5.* transitional) @@ -87,7 +87,7 @@ QUICK INSTALLATION PROCEDURE. INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). ================================================= -1- Check that you have the Objective Caml compiler version 3.10.0 (or later) +1- Check that you have the Objective Caml compiler version 3.11.2 (or later) installed on your computer and that "ocamlmktop" and "ocamlc" (or its native code version "ocamlc.opt") lie in a directory which is present in your $PATH environment variable. @@ -191,6 +191,7 @@ docclean: rm -f doc/common/version.tex rm -f doc/refman/styles.hva doc/refman/cover.html doc/refman/Reference-Manual.html rm -f doc/coq.tex + rm -f doc/refman/styles.hva doc/refman/cover.html archclean: clean-ide optclean voclean rm -rf _build myocamlbuild_config.ml @@ -221,7 +222,6 @@ cleanconfig: rm -f config/Makefile config/coq_config.ml dev/ocamldebug-v7 ide/undo.mli distclean: clean cleanconfig - $(MAKE) -C test-suite distclean voclean: rm -f states/*.coq diff --git a/Makefile.build b/Makefile.build index 59ee457c..41dfabbf 100644 --- a/Makefile.build +++ b/Makefile.build @@ -318,7 +318,7 @@ $(COQIDEOPT): $(LINKIDEOPT) | $(COQTOPOPT) $(STRIP) $@ $(COQIDEBYTE): $(LINKIDE) | $(COQTOPBYTE) - $(SHOW)'OCAMLOPT -o $@' + $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ unix.cma threads.cma lablgtk.cma gtkThread.cmo\ str.cma $(COQRUNBYTEFLAGS) $(LINKIDE) @@ -446,7 +446,7 @@ noreal: logic arith bool zarith qarith lists sets fsets relations \ # 3) plugins ########################################################################### -.PHONY: plugins omega micromega ring setoid_ring nsatz dp xml extraction +.PHONY: plugins omega micromega ring setoid_ring nsatz xml extraction .PHONY: field fourier funind cc subtac rtauto pluginsopt plugins: $(PLUGINSVO) @@ -455,7 +455,6 @@ micromega: $(MICROMEGAVO) $(MICROMEGACMA) $(CSDPCERT) ring: $(RINGVO) $(RINGCMA) setoid_ring: $(NEWRINGVO) $(NEWRINGCMA) nsatz: $(NSATZVO) $(NSATZCMA) -dp: $(DPCMA) xml: $(XMLVO) $(XMLCMA) extraction: $(EXTRACTIONCMA) field: $(FIELDVO) $(FIELDCMA) @@ -623,7 +622,7 @@ INSTALLCMI = $(sort \ install-library: $(MKDIR) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS) $(PLUGINSOPT) + $(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS) $(MKDIR) $(FULLCOQLIB)/states $(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states $(MKDIR) $(FULLCOQLIB)/user-contrib @@ -632,7 +631,7 @@ install-library: $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI) ifeq ($(BEST),opt) $(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(CONFIG:.cmo=.cmx) $(CONFIG:.cmo=.o) $(LINKCMO:.cma=.cmxa) $(LINKCMO:.cma=.a) + $(INSTALLSH) $(FULLCOQLIB) $(CONFIG:.cmo=.cmx) $(CONFIG:.cmo=.o) $(LINKCMO:.cma=.cmxa) $(LINKCMO:.cma=.a) $(PLUGINSOPT) endif # csdpcert is not meant to be directly called by the user; we install # it with libraries @@ -643,11 +642,14 @@ endif install-library-light: $(MKDIR) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS) $(INITPLUGINSOPT) + $(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS) $(MKDIR) $(FULLCOQLIB)/states $(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states rm -f $(FULLCOQLIB)/revision -$(INSTALLLIB) revision $(FULLCOQLIB) +ifeq ($(BEST),opt) + $(INSTALLSH) $(FULLCOQLIB) $(INITPLUGINSOPT) +endif install-coq-info: install-coq-manpages install-emacs install-latex diff --git a/Makefile.common b/Makefile.common index b560bae5..3740b52e 100644 --- a/Makefile.common +++ b/Makefile.common @@ -79,7 +79,7 @@ SRCDIRS:=\ pretyping interp toplevel/utils toplevel parsing \ ide/utils ide \ $(addprefix plugins/, \ - omega romega micromega quote ring dp \ + omega romega micromega quote ring \ setoid_ring xml extraction fourier \ cc funind firstorder field subtac \ rtauto nsatz syntax decl_mode) @@ -125,14 +125,15 @@ REFMANCOQTEXFILES:=$(addprefix doc/refman/, \ RefMan-cic.v.tex RefMan-lib.v.tex \ RefMan-tacex.v.tex RefMan-syn.v.tex \ RefMan-oth.v.tex RefMan-ltac.v.tex \ - RefMan-decl.v.tex \ + RefMan-decl.v.tex RefMan-sch.v.tex \ + RefMan-pro.v.tex \ Cases.v.tex Coercion.v.tex Extraction.v.tex \ Program.v.tex Omega.v.tex Micromega.v.tex Polynom.v.tex Nsatz.v.tex \ Setoid.v.tex Helm.tex Classes.v.tex ) REFMANTEXFILES:=$(addprefix doc/refman/, \ headers.sty Reference-Manual.tex \ - RefMan-pre.tex RefMan-int.tex RefMan-pro.tex RefMan-com.tex \ + RefMan-pre.tex RefMan-int.tex RefMan-com.tex \ RefMan-uti.tex RefMan-ide.tex RefMan-add.tex RefMan-modr.tex ) \ $(REFMANCOQTEXFILES) \ @@ -176,7 +177,6 @@ QUOTECMA:=plugins/quote/quote_plugin.cma RINGCMA:=plugins/ring/ring_plugin.cma NEWRINGCMA:=plugins/setoid_ring/newring_plugin.cma NSATZCMA:=plugins/nsatz/nsatz_plugin.cma -DPCMA:=plugins/dp/dp_plugin.cma FIELDCMA:=plugins/field/field_plugin.cma XMLCMA:=plugins/xml/xml_plugin.cma FOURIERCMA:=plugins/fourier/fourier_plugin.cma @@ -196,14 +196,14 @@ OTHERSYNTAXCMA:=$(addprefix plugins/syntax/, \ DECLMODECMA:=plugins/decl_mode/decl_mode_plugin.cma PLUGINSCMA:=$(OMEGACMA) $(ROMEGACMA) $(MICROMEGACMA) $(DECLMODECMA) \ - $(QUOTECMA) $(RINGCMA) $(NEWRINGCMA) $(DPCMA) $(FIELDCMA) \ + $(QUOTECMA) $(RINGCMA) $(NEWRINGCMA) $(FIELDCMA) \ $(FOURIERCMA) $(EXTRACTIONCMA) $(XMLCMA) \ $(CCCMA) $(FOCMA) $(SUBTACCMA) $(RTAUTOCMA) \ $(FUNINDCMA) $(NSATZCMA) $(NATSYNTAXCMA) $(OTHERSYNTAXCMA) ifneq ($(HASNATDYNLINK),false) STATICPLUGINS:= - INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) $(DPCMA) \ + INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) \ $(XMLCMA) $(FUNINDCMA) $(SUBTACCMA) $(NATSYNTAXCMA) INITPLUGINSOPT:=$(INITPLUGINS:.cma=.cmxs) PLUGINS:=$(PLUGINSCMA) @@ -314,7 +314,6 @@ NEWRINGVO:=$(call cat_vo_itarget, plugins/setoid_ring) NSATZVO:=$(call cat_vo_itarget, plugins/nsatz) FOURIERVO:=$(call cat_vo_itarget, plugins/fourier) FUNINDVO:=$(call cat_vo_itarget, plugins/funind) -DPVO:=$(call cat_vo_itarget, plugins/dp) RTAUTOVO:=$(call cat_vo_itarget, plugins/rtauto) EXTRACTIONVO:=$(call cat_vo_itarget, plugins/extraction) XMLVO:= @@ -322,7 +321,7 @@ CCVO:= PLUGINSVO:= $(OMEGAVO) $(ROMEGAVO) $(MICROMEGAVO) $(RINGVO) $(FIELDVO) \ $(XMLVO) $(FOURIERVO) $(CCVO) $(FUNINDVO) \ - $(RTAUTOVO) $(NEWRINGVO) $(DPVO) $(QUOTEVO) \ + $(RTAUTOVO) $(NEWRINGVO) $(QUOTEVO) \ $(NSATZVO) $(EXTRACTIONVO) ALLVO:= $(THEORIESVO) $(PLUGINSVO) @@ -347,8 +346,6 @@ MANPAGES:=man/coq-tex.1 man/coqdep.1 man/gallina.1 \ man/coqwc.1 man/coqdoc.1 man/coqide.1 \ man/coq_makefile.1 man/coqmktop.1 man/coqchk.1 -DATE=$(shell LANG=C date +"%B %Y") - ########################################################################### # Source documentation ########################################################################### diff --git a/Makefile.doc b/Makefile.doc index 59eb2fe8..685887f5 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -12,7 +12,7 @@ ###################################################################### .PHONY: doc doc-html doc-pdf doc-ps refman refman-quick tutorial -.PHONY: stdlib full-stdlib faq rectutorial +.PHONY: stdlib full-stdlib faq rectutorial refman-html-dir INDEXURLS:=doc/refman/html/index_urls.txt @@ -126,14 +126,16 @@ doc/refman/styles.hva: doc/common/styles/html/$(HTMLSTYLE)/styles.hva INDEXES:= doc/refman/html/command-index.html doc/refman/html/tactic-index.html ALLINDEXES:= doc/refman/html/index.html $(INDEXES) -$(ALLINDEXES): doc/refman/Reference-Manual.html $(REFMANPNGFILES) \ +$(ALLINDEXES): refman-html-dir + +refman-html-dir: doc/refman/Reference-Manual.html $(REFMANPNGFILES) \ doc/refman/cover.html doc/refman/styles.hva doc/refman/index.html - rm -rf doc/refman/html $(MKDIR) doc/refman/html $(INSTALLLIB) $(REFMANPNGFILES) doc/refman/html (cd doc/refman/html; hacha -nolinks -tocbis -o toc.html ../styles.hva ../Reference-Manual.html) $(INSTALLLIB) doc/refman/cover.html doc/refman/html/index.html - $(INSTALLLIB) doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html + -$(INSTALLLIB) doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html refman-quick: (cd doc/refman;\ @@ -200,40 +202,32 @@ doc/faq/html/index.html: doc/faq/FAQ.v.html ### Standard library (browsable html format) ifdef QUICK -doc/stdlib/index-body.html: - - rm -rf doc/stdlib/html - $(MKDIR) doc/stdlib/html - $(COQDOC) -q -boot -d doc/stdlib/html --multi-index --html -g --utf8 \ - -R theories Coq $(THEORIESVO:.vo=.v) - mv doc/stdlib/html/index.html doc/stdlib/index-body.html +doc/stdlib/html/genindex.html: else -doc/stdlib/index-body.html: $(COQDOC) $(THEORIESVO) +doc/stdlib/html/genindex.html: | $(COQDOC) $(THEORIESVO) +endif - rm -rf doc/stdlib/html $(MKDIR) doc/stdlib/html - $(COQDOC) -q -boot -d doc/stdlib/html --multi-index --html -g --utf8 \ + $(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) - mv doc/stdlib/html/index.html doc/stdlib/index-body.html -endif + 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 - ./doc/stdlib/make-library-index doc/stdlib/index-list.html + ./doc/stdlib/make-library-index doc/stdlib/index-list.html doc/stdlib/hidden-files -doc/stdlib/html/index.html: doc/stdlib/index-list.html doc/stdlib/index-body.html doc/stdlib/index-trailer.html - cat doc/stdlib/index-list.html > $@ - sed -n -e '/<table>/,/<\/table>/p' doc/stdlib/index-body.html >> $@ - cat doc/stdlib/index-trailer.html >> $@ +doc/stdlib/html/index.html: doc/stdlib/html/genindex.html doc/stdlib/index-list.html + cat doc/common/styles/html/$(HTMLSTYLE)/header.html doc/stdlib/index-list.html > $@ + cat doc/common/styles/html/$(HTMLSTYLE)/footer.html >> $@ ### Standard library (light version, full version is definitely too big) ifdef QUICK doc/stdlib/Library.coqdoc.tex: - $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ - -R theories Coq $(THEORIESLIGHTVO:.vo=.v) > $@ else -doc/stdlib/Library.coqdoc.tex: $(COQDOC) $(THEORIESLIGHTVO) - $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ - -R theories Coq $(THEORIESLIGHTVO:.vo=.v) > $@ +doc/stdlib/Library.coqdoc.tex: | $(COQDOC) $(THEORIESLIGHTVO) endif + $(COQDOC) -q -boot --gallina --body-only --latex --stdout \ + -R theories Coq $(THEORIESLIGHTVO:.vo=.v) >> $@ doc/stdlib/Library.dvi: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Library.tex (cd doc/stdlib;\ @@ -255,12 +249,12 @@ ifdef QUICK doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ -R theories Coq $(THEORIESVO:.vo=.v) > $@ - sed -i "" -e 's///g' $@ + sed -i.tmp -e 's///g' $@ && rm $@.tmp else doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) $(THEORIESVO) $(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \ -R theories Coq $(THEORIESVO:.vo=.v) > $@ - sed -i "" -e 's///g' $@ + sed -i.tmp -e 's///g' $@ && rm $@.tmp endif doc/stdlib/FullLibrary.dvi: $(DOCCOMMON) doc/stdlib/FullLibrary.coqdoc.tex doc/stdlib/FullLibrary.tex @@ -38,7 +38,7 @@ THE COQ CLUB. discuss questions about the Coq system and related topics. The submission address is: - coq-club@coq.inria.fr + coq-club@inria.fr The topics to be discussed in the club should include: @@ -55,7 +55,7 @@ THE COQ CLUB. To be added to, or removed from, the mailing list, please write to: - coq-club-request@coq.inria.fr + coq-club-request@inria.fr Please use also this address for any questions/suggestions about the Coq Club. It might sometimes take a few days before your messages get @@ -67,7 +67,7 @@ BUGS REPORT. Send your bug reports by filling a form at - http://logical.saclay.inria.fr/coq-bugs + http://coq.inria.fr/bugs To be effective, bug reports should mention the Caml version used to compile and run Coq, the Coq version (coqtop -v), the configuration @@ -1,53 +0,0 @@ -Langage: - -Distribution: - -Environnement: - -- Porter SearchIsos - -Noyau: - -Tactic: - -- Que contradiction raisonne a isomorphisme pres de False - -Vernac: - -- Print / Print Proof en fait identiques ; Print ne devrait pas afficher - les constantes opaques (devrait afficher qqchose comme <opaque>) - -Theories: - -- Rendre transparent tous les theoremes prouvant {A}+{B} -- Faire demarrer PolyList.nth a` l'indice 0 - Renommer l'actuel nth en nth1 ?? - -Doc: - -- Mettre à jour les messages d'erreurs de Discriminate/Simplify_eq/Injection -- Documenter le filtrage sur les types inductifs avec let-ins (dont la - compatibilite V6) - -- Ajouter let dans les règles du CIC - -> FAIT, mais reste a documenter le let dans les inductifs - et les champs manifestes dans les Record -- revoir le chapitre sur les tactiques utilisateur -- faut-il mieux spécifier la sémantique de Simpl (??) - -- Préciser la clarification syntaxique de IntroPattern -- preciser que Goal vient en dernier dans une clause pattern list et - qu'il doit apparaitre si il y a un "in" - -- Omega Time debranche mais Omega System et Omega Action remarchent ? -- Ajout "Replace in" (mais TODO) -- Syntaxe Conditional tac Rewrite marche, à documenter -- Documenter Dependent Rewrite et CutRewrite ? -- Ajouter les motifs sous-termes de ltac - -- ajouter doc de GenFixpoint (mais avant: changer syntaxe) (J. Forest ou Pierre C.) -- mettre à jour la doc de induction (arguments multiples) (Pierre C.) -- mettre à jour la doc de functional induction/scheme (J. Forest ou Pierre C.) ---> mettre à jour le CHANGES (vers la ligne 72) - - diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 9942816d..e3431fec 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -53,10 +53,14 @@ let path_of_mexpr = function | SEBident mp -> mp | _ -> raise Not_path -let rec list_split_assoc k rev_before = function +let is_modular = function + | SFBmodule _ | SFBmodtype _ -> true + | SFBconst _ | SFBmind _ -> false + +let rec list_split_assoc ((k,m) as km) rev_before = function | [] -> raise Not_found - | (k',b)::after when k=k' -> rev_before,b,after - | h::tail -> list_split_assoc k (h::rev_before) tail + | (k',b)::after when k=k' && is_modular b = m -> rev_before,b,after + | h::tail -> list_split_assoc km (h::rev_before) tail let check_definition_sub env cb1 cb2 = let check_type env t1 t2 = @@ -131,38 +135,35 @@ let lookup_modtype mp env = let rec check_with env mtb with_decl mp= match with_decl with - | With_definition_body _ -> - check_with_aux_def env mtb with_decl mp; + | With_definition_body (idl,c) -> + check_with_def env mtb (idl,c) mp; mtb - | With_module_body _ -> - check_with_aux_mod env mtb with_decl mp; + | With_module_body (idl,mp1) -> + check_with_mod env mtb (idl,mp1) mp; mtb -and check_with_aux_def env mtb with_decl mp = +and check_with_def env mtb (idl,c) mp = let sig_b = match mtb with | SEBstruct(sig_b) -> sig_b | _ -> error_signature_expected mtb in - let id,idl = match with_decl with - | With_definition_body (id::idl,_) | With_module_body (id::idl,_) -> - id,idl - | With_definition_body ([],_) | With_module_body ([],_) -> assert false + let id,idl = match idl with + | [] -> assert false + | id::idl -> id,idl in let l = label_of_id id in try - let rev_before,spec,after = list_split_assoc l [] sig_b in + let rev_before,spec,after = list_split_assoc (l,(idl<>[])) [] sig_b in let before = List.rev rev_before in let env' = Modops.add_signature mp before empty_delta_resolver env in - match with_decl with - | With_definition_body ([],_) -> assert false - | With_definition_body ([id],c) -> + if idl = [] then let cb = match spec with SFBconst cb -> cb | _ -> error_not_a_constant l in check_definition_sub env' c cb - | With_definition_body (_::_,_) -> + else let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l @@ -170,49 +171,36 @@ and check_with_aux_def env mtb with_decl mp = begin match old.mod_expr with | None -> - let new_with_decl = match with_decl with - With_definition_body (_,c) -> - With_definition_body (idl,c) - | With_module_body (_,c) -> - With_module_body (idl,c) in - check_with_aux_def env' old.mod_type new_with_decl (MPdot(mp,l)) + check_with_def env' old.mod_type (idl,c) (MPdot(mp,l)) | Some msb -> error_a_generative_module_expected l end - | _ -> anomaly "Modtyping:incorrect use of with" with Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l -and check_with_aux_mod env mtb with_decl mp = +and check_with_mod env mtb (idl,mp1) mp = let sig_b = match mtb with | SEBstruct(sig_b) -> sig_b | _ -> error_signature_expected mtb in - let id,idl = match with_decl with - | With_definition_body (id::idl,_) | With_module_body (id::idl,_) -> - id,idl - | With_definition_body ([],_) | With_module_body ([],_) -> assert false + let id,idl = match idl with + | [] -> assert false + | id::idl -> id,idl in let l = label_of_id id in try - let rev_before,spec,after = list_split_assoc l [] sig_b in + let rev_before,spec,after = list_split_assoc (l,false) [] sig_b in let before = List.rev rev_before in - let rec mp_rec = function - | [] -> mp - | i::r -> MPdot(mp_rec r,label_of_id i) - in let env' = Modops.add_signature mp before empty_delta_resolver env in - match with_decl with - | With_module_body ([],_) -> assert false - | With_module_body ([id], mp1) -> + if idl = [] then let _ = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l in let (_:module_body) = (lookup_module mp1 env) in () - | With_module_body (_::_,mp) -> + else let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l @@ -220,17 +208,11 @@ and check_with_aux_mod env mtb with_decl mp = begin match old.mod_expr with None -> - let new_with_decl = match with_decl with - With_definition_body (_,c) -> - With_definition_body (idl,c) - | With_module_body (_,c) -> - With_module_body (idl,c) in - check_with_aux_mod env' - old.mod_type new_with_decl (MPdot(mp,l)) + check_with_mod env' + old.mod_type (idl,mp1) (MPdot(mp,l)) | Some msb -> error_a_generative_module_expected l end - | _ -> anomaly "Modtyping:incorrect use of with" with Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 0c97254b..9870ba13 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -28,15 +28,18 @@ type namedobject = | Constant of constant_body | IndType of inductive * mutual_inductive_body | IndConstr of constructor * mutual_inductive_body + +type namedmodule = | Module of module_body | Modtype of module_type_body (* adds above information about one mutual inductive: all types and constructors *) -let add_nameobjects_of_mib ln mib map = - let add_nameobjects_of_one j oib map = - let ip = (ln,j) in +let add_mib_nameobjects mp l mib map = + let ind = make_mind mp empty_dirpath l in + let add_mip_nameobjects j oib map = + let ip = (ind,j) in let map = array_fold_right_i (fun i id map -> @@ -46,22 +49,32 @@ let add_nameobjects_of_mib ln mib map = in Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map in - array_fold_right_i add_nameobjects_of_one mib.mind_packets map + array_fold_right_i add_mip_nameobjects mib.mind_packets map + + +(* creates (namedobject/namedmodule) map for the whole signature *) +type labmap = { objs : namedobject Labmap.t; mods : namedmodule Labmap.t } -(* creates namedobject map for the whole signature *) +let empty_labmap = { objs = Labmap.empty; mods = Labmap.empty } -let make_label_map mp list = +let get_obj mp map l = + try Labmap.find l map.objs + with Not_found -> error_no_such_label_sub l mp + +let get_mod mp map l = + try Labmap.find l map.mods + with Not_found -> error_no_such_label_sub l mp + +let make_labmap mp list = let add_one (l,e) map = - let add_map obj = Labmap.add l obj map in match e with - | SFBconst cb -> add_map (Constant cb) - | SFBmind mib -> - add_nameobjects_of_mib (make_mind mp empty_dirpath l) mib map - | SFBmodule mb -> add_map (Module mb) - | SFBmodtype mtb -> add_map (Modtype mtb) + | SFBconst cb -> { map with objs = Labmap.add l (Constant cb) map.objs } + | SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs } + | SFBmodule mb -> { map with mods = Labmap.add l (Module mb) map.mods } + | SFBmodtype mtb -> { map with mods = Labmap.add l (Modtype mtb) map.mods } in - List.fold_right add_one list Labmap.empty + List.fold_right add_one list empty_labmap let check_conv_error error f env a1 a2 = @@ -282,7 +295,6 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in let ty2 = Typeops.type_of_constant_type env cb2.const_type in check_conv conv env ty1 ty2 - | _ -> error () let rec check_modules env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module None msb1 in @@ -291,29 +303,25 @@ let rec check_modules env msb1 msb2 subst1 subst2 = and check_signatures env mp1 sig1 sig2 subst1 subst2 = - let map1 = make_label_map mp1 sig1 in + let map1 = make_labmap mp1 sig1 in let check_one_body (l,spec2) = - let info1 = - try - Labmap.find l map1 - with - Not_found -> error_no_such_label_sub l mp1 - in match spec2 with | SFBconst cb2 -> - check_constant env mp1 l info1 cb2 spec2 subst1 subst2 + check_constant env mp1 l (get_obj mp1 map1 l) + cb2 spec2 subst1 subst2 | SFBmind mib2 -> - check_inductive env mp1 l info1 mib2 spec2 subst1 subst2 + check_inductive env mp1 l (get_obj mp1 map1 l) + mib2 spec2 subst1 subst2 | SFBmodule msb2 -> begin - match info1 with + match get_mod mp1 map1 l with | Module msb -> check_modules env msb msb2 subst1 subst2 | _ -> error_not_match l spec2 end | SFBmodtype mtb2 -> let mtb1 = - match info1 with + match get_mod mp1 map1 l with | Modtype mtb -> mtb | _ -> error_not_match l spec2 in @@ -6,10 +6,10 @@ # ################################## -VERSION=8.4beta +VERSION=8.4beta2 VOMAGIC=08400 STATEMAGIC=58400 -DATE="December 2011" +DATE=`LC_ALL=C LANG=C date +"%B %Y"` # Create the bin/ directory if non-existent test -d bin || mkdir bin @@ -292,7 +292,7 @@ case $DATEPGM in "") echo "I can't find the program \"date\" in your path." echo "Please give me the current date" read COMPILEDATE;; - *) COMPILEDATE=`date +"%h %d %Y %H:%M:%S"`;; + *) COMPILEDATE=`LC_ALL=C LANG=C date +"%h %d %Y %H:%M:%S"`;; esac # Architecture @@ -388,7 +388,7 @@ fi if [ "$browser_spec" = "no" ]; then case $ARCH in - win32) BROWSER='C:\PROGRA~1\INTERN~1\IEXPLORE %s' ;; + win32) BROWSER='start %s' ;; Darwin) BROWSER='open %s' ;; *) BROWSER='firefox -remote "OpenURL(%s,new-tab)" || firefox %s &' ;; esac @@ -445,16 +445,16 @@ esac CAMLVERSION=`"$bytecamlc" -version` case $CAMLVERSION in - 1.*|2.*|3.0*) + 1.*|2.*|3.0*|3.10*|3.11.[01]) echo "Your version of Objective-Caml is $CAMLVERSION." if [ "$force_caml_version" = "yes" ]; then echo "*Warning* You are compiling Coq with an outdated version of Objective-Caml." else - echo " You need Objective-Caml 3.10.0 or later." + echo " You need Objective-Caml 3.11.2 or later." echo " Configuration script failed!" exit 1 fi;; - 3.1*) + 3.11.2|3.12*) CAMLP4COMPAT="-loc loc" echo "You have Objective-Caml $CAMLVERSION. Good!";; *) @@ -742,7 +742,7 @@ case $ARCH$CYGWIN in bindir_def=${W32PREF}bin libdir_def=${W32PREF}lib configdir_def=${W32PREF}config - datadir_def=${W32PREF}data + datadir_def=${W32PREF}share mandir_def=${W32PREF}man docdir_def=${W32PREF}doc emacslib_def=${W32PREF}emacs @@ -795,10 +795,15 @@ case $libdir_spec in *) LIBDIR_OPTION="None";; esac -case $configdir_spec/$local in - yes/*) CONFIGDIR=$configdir;; - */true) CONFIGDIR=$COQTOP/ide - configdir_spec=yes;; +case $configdir_spec/$prefix_spec/$local in + yes/*/*) CONFIGDIR=$configdir;; + */yes/*) configdir_spec=yes + case $ARCH in + win32) CONFIGDIR=$prefix/config;; + *) CONFIGDIR=$prefix/etc/xdg/coq;; + esac;; + */*/true) CONFIGDIR=$COQTOP/ide + configdir_spec=yes;; *) printf "Where should I install the Coqide configuration files [$configdir_def]? " read CONFIGDIR case $CONFIGDIR in diff --git a/dev/base_include b/dev/base_include index d1125965..ad2a3aec 100644 --- a/dev/base_include +++ b/dev/base_include @@ -123,7 +123,6 @@ open Decl_mode open Auto open Autorewrite open Contradiction -open Dhyp open Eauto open Elim open Equality @@ -199,6 +198,11 @@ let current_goal () = get_nth_goal 1;; let pf_e gl s = Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s);; +(* Set usual printing since the global env is available from the tracer *) +let _ = Constrextern.in_debugger := false +let _ = Constrextern.set_debug_global_reference_printer + (fun loc r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));; + open Toplevel let go = loop diff --git a/dev/printers.mllib b/dev/printers.mllib index 6a42678e..40a5a822 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -105,12 +105,12 @@ Notation Dumpglob Reserve Impargs -Constrextern Syntax_def Implicit_quantifiers Smartlocate Constrintern Modintern +Constrextern Tacexpr Proof_type Goal diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 3fc90761..3116cbf2 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -487,5 +487,9 @@ let short_string_of_ref loc = function [id_of_label (pi3 (repr_mind kn));id_of_string ("_"^string_of_int i)] (id_of_string ("_"^string_of_int j)) +(* Anticipate that printers can be used from ocamldebug and that + pretty-printer should not make calls to the global env since ocamldebug + runs in a different process and does not have the proper env at hand *) +let _ = Constrextern.in_debugger := true let _ = Constrextern.set_debug_global_reference_printer (if !rawdebug then raw_string_of_ref else short_string_of_ref) diff --git a/doc/common/styles/html/coqremote/footer.html b/doc/common/styles/html/coqremote/footer.html new file mode 100644 index 00000000..138c3025 --- /dev/null +++ b/doc/common/styles/html/coqremote/footer.html @@ -0,0 +1,45 @@ +<div id="sidebarWrapper"> +<div id="sidebar"> + +<div class="block"> +<h2 class="title">Navigation</h2> +<div class="content"> + +<ul class="menu"> + +<li class="leaf">Standard Library + <ul class="menu"> + <li><a href="index.html">Table of contents</a></li> + <li><a href="genindex.html">Index</a></li> + </ul> +</li> + +</ul> + +</div> +</div> + +</div> +</div> + + +</div> + +</div> + +<div id="footer"> +<div id="nav-footer"> + <ul class="links-menu-footer"> + <li><a href="mailto:webmaster_@_www.lix.polytechnique.fr">webmaster</a></li> + <li><a href="http://validator.w3.org/check?uri=referer">xhtml valid</a></li> + <li><a href="http://jigsaw.w3.org/css-validator/check/referer">CSS valid</a></li> + </ul> + +</div> +</div> + +</div> + +</body> +</html> + diff --git a/doc/common/styles/html/coqremote/header.html b/doc/common/styles/html/coqremote/header.html new file mode 100644 index 00000000..afcdbe73 --- /dev/null +++ b/doc/common/styles/html/coqremote/header.html @@ -0,0 +1,49 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en"> + +<head> +<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> +<title>Standard Library | The Coq Proof Assistant</title> + +<link rel="shortcut icon" href="favicon.ico" type="image/x-icon" /> +<style type="text/css" media="all">@import "http://www.lix.polytechnique.fr/coq/modules/node/node.css";</style> + +<style type="text/css" media="all">@import "http://www.lix.polytechnique.fr/coq/modules/system/defaults.css";</style> +<style type="text/css" media="all">@import "http://www.lix.polytechnique.fr/coq/modules/system/system.css";</style> +<style type="text/css" media="all">@import "http://www.lix.polytechnique.fr/coq/modules/user/user.css";</style> + +<style type="text/css" media="all">@import "http://www.lix.polytechnique.fr/coq/sites/all/themes/coq/style.css";</style> +<style type="text/css" media="all">@import "http://www.lix.polytechnique.fr/coq/sites/all/themes/coq/coqdoc.css";</style> + +</head> + +<body> + +<div id="container"> +<div id="headertop"> +<div id="nav"> + <ul class="links-menu"> + <li><a href="http://www.lix.polytechnique.fr/coq/" class="active">Home</a></li> + + <li><a href="http://www.lix.polytechnique.fr/coq/about-coq" title="More about coq">About Coq</a></li> + <li><a href="http://www.lix.polytechnique.fr/coq/download">Get Coq</a></li> + <li><a href="http://www.lix.polytechnique.fr/coq/documentation">Documentation</a></li> + <li><a href="http://www.lix.polytechnique.fr/coq/community">Community</a></li> + </ul> +</div> +</div> + +<div id="header"> + +<div id="logoWrapper"> + +<div id="logo"><a href="http://www.lix.polytechnique.fr/coq/" title="Home"><img src="http://www.lix.polytechnique.fr/coq/files/barron_logo.png" alt="Home" /></a> +</div> +<div id="siteName"><a href="http://www.lix.polytechnique.fr/coq/" title="Home">The Coq Proof Assistant</a> +</div> + +</div> +</div> + +<div id="content"> + diff --git a/doc/stdlib/index-trailer.html b/doc/common/styles/html/simple/footer.html index 308b1d01..308b1d01 100644 --- a/doc/stdlib/index-trailer.html +++ b/doc/common/styles/html/simple/footer.html diff --git a/doc/common/styles/html/simple/header.html b/doc/common/styles/html/simple/header.html new file mode 100644 index 00000000..14d2f988 --- /dev/null +++ b/doc/common/styles/html/simple/header.html @@ -0,0 +1,13 @@ +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> + +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-15"/> +<link rel="stylesheet" href="coqdoc.css" type="text/css"/> +<title>The Coq Standard Library</title> +</head> + +<body> + diff --git a/doc/refman/RefMan-sch.tex b/doc/refman/RefMan-sch.tex new file mode 100644 index 00000000..707ee824 --- /dev/null +++ b/doc/refman/RefMan-sch.tex @@ -0,0 +1,418 @@ +\chapter{Proof schemes} + +\section{Generation of induction principles with {\tt Scheme}} +\label{Scheme} +\index{Schemes} +\comindex{Scheme} + +The {\tt Scheme} command is a high-level tool for generating +automatically (possibly mutual) induction principles for given types +and sorts. Its syntax follows the schema: +\begin{quote} +{\tt Scheme {\ident$_1$} := Induction for \ident'$_1$ Sort {\sort$_1$} \\ + with\\ + \mbox{}\hspace{0.1cm} \dots\\ + with {\ident$_m$} := Induction for {\ident'$_m$} Sort + {\sort$_m$}} +\end{quote} +where \ident'$_1$ \dots\ \ident'$_m$ are different inductive type +identifiers belonging to the same package of mutual inductive +definitions. This command generates {\ident$_1$}\dots{} {\ident$_m$} +to be mutually recursive definitions. Each term {\ident$_i$} proves a +general principle of mutual induction for objects in type {\term$_i$}. + +\begin{Variants} +\item {\tt Scheme {\ident$_1$} := Minimality for \ident'$_1$ Sort {\sort$_1$} \\ + with\\ + \mbox{}\hspace{0.1cm} \dots\ \\ + with {\ident$_m$} := Minimality for {\ident'$_m$} Sort + {\sort$_m$}} + + Same as before but defines a non-dependent elimination principle more + natural in case of inductively defined relations. + +\item {\tt Scheme Equality for \ident$_1$\comindex{Scheme Equality}} + + Tries to generate a boolean equality and a proof of the + decidability of the usual equality. If \ident$_i$ involves + some other inductive types, their equality has to be defined first. + +\item {\tt Scheme Induction for \ident$_1$ Sort {\sort$_1$} \\ + with\\ + \mbox{}\hspace{0.1cm} \dots\\ + with Induction for {\ident$_m$} Sort + {\sort$_m$}} + + If you do not provide the name of the schemes, they will be automatically + computed from the sorts involved (works also with Minimality). + +\end{Variants} +\label{Scheme-examples} + +\firstexample +\example{Induction scheme for \texttt{tree} and \texttt{forest}} + +The definition of principle of mutual induction for {\tt tree} and +{\tt forest} over the sort {\tt Set} is defined by the command: + +\begin{coq_eval} +Reset Initial. +Variables A B : Set. +\end{coq_eval} + +\begin{coq_example*} +Inductive tree : Set := + node : A -> forest -> tree +with forest : Set := + | leaf : B -> forest + | cons : tree -> forest -> forest. + +Scheme tree_forest_rec := Induction for tree Sort Set + with forest_tree_rec := Induction for forest Sort Set. +\end{coq_example*} + +You may now look at the type of {\tt tree\_forest\_rec}: + +\begin{coq_example} +Check tree_forest_rec. +\end{coq_example} + +This principle involves two different predicates for {\tt trees} and +{\tt forests}; it also has three premises each one corresponding to a +constructor of one of the inductive definitions. + +The principle {\tt forest\_tree\_rec} shares exactly the same +premises, only the conclusion now refers to the property of forests. + +\begin{coq_example} +Check forest_tree_rec. +\end{coq_example} + +\example{Predicates {\tt odd} and {\tt even} on naturals} + +Let {\tt odd} and {\tt even} be inductively defined as: + +% Reset Initial. +\begin{coq_eval} +Open Scope nat_scope. +\end{coq_eval} + +\begin{coq_example*} +Inductive odd : nat -> Prop := + oddS : forall n:nat, even n -> odd (S n) +with even : nat -> Prop := + | evenO : even 0 + | evenS : forall n:nat, odd n -> even (S n). +\end{coq_example*} + +The following command generates a powerful elimination +principle: + +\begin{coq_example} +Scheme odd_even := Minimality for odd Sort Prop + with even_odd := Minimality for even Sort Prop. +\end{coq_example} + +The type of {\tt odd\_even} for instance will be: + +\begin{coq_example} +Check odd_even. +\end{coq_example} + +The type of {\tt even\_odd} shares the same premises but the +conclusion is {\tt (n:nat)(even n)->(Q n)}. + +\subsection{Automatic declaration of schemes} +\comindex{Set Equality Schemes} +\comindex{Set Elimination Schemes} + +It is possible to deactivate the automatic declaration of the induction + principles when defining a new inductive type with the + {\tt Unset Elimination Schemes} command. It may be +reactivated at any time with {\tt Set Elimination Schemes}. +\\ + +You can also activate the automatic declaration of those boolean equalities +(see the second variant of {\tt Scheme}) with the {\tt Set Equality Schemes} + command. However you have to be careful with this option since +\Coq~ may now reject well-defined inductive types because it cannot compute +a boolean equality for them. + +\subsection{\tt Combined Scheme} +\label{CombinedScheme} +\comindex{Combined Scheme} + +The {\tt Combined Scheme} command is a tool for combining +induction principles generated by the {\tt Scheme} command. +Its syntax follows the schema : +\begin{quote} +{\tt Combined Scheme {\ident$_0$} from {\ident$_1$}, .., {\ident$_n$}} +\end{quote} +where +\ident$_1$ \ldots \ident$_n$ are different inductive principles that must belong to +the same package of mutual inductive principle definitions. This command +generates {\ident$_0$} to be the conjunction of the principles: it is +built from the common premises of the principles and concluded by the +conjunction of their conclusions. + +\Example +We can define the induction principles for trees and forests using: +\begin{coq_example} +Scheme tree_forest_ind := Induction for tree Sort Prop + with forest_tree_ind := Induction for forest Sort Prop. +\end{coq_example} + +Then we can build the combined induction principle which gives the +conjunction of the conclusions of each individual principle: +\begin{coq_example} +Combined Scheme tree_forest_mutind from tree_forest_ind, forest_tree_ind. +\end{coq_example} + +The type of {\tt tree\_forest\_mutrec} will be: +\begin{coq_example} +Check tree_forest_mutind. +\end{coq_example} + +\section{Generation of induction principles with {\tt Functional Scheme}} +\label{FunScheme} +\comindex{Functional Scheme} + +The {\tt Functional Scheme} command is a high-level experimental +tool for generating automatically induction principles +corresponding to (possibly mutually recursive) functions. Its +syntax follows the schema: +\begin{quote} +{\tt Functional Scheme {\ident$_1$} := Induction for \ident'$_1$ Sort {\sort$_1$} \\ + with\\ + \mbox{}\hspace{0.1cm} \dots\ \\ + with {\ident$_m$} := Induction for {\ident'$_m$} Sort + {\sort$_m$}} +\end{quote} +where \ident'$_1$ \dots\ \ident'$_m$ are different mutually defined function +names (they must be in the same order as when they were defined). +This command generates the induction principles +\ident$_1$\dots\ident$_m$, following the recursive structure and case +analyses of the functions \ident'$_1$ \dots\ \ident'$_m$. + +\Rem +There is a difference between obtaining an induction scheme by using +\texttt{Functional Scheme} on a function defined by \texttt{Function} +or not. Indeed \texttt{Function} generally produces smaller +principles, closer to the definition written by the user. + +\firstexample +\example{Induction scheme for \texttt{div2}} +\label{FunScheme-examples} + +We define the function \texttt{div2} as follows: + +\begin{coq_eval} +Reset Initial. +\end{coq_eval} + +\begin{coq_example*} +Require Import Arith. +Fixpoint div2 (n:nat) : nat := + match n with + | O => 0 + | S O => 0 + | S (S n') => S (div2 n') + end. +\end{coq_example*} + +The definition of a principle of induction corresponding to the +recursive structure of \texttt{div2} is defined by the command: + +\begin{coq_example} +Functional Scheme div2_ind := Induction for div2 Sort Prop. +\end{coq_example} + +You may now look at the type of {\tt div2\_ind}: + +\begin{coq_example} +Check div2_ind. +\end{coq_example} + +We can now prove the following lemma using this principle: + +\begin{coq_example*} +Lemma div2_le' : forall n:nat, div2 n <= n. +intro n. + pattern n , (div2 n). +\end{coq_example*} + +\begin{coq_example} +apply div2_ind; intros. +\end{coq_example} + +\begin{coq_example*} +auto with arith. +auto with arith. +simpl; auto with arith. +Qed. +\end{coq_example*} + +We can use directly the \texttt{functional induction} +(\ref{FunInduction}) tactic instead of the pattern/apply trick: +\tacindex{functional induction} + +\begin{coq_example*} +Reset div2_le'. +Lemma div2_le : forall n:nat, div2 n <= n. +intro n. +\end{coq_example*} + +\begin{coq_example} +functional induction (div2 n). +\end{coq_example} + +\begin{coq_example*} +auto with arith. +auto with arith. +auto with arith. +Qed. +\end{coq_example*} + +\Rem There is a difference between obtaining an induction scheme for a +function by using \texttt{Function} (see Section~\ref{Function}) and by +using \texttt{Functional Scheme} after a normal definition using +\texttt{Fixpoint} or \texttt{Definition}. See \ref{Function} for +details. + + +\example{Induction scheme for \texttt{tree\_size}} + +\begin{coq_eval} +Reset Initial. +\end{coq_eval} + +We define trees by the following mutual inductive type: + +\begin{coq_example*} +Variable A : Set. +Inductive tree : Set := + node : A -> forest -> tree +with forest : Set := + | empty : forest + | cons : tree -> forest -> forest. +\end{coq_example*} + +We define the function \texttt{tree\_size} that computes the size +of a tree or a forest. Note that we use \texttt{Function} which +generally produces better principles. + +\begin{coq_example*} +Function tree_size (t:tree) : nat := + match t with + | node A f => S (forest_size f) + end + with forest_size (f:forest) : nat := + match f with + | empty => 0 + | cons t f' => (tree_size t + forest_size f') + end. +\end{coq_example*} + +\Rem \texttt{Function} generates itself non mutual induction +principles {\tt tree\_size\_ind} and {\tt forest\_size\_ind}: + +\begin{coq_example} +Check tree_size_ind. +\end{coq_example} + +The definition of mutual induction principles following the recursive +structure of \texttt{tree\_size} and \texttt{forest\_size} is defined +by the command: + +\begin{coq_example*} +Functional Scheme tree_size_ind2 := Induction for tree_size Sort Prop +with forest_size_ind2 := Induction for forest_size Sort Prop. +\end{coq_example*} + +You may now look at the type of {\tt tree\_size\_ind2}: + +\begin{coq_example} +Check tree_size_ind2. +\end{coq_example} + +\section{Generation of inversion principles with \tt Derive Inversion} +\label{Derive-Inversion} +\comindex{Derive Inversion} + +The syntax of {\tt Derive Inversion} follows the schema: +\begin{quote} +{\tt Derive Inversion {\ident} with forall + $(\vec{x} : \vec{T})$, $I~\vec{t}$ Sort \sort} +\end{quote} + +This command generates an inversion principle for the +\texttt{inversion \dots\ using} tactic. +\tacindex{inversion \dots\ using} +Let $I$ be an inductive predicate and $\vec{x}$ the variables +occurring in $\vec{t}$. This command generates and stocks the +inversion lemma for the sort \sort~ corresponding to the instance +$\forall (\vec{x}:\vec{T}), I~\vec{t}$ with the name {\ident} in the {\bf +global} environment. When applied, it is equivalent to having inverted +the instance with the tactic {\tt inversion}. + +\begin{Variants} +\item \texttt{Derive Inversion\_clear {\ident} with forall + $(\vec{x}:\vec{T})$, $I~\vec{t}$ Sort \sort}\\ + \comindex{Derive Inversion\_clear} + When applied, it is equivalent to having + inverted the instance with the tactic \texttt{inversion} + replaced by the tactic \texttt{inversion\_clear}. +\item \texttt{Derive Dependent Inversion {\ident} with forall + $(\vec{x}:\vec{T})$, $I~\vec{t}$ Sort \sort}\\ + \comindex{Derive Dependent Inversion} + When applied, it is equivalent to having + inverted the instance with the tactic \texttt{dependent inversion}. +\item \texttt{Derive Dependent Inversion\_clear {\ident} with forall + $(\vec{x}:\vec{T})$, $I~\vec{t}$ Sort \sort}\\ + \comindex{Derive Dependent Inversion\_clear} + When applied, it is equivalent to having + inverted the instance with the tactic \texttt{dependent inversion\_clear}. +\end{Variants} + +\Example + +Let us consider the relation \texttt{Le} over natural numbers and the +following variable: + +\begin{coq_eval} +Reset Initial. +\end{coq_eval} + +\begin{coq_example*} +Inductive Le : nat -> nat -> Set := + | LeO : forall n:nat, Le 0 n + | LeS : forall n m:nat, Le n m -> Le (S n) (S m). +Variable P : nat -> nat -> Prop. +\end{coq_example*} + +To generate the inversion lemma for the instance +\texttt{(Le (S n) m)} and the sort \texttt{Prop}, we do: + +\begin{coq_example*} +Derive Inversion_clear leminv with (forall n m:nat, Le (S n) m) Sort Prop. +\end{coq_example*} + +\begin{coq_example} +Check leminv. +\end{coq_example} + +Then we can use the proven inversion lemma: + +\begin{coq_eval} +Lemma ex : forall n m:nat, Le (S n) m -> P n m. +intros. +\end{coq_eval} + +\begin{coq_example} +Show. +\end{coq_example} + +\begin{coq_example} +inversion H using leminv. +\end{coq_example} + diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/doc/stdlib/hidden-files diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 35c13f3b..0ee101c8 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -1,17 +1,5 @@ -<!DOCTYPE html - PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" - "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> -<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> -<head> -<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-15"/> -<link rel="stylesheet" href="css/context.css" type="text/css"/> -<title>The Coq Standard Library</title> -</head> - -<body> - -<H1>The Coq Standard Library</H1> +<h1>The Coq Standard Library</h1> <p>Here is a short description of the Coq standard library, which is distributed with the system. @@ -68,6 +56,7 @@ through the <tt>Require Import</tt> command.</p> theories/Logic/Epsilon.v theories/Logic/IndefiniteDescription.v theories/Logic/FunctionalExtensionality.v + theories/Logic/ExtensionalityFacts.v </dd> <dt> <b>Structures</b>: @@ -184,6 +173,8 @@ through the <tt>Require Import</tt> command.</p> theories/ZArith/Zpow_def.v theories/ZArith/Zpow_alt.v theories/ZArith/Zpower.v + theories/ZArith/ZOdiv_def.v + theories/ZArith/ZOdiv.v theories/ZArith/Zdiv.v theories/ZArith/Zquot.v theories/ZArith/Zeuclid.v @@ -414,6 +405,16 @@ through the <tt>Require Import</tt> command.</p> theories/Lists/ListTactics.v </dd> + <dt> <b>Vectors</b>: + Dependent datastructures storing their length + </dt> + <dd> + theories/Vectors/Fin.v + theories/Vectors/VectorDef.v + theories/Vectors/VectorSpec.v + (theories/Vectors/Vector.v) + </dd> + <dt> <b>Sorting</b>: Axiomatizations of sorts </dt> @@ -454,7 +455,9 @@ through the <tt>Require Import</tt> command.</p> theories/MSets/MSetEqProperties.v theories/MSets/MSetWeakList.v theories/MSets/MSetList.v + theories/MSets/MSetGenTree.v theories/MSets/MSetAVL.v + theories/MSets/MSetRBT.v theories/MSets/MSetPositive.v theories/MSets/MSetToFiniteSet.v (theories/MSets/MSets.v) @@ -576,4 +579,11 @@ through the <tt>Require Import</tt> command.</p> theories/Program/Combinators.v </dd> + <dt> <b>Unicode</b>: + Unicode-based notations + </dt> + <dd> + theories/Unicode/Utf8_core.v + theories/Unicode/Utf8.v + </dd> </dl> diff --git a/doc/stdlib/make-library-index b/doc/stdlib/make-library-index index 8e496fdd..1a70567f 100755 --- a/doc/stdlib/make-library-index +++ b/doc/stdlib/make-library-index @@ -3,37 +3,55 @@ # Instantiate links to library files in index template FILE=$1 +HIDDEN=$2 cp -f $FILE.template tmp echo -n Building file index-list.prehtml ... -LIBDIRS="Init Logic Structures Bool Arith PArith NArith ZArith QArith Relations Sets Classes Setoids Lists Sorting Wellfounded MSets FSets Reals Program Numbers Numbers/Natural/Abstract Numbers/Natural/Peano Numbers/Natural/Binary Numbers/Natural/BigN Numbers/Natural/SpecViaZ Numbers/Integer/Abstract Numbers/Integer/NatPairs Numbers/Integer/Binary Numbers/Integer/SpecViaZ Numbers/Integer/BigZ Numbers/NatInt Numbers/Cyclic/Abstract Numbers/Cyclic/Int31 Numbers/Cyclic/ZModulo Numbers/Cyclic/DoubleCyclic Numbers/Rational/BigQ Numbers/Rational/SpecViaQ Strings" +#LIBDIRS="Init Logic Structures Bool Arith PArith NArith ZArith QArith Relations Sets Classes Setoids Lists Vectors Sorting Wellfounded MSets FSets Reals Program Numbers Numbers/Natural/Abstract Numbers/Natural/Peano Numbers/Natural/Binary Numbers/Natural/BigN Numbers/Natural/SpecViaZ Numbers/Integer/Abstract Numbers/Integer/NatPairs Numbers/Integer/Binary Numbers/Integer/SpecViaZ Numbers/Integer/BigZ Numbers/NatInt Numbers/Cyclic/Abstract Numbers/Cyclic/Int31 Numbers/Cyclic/ZModulo Numbers/Cyclic/DoubleCyclic Numbers/Rational/BigQ Numbers/Rational/SpecViaQ Strings" +LIBDIRS=`find theories/* -type d | sed -e "s:^theories/::"` for k in $LIBDIRS; do i=theories/$k echo $i d=`basename $i` - if [ "$d" != "Num" -a "$d" != "CVS" ]; then + if [ "$d" != "CVS" ]; then + ls $i | grep -q \.v'$' + if [ $? = 0 ]; then for j in $i/*.v; do b=`basename $j .v` rm -f tmp2 grep -q theories/$k/$b.v tmp a=$? + grep -q theories/$k/$b.v $HIDDEN + h=$? if [ $a = 0 ]; then - p=`echo $k | sed 's:/:.:g'` - sed -e "s:theories/$k/$b.v:<a href=\"Coq.$p.$b.html\">$b</a>:g" tmp > tmp2 - mv -f tmp2 tmp + if [ $h = 0 ]; then + echo Error: $FILE and $HIDDEN both mention theories/$k/$b.v; exit 1 + else + p=`echo $k | sed 's:/:.:g'` + sed -e "s:theories/$k/$b.v:<a href=\"Coq.$p.$b.html\">$b</a>:g" tmp > tmp2 + mv -f tmp2 tmp + fi else - echo Warning: theories/$k/$b.v is missing in the template file - fi + if [ $h = 0 ]; then + echo Error: theories/$k/$b.v is missing in the template file + exit 1 + else + echo Error: none of $FILE and $HIDDEN mention theories/$k/$b.v + exit 1 + fi + + fi done + fi fi rm -f tmp2 sed -e "s/#$d#//" tmp > tmp2 mv -f tmp2 tmp done a=`grep theories tmp` -if [ $? = 0 ]; then echo Warning: extra files:; echo $a; fi +if [ $? = 0 ]; then echo Error: extra files:; echo $a; exit 1; fi mv tmp $FILE echo Done diff --git a/ide/command_windows.ml b/ide/command_windows.ml index 939238d3..a34e5ebe 100644 --- a/ide/command_windows.ml +++ b/ide/command_windows.ml @@ -13,6 +13,7 @@ class command_window coqtop current = ~position:`CENTER ~title:"CoqIde queries" ~show:false () in *) + let views = ref [] in let frame = GBin.frame ~label:"Command Pane" ~shadow_type:`IN () in let _ = frame#misc#hide () in let _ = GtkData.AccelGroup.create () in @@ -49,12 +50,17 @@ class command_window coqtop current = () in + let remove_cb () = + let index = notebook#current_page in + let () = notebook#remove_page index in + views := Minilib.list_filter_i (fun i x -> i <> index) !views + in let _ = toolbar#insert_button ~tooltip:"Delete Page" ~text:"Delete Page" ~icon:(Ideutils.stock_to_widget `DELETE) - ~callback:(fun () -> notebook#remove_page notebook#current_page) + ~callback:remove_cb () in object(self) @@ -63,14 +69,14 @@ object(self) val new_page_menu = new_page_menu val notebook = notebook + method frame = frame method new_command ?command ?term () = - let appendp x = ignore (notebook#append_page x) in let frame = GBin.frame ~shadow_type:`ETCHED_OUT - ~packing:appendp () in + let _ = notebook#append_page frame#coerce in notebook#goto_page (notebook#page_num frame#coerce); let vbox = GPack.vbox ~homogeneous:false ~packing:frame#add () in let hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in @@ -91,7 +97,10 @@ object(self) ~packing:(vbox#pack ~fill:true ~expand:true) () in let ok_b = GButton.button ~label:"Ok" ~packing:(hbox#pack ~expand:false) () in let result = GText.view ~packing:r_bin#add () in + let () = views := !views @ [result] in result#misc#modify_font !current.Preferences.text_font; + let clr = Tags.color_of_string !current.Preferences.background_color in + result#misc#modify_base [`NORMAL, `COLOR clr]; result#misc#set_can_focus true; (* false causes problems for selection *) result#set_editable false; let callback () = @@ -134,6 +143,15 @@ object(self) ignore (combo#entry#connect#activate ~callback); self#frame#misc#show () + method refresh_font () = + let iter view = view#misc#modify_font !current.Preferences.text_font in + List.iter iter !views + + method refresh_color () = + let clr = Tags.color_of_string !current.Preferences.background_color in + let iter view = view#misc#modify_base [`NORMAL, `COLOR clr] in + List.iter iter !views + initializer ignore (new_page_menu#connect#clicked ~callback:self#new_command); (* ignore (window#event#connect#delete (fun _ -> window#misc#hide(); true));*) diff --git a/ide/command_windows.mli b/ide/command_windows.mli index 8c7319aa..c34b6cf6 100644 --- a/ide/command_windows.mli +++ b/ide/command_windows.mli @@ -11,4 +11,6 @@ class command_window : object method new_command : ?command:string -> ?term:string -> unit -> unit method frame : GBin.frame + method refresh_font : unit -> unit + method refresh_color : unit -> unit end @@ -54,36 +54,106 @@ let rec read_all_lines in_chan = arg::(read_all_lines in_chan) with End_of_file -> [] -let filter_coq_opts args = +let fatal_error_popup msg = + let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok + ~message_type:`ERROR ~message:msg () + in ignore (popup#run ()); exit 1 + +let final_info_popup small msg = + if small then + let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok + ~message_type:`INFO ~message:msg () + in + let _ = popup#run () in + exit 0 + else + let popup = GWindow.dialog () in + let button = GButton.button ~label:"ok" ~packing:popup#action_area#add () + in + let scroll = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC + ~packing:popup#vbox#add ~height:500 () + in + let _ = GMisc.label ~text:msg ~packing:scroll#add_with_viewport () in + let _ = popup#connect#destroy ~callback:(fun _ -> exit 0) in + let _ = button#connect#clicked ~callback:(fun _ -> exit 0) in + let _ = popup#run () in + exit 0 + +let connection_error cmd lines exn = + fatal_error_popup + ("Connection with coqtop failed!\n"^ + "Command was: "^cmd^"\n"^ + "Answer was: "^(String.concat "\n " lines)^"\n"^ + "Exception was: "^Printexc.to_string exn) + +let display_coqtop_answer cmd lines = + final_info_popup (List.length lines < 30) + ("Coqtop exited\n"^ + "Command was: "^cmd^"\n"^ + "Answer was: "^(String.concat "\n " lines)) + +let check_remaining_opt arg = + if arg <> "" && arg.[0] = '-' then fatal_error_popup ("Illegal option: "^arg) + +let rec filter_coq_opts args = let argstr = String.concat " " (List.map Filename.quote args) in - let cmd = Filename.quote !Minilib.coqtop_path ^" -nois -filteropts " ^ argstr in - let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in - let filtered_args = read_all_lines oc in - let message = read_all_lines ec in - match Unix.close_process_full (oc,ic,ec) with - | Unix.WEXITED 0 -> true,filtered_args - | Unix.WEXITED 2 -> false,filtered_args - | _ -> false,message - -exception Coqtop_output of string list + let cmd = Filename.quote (coqtop_path ()) ^" -nois -filteropts " ^ argstr in + let cmd = requote cmd in + let filtered_args = ref [] in + let errlines = ref [] in + try + let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in + filtered_args := read_all_lines oc; + errlines := read_all_lines ec; + match Unix.close_process_full (oc,ic,ec) with + | Unix.WEXITED 0 -> + List.iter check_remaining_opt !filtered_args; !filtered_args + | Unix.WEXITED 127 -> asks_for_coqtop args + | _ -> display_coqtop_answer cmd (!filtered_args @ !errlines) + with Sys_error _ -> asks_for_coqtop args + | e -> connection_error cmd (!filtered_args @ !errlines) e + +and asks_for_coqtop args = + let pb_mes = GWindow.message_dialog + ~message:"Failed to load coqtop. Reset the preference to default ?" + ~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no () in + match pb_mes#run () with + | `YES -> + let () = !Preferences.current.Preferences.cmd_coqtop <- None in + let () = custom_coqtop := None in + let () = pb_mes#destroy () in + filter_coq_opts args + | `DELETE_EVENT | `NO -> + let () = pb_mes#destroy () in + let cmd_sel = GWindow.file_selection + ~title:"Coqtop to execute (edit your preference then)" + ~filename:(coqtop_path ()) ~urgency_hint:true () in + match cmd_sel#run () with + | `OK -> + let () = custom_coqtop := (Some cmd_sel#filename) in + let () = cmd_sel#destroy () in + filter_coq_opts args + | `CANCEL | `DELETE_EVENT | `HELP -> exit 0 + +exception WrongExitStatus of string + +let print_status = function + | Unix.WEXITED n -> "WEXITED "^string_of_int n + | Unix.WSIGNALED n -> "WSIGNALED "^string_of_int n + | Unix.WSTOPPED n -> "WSTOPPED "^string_of_int n let check_connection args = + let lines = ref [] in + let argstr = String.concat " " (List.map Filename.quote args) in + let cmd = Filename.quote (coqtop_path ()) ^ " -batch " ^ argstr in + let cmd = requote cmd in try - let argstr = String.concat " " (List.map Filename.quote args) in - let cmd = Filename.quote !Minilib.coqtop_path ^ " -batch " ^ argstr in let ic = Unix.open_process_in cmd in - let lines = read_all_lines ic in + lines := read_all_lines ic; match Unix.close_process_in ic with - | Unix.WEXITED 0 -> prerr_endline "coqtop seems ok" - | _ -> raise (Coqtop_output lines) - with - | End_of_file -> - Minilib.safe_prerr_endline "Cannot start connection with coqtop"; - exit 1 - | Coqtop_output lines -> - Minilib.safe_prerr_endline "Connection with coqtop failed:"; - List.iter Minilib.safe_prerr_endline lines; - exit 1 + | Unix.WEXITED 0 -> () (* coqtop seems ok *) + | st -> raise (WrongExitStatus (print_status st)) + with e -> connection_error cmd !lines e (** * The structure describing a coqtop sub-process *) @@ -139,7 +209,7 @@ let open_process_pid prog args = let spawn_coqtop sup_args = Mutex.lock toplvl_ctr_mtx; try - let prog = !Minilib.coqtop_path in + let prog = coqtop_path () in let args = Array.of_list (prog :: "-ideslave" :: sup_args) in let (pid,ic,oc) = open_process_pid prog args in incr toplvl_ctr; diff --git a/ide/coq.mli b/ide/coq.mli index 9d64da6c..7f61521e 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -13,11 +13,15 @@ val short_version : unit -> string val version : unit -> string -(** * Initial checks by launching test coqtop processes *) - -val filter_coq_opts : string list -> bool * string list - -(** A mock coqtop launch, checking in particular that initial.coq is found *) +(** * Launch a test coqtop processes, ask for a correct coqtop if it fails. + @return the list of arguments that coqtop did not understand + (the files probably ..). This command may terminate coqide in + case of trouble. *) +val filter_coq_opts : string list -> string list + +(** Launch a coqtop with the user args in order to be sure that it works, + checking in particular that initial.coq is found. This command + may terminate coqide in case of trouble *) val check_connection : string list -> unit (** * The structure describing a coqtop sub-process *) diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index b9e14145..256426d2 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -127,7 +127,6 @@ let commands = [ "Show Script"; "Show Tree";*) "Structure"; - (* "Suspend"; *) "Syntactic Definition"; "Syntax";]; [ diff --git a/ide/coq_lex.mll b/ide/coq_lex.mll index f0f1afb7..c9a9a826 100644 --- a/ide/coq_lex.mll +++ b/ide/coq_lex.mll @@ -24,7 +24,7 @@ let one_word_commands = [ "Add" ; "Check"; "Eval"; "Extraction" ; "Load" ; "Undo"; "Goal"; - "Proof" ; "Print";"Save" ; + "Proof" ; "Print";"Save" ; "Restart"; "End" ; "Section"; "Chapter"; "Transparent"; "Opaque"; "Comments" ] in let one_word_declarations = @@ -37,7 +37,8 @@ (* Inductive *) "Inductive" ; "CoInductive" ; "Record" ; "Structure" ; (* Other *) - "Ltac" ; "Typeclasses"; "Instance"; "Include"; "Context"; "Class" ] + "Ltac" ; "Instance"; "Include"; "Context"; "Class" ; + "Arguments" ] in let proof_declarations = [ "Theorem" ; "Lemma" ; " Fact" ; "Remark" ; "Corollary" ; @@ -85,33 +86,28 @@ let multiword_declaration = | "Existing" space+ "Instance" "s"? | "Canonical" space+ "Structure" -let locality = ("Local" space+)? +let locality = (space+ "Local")? let multiword_command = - "Set" (space+ ident)* -| "Unset" (space+ ident)* -| "Open" space+ locality "Scope" -| "Close" space+ locality "Scope" -| "Bind" space+ "Scope" -| "Arguments" space+ "Scope" -| "Reserved" space+ "Notation" space+ locality -| "Delimit" space+ "Scope" + ("Uns" | "S")" et" (space+ ident)* +| (("Open" | "Close") locality | "Bind" | " Delimit" ) + space+ "Scope" +| (("Reserved" space+)? "Notation" | "Infix") locality space+ | "Next" space+ "Obligation" | "Solve" space+ "Obligations" | "Require" space+ ("Import"|"Export")? -| "Infix" space+ locality -| "Notation" space+ locality -| "Hint" space+ locality ident +| "Hint" locality space+ ident | "Reset" (space+ "Initial")? | "Tactic" space+ "Notation" -| "Implicit" space+ "Arguments" -| "Implicit" space+ ("Type"|"Types") +| "Implicit" space+ "Type" "s"? | "Combined" space+ "Scheme" | "Extraction" space+ (("Language" space+ ("Ocaml"|"Haskell"|"Scheme"|"Toplevel"))| ("Library"|"Inline"|"NoInline"|"Blacklist")) | "Recursive" space+ "Extraction" (space+ "Library")? | ("Print"|"Reset") space+ "Extraction" space+ ("Inline"|"Blacklist") | "Extract" space+ (("Inlined" space+) "Constant"| "Inductive") +| "Typeclasses" space+ ("eauto" | "Transparent" | "Opaque") +| ("Generalizable" space+) ("All" | "No")? "Variable" "s"? (* At least still missing: "Inline" + decl, variants of "Identity Coercion", variants of Print, Add, ... *) diff --git a/ide/coqide-gtk2rc b/ide/coqide-gtk2rc index 621d4e84..9da99551 100644 --- a/ide/coqide-gtk2rc +++ b/ide/coqide-gtk2rc @@ -23,16 +23,6 @@ binding "text" { class "GtkTextView" binding "text" -style "views" { -base[NORMAL] = "CornSilk" -# bg_pixmap[NORMAL] = "background.jpg" -} -class "GtkTextView" style "views" - -widget "*.*.*.*.*.ScriptWindow" style "views" -widget "*.*.*.*.GoalWindow" style "views" -widget "*.*.*.*.MessageWindow" style "views" - gtk-font-name = "Sans 12" style "location" { diff --git a/ide/coqide.ml b/ide/coqide.ml index 009a1989..61280fd9 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -27,7 +27,6 @@ let safety_tag = function class type analyzed_views= object val mutable act_id : GtkSignal.id option - val mutable deact_id : GtkSignal.id option val input_buffer : GText.buffer val input_view : Undo.undoable_view val last_array : string array @@ -65,7 +64,6 @@ object method backtrack_to : GText.iter -> unit method backtrack_to_no_lock : GText.iter -> unit method clear_message : unit - method disconnected_keypress_handler : GdkEvent.Key.t -> bool method find_phrase_starting_at : GText.iter -> (GText.iter * GText.iter) option method get_insert : GText.iter @@ -84,6 +82,7 @@ object method reset_initial : unit method force_reset_initial : unit method set_message : string -> unit + method raw_coq_query : string -> unit method show_goals : unit method show_goals_full : unit method undo_last_step : unit @@ -889,11 +888,32 @@ object(self) raise RestartCoqtop | e -> sync display_error (None, Printexc.to_string e); None + (* This method is intended to perform stateless commands *) + method raw_coq_query phrase = + let () = prerr_endline "raw_coq_query starting now" in + let display_error s = + if not (Glib.Utf8.validate s) then + flash_info "This error is so nasty that I can't even display it." + else begin + self#insert_message s; + message_view#misc#draw None + end + in + try + match Coq.interp !mycoqtop ~raw:true ~verbose:false phrase with + | Interface.Fail (_, err) -> sync display_error err + | Interface.Good msg -> sync self#insert_message msg + with + | End_of_file -> raise RestartCoqtop + | e -> sync display_error (Printexc.to_string e) + method find_phrase_starting_at (start:GText.iter) = try let start = grab_sentence_start start self#get_start_of_input in let stop = grab_sentence_stop start in - if is_sentence_end stop#backward_char then Some (start,stop) + (* Is this phrase non-empty and complete ? *) + if stop#compare start > 0 && is_sentence_end stop#backward_char + then Some (start,stop) else None with Not_found -> None @@ -1217,22 +1237,6 @@ object(self) let state = GdkEvent.Key.state k in begin match state with - | l when List.mem `MOD1 l -> - let k = GdkEvent.Key.keyval k in - if GdkKeysyms._Return=k - then ignore( - if (input_buffer#insert_interactive "\n") then - begin - let i= self#get_insert#backward_word_start in - prerr_endline "active_kp_hf: Placing cursor"; - self#process_until_iter_or_error i - end); - true - | l when List.mem `CONTROL l -> - let k = GdkEvent.Key.keyval k in - if GdkKeysyms._Break=k - then break (); - false | l -> if GdkEvent.Key.keyval k = GdkKeysyms._Tab then begin prerr_endline "active_kp_handler for Tab"; @@ -1241,18 +1245,6 @@ object(self) end else false end - - method disconnected_keypress_handler k = - match GdkEvent.Key.state k with - | l when List.mem `CONTROL l -> - let k = GdkEvent.Key.keyval k in - if GdkKeysyms._c=k - then break (); - false - | l -> false - - - val mutable deact_id = None val mutable act_id = None method activate () = if not is_active then begin @@ -1523,9 +1515,15 @@ let create_session file = script#buffer#place_cursor ~where:(script#buffer#start_iter); proof#misc#set_can_focus true; message#misc#set_can_focus true; + (* setting fonts *) script#misc#modify_font !current.text_font; proof#misc#modify_font !current.text_font; message#misc#modify_font !current.text_font; + (* setting colors *) + script#misc#modify_base [`NORMAL, `NAME !current.background_color]; + proof#misc#modify_base [`NORMAL, `NAME !current.background_color]; + message#misc#modify_base [`NORMAL, `NAME !current.background_color]; + { tab_label=basename; filename=begin match file with None -> "" |Some f -> f end; script=script; @@ -1798,12 +1796,6 @@ let forbid_quit_to_save () = else false) let main files = - (* Statup preferences *) - begin - try load_pref () - with e -> - flash_info ("Could not load preferences ("^Printexc.to_string e^")."); - end; (* Main window *) let w = GWindow.window @@ -1823,9 +1815,9 @@ let main files = let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in let new_f _ = - match select_file_for_save ~title:"Create file" () with - | None -> () - | Some f -> do_load f + let session = create_session None in + let index = session_notebook#append_term session in + session_notebook#goto_page index in let load_f _ = match select_file_for_open ~title:"Load file" () with @@ -2181,6 +2173,7 @@ let main files = true)) in reset_auto_save_timer (); (* to enable statup preferences timer *) (* end Preferences *) + let do_or_activate f () = do_if_not_computing "do_or_activate" (fun current -> @@ -2327,13 +2320,13 @@ let main files = in let file_actions = GAction.action_group ~name:"File" () in - let export_actions = GAction.action_group ~name:"Export" () in let edit_actions = GAction.action_group ~name:"Edit" () in + let view_actions = GAction.action_group ~name:"View" () in + let export_actions = GAction.action_group ~name:"Export" () in let navigation_actions = GAction.action_group ~name:"Navigation" () in let tactics_actions = GAction.action_group ~name:"Tactics" () in let templates_actions = GAction.action_group ~name:"Templates" () in let queries_actions = GAction.action_group ~name:"Queries" () in - let display_actions = GAction.action_group ~name:"Display" () in let compile_actions = GAction.action_group ~name:"Compile" () in let windows_actions = GAction.action_group ~name:"Windows" () in let help_actions = GAction.action_group ~name:"Help" () in @@ -2362,10 +2355,18 @@ let main files = ~accel:(!current.modifier_for_tactics^sc) ~callback:(do_if_active (fun a -> a#insert_command ("progress "^s^".\n") (s^".\n"))) in - let query_shortcut s accel = GAction.add_action s ~label:("_"^s) ?accel - ~callback:(fun _ -> let term = get_current_word () in - session_notebook#current_term.command#new_command ~command:s ~term ()) - in let add_complex_template (name, label, text, offset, len, key) = + let query_callback command _ = + let word = get_current_word () in + if not (word = "") then + let term = session_notebook#current_term in + let query = command ^ " " ^ word ^ "." in + term.message_view#buffer#set_text ""; + term.analyzed_view#raw_coq_query query + in + let query_shortcut s accel = + GAction.add_action s ~label:("_"^s) ?accel ~callback:(query_callback s) + in + let add_complex_template (name, label, text, offset, len, key) = (* Templates/Lemma *) let callback _ = let {script = view } = session_notebook#current_term in @@ -2450,6 +2451,31 @@ let main files = end; reset_revert_timer ()) ~stock:`PREFERENCES; (* GAction.add_action "Save preferences" ~label:"_Save preferences" ~callback:(fun _ -> save_pref ()); *) ]; + GAction.add_actions view_actions [ + GAction.add_action "View" ~label:"_View"; + GAction.add_action "Previous tab" ~label:"_Previous tab" ~accel:("<SHIFT>Left") ~stock:`GO_BACK + ~callback:(fun _ -> session_notebook#previous_page ()); + GAction.add_action "Next tab" ~label:"_Next tab" ~accel:("<SHIFT>Right") ~stock:`GO_FORWARD + ~callback:(fun _ -> session_notebook#next_page ()); + GAction.add_toggle_action "Show Toolbar" ~label:"Show _Toolbar" + ~active:(!current.show_toolbar) ~callback: + (fun _ -> !current.show_toolbar <- not !current.show_toolbar; + !refresh_toolbar_hook ()); + GAction.add_toggle_action "Show Query Pane" ~label:"Show _Query Pane" + ~callback:(fun _ -> let ccw = session_notebook#current_term.command in + if ccw#frame#misc#visible + then ccw#frame#misc#hide () + else ccw#frame#misc#show ()) + ~accel:"Escape"; + ]; + List.iter + (fun (opts,name,label,key,dflt) -> + GAction.add_toggle_action name ~active:dflt ~label + ~accel:(!current.modifier_for_display^key) + ~callback:(fun v -> do_or_activate (fun a -> + let () = setopts !(session_notebook#current_term.toplvl) opts v#get_active in + a#show_goals) ()) view_actions) + print_items; GAction.add_actions navigation_actions [ GAction.add_action "Navigation" ~label:"_Navigation"; GAction.add_action "Forward" ~label:"_Forward" ~stock:`GO_DOWN @@ -2532,15 +2558,6 @@ let main files = query_shortcut "Locate" None; query_shortcut "Whelp Locate" None; ]; - GAction.add_action "Display" ~label:"_Display" display_actions; - List.iter - (fun (opts,name,label,key,dflt) -> - GAction.add_toggle_action name ~active:dflt ~label - ~accel:(!current.modifier_for_display^key) - ~callback:(fun v -> do_or_activate (fun a -> - let () = setopts !(session_notebook#current_term.toplvl) opts v#get_active in - a#show_goals) ()) display_actions) - print_items; GAction.add_actions compile_actions [ GAction.add_action "Compile" ~label:"_Compile"; GAction.add_action "Compile buffer" ~label:"_Compile buffer" ~callback:compile_f; @@ -2551,16 +2568,6 @@ let main files = ]; GAction.add_actions windows_actions [ GAction.add_action "Windows" ~label:"_Windows"; - GAction.add_toggle_action "Show/Hide Query Pane" ~label:"Show/Hide _Query Pane" - ~callback:(fun _ -> let ccw = session_notebook#current_term.command in - if ccw#frame#misc#visible - then ccw#frame#misc#hide () - else ccw#frame#misc#show ()) - ~accel:"Escape"; - GAction.add_toggle_action "Show/Hide Toolbar" ~label:"Show/Hide _Toolbar" - ~active:(!current.show_toolbar) ~callback: - (fun _ -> !current.show_toolbar <- not !current.show_toolbar; - !show_toolbar !current.show_toolbar); GAction.add_action "Detach View" ~label:"Detach _View" ~callback:(fun _ -> do_if_not_computing "detach view" (function {script=v;analyzed_view=av} -> @@ -2608,11 +2615,11 @@ let main files = Coqide_ui.ui_m#insert_action_group file_actions 0; Coqide_ui.ui_m#insert_action_group export_actions 0; Coqide_ui.ui_m#insert_action_group edit_actions 0; + Coqide_ui.ui_m#insert_action_group view_actions 0; Coqide_ui.ui_m#insert_action_group navigation_actions 0; Coqide_ui.ui_m#insert_action_group tactics_actions 0; Coqide_ui.ui_m#insert_action_group templates_actions 0; Coqide_ui.ui_m#insert_action_group queries_actions 0; - Coqide_ui.ui_m#insert_action_group display_actions 0; Coqide_ui.ui_m#insert_action_group compile_actions 0; Coqide_ui.ui_m#insert_action_group windows_actions 0; Coqide_ui.ui_m#insert_action_group help_actions 0; @@ -2625,9 +2632,6 @@ let main files = let toolbar = new GObj.widget tbar in vbox#pack toolbar; - show_toolbar := - (fun b -> if b then toolbar#misc#show () else toolbar#misc#hide ()); - ignore (w#event#connect#delete ~callback:(fun _ -> quit_f (); true)); (* The vertical Separator between Scripts and Goals *) @@ -2790,17 +2794,39 @@ let main files = (* Progress Bar *) lower_hbox#pack pbar#coerce; pbar#set_text "CoqIde started"; - (* XXX *) - change_font := - (fun fd -> - List.iter - (fun {script=view; proof_view=prf_v; message_view=msg_v} -> - view#misc#modify_font fd; - prf_v#misc#modify_font fd; - msg_v#misc#modify_font fd - ) - session_notebook#pages; + + (* Initializing hooks *) + + refresh_toolbar_hook := + (fun () -> if !current.show_toolbar then toolbar#misc#show () else toolbar#misc#hide ()); + refresh_font_hook := + (fun () -> + let fd = !current.text_font in + let iter_page p = + p.script#misc#modify_font fd; + p.proof_view#misc#modify_font fd; + p.message_view#misc#modify_font fd; + p.command#refresh_font () + in + List.iter iter_page session_notebook#pages; ); + refresh_background_color_hook := + (fun () -> + let clr = Tags.color_of_string !current.background_color in + let iter_page p = + p.script#misc#modify_base [`NORMAL, `COLOR clr]; + p.proof_view#misc#modify_base [`NORMAL, `COLOR clr]; + p.message_view#misc#modify_base [`NORMAL, `COLOR clr]; + p.command#refresh_color () + in + List.iter iter_page session_notebook#pages; + ); + resize_window_hook := (fun () -> + w#resize + ~width:!current.window_width + ~height:!current.window_height); + refresh_tabs_hook := update_notebook_pos; + let about_full_string = "\nCoq is developed by the Coq Development Team\ \n(INRIA - CNRS - LIX - LRI - PPS)\ @@ -2865,10 +2891,12 @@ let main files = (* *) - resize_window := (fun () -> - w#resize - ~width:!current.window_width - ~height:!current.window_height); +(* Begin Color configuration *) + + Tags.set_processing_color (Tags.color_of_string !current.processing_color); + Tags.set_processed_color (Tags.color_of_string !current.processed_color); + +(* End of color configuration *) ignore(nb#connect#switch_page ~callback: (fun i -> @@ -2892,7 +2920,7 @@ let main files = session_notebook#goto_page index; end; initial_about session_notebook#current_term.proof_view#buffer; - !show_toolbar !current.show_toolbar; + !refresh_toolbar_hook (); session_notebook#current_term.script#misc#grab_focus ();; (* This function check every half of second if GeoProof has send @@ -2921,43 +2949,24 @@ let rec check_for_geoproof_input () = in the path. Note that the -coqtop option to coqide allows to override this default coqtop path *) -let default_coqtop_path () = - let prog = Sys.executable_name in - try - let pos = String.length prog - 6 in - let i = Str.search_backward (Str.regexp_string "coqide") prog pos in - String.blit "coqtop" 0 prog i 6; - prog - with _ -> "coqtop" - let read_coqide_args argv = let rec filter_coqtop coqtop project_files out = function | "-coqtop" :: prog :: args -> - if coqtop = "" then filter_coqtop prog project_files out args + if coqtop = None then filter_coqtop (Some prog) project_files out args else - (output_string stderr "Error: multiple -coqtop options"; exit 1) + (output_string stderr "Error: multiple -coqtop options"; exit 1) | "-f" :: file :: args -> filter_coqtop coqtop ((Minilib.canonical_path_name (Filename.dirname file), Project_file.read_project_file file) :: project_files) out args | "-f" :: [] -> output_string stderr "Error: missing project file name"; exit 1 + | "-coqtop" :: [] -> output_string stderr "Error: missing argument after -coqtop"; exit 1 + | "-debug"::args -> Ideutils.debug := true; + filter_coqtop coqtop project_files ("-debug"::out) args | arg::args -> filter_coqtop coqtop project_files (arg::out) args - | [] -> ((if coqtop = "" then default_coqtop_path () else coqtop), - List.rev project_files,List.rev out) + | [] -> (coqtop,List.rev project_files,List.rev out) in - let coqtop,project_files,argv = filter_coqtop "" [] [] argv in - Minilib.coqtop_path := coqtop; + let coqtop,project_files,argv = filter_coqtop None [] [] argv in + Ideutils.custom_coqtop := coqtop; custom_project_files := project_files; argv - -let process_argv argv = - try - let continue,filtered = Coq.filter_coq_opts (List.tl argv) in - if not continue then - (List.iter Minilib.safe_prerr_endline filtered; exit 0); - let opts = List.filter (fun arg -> String.get arg 0 == '-') filtered in - if opts <> [] then - (Minilib.safe_prerr_endline ("Illegal option: "^List.hd opts); exit 1); - filtered - with _ -> - (Minilib.safe_prerr_endline "coqtop choked on one of your option"; exit 1) diff --git a/ide/coqide.mli b/ide/coqide.mli index 38b0fab0..57158a6a 100644 --- a/ide/coqide.mli +++ b/ide/coqide.mli @@ -16,9 +16,6 @@ val sup_args : string list ref Minilib.coqtop_path accordingly *) val read_coqide_args : string list -> string list -(** Ask coqtop the remaining options it doesn't recognize *) -val process_argv : string list -> string list - (** Prepare the widgets, load the given files in tabs *) val main : string list -> unit diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4 index 3fec0631..6f4b8b13 100644 --- a/ide/coqide_main.ml4 +++ b/ide/coqide_main.ml4 @@ -65,21 +65,21 @@ let () = END let () = - let argl = Array.to_list Sys.argv in - let argl = Coqide.read_coqide_args argl in - let files = Coqide.process_argv argl in - let args = List.filter (fun x -> not (List.mem x files)) (List.tl argl) in - Coq.check_connection args; - Coqide.sup_args := args; Coqide.ignore_break (); + ignore (GtkMain.Main.init ()); + initmac () ; (try let gtkrcdir = List.find (fun x -> Sys.file_exists (Filename.concat x "coqide-gtk2rc")) Minilib.xdg_config_dirs in GtkMain.Rc.add_default_file (Filename.concat gtkrcdir "coqide-gtk2rc"); with Not_found -> ()); - ignore (GtkMain.Main.init ()); - initmac () ; + (* Statup preferences *) + begin + try Preferences.load_pref () + with e -> + Ideutils.flash_info ("Could not load preferences ("^Printexc.to_string e^")."); + end; (* GtkData.AccelGroup.set_default_mod_mask (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);*) ignore ( @@ -89,7 +89,13 @@ let () = if level land Glib.Message.log_level `WARNING <> 0 then Printf.eprintf "Warning: %s\n" msg else failwith ("Coqide internal error: " ^ msg))); - Coqide.main files; + let argl = Array.to_list Sys.argv in + let argl = Coqide.read_coqide_args argl in + let files = Coq.filter_coq_opts (List.tl argl) in + let args = List.filter (fun x -> not (List.mem x files)) (List.tl argl) in + Coq.check_connection args; + Coqide.sup_args := args; + Coqide.main files; if !Coq_config.with_geoproof then ignore (Thread.create Coqide.check_for_geoproof_input ()); macready (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar") (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs") (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help/Abt"); diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index 0d7c67ac..eaf1e934 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -56,6 +56,22 @@ let init () = <separator /> <menuitem name='Prefs' action='Preferences' /> </menu> + <menu name='View' action='View'> + <menuitem action='Previous tab' /> + <menuitem action='Next tab' /> + <separator/> + <menuitem action='Show Toolbar' /> + <menuitem action='Show Query Pane' /> + <separator/> + <menuitem action='Display implicit arguments' /> + <menuitem action='Display coercions' /> + <menuitem action='Display raw matching expressions' /> + <menuitem action='Display notations' /> + <menuitem action='Display all basic low-level contents' /> + <menuitem action='Display existential variable instances' /> + <menuitem action='Display universe levels' /> + <menuitem action='Display all low-level contents' /> + </menu> <menu action='Navigation'> <menuitem action='Forward' /> <menuitem action='Backward' /> @@ -100,16 +116,6 @@ let init () = <menuitem action='Locate' /> <menuitem action='Whelp Locate' /> </menu> - <menu action='Display'> - <menuitem action='Display implicit arguments' /> - <menuitem action='Display coercions' /> - <menuitem action='Display raw matching expressions' /> - <menuitem action='Display notations' /> - <menuitem action='Display all basic low-level contents' /> - <menuitem action='Display existential variable instances' /> - <menuitem action='Display universe levels' /> - <menuitem action='Display all low-level contents' /> - </menu> <menu action='Compile'> <menuitem action='Compile buffer' /> <menuitem action='Make' /> @@ -117,8 +123,6 @@ let init () = <menuitem action='Make makefile' /> </menu> <menu action='Windows'> - <menuitem action='Show/Hide Query Pane' /> - <menuitem action='Show/Hide Toolbar' /> <menuitem action='Detach View' /> </menu> <menu name='Help' action='Help'> diff --git a/ide/ideproof.ml b/ide/ideproof.ml index 3c3324cb..b79d6469 100644 --- a/ide/ideproof.ml +++ b/ide/ideproof.ml @@ -53,7 +53,7 @@ let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with "%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "" else "s") in let goal_str index total = Printf.sprintf - "\n______________________________________(%d/%d)\n" index total + "______________________________________(%d/%d)\n" index total in (* Insert current goal and its hypotheses *) let hyps_hints, goal_hints = match hints with @@ -76,14 +76,15 @@ let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with let () = proof#buffer#insert head_str in let () = insert_hyp hyps_hints hyps in let () = - let tags = if goal_hints <> [] then + let tags = Tags.Proof.goal :: if goal_hints <> [] then let tag = proof#buffer#create_tag [] in let () = hook_tag_cb tag goal_hints sel_cb on_hover in [tag] else [] in proof#buffer#insert (goal_str 1 goals_cnt); - proof#buffer#insert ~tags (cur_goal ^ "\n") + proof#buffer#insert ~tags cur_goal; + proof#buffer#insert "\n" in (* Insert remaining goals (no hypotheses) *) let fold_goal i _ { Interface.goal_ccl = g } = @@ -91,10 +92,11 @@ let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with proof#buffer#insert (g ^ "\n") in let () = Minilib.list_fold_left_i fold_goal 2 () rem_goals in - ignore(proof#buffer#place_cursor - ~where:((proof#buffer#get_iter_at_mark `INSERT)#backward_lines (3*goals_cnt - 2))); - ignore(proof#scroll_to_mark `INSERT) + ignore(proof#buffer#place_cursor + ~where:(proof#buffer#end_iter#backward_to_tag_toggle + (Some Tags.Proof.goal))); + ignore(proof#scroll_to_mark ~use_align:true ~yalign:0.95 `INSERT) let mode_cesar (proof:GText.view) = function | [] -> assert false @@ -123,7 +125,7 @@ let display mode (view:GText.view) goals hints evars = in List.iter iter evs | _ -> - view#buffer#insert "Proof Completed." + view#buffer#insert "No more subgoals." end | Some { Interface.fg_goals = []; Interface.bg_goals = bg } -> (* No foreground proofs, but still unfocused ones *) diff --git a/ide/ideutils.ml b/ide/ideutils.ml index fd460c4e..a208ad0e 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -63,28 +63,25 @@ let print_id id = let do_convert s = Utf8_convert.f (if Glib.Utf8.validate s then begin - prerr_endline "Input is UTF-8";s - end else - let from_loc () = - let _,char_set = Glib.Convert.get_charset () in - flash_info - ("Converting from locale ("^char_set^")"); - Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s - in - let from_manual () = - flash_info - ("Converting from "^ !current.encoding_manual); - Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:!current.encoding_manual - in - if !current.encoding_use_utf8 || !current.encoding_use_locale then begin - try - from_loc () - with _ -> from_manual () - end else begin - try - from_manual () - with _ -> from_loc () - end) + prerr_endline "Input is UTF-8";s + end else + let from_loc () = + let _,char_set = Glib.Convert.get_charset () in + flash_info + ("Converting from locale ("^char_set^")"); + Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s + in + let from_manual enc = + flash_info + ("Converting from "^ enc); + Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:enc + in + match !current.encoding with + |Preferences.Eutf8 | Preferences.Elocale -> from_loc () + |Emanual enc -> + try + from_manual enc + with _ -> from_loc ()) let try_convert s = try @@ -96,18 +93,21 @@ Please choose a correct encoding in the preference panel.*)";; let try_export file_name s = try let s = - try if !current.encoding_use_utf8 then begin - (prerr_endline "UTF-8 is enforced" ;s) - end else if !current.encoding_use_locale then begin - let is_unicode,char_set = Glib.Convert.get_charset () in - if is_unicode then - (prerr_endline "Locale is UTF-8" ;s) - else - (prerr_endline ("Locale is "^char_set); - Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s) - end else - (prerr_endline ("Manual charset is "^ !current.encoding_manual); - Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:!current.encoding_manual s) + try match !current.encoding with + |Eutf8 -> begin + (prerr_endline "UTF-8 is enforced" ;s) + end + |Elocale -> begin + let is_unicode,char_set = Glib.Convert.get_charset () in + if is_unicode then + (prerr_endline "Locale is UTF-8" ;s) + else + (prerr_endline ("Locale is "^char_set); + Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s) + end + |Emanual enc -> + (prerr_endline ("Manual charset is "^ enc); + Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:enc s) with e -> (prerr_endline ("Error ("^(Printexc.to_string e)^") in transcoding: falling back to UTF-8") ;s) in let oc = open_out file_name in @@ -252,14 +252,40 @@ let stock_to_widget ?(size=`DIALOG) s = in img#set_stock s; img#coerce +let custom_coqtop = ref None + +let coqtop_path () = + let file = match !custom_coqtop with + | Some s -> s + | None -> + match !current.cmd_coqtop with + | Some s -> s + | None -> + let prog = String.copy Sys.executable_name in + try + let pos = String.length prog - 6 in + let i = Str.search_backward (Str.regexp_string "coqide") prog pos in + String.blit "coqtop" 0 prog i 6; + prog + with Not_found -> "coqtop" + in file + let rec print_list print fmt = function | [] -> () | [x] -> print fmt x | x :: r -> print fmt x; print_list print fmt r +(* In win32, when a command-line is to be executed via cmd.exe + (i.e. Sys.command, Unix.open_process, ...), it cannot contain several + quoted "..." zones otherwise some quotes are lost. Solution: we re-quote + everything. Reference: http://ss64.com/nt/cmd.html *) + +let requote cmd = if Sys.os_type = "Win32" then "\""^cmd^"\"" else cmd + (* TODO: allow to report output as soon as it comes (user-fiendlier for long commands like make...) *) let run_command f c = + let c = requote c in let result = Buffer.create 127 in let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in let buff = String.make 127 ' ' in @@ -279,11 +305,12 @@ let run_command f c = let browse f url = let com = Minilib.subst_command_placeholder !current.cmd_browse url in - let s = Sys.command com in + let _ = Unix.open_process_out com in () +(* This beautiful message will wait for twt ... if s = 127 then f ("Could not execute\n\""^com^ "\"\ncheck your preferences for setting a valid browser command\n") - +*) let doc_url () = if !current.doc_url = use_default_doc_url || !current.doc_url = "" then let addr = List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";"index.html"] in diff --git a/ide/ideutils.mli b/ide/ideutils.mli index 1e29d323..c433d92a 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -52,6 +52,12 @@ val print_list : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit val run_command : (string -> unit) -> string -> Unix.process_status*string +val custom_coqtop : string option ref +(* @return command to call coqtop + - custom_coqtop if set + - from the prefs is set + - try to infer it else *) +val coqtop_path : unit -> string val status : GMisc.statusbar @@ -67,3 +73,10 @@ val pbar : GRange.progress_bar returns an absolute filename equivalent to given filename *) val absolute_filename : string -> string + +(* In win32, when a command-line is to be executed via cmd.exe + (i.e. Sys.command, Unix.open_process, ...), it cannot contain several + quoted "..." zones otherwise some quotes are lost. Solution: we re-quote + everything. Reference: http://ss64.com/nt/cmd.html *) + +val requote : string -> string diff --git a/ide/minilib.ml b/ide/minilib.ml index cec77f3b..4ccb1ccb 100644 --- a/ide/minilib.ml +++ b/ide/minilib.ml @@ -64,9 +64,10 @@ let string_map f s = let subst_command_placeholder s t = Str.global_replace (Str.regexp_string "%s") t s -let path_to_list p = - let sep = Str.regexp (if Sys.os_type = "Win32" then ";" else ":") in - Str.split sep p +(* Split the content of a variable such as $PATH in a list of directories. + The separators are either ":" in unix or ";" in win32 *) + +let path_to_list = Str.split (Str.regexp "[:;]") (* On win32, the home directory is probably not in $HOME, but in some other environment variable *) @@ -76,28 +77,50 @@ let home = try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found -> try Sys.getenv "USERPROFILE" with Not_found -> Filename.current_dir_name +let opt2list = function None -> [] | Some x -> [x] + +let rec lconcat = function + | [] -> assert false + | [x] -> x + | x::l -> Filename.concat x (lconcat l) + let xdg_config_home = try Filename.concat (Sys.getenv "XDG_CONFIG_HOME") "coq" with Not_found -> - Filename.concat home "/.config/coq" + lconcat [home;".config";"coq"] + +let static_xdg_config_dirs = + if Sys.os_type = "Win32" then + let base = Filename.dirname (Filename.dirname Sys.executable_name) in + [Filename.concat base "config"] + else ["/etc/xdg/coq"] let xdg_config_dirs = - xdg_config_home :: (try - List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_CONFIG_DIRS")) - with Not_found -> "/etc/xdg/coq"::(match Coq_config.configdir with |None -> [] |Some d -> [d])) + xdg_config_home :: + try + List.map (fun dir -> Filename.concat dir "coq") + (path_to_list (Sys.getenv "XDG_CONFIG_DIRS")) + with Not_found -> static_xdg_config_dirs @ opt2list Coq_config.configdir let xdg_data_home = try Filename.concat (Sys.getenv "XDG_DATA_HOME") "coq" with Not_found -> - Filename.concat home "/.local/share/coq" + lconcat [home;".local";"share";"coq"] + +let static_xdg_data_dirs = + if Sys.os_type = "Win32" then + let base = Filename.dirname (Filename.dirname Sys.executable_name) in + [Filename.concat base "share"] + else ["/usr/local/share/coq";"/usr/share/coq"] let xdg_data_dirs = - xdg_data_home :: (try - List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_DATA_DIRS")) - with Not_found -> - "/usr/local/share/coq"::"/usr/share/coq"::(match Coq_config.datadir with |None -> [] |Some d -> [d])) + xdg_data_home :: + try + List.map (fun dir -> Filename.concat dir "coq") + (path_to_list (Sys.getenv "XDG_DATA_DIRS")) + with Not_found -> static_xdg_data_dirs @ opt2list Coq_config.datadir let coqtop_path = ref "" diff --git a/ide/preferences.ml b/ide/preferences.ml index 02673098..d320ddda 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -10,9 +10,22 @@ open Configwin open Printf let pref_file = Filename.concat Minilib.xdg_config_home "coqiderc" - let accel_file = Filename.concat Minilib.xdg_config_home "coqide.keys" +let get_config_file name = + let find_config dir = Sys.file_exists (Filename.concat dir name) in + let config_dir = List.find find_config Minilib.xdg_config_dirs in + Filename.concat config_dir name + +(* Small hack to handle v8.3 to v8.4 change in configuration file *) +let loaded_pref_file = + try get_config_file "coqiderc" + with Not_found -> Filename.concat Minilib.home ".coqiderc" + +let loaded_accel_file = + try get_config_file "coqide.keys" + with Not_found -> Filename.concat Minilib.home ".coqide.keys" + let mod_to_str (m:Gdk.Tags.modifier) = match m with | `MOD1 -> "<Alt>" @@ -40,8 +53,32 @@ let project_behavior_of_string s = else if s = "appended to arguments" then Append_args else Ignore_args +type inputenc = Elocale | Eutf8 | Emanual of string + +let string_of_inputenc = function + |Elocale -> "LOCALE" + |Eutf8 -> "UTF-8" + |Emanual s -> s + +let inputenc_of_string s = + (if s = "UTF-8" then Eutf8 + else if s = "LOCALE" then Elocale + else Emanual s) + + +(** Hooks *) + +let refresh_font_hook = ref (fun () -> ()) +let refresh_background_color_hook = ref (fun () -> ()) +let refresh_toolbar_hook = ref (fun () -> ()) +let auto_complete_hook = ref (fun x -> ()) +let contextual_menus_on_goal_hook = ref (fun x -> ()) +let resize_window_hook = ref (fun () -> ()) +let refresh_tabs_hook = ref (fun () -> ()) + type pref = { + mutable cmd_coqtop : string option; mutable cmd_coqc : string; mutable cmd_make : string; mutable cmd_coqmakefile : string; @@ -57,9 +94,7 @@ type pref = mutable read_project : project_behavior; mutable project_file_name : string; - mutable encoding_use_locale : bool; - mutable encoding_use_utf8 : bool; - mutable encoding_manual : string; + mutable encoding : inputenc; mutable automatic_tactics : string list; mutable cmd_print : string; @@ -89,15 +124,20 @@ type pref = *) mutable auto_complete : bool; mutable stop_before : bool; - mutable lax_syntax : bool; mutable vertical_tabs : bool; mutable opposite_tabs : bool; + + mutable background_color : string; + mutable processing_color : string; + mutable processed_color : string; + } let use_default_doc_url = "(automatic)" let (current:pref ref) = ref { + cmd_coqtop = None; cmd_coqc = "coqc"; cmd_make = "make"; cmd_coqmakefile = "coq_makefile -o makefile *.v"; @@ -114,9 +154,7 @@ let (current:pref ref) = read_project = Ignore_args; project_file_name = "_CoqProject"; - encoding_use_locale = true; - encoding_use_utf8 = false; - encoding_manual = "ISO_8859-1"; + encoding = if Sys.os_type = "Win32" then Eutf8 else Elocale; automatic_tactics = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ]; @@ -150,32 +188,25 @@ let (current:pref ref) = *) auto_complete = false; stop_before = true; - lax_syntax = true; vertical_tabs = false; opposite_tabs = false; - } - - -let change_font = ref (fun f -> ()) -let show_toolbar = ref (fun x -> ()) + background_color = "cornsilk"; + processed_color = "light green"; + processing_color = "light blue"; -let auto_complete = ref (fun x -> ()) - -let contextual_menus_on_goal = ref (fun x -> ()) - -let resize_window = ref (fun () -> ()) + } let save_pref () = if not (Sys.file_exists Minilib.xdg_config_home) then Unix.mkdir Minilib.xdg_config_home 0o700; - (try GtkData.AccelMap.save accel_file - with _ -> ()); + let () = try GtkData.AccelMap.save accel_file with _ -> () in let p = !current in let add = Minilib.Stringmap.add in let (++) x f = f x in Minilib.Stringmap.empty ++ + add "cmd_coqtop" (match p.cmd_coqtop with | None -> [] | Some v-> [v]) ++ add "cmd_coqc" [p.cmd_coqc] ++ add "cmd_make" [p.cmd_make] ++ add "cmd_coqmakefile" [p.cmd_coqmakefile] ++ @@ -190,9 +221,7 @@ let save_pref () = add "project_options" [string_of_project_behavior p.read_project] ++ add "project_file_name" [p.project_file_name] ++ - add "encoding_use_locale" [string_of_bool p.encoding_use_locale] ++ - add "encoding_use_utf8" [string_of_bool p.encoding_use_utf8] ++ - add "encoding_manual" [p.encoding_manual] ++ + add "encoding" [string_of_inputenc p.encoding] ++ add "automatic_tactics" p.automatic_tactics ++ add "cmd_print" [p.cmd_print] ++ @@ -217,19 +246,18 @@ let save_pref () = add "query_window_width" [string_of_int p.query_window_width] ++ add "auto_complete" [string_of_bool p.auto_complete] ++ add "stop_before" [string_of_bool p.stop_before] ++ - add "lax_syntax" [string_of_bool p.lax_syntax] ++ add "vertical_tabs" [string_of_bool p.vertical_tabs] ++ add "opposite_tabs" [string_of_bool p.opposite_tabs] ++ + add "background_color" [p.background_color] ++ + add "processing_color" [p.processing_color] ++ + add "processed_color" [p.processed_color] ++ Config_lexer.print_file pref_file let load_pref () = - let accel_dir = List.find - (fun x -> Sys.file_exists (Filename.concat x "coqide.keys")) - Minilib.xdg_config_dirs in - GtkData.AccelMap.load (Filename.concat accel_dir "coqide.keys"); + let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in let p = !current in - let m = Config_lexer.load_file pref_file in + let m = Config_lexer.load_file loaded_pref_file in let np = { p with cmd_coqc = p.cmd_coqc } in let set k f = try let v = Minilib.Stringmap.find k m in f v with _ -> () in let set_hd k f = set k (fun v -> f (List.hd v)) in @@ -239,6 +267,8 @@ let load_pref () = let set_command_with_pair_compat k f = set k (function [v1;v2] -> f (v1^"%s"^v2) | [v] -> f v | _ -> raise Exit) in + let set_option k f = set k (fun v -> f (match v with |[] -> None |h::_ -> Some h)) in + set_option "cmd_coqtop" (fun v -> np.cmd_coqtop <- v); set_hd "cmd_coqc" (fun v -> np.cmd_coqc <- v); set_hd "cmd_make" (fun v -> np.cmd_make <- v); set_hd "cmd_coqmakefile" (fun v -> np.cmd_coqmakefile <- v); @@ -249,9 +279,7 @@ let load_pref () = set_bool "auto_save" (fun v -> np.auto_save <- v); set_int "auto_save_delay" (fun v -> np.auto_save_delay <- v); set_pair "auto_save_name" (fun v1 v2 -> np.auto_save_name <- (v1,v2)); - set_bool "encoding_use_locale" (fun v -> np.encoding_use_locale <- v); - set_bool "encoding_use_utf8" (fun v -> np.encoding_use_utf8 <- v); - set_hd "encoding_manual" (fun v -> np.encoding_manual <- v); + set_hd "encoding_manual" (fun v -> np.encoding <- (inputenc_of_string v)); 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); @@ -290,15 +318,21 @@ let load_pref () = set_int "query_window_height" (fun v -> np.query_window_height <- v); set_bool "auto_complete" (fun v -> np.auto_complete <- v); set_bool "stop_before" (fun v -> np.stop_before <- v); - set_bool "lax_syntax" (fun v -> np.lax_syntax <- v); set_bool "vertical_tabs" (fun v -> np.vertical_tabs <- v); set_bool "opposite_tabs" (fun v -> np.opposite_tabs <- v); + set_hd "background_color" (fun v -> np.background_color <- v); + set_hd "processing_color" (fun v -> np.processing_color <- v); + set_hd "processed_color" (fun v -> np.processed_color <- v); current := np (* Format.printf "in load_pref: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) let configure ?(apply=(fun () -> ())) () = + let cmd_coqtop = + string + ~f:(fun s -> !current.cmd_coqtop <- if s = "AUTO" then None else Some s) + " coqtop" (match !current.cmd_coqtop with |None -> "AUTO" | Some x -> x) in let cmd_coqc = string ~f:(fun s -> !current.cmd_coqc <- s) @@ -325,7 +359,7 @@ let configure ?(apply=(fun () -> ())) () = let w = GMisc.font_selection () in w#set_preview_text "Goal (∃n : nat, n ≤ 0)∧(∀x,y,z, x∈y⋃z↔x∈y∨x∈z)."; - box#pack w#coerce; + box#pack ~expand:true w#coerce; ignore (w#misc#connect#realize ~callback:(fun () -> w#set_font_name (Pango.Font.to_string !current.text_font))); @@ -338,9 +372,67 @@ let configure ?(apply=(fun () -> ())) () = (* Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) - !change_font !current.text_font) + !refresh_font_hook ()) true in + + let config_color = + let box = GPack.vbox () in + let table = GPack.table + ~row_spacings:5 + ~col_spacings:5 + ~border_width:2 + ~packing:(box#pack ~expand:true) () + in + let background_label = GMisc.label + ~text:"Background color" + ~packing:(table#attach ~expand:`X ~left:0 ~top:0) () + in + let processed_label = GMisc.label + ~text:"Background color of processed text" + ~packing:(table#attach ~expand:`X ~left:0 ~top:1) () + in + let processing_label = GMisc.label + ~text:"Background color of text being processed" + ~packing:(table#attach ~expand:`X ~left:0 ~top:2) () + in + let () = background_label#set_xalign 0. in + let () = processed_label#set_xalign 0. in + let () = processing_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) () + in + let processed_button = GButton.color_button + ~color:(Tags.get_processed_color ()) + ~packing:(table#attach ~left:1 ~top:1) () + in + let processing_button = GButton.color_button + ~color:(Tags.get_processing_color ()) + ~packing:(table#attach ~left:1 ~top:2) () + 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"); + in + let _ = reset_button#connect#clicked ~callback:reset_cb in + let label = "Color configuration" in + let callback () = + !current.background_color <- Tags.string_of_color background_button#color; + !current.processing_color <- Tags.string_of_color processing_button#color; + !current.processed_color <- Tags.string_of_color processed_button#color; + !refresh_background_color_hook (); + Tags.set_processing_color processing_button#color; + Tags.set_processed_color processed_button#color + in + custom ~label box callback true + in + (* let show_toolbar = bool @@ -369,7 +461,7 @@ let configure ?(apply=(fun () -> ())) () = bool ~f:(fun s -> !current.auto_complete <- s; - !auto_complete s) + !auto_complete_hook s) "Auto Complete" !current.auto_complete in @@ -416,44 +508,28 @@ let configure ?(apply=(fun () -> ())) () = "Stop interpreting before the current point" !current.stop_before in - let lax_syntax = - bool - ~f:(fun s -> !current.lax_syntax <- s) - "Relax read-only constraint at end of command" !current.lax_syntax - in - let vertical_tabs = bool - ~f:(fun s -> !current.vertical_tabs <- s) + ~f:(fun s -> !current.vertical_tabs <- s; !refresh_tabs_hook ()) "Vertical tabs" !current.vertical_tabs in let opposite_tabs = bool - ~f:(fun s -> !current.opposite_tabs <- s) + ~f:(fun s -> !current.opposite_tabs <- s; !refresh_tabs_hook ()) "Tabs on opposite side" !current.opposite_tabs in let encodings = combo "File charset encoding " - ~f:(fun s -> - match s with - | "UTF-8" -> - !current.encoding_use_utf8 <- true; - !current.encoding_use_locale <- false - | "LOCALE" -> - !current.encoding_use_utf8 <- false; - !current.encoding_use_locale <- true - | _ -> - !current.encoding_use_utf8 <- false; - !current.encoding_use_locale <- false; - !current.encoding_manual <- s; - ) + ~f:(fun s -> !current.encoding <- (inputenc_of_string s)) ~new_allowed: true - ["UTF-8";"LOCALE";!current.encoding_manual] - (if !current.encoding_use_utf8 then "UTF-8" - else if !current.encoding_use_locale then "LOCALE" else !current.encoding_manual) + ("UTF-8"::"LOCALE":: match !current.encoding with + |Emanual s -> [s] + |_ -> [] + ) + (string_of_inputenc !current.encoding) in let read_project = combo @@ -579,11 +655,11 @@ let configure ?(apply=(fun () -> ())) () = bool ~f:(fun s -> !current.contextual_menus_on_goal <- s; - !contextual_menus_on_goal s) + !contextual_menus_on_goal_hook s) "Contextual menus on goal" !current.contextual_menus_on_goal in - let misc = [contextual_menus_on_goal;auto_complete;stop_before;lax_syntax; + let misc = [contextual_menus_on_goal;auto_complete;stop_before; vertical_tabs;opposite_tabs] in (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!! @@ -591,6 +667,7 @@ let configure ?(apply=(fun () -> ())) () = let cmds = [Section("Fonts", Some `SELECT_FONT, [config_font]); + Section("Colors", Some `SELECT_COLOR, [config_color]); Section("Files", Some `DIRECTORY, [global_auto_revert;global_auto_revert_delay; auto_save; auto_save_delay; (* auto_save_name*) @@ -604,9 +681,8 @@ let configure ?(apply=(fun () -> ())) () = config_appearance); *) Section("Externals", None, - [cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print; - cmd_editor; - cmd_browse;doc_url;library_url]); + [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; + cmd_print;cmd_editor;cmd_browse;doc_url;library_url]); Section("Tactics Wizard", None, [automatic_tactics]); Section("Shortcuts", Some `PREFERENCES, @@ -618,7 +694,7 @@ let configure ?(apply=(fun () -> ())) () = (* Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) - let x = edit ~apply ~width:500 "Customizations" cmds in + let x = edit ~apply "Customizations" cmds in (* Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) diff --git a/ide/preferences.mli b/ide/preferences.mli index f55088f1..b680c6f0 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -7,9 +7,11 @@ (************************************************************************) type project_behavior = Ignore_args | Append_args | Subst_args +type inputenc = Elocale | Eutf8 | Emanual of string type pref = { + mutable cmd_coqtop : string option; mutable cmd_coqc : string; mutable cmd_make : string; mutable cmd_coqmakefile : string; @@ -25,9 +27,7 @@ type pref = mutable read_project : project_behavior; mutable project_file_name : string; - mutable encoding_use_locale : bool; - mutable encoding_use_utf8 : bool; - mutable encoding_manual : string; + mutable encoding : inputenc; mutable automatic_tactics : string list; mutable cmd_print : string; @@ -57,9 +57,12 @@ type pref = *) mutable auto_complete : bool; mutable stop_before : bool; - mutable lax_syntax : bool; mutable vertical_tabs : bool; mutable opposite_tabs : bool; + + mutable background_color : string; + mutable processing_color : string; + mutable processed_color : string; } val save_pref : unit -> unit @@ -69,9 +72,11 @@ val current : pref ref val configure : ?apply:(unit -> unit) -> unit -> unit -val change_font : ( Pango.font_description -> unit) ref -val show_toolbar : (bool -> unit) ref -val auto_complete : (bool -> unit) ref -val resize_window : (unit -> unit) ref +(* Hooks *) +val refresh_font_hook : (unit -> unit) ref +val refresh_background_color_hook : (unit -> unit) ref +val refresh_toolbar_hook : (unit -> unit) ref +val resize_window_hook : (unit -> unit) ref +val refresh_tabs_hook : (unit -> unit) ref val use_default_doc_url : string diff --git a/ide/tags.ml b/ide/tags.ml index 52ba54dc..eeace465 100644 --- a/ide/tags.ml +++ b/ide/tags.ml @@ -13,6 +13,9 @@ 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" + module Script = struct let table = GText.tag_table () @@ -23,8 +26,8 @@ struct let comment = make_tag table ~name:"comment" [`FOREGROUND "brown"] let reserved = make_tag table ~name:"reserved" [`FOREGROUND "dark red"] let error = make_tag table ~name:"error" [`UNDERLINE `DOUBLE ; `FOREGROUND "red"] - let to_process = make_tag table ~name:"to_process" [`BACKGROUND "light blue" ;`EDITABLE false] - let processed = make_tag table ~name:"processed" [`BACKGROUND "light green" ;`EDITABLE false] + let to_process = make_tag table ~name:"to_process" [`BACKGROUND !processing_color ;`EDITABLE false] + let processed = make_tag table ~name:"processed" [`BACKGROUND !processed_color;`EDITABLE false] let unjustified = make_tag table ~name:"unjustified" [`UNDERLINE `SINGLE; `FOREGROUND "red"; `BACKGROUND "gold";`EDITABLE false] let found = make_tag table ~name:"found" [`BACKGROUND "blue"; `FOREGROUND "white"] let hidden = make_tag table ~name:"hidden" [`INVISIBLE true; `EDITABLE false] @@ -35,7 +38,7 @@ end module Proof = struct let table = GText.tag_table () - let highlight = make_tag table ~name:"highlight" [`BACKGROUND "light green"] + let highlight = make_tag table ~name:"highlight" [`BACKGROUND !processed_color] let hypothesis = make_tag table ~name:"hypothesis" [] let goal = make_tag table ~name:"goal" [] end @@ -45,3 +48,27 @@ struct let error = make_tag table ~name:"error" [`FOREGROUND "red"] end +let string_of_color clr = + let r = Gdk.Color.red clr in + let g = Gdk.Color.green clr in + let b = Gdk.Color.blue clr in + Printf.sprintf "#%04X%04X%04X" r g b + +let color_of_string s = + let colormap = Gdk.Color.get_system_colormap () in + Gdk.Color.alloc ~colormap (`NAME s) + +let get_processed_color () = color_of_string !processed_color + +let set_processed_color clr = + let s = string_of_color clr in + processed_color := s; + Script.processed#set_property (`BACKGROUND s); + Proof.highlight#set_property (`BACKGROUND s) + +let get_processing_color () = color_of_string !processing_color + +let set_processing_color clr = + let s = string_of_color clr in + processing_color := s; + Script.to_process#set_property (`BACKGROUND s) diff --git a/ide/tags.mli b/ide/tags.mli new file mode 100644 index 00000000..53a8c493 --- /dev/null +++ b/ide/tags.mli @@ -0,0 +1,50 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +module Script : +sig + val table : GText.tag_table + val kwd : GText.tag + val qed : GText.tag + val decl : GText.tag + val proof_decl : GText.tag + val comment : GText.tag + val reserved : GText.tag + val error : GText.tag + val to_process : GText.tag + val processed : GText.tag + val unjustified : GText.tag + val found : GText.tag + val hidden : GText.tag + val folded : GText.tag + val paren : GText.tag + val sentence : GText.tag +end + +module Proof : +sig + val table : GText.tag_table + val highlight : GText.tag + val hypothesis : GText.tag + val goal : GText.tag +end + +module Message : +sig + val table : GText.tag_table + val error : GText.tag +end + +val string_of_color : Gdk.color -> string +val color_of_string : string -> Gdk.color + +val get_processed_color : unit -> Gdk.color +val set_processed_color : Gdk.color -> unit + +val get_processing_color : unit -> Gdk.color +val set_processing_color : Gdk.color -> unit diff --git a/ide/utils/configwin.ml b/ide/utils/configwin.ml index 3ff60799..4606ef29 100644 --- a/ide/utils/configwin.ml +++ b/ide/utils/configwin.ml @@ -60,9 +60,9 @@ let html = Configwin_ihm.html let edit ?(apply=(fun () -> ())) - title ?(width=400) ?(height=400) + title ?width ?height conf_struct_list = - Configwin_ihm.edit ~with_apply: true ~apply title ~width ~height conf_struct_list + Configwin_ihm.edit ~with_apply: true ~apply title ?width ?height conf_struct_list let get = Configwin_ihm.edit ~with_apply: false ~apply: (fun () -> ()) diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml index 9ddc90ef..7dbd0452 100644 --- a/ide/utils/configwin_ihm.ml +++ b/ide/utils/configwin_ihm.ml @@ -1022,7 +1022,7 @@ class configuration_box (tt : GData.tooltips) conf_struct = let rec make_tree iter conf_struct = (* box is not shown at first *) - let box = GPack.vbox ~packing:menu_box#add ~show:false () in + let box = GPack.vbox ~packing:(menu_box#pack ~expand:true) ~show:false () in let new_iter = match iter with | None -> tree#append () | Some parent -> tree#append ~parent () @@ -1136,12 +1136,12 @@ let tabbed_box conf_struct_list buttons tooltips = to configure the various parameters. *) let edit ?(with_apply=true) ?(apply=(fun () -> ())) - title ?(width=400) ?(height=400) + title ?width ?height conf_struct = let dialog = GWindow.dialog ~position:`CENTER ~modal: true ~title: title - ~height ~width + ?height ?width () in let tooltips = GData.tooltips () in diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 193b38dd..82e3cbe1 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -140,14 +140,18 @@ let extern_evar loc n l = let debug_global_reference_printer = ref (fun _ -> failwith "Cannot print a global reference") +let in_debugger = ref false + let set_debug_global_reference_printer f = debug_global_reference_printer := f let extern_reference loc vars r = - try Qualid (loc,shortest_qualid_of_global vars r) - with Not_found -> - (* happens in debugger *) + if !in_debugger then + (* Debugger does not have the tables of global reference at hand *) !debug_global_reference_printer loc r + else + Qualid (loc,shortest_qualid_of_global vars r) + (************************************************************************) (* Equality up to location (useful for translator v8) *) @@ -344,7 +348,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = let args = List.map (extern_cases_pattern_in_scope scopes vars) args in let p = try - if !Flags.raw_print then raise Exit; + if !in_debugger || !Flags.raw_print then raise Exit; let projs = Recordops.lookup_projections (fst cstrsp) in let rec ip projs args acc = match projs with @@ -447,6 +451,7 @@ let is_needed_for_correct_partial_application tail imp = (* Implicit args indexes are in ascending order *) (* inctx is useful only if there is a last argument to be deduced from ctxt *) let explicitize loc inctx impl (cf,f) args = + let impl = if !Constrintern.parsing_explicit then [] else impl in let n = List.length args in let rec exprec q = function | a::args, imp::impl when is_status_implicit imp -> @@ -482,7 +487,9 @@ let explicitize loc inctx impl (cf,f) args = if args = [] then f else CApp (loc, (None, f), args) let extern_global loc impl f = - if impl <> [] & List.for_all is_status_implicit impl then + if not !Constrintern.parsing_explicit && + impl <> [] && List.for_all is_status_implicit impl + then CAppExpl (loc, (None, f), []) else CRef f @@ -491,7 +498,7 @@ let extern_app loc inctx impl (cf,f) args = if args = [] (* maybe caused by a hidden coercion *) then extern_global loc impl f else - if + if not !Constrintern.parsing_explicit && ((!Flags.raw_print or (!print_implicits & not !print_implicits_explicit_args)) & List.exists is_status_implicit impl) @@ -761,7 +768,7 @@ and factorize_prod scopes vars aty c = and factorize_lambda inctx scopes vars aty c = try if !Flags.raw_print or !print_no_symbol then raise No_match; - ([],extern_symbol scopes vars c (uninterp_notations c)) + ([],extern_symbol (Some Notation.type_scope,snd scopes) vars c (uninterp_notations c)) with No_match -> match c with | GLambda (loc,na,bk,ty,c) when same aty (extern_typ scopes vars (anonymize_if_reserved na ty)) @@ -889,21 +896,30 @@ let extern_glob_type vars c = let loc = dummy_loc (* for constr and pattern, locations are lost *) -let extern_constr_gen at_top scopt env t = - let avoid = if at_top then ids_of_context env else [] in - let r = Detyping.detype at_top avoid (names_of_rel_context env) t in +let extern_constr_gen goal_concl_style scopt env t = + (* "goal_concl_style" means do alpha-conversion using the "goal" convention *) + (* i.e.: avoid using the names of goal/section/rel variables and the short *) + (* names of global definitions of current module when computing names for *) + (* bound variables. *) + (* Not "goal_concl_style" means do alpha-conversion avoiding only *) + (* those goal/section/rel variables that occurs in the subterm under *) + (* consideration; see namegen.ml for further details *) + let avoid = if goal_concl_style then ids_of_context env else [] in + let rel_env_names = names_of_rel_context env in + let r = Detyping.detype goal_concl_style avoid rel_env_names t in let vars = vars_of_env env in extern false (scopt,[]) vars r -let extern_constr_in_scope at_top scope env t = - extern_constr_gen at_top (Some scope) env t +let extern_constr_in_scope goal_concl_style scope env t = + extern_constr_gen goal_concl_style (Some scope) env t -let extern_constr at_top env t = - extern_constr_gen at_top None env t +let extern_constr goal_concl_style env t = + extern_constr_gen goal_concl_style None env t -let extern_type at_top env t = - let avoid = if at_top then ids_of_context env else [] in - let r = Detyping.detype at_top avoid (names_of_rel_context env) t in +let extern_type goal_concl_style env t = + let avoid = if goal_concl_style then ids_of_context env else [] in + let rel_env_names = names_of_rel_context env in + let r = Detyping.detype goal_concl_style avoid rel_env_names t in extern_glob_type (vars_of_env env) r let extern_sort s = extern_glob_sort (detype_sort s) diff --git a/interp/constrextern.mli b/interp/constrextern.mli index e1fdd068..2a53eb85 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -53,6 +53,7 @@ val print_projections : bool ref (** Debug printing options *) val set_debug_global_reference_printer : (loc -> global_reference -> reference) -> unit +val in_debugger : bool ref (** This governs printing of implicit arguments. If [with_implicits] is on and not [with_arguments] then implicit args are printed prefixed diff --git a/interp/constrintern.ml b/interp/constrintern.ml index b161d001..1dd735ad 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -166,6 +166,8 @@ let error_inductive_parameter_not_implicit loc = (* Pre-computing the implicit arguments and arguments scopes needed *) (* for interpretation *) +let parsing_explicit = ref false + let empty_internalization_env = Idmap.empty let compute_explicitable_implicit imps = function @@ -408,12 +410,12 @@ let intern_local_binder_aux ?(global_level=false) intern intern_type lvar (env,b | LocalRawAssum(nal,bk,ty) -> (match bk with | Default k -> - let (loc,na) = List.hd nal in - (* TODO: fail if several names with different implicit types *) - let ty = locate_if_isevar loc na (intern_type env ty) in + let ty = intern_type env ty in + let impls = impls_type_list ty in List.fold_left - (fun (env,bl) na -> - (push_name_env lvar (impls_type_list ty) env na,(snd na,k,None,ty)::bl)) + (fun (env,bl) (loc,na as locna) -> + (push_name_env lvar impls env locna, + (na,k,None,locate_if_isevar loc na ty)::bl)) (env,bl) nal | Generalized (b,b',t) -> let env, b = intern_generalized_binder ~global_level intern_type lvar env bl (List.hd nal) b b' t ty in @@ -452,12 +454,12 @@ let iterate_binder intern lvar (env,bl) = function let intern_type env = intern (set_type_scope env) in (match bk with | Default k -> - let (loc,na) = List.hd nal in - (* TODO: fail if several names with different implicit types *) let ty = intern_type env ty in - let ty = locate_if_isevar loc na ty in + let impls = impls_type_list ty in List.fold_left - (fun (env,bl) na -> (push_name_env lvar (impls_type_list ty) env na,(snd na,k,None,ty)::bl)) + (fun (env,bl) (loc,na as locna) -> + (push_name_env lvar impls env locna, + (na,k,None,locate_if_isevar loc na ty)::bl)) (env,bl) nal | Generalized (b,b',t) -> let env, b = intern_generalized_binder intern_type lvar env bl (List.hd nal) b b' t ty in @@ -731,8 +733,9 @@ let apply_scope_env env = function | [] -> {env with tmp_scope = None}, [] | sc::scl -> {env with tmp_scope = sc}, scl -let rec simple_adjust_scopes n = function - | [] -> if n=0 then [] else None :: simple_adjust_scopes (n-1) [] +let rec simple_adjust_scopes n scopes = + if n=0 then [] else match scopes with + | [] -> None :: simple_adjust_scopes (n-1) [] | sc::scopes -> sc :: simple_adjust_scopes (n-1) scopes let find_remaining_constructor_scopes pl1 pl2 (ind,j as cstr) = @@ -809,9 +812,6 @@ let message_redundant_alias (id1,id2) = (* Expanding notations *) -let error_invalid_pattern_notation loc = - user_err_loc (loc,"",str "Invalid notation for pattern.") - let chop_aconstr_constructor loc (ind,k) args = if List.length args = 0 then (* Tolerance for a @id notation *) args else begin @@ -1293,7 +1293,7 @@ let internalize sigma globalenv env allow_patvar lvar c = find_appl_head_data c, args | x -> (intern env f,[],[],[]), args in let args = - intern_impargs c env impargs args_scopes (merge_impargs l args) in + intern_impargs c env impargs args_scopes (merge_impargs l args) in check_projection isproj (List.length args) c; (match c with (* Now compact "(f args') args" *) @@ -1417,13 +1417,16 @@ let internalize sigma globalenv env allow_patvar lvar c = (tm',(snd na,typ)), na::ids and iterate_prod loc2 env bk ty body nal = - let rec default env bk = function - | (loc1,na as locna)::nal -> - if nal <> [] then check_capture loc1 ty na; - let ty = locate_if_isevar loc1 na (intern_type env ty) in - let body = default (push_name_env lvar (impls_type_list ty) env locna) bk nal in - GProd (join_loc loc1 loc2, na, bk, ty, body) - | [] -> intern_type env body + let default env bk = function + | (loc1,na)::nal' as nal -> + if nal' <> [] then check_capture loc1 ty na; + let ty = intern_type env ty in + let impls = impls_type_list ty in + let env = List.fold_left (push_name_env lvar impls) env nal in + List.fold_right (fun (loc,na) c -> + GProd (join_loc loc loc2, na, bk, locate_if_isevar loc na ty, c)) + nal (intern_type env body) + | [] -> assert false in match bk with | Default b -> default env b nal @@ -1433,13 +1436,16 @@ let internalize sigma globalenv env allow_patvar lvar c = it_mkGProd ibind body and iterate_lam loc2 env bk ty body nal = - let rec default env bk = function - | (loc1,na as locna)::nal -> - if nal <> [] then check_capture loc1 ty na; - let ty = locate_if_isevar loc1 na (intern_type env ty) in - let body = default (push_name_env lvar (impls_type_list ty) env locna) bk nal in - GLambda (join_loc loc1 loc2, na, bk, ty, body) - | [] -> intern env body + let default env bk = function + | (loc1,na)::nal' as nal -> + if nal' <> [] then check_capture loc1 ty na; + let ty = intern_type env ty in + let impls = impls_type_list ty in + let env = List.fold_left (push_name_env lvar impls) env nal in + List.fold_right (fun (loc,na) c -> + GLambda (join_loc loc loc2, na, bk, locate_if_isevar loc na ty, c)) + nal (intern env body) + | [] -> assert false in match bk with | Default b -> default env b nal | Generalized (b, b', t) -> @@ -1450,6 +1456,12 @@ let internalize sigma globalenv env allow_patvar lvar c = and intern_impargs c env l subscopes args = let l = select_impargs_size (List.length args) l in let eargs, rargs = extract_explicit_arg l args in + if !parsing_explicit then + if eargs <> [] then + error "Arguments given by name or position not supported in explicit mode." + else + intern_args env subscopes rargs + else let rec aux n impl subscopes eargs rargs = let (enva,subscopes') = apply_scope_env env subscopes in match (impl,rargs) with diff --git a/interp/constrintern.mli b/interp/constrintern.mli index be78837f..7d000902 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -178,5 +178,8 @@ val interp_aconstr : ?impls:internalization_env -> (identifier * identifier) list -> constr_expr -> (identifier * (subscopes * notation_var_internalization_type)) list * aconstr +(** Globalization options *) +val parsing_explicit : bool ref + (** Globalization leak for Grammar *) val for_grammar : ('a -> 'b) -> 'a -> 'b diff --git a/interp/genarg.ml b/interp/genarg.ml index e564bd11..594e8fd9 100644 --- a/interp/genarg.ml +++ b/interp/genarg.ml @@ -63,23 +63,10 @@ type 'a with_ebindings = 'a * open_constr bindings type 'a generic_argument = argument_type * Obj.t -let dyntab = ref ([] : string list) - type rlevel type glevel type tlevel -type ('a,'b) abstract_argument_type = argument_type - -let create_arg s = - if List.mem s !dyntab then - anomaly ("Genarg.create: already declared generic argument " ^ s); - dyntab := s :: !dyntab; - let t = ExtraArgType s in - (t,t,t) - -let exists_argtype s = List.mem s !dyntab - type intro_pattern_expr = | IntroOrAndPattern of or_and_intro_pattern_expr | IntroWildcard @@ -259,3 +246,32 @@ let unquote x = x type an_arg_of_this_type = Obj.t let in_generic t x = (t, Obj.repr x) + +let dyntab = ref ([] : (string * glevel generic_argument option) list) + +type ('a,'b) abstract_argument_type = argument_type + +let create_arg v s = + if List.mem_assoc s !dyntab then + anomaly ("Genarg.create: already declared generic argument " ^ s); + let t = ExtraArgType s in + dyntab := (s,Option.map (in_gen t) v) :: !dyntab; + (t,t,t) + +let exists_argtype s = List.mem_assoc s !dyntab + +let default_empty_argtype_value s = List.assoc s !dyntab + +let default_empty_value t = + let rec aux = function + | List0ArgType _ -> Some (in_gen t []) + | OptArgType _ -> Some (in_gen t None) + | PairArgType(t1,t2) -> + (match aux t1, aux t2 with + | Some (_,v1), Some (_,v2) -> Some (in_gen t (v1,v2)) + | _ -> None) + | ExtraArgType s -> default_empty_argtype_value s + | _ -> None in + match aux t with + | Some v -> Some (out_gen t v) + | None -> None diff --git a/interp/genarg.mli b/interp/genarg.mli index 54aadba1..01217204 100644 --- a/interp/genarg.mli +++ b/interp/genarg.mli @@ -256,7 +256,8 @@ val app_pair : (** create a new generic type of argument: force to associate unique ML types at each of the three levels *) -val create_arg : string -> +val create_arg : 'rawa option -> + string -> ('a,tlevel) abstract_argument_type * ('globa,glevel) abstract_argument_type * ('rawa,rlevel) abstract_argument_type @@ -298,7 +299,6 @@ val in_gen : val out_gen : ('a,'co) abstract_argument_type -> 'co generic_argument -> 'a - (** [in_generic] is used in combination with camlp4 [Gramext.action] magic [in_generic: !l:type, !a:argument_type -> |a|_l -> 'l generic_argument] @@ -312,3 +312,5 @@ type an_arg_of_this_type val in_generic : argument_type -> an_arg_of_this_type -> 'co generic_argument + +val default_empty_value : ('a,rlevel) abstract_argument_type -> 'a option diff --git a/interp/notation.ml b/interp/notation.ml index 8f19ab85..d2bee550 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -817,3 +817,8 @@ let _ = { freeze_function = freeze; unfreeze_function = unfreeze; init_function = init } + +let with_notation_protection f x = + let fs = freeze () in + try let a = f x in unfreeze fs; a + with e -> unfreeze fs; raise e diff --git a/interp/notation.mli b/interp/notation.mli index f92ef94e..f429e377 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -177,3 +177,5 @@ val declare_notation_printing_rule : notation -> unparsing_rule -> unit val find_notation_printing_rule : notation -> unparsing_rule (** Rem: printing rules for primitive token are canonical *) + +val with_notation_protection : ('a -> 'b) -> 'a -> 'b diff --git a/interp/topconstr.ml b/interp/topconstr.ml index b484d175..04d39fbf 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -239,7 +239,7 @@ let compare_recursive_parts found f (iterator,subc) = | GLambda (_,Name x,_,t_x,c), GLambda (_,Name y,_,t_y,term) | GProd (_,Name x,_,t_x,c), GProd (_,Name y,_,t_y,term) -> (* We found a binding position where it differs *) - check_is_hole y t_x; + check_is_hole x t_x; check_is_hole y t_y; !diff = None && (diff := Some (x,y,None); aux c term) | _ -> @@ -564,8 +564,11 @@ let match_opt f sigma t1 t2 = match (t1,t2) with | _ -> raise No_match let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with - | (Name id1,Name id2) when List.mem id2 (fst metas) -> - alp, bind_env alp sigma id2 (GVar (dummy_loc,id1)) + | (_,Name id2) when List.mem id2 (fst metas) -> + let rhs = match na1 with + | Name id1 -> GVar (dummy_loc,id1) + | Anonymous -> GHole (dummy_loc,Evd.InternalHole) in + alp, bind_env alp sigma id2 rhs | (Name id1,Name id2) -> (id1,id2)::alp,sigma | (Anonymous,Anonymous) -> alp,sigma | _ -> raise No_match @@ -922,6 +925,12 @@ let names_of_local_binders bl = List.flatten (List.map (function LocalRawAssum(l,_,_)->l|LocalRawDef(l,_)->[l]) bl) (**********************************************************************) +(* Miscellaneous *) + +let error_invalid_pattern_notation loc = + user_err_loc (loc,"",str "Invalid notation for pattern.") + +(**********************************************************************) (* Functions on constr_expr *) let constr_loc = function diff --git a/interp/topconstr.mli b/interp/topconstr.mli index 4527dc48..79bab389 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -268,3 +268,7 @@ val ntn_loc : Util.loc -> constr_notation_substitution -> string -> (int * int) list val patntn_loc : Util.loc -> cases_pattern_notation_substitution -> string -> (int * int) list + +(** For cases pattern parsing errors *) + +val error_invalid_pattern_notation : Util.loc -> 'a diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 5b800ede..7cf74ba3 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -192,6 +192,10 @@ type structure_field_body = | SFBmodule of module_body | SFBmodtype of module_type_body +(** NB: we may encounter now (at most) twice the same label in + a [structure_body], once for a module ([SFBmodule] or [SFBmodtype]) + and once for an object ([SFBconst] or [SFBmind]) *) + and structure_body = (label * structure_field_body) list and struct_expr_body = diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index a384c836..bfc6f3c7 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -35,10 +35,14 @@ let rec mp_from_mexpr = function | MSEfunctor (_,_,expr) -> mp_from_mexpr expr | MSEwith (expr,_) -> mp_from_mexpr expr -let rec list_split_assoc k rev_before = function +let is_modular = function + | SFBmodule _ | SFBmodtype _ -> true + | SFBconst _ | SFBmind _ -> false + +let rec list_split_assoc ((k,m) as km) rev_before = function | [] -> raise Not_found - | (k',b)::after when k=k' -> rev_before,b,after - | h::tail -> list_split_assoc k (h::rev_before) tail + | (k',b)::after when k=k' && is_modular b = m -> rev_before,b,after + | h::tail -> list_split_assoc km (h::rev_before) tail let discr_resolver env mtb = match mtb.typ_expr with @@ -54,35 +58,34 @@ let rec rebuild_mp mp l = let rec check_with env sign with_decl alg_sign mp equiv = let sign,wd,equiv,cst= match with_decl with - | With_Definition (id,_) -> - let sign,cb,cst = check_with_aux_def env sign with_decl mp equiv in - sign,With_definition_body(id,cb),equiv,cst - | With_Module (id,mp1) -> - let sign,equiv,cst = - check_with_aux_mod env sign with_decl mp equiv in - sign,With_module_body(id,mp1),equiv,cst in + | With_Definition (idl,c) -> + let sign,cb,cst = check_with_def env sign (idl,c) mp equiv in + sign,With_definition_body(idl,cb),equiv,cst + | With_Module (idl,mp1) -> + let sign,equiv,cst = check_with_mod env sign (idl,mp1) mp equiv in + sign,With_module_body(idl,mp1),equiv,cst + in if alg_sign = None then sign,None,equiv,cst else sign,Some (SEBwith(Option.get(alg_sign),wd)),equiv,cst -and check_with_aux_def env sign with_decl mp equiv = +and check_with_def env sign (idl,c) mp equiv = let sig_b = match sign with | SEBstruct(sig_b) -> sig_b | _ -> error_signature_expected sign in - let id,idl = match with_decl with - | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl - | With_Definition ([],_) | With_Module ([],_) -> assert false + let id,idl = match idl with + | [] -> assert false + | id::idl -> id,idl in let l = label_of_id id in try - let rev_before,spec,after = list_split_assoc l [] sig_b in + let rev_before,spec,after = list_split_assoc (l,(idl<>[])) [] sig_b in let before = List.rev rev_before in let env' = Modops.add_signature mp before equiv env in - match with_decl with - | With_Definition ([],_) -> assert false - | With_Definition ([id],c) -> + if idl = [] then + (* Toplevel definition *) let cb = match spec with | SFBconst cb -> cb | _ -> error_not_a_constant l @@ -115,8 +118,9 @@ and check_with_aux_def env sign with_decl mp equiv = Cemitcodes.from_val (compile_constant_body env' def); const_constraints = cst } in - SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst - | With_Definition (_::_,c) -> + SEBstruct(before@(l,SFBconst(cb'))::after),cb',cst + else + (* Definition inside a sub-module *) let old = match spec with | SFBmodule msb -> msb | _ -> error_not_a_module (string_of_label l) @@ -124,43 +128,36 @@ and check_with_aux_def env sign with_decl mp equiv = begin match old.mod_expr with | None -> - let new_with_decl = With_Definition (idl,c) in let sign,cb,cst = - check_with_aux_def env' old.mod_type new_with_decl + check_with_def env' old.mod_type (idl,c) (MPdot(mp,l)) old.mod_delta in let new_spec = SFBmodule({old with mod_type = sign; mod_type_alg = None}) in - SEBstruct(before@((l,new_spec)::after)),cb,cst + SEBstruct(before@(l,new_spec)::after),cb,cst | Some msb -> error_generative_module_expected l end - | _ -> anomaly "Modtyping:incorrect use of with" with | Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_incorrect_with_constraint l -and check_with_aux_mod env sign with_decl mp equiv = +and check_with_mod env sign (idl,mp1) mp equiv = let sig_b = match sign with | SEBstruct(sig_b) ->sig_b | _ -> error_signature_expected sign in - let id,idl = match with_decl with - | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl - | With_Definition ([],_) | With_Module ([],_) -> assert false + let id,idl = match idl with + | [] -> assert false + | id::idl -> id,idl in let l = label_of_id id in try - let rev_before,spec,after = list_split_assoc l [] sig_b in + let rev_before,spec,after = list_split_assoc (l,true) [] sig_b in let before = List.rev rev_before in - let rec mp_rec = function - | [] -> mp - | i::r -> MPdot(mp_rec r,label_of_id i) - in let env' = Modops.add_signature mp before equiv env in - match with_decl with - | With_Module ([],_) -> assert false - | With_Module ([id], mp1) -> + if idl = [] then + (* Toplevel module definition *) let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module (string_of_label l) @@ -194,7 +191,8 @@ and check_with_aux_mod env sign with_decl mp equiv = let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) new_mb.mod_delta in SEBstruct(before@(l,new_spec)::subst_signature id_subst after), add_delta_resolver equiv new_mb.mod_delta,cst - | With_Module (idc,mp1) -> + else + (* Module definition of a sub-module *) let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module (string_of_label l) @@ -202,10 +200,9 @@ and check_with_aux_mod env sign with_decl mp equiv = begin match old.mod_expr with None -> - let new_with_decl = With_Module (idl,mp1) in let sign,equiv',cst = - check_with_aux_mod env' - old.mod_type new_with_decl (MPdot(mp,l)) old.mod_delta in + check_with_mod env' + old.mod_type (idl,mp1) (MPdot(mp,l)) old.mod_delta in let new_equiv = add_delta_resolver equiv equiv' in let new_spec = SFBmodule {old with mod_type = sign; @@ -223,7 +220,6 @@ and check_with_aux_mod env sign with_decl mp equiv = | _ -> error_generative_module_expected l end - | _ -> anomaly "Modtyping:incorrect use of with" with Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_incorrect_with_constraint l @@ -368,7 +364,7 @@ let rec add_struct_expr_constraints env = function | SEBstruct (structure_body) -> List.fold_left - (fun env (l,item) -> add_struct_elem_constraints env item) + (fun env (_,item) -> add_struct_elem_constraints env item) env structure_body @@ -413,7 +409,7 @@ let rec struct_expr_constraints cst = function | SEBstruct (structure_body) -> List.fold_left - (fun cst (l,item) -> struct_elem_constraints cst item) + (fun cst (_,item) -> struct_elem_constraints cst item) cst structure_body diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index c2d71ebb..d7a8b005 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -101,7 +101,8 @@ type safe_environment = { old : safe_environment; env : env; modinfo : module_info; - labset : Labset.t; + modlabels : Labset.t; + objlabels : Labset.t; revstruct : structure_body; univ : Univ.constraints; engagement : engagement option; @@ -109,13 +110,16 @@ type safe_environment = loads : (module_path * module_body) list; local_retroknowledge : Retroknowledge.action list} -let exists_label l senv = Labset.mem l senv.labset +let exists_modlabel l senv = Labset.mem l senv.modlabels +let exists_objlabel l senv = Labset.mem l senv.objlabels -let check_label l senv = - if exists_label l senv then error_existing_label l +let check_modlabel l senv = + if exists_modlabel l senv then error_existing_label l +let check_objlabel l senv = + if exists_objlabel l senv then error_existing_label l -let check_labels ls senv = - Labset.iter (fun l -> check_label l senv) ls +let check_objlabels ls senv = + Labset.iter (fun l -> check_objlabel l senv) ls let labels_of_mib mib = let add,get = @@ -140,7 +144,8 @@ let rec empty_environment = variant = NONE; resolver = empty_delta_resolver; resolver_of_param = empty_delta_resolver}; - labset = Labset.empty; + modlabels = Labset.empty; + objlabels = Labset.empty; revstruct = []; univ = Univ.empty_constraint; engagement = None; @@ -172,11 +177,15 @@ type generic_name = | M let add_field ((l,sfb) as field) gn senv = - let labels = match sfb with - | SFBmind mib -> labels_of_mib mib - | _ -> Labset.singleton l + let mlabs,olabs = match sfb with + | SFBmind mib -> + let l = labels_of_mib mib in + check_objlabels l senv; (Labset.empty,l) + | SFBconst _ -> + check_objlabel l senv; (Labset.empty, Labset.singleton l) + | SFBmodule _ | SFBmodtype _ -> + check_modlabel l senv; (Labset.singleton l, Labset.empty) in - check_labels labels senv; let senv = add_constraints (constraints_of_sfb sfb) senv in let env' = match sfb, gn with | SFBconst cb, C con -> Environ.add_constant con cb senv.env @@ -187,7 +196,8 @@ let add_field ((l,sfb) as field) gn senv = in { senv with env = env'; - labset = Labset.union labels senv.labset; + modlabels = Labset.union mlabs senv.modlabels; + objlabels = Labset.union olabs senv.objlabels; revstruct = field :: senv.revstruct } (* Applying a certain function to the resolver of a safe environment *) @@ -320,7 +330,7 @@ let add_module l me inl senv = (* Interactive modules *) let start_module l senv = - check_label l senv; + check_modlabel l senv; let mp = MPdot(senv.modinfo.modpath, l) in let modinfo = { modpath = mp; label = l; @@ -331,7 +341,8 @@ let start_module l senv = mp, { old = senv; env = senv.env; modinfo = modinfo; - labset = Labset.empty; + modlabels = Labset.empty; + objlabels = Labset.empty; revstruct = []; univ = Univ.empty_constraint; engagement = None; @@ -415,7 +426,8 @@ let end_module l restype senv = mp,resolver,{ old = oldsenv.old; env = newenv; modinfo = modinfo; - labset = Labset.add l oldsenv.labset; + modlabels = Labset.add l oldsenv.modlabels; + objlabels = oldsenv.objlabels; revstruct = (l,SFBmodule mb)::oldsenv.revstruct; univ = Univ.union_constraints senv'.univ oldsenv.univ; (* engagement is propagated to the upper level *) @@ -510,7 +522,8 @@ let add_module_parameter mbid mte inl senv = variant = new_variant; resolver_of_param = add_delta_resolver resolver_of_param senv.modinfo.resolver_of_param}; - labset = senv.labset; + modlabels = senv.modlabels; + objlabels = senv.objlabels; revstruct = []; univ = senv.univ; engagement = senv.engagement; @@ -522,7 +535,7 @@ let add_module_parameter mbid mte inl senv = (* Interactive module types *) let start_modtype l senv = - check_label l senv; + check_modlabel l senv; let mp = MPdot(senv.modinfo.modpath, l) in let modinfo = { modpath = mp; label = l; @@ -533,7 +546,8 @@ let start_modtype l senv = mp, { old = senv; env = senv.env; modinfo = modinfo; - labset = Labset.empty; + modlabels = Labset.empty; + objlabels = Labset.empty; revstruct = []; univ = Univ.empty_constraint; engagement = None; @@ -584,7 +598,8 @@ let end_modtype l senv = mp, { old = oldsenv.old; env = newenv; modinfo = oldsenv.modinfo; - labset = Labset.add l oldsenv.labset; + modlabels = Labset.add l oldsenv.modlabels; + objlabels = oldsenv.objlabels; revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct; univ = Univ.union_constraints senv.univ oldsenv.univ; engagement = senv.engagement; @@ -643,7 +658,8 @@ let start_library dir senv = mp, { old = senv; env = senv.env; modinfo = modinfo; - labset = Labset.empty; + modlabels = Labset.empty; + objlabels = Labset.empty; revstruct = []; univ = Univ.empty_constraint; engagement = None; diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 6f46a45b..ad275d49 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -138,7 +138,7 @@ val typing : safe_environment -> constr -> judgment (** {7 Query } *) -val exists_label : label -> safe_environment -> bool +val exists_objlabel : label -> safe_environment -> bool (*spiwack: safe retroknowledge functionalities *) diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index c141a02a..08ee67b4 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -32,15 +32,18 @@ type namedobject = | Constant of constant_body | IndType of inductive * mutual_inductive_body | IndConstr of constructor * mutual_inductive_body + +type namedmodule = | Module of module_body | Modtype of module_type_body (* adds above information about one mutual inductive: all types and constructors *) -let add_nameobjects_of_mib ln mib map = - let add_nameobjects_of_one j oib map = - let ip = (ln,j) in +let add_mib_nameobjects mp l mib map = + let ind = make_mind mp empty_dirpath l in + let add_mip_nameobjects j oib map = + let ip = (ind,j) in let map = array_fold_right_i (fun i id map -> @@ -50,22 +53,33 @@ let add_nameobjects_of_mib ln mib map = in Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map in - array_fold_right_i add_nameobjects_of_one mib.mind_packets map + array_fold_right_i add_mip_nameobjects mib.mind_packets map + + +(* creates (namedobject/namedmodule) map for the whole signature *) + +type labmap = { objs : namedobject Labmap.t; mods : namedmodule Labmap.t } +let empty_labmap = { objs = Labmap.empty; mods = Labmap.empty } -(* creates namedobject map for the whole signature *) +let get_obj mp map l = + try Labmap.find l map.objs + with Not_found -> error_no_such_label_sub l (string_of_mp mp) -let make_label_map mp list = +let get_mod mp map l = + try Labmap.find l map.mods + with Not_found -> error_no_such_label_sub l (string_of_mp mp) + +let make_labmap mp list = let add_one (l,e) map = - let add_map obj = Labmap.add l obj map in match e with - | SFBconst cb -> add_map (Constant cb) - | SFBmind mib -> - add_nameobjects_of_mib (make_mind mp empty_dirpath l) mib map - | SFBmodule mb -> add_map (Module mb) - | SFBmodtype mtb -> add_map (Modtype mtb) + | SFBconst cb -> { map with objs = Labmap.add l (Constant cb) map.objs } + | SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs } + | SFBmodule mb -> { map with mods = Labmap.add l (Module mb) map.mods } + | SFBmodtype mtb -> { map with mods = Labmap.add l (Modtype mtb) map.mods } in - List.fold_right add_one list Labmap.empty + List.fold_right add_one list empty_labmap + let check_conv_error error why cst f env a1 a2 = try @@ -299,7 +313,6 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in let ty2 = Typeops.type_of_constant_type env cb2.const_type in check_conv NotConvertibleTypeField cst conv env ty1 ty2 - | _ -> error DefinitionFieldExpected let rec check_modules cst env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module None msb1 in @@ -308,33 +321,24 @@ let rec check_modules cst env msb1 msb2 subst1 subst2 = cst and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2= - let map1 = make_label_map mp1 sig1 in + let map1 = make_labmap mp1 sig1 in let check_one_body cst (l,spec2) = - let info1 = - try - Labmap.find l map1 - with - Not_found -> error_no_such_label_sub l - (string_of_mp mp1) - in - match spec2 with + match spec2 with | SFBconst cb2 -> - check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 + check_constant cst env mp1 l (get_obj mp1 map1 l) + cb2 spec2 subst1 subst2 | SFBmind mib2 -> - check_inductive cst env - mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 + check_inductive cst env mp1 l (get_obj mp1 map1 l) + mp2 mib2 spec2 subst1 subst2 reso1 reso2 | SFBmodule msb2 -> - begin - match info1 with - | Module msb -> check_modules cst env msb msb2 - subst1 subst2 - | _ -> error_signature_mismatch l spec2 ModuleFieldExpected + begin match get_mod mp1 map1 l with + | Module msb -> check_modules cst env msb msb2 subst1 subst2 + | _ -> error_signature_mismatch l spec2 ModuleFieldExpected end | SFBmodtype mtb2 -> - let mtb1 = - match info1 with - | Modtype mtb -> mtb - | _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected + let mtb1 = match get_mod mp1 map1 l with + | Modtype mtb -> mtb + | _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected in let env = add_module (module_body_of_type mtb2.typ_mp mtb2) (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in diff --git a/kernel/term.ml b/kernel/term.ml index dcb63cf7..46bc7c56 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -322,6 +322,7 @@ let isCast c = match kind_of_term c with Cast _ -> true | _ -> false (* Tests if a de Bruijn index *) let isRel c = match kind_of_term c with Rel _ -> true | _ -> false +let isRelN n c = match kind_of_term c with Rel n' -> n = n' | _ -> false (* Tests if a variable *) let isVar c = match kind_of_term c with Var _ -> true | _ -> false diff --git a/kernel/term.mli b/kernel/term.mli index d5899f18..e83be6d6 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -229,8 +229,9 @@ val kind_of_type : types -> (constr, types) kind_of_type (** {6 Simple term case analysis. } *) val isRel : constr -> bool +val isRelN : int -> constr -> bool val isVar : constr -> bool -val isVarId : identifier -> constr -> bool +val isVarId : identifier -> constr -> bool val isInd : constr -> bool val isEvar : constr -> bool val isMeta : constr -> bool @@ -435,8 +436,7 @@ val it_mkProd_or_LetIn : types -> rel_context -> types (** {6 Other term destructors. } *) (** Transforms a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair - {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a product. - It includes also local definitions *) + {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a product. *) val decompose_prod : constr -> (name*constr) list * constr (** Transforms a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair diff --git a/kernel/univ.ml b/kernel/univ.ml index a8934544..0193542a 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -260,46 +260,62 @@ type order = EQ | LT | LE | NLE (** [compare_neq] : is [arcv] in the transitive upward closure of [arcu] ? - We try to avoid visiting unneeded parts of this transitive closure, - by stopping as soon as [arcv] is encountered. During the recursive - traversal, [lt_done] and [le_done] are universes we have already - visited, they do not contain [arcv]. The 3rd arg is - [(lt_todo,le_todo)], two lists of universes not yet considered, - known to be above [arcu], strictly or not. + In [strict] mode, we fully distinguish between LE and LT, while in + non-strict mode, we simply answer LE for both situations. + + If [arcv] is encountered in a LT part, we could directly answer + without visiting unneeded parts of this transitive closure. + In [strict] mode, if [arcv] is encountered in a LE part, we could only + change the default answer (1st arg [c]) from NLE to LE, since a strict + constraint may appear later. During the recursive traversal, + [lt_done] and [le_done] are universes we have already visited, + they do not contain [arcv]. The 4rd arg is [(lt_todo,le_todo)], + two lists of universes not yet considered, known to be above [arcu], + strictly or not. We use depth-first search, but the presence of [arcv] in [new_lt] is checked as soon as possible : this seems to be slightly faster on a test. *) -let compare_neq g arcu arcv = - let rec cmp lt_done le_done = function - | [],[] -> NLE +let compare_neq strict g arcu arcv = + let rec cmp c lt_done le_done = function + | [],[] -> c | arc::lt_todo, le_todo -> if List.memq arc lt_done then - cmp lt_done le_done (lt_todo,le_todo) + cmp c lt_done le_done (lt_todo,le_todo) else let lt_new = can g (arc.lt@arc.le) in - if List.memq arcv lt_new then LT - else cmp (arc::lt_done) le_done (lt_new@lt_todo,le_todo) + if List.memq arcv lt_new then + if strict then LT else LE + else cmp c (arc::lt_done) le_done (lt_new@lt_todo,le_todo) | [], arc::le_todo -> - if arc == arcv then LE - (* No need to continue inspecting universes above arc: - if arcv is strictly above arc, then we would have a cycle *) + if arc == arcv then + (* No need to continue inspecting universes above arc: + if arcv is strictly above arc, then we would have a cycle. + But we cannot answer LE yet, a stronger constraint may + come later from [le_todo]. *) + if strict then cmp LE lt_done le_done ([],le_todo) else LE else if (List.memq arc lt_done) || (List.memq arc le_done) then - cmp lt_done le_done ([],le_todo) + cmp c lt_done le_done ([],le_todo) else let lt_new = can g arc.lt in - if List.memq arcv lt_new then LT + if List.memq arcv lt_new then + if strict then LT else LE else let le_new = can g arc.le in - cmp lt_done (arc::le_done) (lt_new, le_new@le_todo) + cmp c lt_done (arc::le_done) (lt_new, le_new@le_todo) in - cmp [] [] ([],[arcu]) + cmp NLE [] [] ([],[arcu]) let compare g arcu arcv = - if arcu == arcv then EQ else compare_neq g arcu arcv + if arcu == arcv then EQ else compare_neq true g arcu arcv + +let is_leq g arcu arcv = + arcu == arcv || (compare_neq false g arcu arcv = LE) + +let is_lt g arcu arcv = (compare g arcu arcv = LT) (* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ compare(u,v) = LT or LE => compare(v,u) = NLE @@ -337,11 +353,11 @@ let rec check_eq g u v = let compare_greater g strict u v = let g, arcu = safe_repr g u in let g, arcv = safe_repr g v in - if not strict && arcv == snd (safe_repr g UniverseLevel.Set) then true else - match compare g arcv arcu with - | (EQ|LE) -> not strict - | LT -> true - | NLE -> false + if strict then + is_lt g arcv arcu + else + arcv == snd (safe_repr g UniverseLevel.Set) || is_leq g arcv arcu + (* let compare_greater g strict u v = let b = compare_greater g strict u v in @@ -368,9 +384,8 @@ let setlt g arcu arcv = (* checks that non-redundant *) let setlt_if (g,arcu) v = let arcv = repr g v in - match compare g arcu arcv with - | LT -> g, arcu - | _ -> setlt g arcu arcv + if is_lt g arcu arcv then g, arcu + else setlt g arcu arcv (* setleq : UniverseLevel.t -> UniverseLevel.t -> unit *) (* forces u >= v *) @@ -383,9 +398,8 @@ let setleq g arcu arcv = (* checks that non-redundant *) let setleq_if (g,arcu) v = let arcv = repr g v in - match compare g arcu arcv with - | NLE -> setleq g arcu arcv - | _ -> g, arcu + if is_leq g arcu arcv then g, arcu + else setleq g arcu arcv (* merge : UniverseLevel.t -> UniverseLevel.t -> unit *) (* we assume compare(u,v) = LE *) @@ -429,14 +443,12 @@ let error_inconsistency o u v = raise (UniverseInconsistency (o,Atom u,Atom v)) let enforce_univ_leq u v g = let g,arcu = safe_repr g u in let g,arcv = safe_repr g v in - match compare g arcu arcv with - | NLE -> - (match compare g arcv arcu with - | LT -> error_inconsistency Le u v - | LE -> merge g arcv arcu - | NLE -> fst (setleq g arcu arcv) - | EQ -> anomaly "Univ.compare") - | _ -> g + if is_leq g arcu arcv then g + else match compare g arcv arcu with + | LT -> error_inconsistency Le u v + | LE -> merge g arcv arcu + | NLE -> fst (setleq g arcu arcv) + | EQ -> anomaly "Univ.compare" (* enforc_univ_eq : UniverseLevel.t -> UniverseLevel.t -> unit *) (* enforc_univ_eq u v will force u=v if possible, will fail otherwise *) @@ -463,9 +475,8 @@ let enforce_univ_lt u v g = | LE -> fst (setlt g arcu arcv) | EQ -> error_inconsistency Lt u v | NLE -> - (match compare g arcv arcu with - | NLE -> fst (setlt g arcu arcv) - | _ -> error_inconsistency Lt u v) + if is_leq g arcv arcu then error_inconsistency Lt u v + else fst (setlt g arcu arcv) (* Constraints and sets of consrtaints. *) @@ -480,7 +491,13 @@ let enforce_constraint cst g = module Constraint = Set.Make( struct type t = univ_constraint - let compare = Pervasives.compare + let compare (u,c,v) (u',c',v') = + let i = Pervasives.compare c c' in + if i <> 0 then i + else + let i' = UniverseLevel.compare u u' in + if i' <> 0 then i' + else UniverseLevel.compare v v' end) type constraints = Constraint.t @@ -784,6 +801,14 @@ let no_upper_constraints u cst = | Atom u -> Constraint.for_all (fun (u1,_,_) -> u1 <> u) cst | Max _ -> anomaly "no_upper_constraints" +(* Is u mentionned in v (or equals to v) ? *) + +let univ_depends u v = + match u, v with + | Atom u, Atom v -> u = v + | Atom u, Max (gel,gtl) -> List.mem u gel || List.mem u gtl + | _ -> anomaly "univ_depends given a non-atomic 1st arg" + (* Pretty-printing *) let pr_arc = function diff --git a/kernel/univ.mli b/kernel/univ.mli index 8b3f6291..e4e66915 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -91,6 +91,10 @@ val subst_large_constraints : val no_upper_constraints : universe -> constraints -> bool +(** Is u mentionned in v (or equals to v) ? *) + +val univ_depends : universe -> universe -> bool + (** {6 Pretty-printing of universes. } *) val pr_uni_level : universe_level -> Pp.std_ppcmds diff --git a/lib/envars.ml b/lib/envars.ml index e5c93803..17cfa122 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -62,10 +62,10 @@ let xdg_config_home = "coq" let xdg_data_dirs = - try + (try List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_DATA_DIRS")) - with Not_found -> "/usr/local/share/coq" :: "/usr/share/coq" - :: (match Coq_config.datadir with |None -> [] |Some datadir -> [datadir]) + with Not_found -> ["/usr/local/share/coq";"/usr/share/coq"]) + @ (match Coq_config.datadir with |None -> [] |Some datadir -> [datadir]) let xdg_dirs = let dirs = xdg_data_home :: xdg_data_dirs diff --git a/lib/explore.ml b/lib/explore.ml index 407bf1e9..e353c907 100644 --- a/lib/explore.ml +++ b/lib/explore.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Format +open Pp (*s Definition of a search problem. *) @@ -14,20 +14,20 @@ module type SearchProblem = sig type state val branching : state -> state list val success : state -> bool - val pp : state -> unit + val pp : state -> std_ppcmds end module Make = functor(S : SearchProblem) -> struct type position = int list - let pp_position p = + let msg_with_position p pp = let rec pp_rec = function - | [] -> () - | [i] -> printf "%d" i - | i :: l -> pp_rec l; printf ".%d" i + | [] -> mt () + | [i] -> int i + | i :: l -> pp_rec l ++ str "." ++ int i in - open_hbox (); pp_rec p; close_box () + msg_debug (h 0 (pp_rec p) ++ pp) (*s Depth first search. *) @@ -40,7 +40,7 @@ module Make = functor(S : SearchProblem) -> struct let debug_depth_first s = let rec explore p s = - pp_position p; S.pp s; + msg_with_position p (S.pp s); if S.success s then s else explore_many 1 p (S.branching s) and explore_many i p = function | [] -> raise Not_found @@ -83,7 +83,7 @@ module Make = functor(S : SearchProblem) -> struct explore q | s :: l -> let ps = i::p in - pp_position ps; S.pp s; + msg_with_position ps (S.pp s); if S.success s then s else enqueue (succ i) p (push (ps,s) q) l in enqueue 1 [] empty [s] diff --git a/lib/explore.mli b/lib/explore.mli index e64459f1..a292fd83 100644 --- a/lib/explore.mli +++ b/lib/explore.mli @@ -27,7 +27,7 @@ module type SearchProblem = sig val success : state -> bool - val pp : state -> unit + val pp : state -> Pp.std_ppcmds end @@ -274,17 +274,15 @@ let pp_dirs ft = (* pretty print on stdout and stderr *) (* Special chars for emacs, to detect warnings inside goal output *) -let emacs_warning_start_string = String.make 1 (Char.chr 254) -let emacs_warning_end_string = String.make 1 (Char.chr 255) +let emacs_quote_start = String.make 1 (Char.chr 254) +let emacs_quote_end = String.make 1 (Char.chr 255) -let warnstart() = - if not !print_emacs then mt() else str emacs_warning_start_string +let emacs_quote strm = + if !print_emacs then + [< str emacs_quote_start; hov 0 strm; str emacs_quote_end >] + else hov 0 strm -let warnend() = - if not !print_emacs then mt() else str emacs_warning_end_string - -let warnbody strm = - [< warnstart() ; hov 0 (str "Warning: " ++ strm) ; warnend() >] +let warnbody strm = emacs_quote (str "Warning: " ++ strm) (* pretty printing functions WITHOUT FLUSH *) let pp_with ft strm = @@ -333,6 +331,9 @@ let msgerr x = msg_with !err_ft x let msgerrnl x = msgnl_with !err_ft x let msg_warning x = msg_warning_with !err_ft x +(* Same specific display in emacs as warning, but without the "Warning:" *) +let msg_debug x = msgnl (emacs_quote x) + let string_of_ppcmds c = msg_with Format.str_formatter c; Format.flush_str_formatter () @@ -113,4 +113,7 @@ val msgerr : std_ppcmds -> unit val msgerrnl : std_ppcmds -> unit val msg_warning : std_ppcmds -> unit +(** Same specific display in emacs as warning, but without the "Warning:" **) +val msg_debug : std_ppcmds -> unit + val string_of_ppcmds : std_ppcmds -> string diff --git a/lib/util.ml b/lib/util.ml index 287dd371..4f14b83a 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -499,6 +499,9 @@ let list_map4 f l1 l2 l3 l4 = in map (l1,l2,l3,l4) +let list_map_to_array f l = + Array.of_list (List.map f l) + let rec list_smartfilter f l = match l with [] -> l | h::tl -> @@ -708,6 +711,12 @@ let list_map_filter_i f = match f i x with None -> l' | Some y -> y::l' in aux 0 +let list_filter_along f filter l = + snd (list_filter2 (fun b c -> f b) (filter,l)) + +let list_filter_with filter l = + list_filter_along (fun x -> x) filter l + let list_subset l1 l2 = let t2 = Hashtbl.create 151 in List.iter (fun x -> Hashtbl.add t2 x ()) l2; @@ -741,7 +750,7 @@ let list_split_when p = split_when_loop [] (* [list_split_by p l] splits [l] into two lists [(l1,l2)] such that elements of - [l1] satisfy [p] and elements of [l2] do not *) + [l1] satisfy [p] and elements of [l2] do not; order is preserved *) let list_split_by p = let rec split_by_loop = function | [] -> ([],[]) @@ -900,6 +909,14 @@ let rec list_cartesians_filter op init ll = let rec list_drop_last = function [] -> assert false | hd :: [] -> [] | hd :: tl -> hd :: list_drop_last tl +(* Factorize lists of pairs according to the left argument *) +let rec list_factorize_left = function + | (a,b)::l -> + let al,l' = list_split_by (fun (a',b) -> a=a') l in + (a,(b::List.map snd al)) :: list_factorize_left l' + | [] -> + [] + (* Arrays *) let array_compare item_cmp v1 v2 = @@ -1217,6 +1234,12 @@ let array_rev_to_list a = if i >= Array.length a then res else tolist (i+1) (a.(i) :: res) in tolist 0 [] +let array_filter_along f filter v = + Array.of_list (list_filter_along f filter (Array.to_list v)) + +let array_filter_with filter v = + Array.of_list (list_filter_with filter (Array.to_list v)) + (* Stream *) let stream_nth n st = diff --git a/lib/util.mli b/lib/util.mli index 1fec2295..a0a28970 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -135,6 +135,8 @@ val list_duplicates : 'a list -> 'a list val list_filter2 : ('a -> 'b -> bool) -> 'a list * 'b list -> 'a list * 'b list val list_map_filter : ('a -> 'b option) -> 'a list -> 'b list val list_map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list +val list_filter_with : bool list -> 'a list -> 'a list +val list_filter_along : ('a -> bool) -> 'a list -> 'b list -> 'b list (** [list_smartmap f [a1...an] = List.map f [a1...an]] but if for all i [ f ai == ai], then [list_smartmap f l==l] *) @@ -147,6 +149,7 @@ val list_map3 : ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list val list_map4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list +val list_map_to_array : ('a -> 'b) -> 'a list -> 'b array val list_filter_i : (int -> 'a -> bool) -> 'a list -> 'a list @@ -239,6 +242,7 @@ val list_cartesians_filter : ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list val list_union_map : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b +val list_factorize_left : ('a * 'b) list -> ('a * 'b list) list (** {6 Arrays. } *) @@ -291,6 +295,8 @@ val array_fold_map2' : val array_distinct : 'a array -> bool val array_union_map : ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b val array_rev_to_list : 'a array -> 'a list +val array_filter_along : ('a -> bool) -> 'a list -> 'b array -> 'b array +val array_filter_with : bool list -> 'a array -> 'a array (** {6 Streams. } *) diff --git a/lib/xml_parser.mli b/lib/xml_parser.mli index a3e8aa4a..e3e7ac4d 100644 --- a/lib/xml_parser.mli +++ b/lib/xml_parser.mli @@ -42,7 +42,7 @@ type t and the {!Xml.error_pos} can be used to retreive the document location where the error occured at.} {li {!Xml.File_not_found} is raised when and error occured while - opening a file with the {!Xml.parse_file} function. + opening a file with the {!Xml.parse_file} function.} } *) diff --git a/library/assumptions.ml b/library/assumptions.ml index adc7f8ed..d2f8ad53 100644 --- a/library/assumptions.ml +++ b/library/assumptions.ml @@ -54,6 +54,16 @@ module ContextObjectMap = Map.Make (OrderedContextObject) let modcache = ref (MPmap.empty : structure_body MPmap.t) +let rec search_mod_label lab = function + | [] -> raise Not_found + | (l,SFBmodule mb) :: _ when l = lab -> mb + | _ :: fields -> search_mod_label lab fields + +let rec search_cst_label lab = function + | [] -> raise Not_found + | (l,SFBconst cb) :: _ when l = lab -> cb + | _ :: fields -> search_cst_label lab fields + let rec lookup_module_in_impl mp = try Global.lookup_module mp with Not_found -> @@ -64,9 +74,7 @@ let rec lookup_module_in_impl mp = raise Not_found (* should have been found by [lookup_module] *) | MPdot (mp',lab') -> let fields = memoize_fields_of_mp mp' in - match List.assoc lab' fields with - | SFBmodule mb -> mb - | _ -> assert false (* same label for a non-module ?! *) + search_mod_label lab' fields and memoize_fields_of_mp mp = try MPmap.find mp !modcache @@ -126,9 +134,7 @@ let lookup_constant_in_impl cst fallback = let fields = memoize_fields_of_mp mp in (* A module found this way is necessarily closed, in particular our constant cannot be in an opened section : *) - match List.assoc lab fields with - | SFBconst cb -> cb - | _ -> assert false (* label not pointing to a constant ?! *) + search_cst_label lab fields with Not_found -> (* Either: - The module part of the constant isn't registered yet : diff --git a/library/declare.ml b/library/declare.ml index 28858085..066c97a4 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -116,7 +116,7 @@ let open_constant i ((sp,kn),_) = Nametab.push (Nametab.Exactly i) sp (ConstRef con) let exists_name id = - variable_exists id or Global.exists_label (label_of_id id) + variable_exists id or Global.exists_objlabel (label_of_id id) let check_exists sp = let id = basename sp in diff --git a/library/global.ml b/library/global.ml index ab70bb7c..a0871f0c 100644 --- a/library/global.ml +++ b/library/global.ml @@ -133,7 +133,7 @@ let mind_of_delta_kn kn = Mod_subst.mind_of_delta resolver_param (Mod_subst.mind_of_delta_kn resolver kn) -let exists_label id = exists_label id !global_env +let exists_objlabel id = exists_objlabel id !global_env let start_library dir = let mp,newenv = start_library dir !global_env in diff --git a/library/global.mli b/library/global.mli index 1a0fabdc..77fd465c 100644 --- a/library/global.mli +++ b/library/global.mli @@ -87,7 +87,7 @@ val lookup_module : module_path -> module_body val lookup_modtype : module_path -> module_type_body val constant_of_delta_kn : kernel_name -> constant val mind_of_delta_kn : kernel_name -> mutual_inductive -val exists_label : label -> bool +val exists_objlabel : label -> bool (** Compiled modules *) val start_library : dir_path -> module_path diff --git a/library/goptions.ml b/library/goptions.ml index 90c8728c..5af18689 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -247,6 +247,7 @@ let declare_option cast uncast declare_object {(default_object ("G "^nickname key)) with cache_function = (fun (_,v) -> write v); classify_function = (fun v -> Substitute v); + subst_function = (fun (_,v) -> v); discharge_function = (fun (_,v) -> Some v); load_function = (fun _ (_,v) -> write v)} in diff --git a/library/impargs.ml b/library/impargs.ml index ef7f5921..73699a90 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -207,11 +207,10 @@ let rec is_rigid_head t = match kind_of_term t with (* calcule la liste des arguments implicites *) -let find_displayed_name_in all avoid na b = - if all then - compute_and_force_displayed_name_in (RenamingElsewhereFor b) avoid na b - else - compute_displayed_name_in (RenamingElsewhereFor b) avoid na b +let find_displayed_name_in all avoid na (_,b as envnames_b) = + let flag = RenamingElsewhereFor envnames_b in + if all then compute_and_force_displayed_name_in flag avoid na b + else compute_displayed_name_in flag avoid na b let compute_implicits_gen strict strongly_strict revpat contextual all env t = let rigid = ref true in @@ -219,7 +218,7 @@ let compute_implicits_gen strict strongly_strict revpat contextual all env t = let t = whd_betadeltaiota env t in match kind_of_term t with | Prod (na,a,b) -> - let na',avoid' = find_displayed_name_in all avoid na b in + let na',avoid' = find_displayed_name_in all avoid na (names,b) in add_free_rels_until strict strongly_strict revpat n env a (Hyp (n+1)) (aux (push_rel (na',None,a) env) avoid' (n+1) (na'::names) b) | _ -> @@ -232,7 +231,7 @@ let compute_implicits_gen strict strongly_strict revpat contextual all env t = in match kind_of_term (whd_betadeltaiota env t) with | Prod (na,a,b) -> - let na',avoid = find_displayed_name_in all [] na b in + let na',avoid = find_displayed_name_in all [] na ([],b) in let v = aux (push_rel (na',None,a) env) avoid 1 [na'] b in !rigid, Array.to_list v | _ -> true, [] diff --git a/library/lib.ml b/library/lib.ml index 7554fd0b..bb3b5716 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -572,72 +572,16 @@ let reset_to_gen test = let reset_to sp = reset_to_gen (fun x -> fst x = sp) -(* LEM: TODO - * We will need to muck with frozen states in after, too! - * Not only FrozenState, but also those embedded in Opened(Section|Module) - *) -let delete_gen test = - let (after,equal,before) = split_lib_gen test in - let rec chop_at_dot = function - | [] as l -> l - | (_, Leaf o)::t when object_tag o = "DOT" -> t - | _::t -> chop_at_dot t - and chop_before_dot = function - | [] as l -> l - | (_, Leaf o)::t as l when object_tag o = "DOT" -> l - | _::t -> chop_before_dot t - in - set_lib_stk (List.rev_append (chop_at_dot after) (chop_before_dot before)) - -let delete sp = delete_gen (fun x -> fst x = sp) - -let reset_name (loc,id) = - let (sp,_) = - try - find_entry_p (fun (sp,_) -> let (_,spi) = repr_path (fst sp) in id = spi) - with Not_found -> - user_err_loc (loc,"reset_name",pr_id id ++ str ": no such entry") - in - reset_to sp - -let remove_name (loc,id) = - let (sp,_) = - try - find_entry_p (fun (sp,_) -> let (_,spi) = repr_path (fst sp) in id = spi) - with Not_found -> - user_err_loc (loc,"remove_name",pr_id id ++ str ": no such entry") - in - delete sp +let first_command_label = 1 -let is_mod_node = function - | OpenedModule _ | OpenedSection _ - | ClosedModule _ | ClosedSection _ -> true - | Leaf o -> let t = object_tag o in t = "MODULE" || t = "MODULE TYPE" - || t = "MODULE ALIAS" - | _ -> false - -(* Reset on a module or section name in order to bypass constants with - the same name *) - -let reset_mod (loc,id) = - let (_,before) = - try - find_split_p (fun (sp,node) -> - let (_,spi) = repr_path (fst sp) in id = spi - && is_mod_node node) - with Not_found -> - user_err_loc (loc,"reset_mod",pr_id id ++ str ": no such entry") - in - set_lib_stk before - -let mark_end_of_command, current_command_label, set_command_label = - let n = ref 0 in +let mark_end_of_command, current_command_label, reset_command_label = + let n = ref (first_command_label-1) in (fun () -> match !lib_stk with (_,Leaf o)::_ when object_tag o = "DOT" -> () | _ -> incr n;add_anonymous_leaf (inLabel !n)), (fun () -> !n), - (fun x -> n:=x) + (fun x -> n:=x;add_anonymous_leaf (inLabel x)) let is_label_n n x = match x with @@ -650,21 +594,21 @@ let is_label_n n x = let reset_label n = if n >= current_command_label () then error "Cannot backtrack to the current label or a future one"; - let res = reset_to_gen (is_label_n n) in + reset_to_gen (is_label_n n); (* forget state numbers after n only if reset succeeded *) - set_command_label (n-1); - res + reset_command_label n -let rec back_stk n stk = - match stk with - (sp,Leaf o)::tail when object_tag o = "DOT" -> - if n=0 then sp else back_stk (n-1) tail - | _::tail -> back_stk n tail - | [] -> error "Reached begin of command history" +(** Search the last label registered before defining [id] *) -let back n = - reset_to (back_stk n !lib_stk); - set_command_label (current_command_label () - n - 1) +let label_before_name (loc,id) = + let found = ref false in + let search = function + | (_,Leaf o) when !found && object_tag o = "DOT" -> true + | (sp,_) -> (if id = snd (repr_path (fst sp)) then found := true); false + in + match find_entry_p search with + | (_,Leaf o) -> outLabel o + | _ -> raise Not_found (* State and initialization. *) @@ -684,29 +628,6 @@ let init () = path_prefix := initial_prefix; init_summaries() -(* Initial state. *) - -let initial_state = ref None - -let declare_initial_state () = - let name = add_anonymous_entry (FrozenState (freeze_summaries())) in - initial_state := Some name - -let reset_initial () = - match !initial_state with - | None -> - error "Resetting to the initial state is possible only interactively" - | Some sp -> - begin match split_lib sp with - | (_,[_,FrozenState fs as hd],before) -> - lib_stk := hd::before; - recalc_path_prefix (); - set_command_label 0; - unfreeze_summaries fs - | _ -> assert false - end - - (* Misc *) let mp_of_global ref = diff --git a/library/lib.mli b/library/lib.mli index 0d6eb34b..45c598aa 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -62,17 +62,6 @@ val add_leaves : Names.identifier -> Libobject.obj list -> Libnames.object_name val add_frozen_state : unit -> unit -(** Adds a "dummy" entry in lib_stk with a unique new label number. *) -val mark_end_of_command : unit -> unit - -(** Returns the current label number *) -val current_command_label : unit -> int - -(** [reset_label n] resets [lib_stk] to the label n registered by - [mark_end_of_command()]. It forgets the label and anything - registered after it. The label should be strictly in the past. *) -val reset_label : int -> unit - (** {6 ... } *) (** The function [contents_after] returns the current library segment, starting from a given section path. If not given, the entire segment @@ -151,16 +140,28 @@ val remove_section_part : Libnames.global_reference -> Names.dir_path val open_section : Names.identifier -> unit val close_section : unit -> unit -(** {6 Backtracking (undo). } *) +(** {6 Backtracking } *) -val reset_to : Libnames.object_name -> unit -val reset_name : Names.identifier Util.located -> unit -val remove_name : Names.identifier Util.located -> unit -val reset_mod : Names.identifier Util.located -> unit +(** NB: The next commands are low-level ones, do not use them directly + otherwise the command history stack in [Backtrack] will be out-of-sync. + Also note that [reset_initial] is now [reset_label first_command_label] *) -(** [back n] resets to the place corresponding to the {% $ %}n{% $ %}-th call of - [mark_end_of_command] (counting backwards) *) -val back : int -> unit +(** Adds a "dummy" entry in lib_stk with a unique new label number. *) +val mark_end_of_command : unit -> unit + +(** Returns the current label number *) +val current_command_label : unit -> int + +(** The first label number *) +val first_command_label : int + +(** [reset_label n] resets [lib_stk] to the label n registered by + [mark_end_of_command()]. It forgets anything registered after + this label. The label should be strictly in the past. *) +val reset_label : int -> unit + +(** search the label registered immediately before adding some definition *) +val label_before_name : Names.identifier Util.located -> int (** {6 We can get and set the state of the operations (used in [States]). } *) @@ -171,10 +172,6 @@ val unfreeze : frozen -> unit val init : unit -> unit -val declare_initial_state : unit -> unit -val reset_initial : unit -> unit - - (** XML output hooks *) val set_xml_open_section : (Names.identifier -> unit) -> unit val set_xml_close_section : (Names.identifier -> unit) -> unit @@ -40,6 +40,18 @@ with option it accepts the same options as .B coqtop. +.TP +.BI \-image \ bin +use +.I bin +as underlying +.B coqtop +instead of the default one. + +.TP +.BI \-verbose +print the compiled file on the standard output. + .SH SEE ALSO .BR coqtop (1), diff --git a/man/coqtop.1 b/man/coqtop.1 index a3b3aac4..fff813bb 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -53,7 +53,7 @@ read state from file .TP .B \-nois -start with an empty intial state +start with an empty initial state .TP .BI \-outputstate filename @@ -135,12 +135,6 @@ set the rcfile to .I filename .TP -.BI \-user \ uid -use the rcfile of user -.I uid - - -.TP .B \-batch batch mode (exits just after arguments parsing) diff --git a/myocamlbuild.ml b/myocamlbuild.ml index bd4d1c34..c866356a 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -402,6 +402,15 @@ let extra_rules () = begin if w32 then flag ["link"; "ocaml"; "program"; "ide"] (S [A "-ccopt"; A "-link -Wl,-subsystem,windows"; P w32ico]); +(** The mingw32-ocaml cross-compiler currently uses Filename.dir_sep="/". + Let's tweak that... *) + + if w32 then begin + ocaml_lib "tools/win32hack"; + List.iter (fun (_,s,_) -> tag_file (s^".native") ["use_win32hack"]) + all_binaries + end; + (** Coqtop *) let () = diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4 index 3266fcf9..f554522a 100644 --- a/parsing/argextend.ml4 +++ b/parsing/argextend.ml4 @@ -107,6 +107,64 @@ let rec make_wit loc = function value wit = $lid:"wit_"^s$; end in WIT.wit >> +let has_extraarg = + List.exists (function GramNonTerminal(_,ExtraArgType _,_,_) -> true | _ -> false) + +let statically_known_possibly_empty s (prods,_) = + List.for_all (function + | GramNonTerminal(_,ExtraArgType s',_,_) -> + (* For ExtraArg we don't know (we'll have to test dynamically) *) + (* unless it is a recursive call *) + s <> s' + | GramNonTerminal(_,(OptArgType _|List0ArgType _),_,_) -> + (* Opt and List0 parses the empty string *) + true + | _ -> + (* This consumes a token for sure *) false) + prods + +let possibly_empty_subentries loc (prods,act) = + let bind_name p v e = match p with + | None -> e + | Some id -> + let s = Names.string_of_id id in <:expr< let $lid:s$ = $v$ in $e$ >> in + let rec aux = function + | [] -> <:expr< let loc = $default_loc$ in let _ = loc = loc in $act$ >> + | GramNonTerminal(_,OptArgType _,_,p) :: tl -> + bind_name p <:expr< None >> (aux tl) + | GramNonTerminal(_,List0ArgType _,_,p) :: tl -> + bind_name p <:expr< [] >> (aux tl) + | GramNonTerminal(_,(ExtraArgType _ as t),_,p) :: tl -> + (* We check at runtime if extraarg s parses "epsilon" *) + let s = match p with None -> "_" | Some id -> Names.string_of_id id in + <:expr< let $lid:s$ = match Genarg.default_empty_value $make_rawwit loc t$ with + [ None -> raise Exit + | Some v -> v ] in $aux tl$ >> + | _ -> assert false (* already filtered out *) in + if has_extraarg prods then + (* Needs a dynamic check; catch all exceptions if ever some rhs raises *) + (* an exception rather than returning a value; *) + (* declares loc because some code can refer to it; *) + (* ensures loc is used to avoid "unused variable" warning *) + (true, <:expr< try Some $aux prods$ with [ _ -> None ] >>) + else + (* Static optimisation *) + (false, aux prods) + +let make_possibly_empty_subentries loc s cl = + let cl = List.filter (statically_known_possibly_empty s) cl in + if cl = [] then + <:expr< None >> + else + let rec aux = function + | (true, e) :: l -> + <:expr< match $e$ with [ Some v -> Some v | None -> $aux l$ ] >> + | (false, e) :: _ -> + <:expr< Some $e$ >> + | [] -> + <:expr< None >> in + aux (List.map (possibly_empty_subentries loc) cl) + let make_act loc act pil = let rec make = function | [] -> <:expr< Pcoq.Gram.action (fun loc -> ($act$ : 'a)) >> @@ -144,9 +202,11 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = let interp = match f with | None -> <:expr< fun ist gl x -> - out_gen $make_wit loc globtyp$ - (Tacinterp.interp_genarg ist gl - (Genarg.in_gen $make_globwit loc globtyp$ x)) >> + let (sigma,a_interp) = + Tacinterp.interp_genarg ist gl + (Genarg.in_gen $make_globwit loc globtyp$ x) + in + (sigma , out_gen $make_wit loc globtyp$ a_interp)>> | Some f -> <:expr< $lid:f$>> in let substitute = match h with | None -> @@ -160,10 +220,11 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = let rawwit = <:expr< $lid:"rawwit_"^s$ >> in let globwit = <:expr< $lid:"globwit_"^s$ >> in let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in + let default_value = <:expr< $make_possibly_empty_subentries loc s cl$ >> in declare_str_items loc [ <:str_item< value ($lid:"wit_"^s$, $lid:"globwit_"^s$, $lid:"rawwit_"^s$) = - Genarg.create_arg $se$ >>; + Genarg.create_arg $default_value$ $se$>>; <:str_item< value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>; <:str_item< do { @@ -171,7 +232,8 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = ((fun e x -> (Genarg.in_gen $globwit$ ($glob$ e (out_gen $rawwit$ x)))), (fun ist gl x -> - (Genarg.in_gen $wit$ ($interp$ ist gl (out_gen $globwit$ x)))), + let (sigma,a_interp) = $interp$ ist gl (out_gen $globwit$ x) in + (sigma , Genarg.in_gen $wit$ a_interp)), (fun subst x -> (Genarg.in_gen $globwit$ ($substitute$ subst (out_gen $globwit$ x))))); Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a)) @@ -195,7 +257,7 @@ let declare_vernac_argument loc s pr cl = [ <:str_item< value (($lid:"wit_"^s$:Genarg.abstract_argument_type unit Genarg.tlevel), ($lid:"globwit_"^s$:Genarg.abstract_argument_type unit Genarg.glevel), - $lid:"rawwit_"^s$) = Genarg.create_arg $se$ >>; + $lid:"rawwit_"^s$) = Genarg.create_arg None $se$ >>; <:str_item< value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>; <:str_item< do { diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml index 4418a45f..82f24242 100644 --- a/parsing/egrammar.ml +++ b/parsing/egrammar.ml @@ -106,11 +106,14 @@ let make_constr_action in make ([],[],[]) (List.rev pil) +let check_cases_pattern_env loc (env,envlist,hasbinders) = + if hasbinders then error_invalid_pattern_notation loc else (env,envlist) + let make_cases_pattern_action (f : loc -> cases_pattern_notation_substitution -> cases_pattern_expr) pil = - let rec make (env,envlist as fullenv) = function + let rec make (env,envlist,hasbinders as fullenv) = function | [] -> - Gram.action (fun loc -> f loc fullenv) + Gram.action (fun loc -> f loc (check_cases_pattern_env loc fullenv)) | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl -> (* parse a non-binding item *) Gram.action (fun _ -> make fullenv tl) @@ -118,28 +121,37 @@ let make_cases_pattern_action (* parse a binding non-terminal *) (match typ with | ETConstr _ -> (* pattern non-terminal *) - Gram.action (fun (v:cases_pattern_expr) -> make (v::env,envlist) tl) + Gram.action (fun (v:cases_pattern_expr) -> + make (v::env, envlist, hasbinders) tl) | ETReference -> Gram.action (fun (v:reference) -> - make (CPatAtom (dummy_loc,Some v) :: env, envlist) tl) + make (CPatAtom (dummy_loc,Some v) :: env, envlist, hasbinders) tl) | ETName -> Gram.action (fun (na:name located) -> - make (cases_pattern_expr_of_name na :: env, envlist) tl) + make (cases_pattern_expr_of_name na :: env, envlist, hasbinders) tl) | ETBigint -> Gram.action (fun (v:Bigint.bigint) -> - make (CPatPrim (dummy_loc,Numeral v) :: env, envlist) tl) + make (CPatPrim (dummy_loc,Numeral v) :: env, envlist, hasbinders) tl) | ETConstrList (_,_) -> Gram.action (fun (vl:cases_pattern_expr list) -> - make (env, vl :: envlist) tl) - | (ETPattern | ETBinderList _ | ETBinder _ | ETOther _) -> - failwith "Unexpected entry of type cases pattern or other") + make (env, vl :: envlist, hasbinders) tl) + | ETBinder _ | ETBinderList (true,_) -> + Gram.action (fun (v:local_binder list) -> + make (env, envlist, hasbinders) tl) + | ETBinderList (false,_) -> + Gram.action (fun (v:local_binder list list) -> + make (env, envlist, true) tl) + | (ETPattern | ETOther _) -> + anomaly "Unexpected entry of type cases pattern or other") | GramConstrListMark (n,b) :: tl -> (* Rebuild expansions of ConstrList *) let heads,env = list_chop n env in - if b then make (env,(heads@List.hd envlist)::List.tl envlist) tl - else make (env,heads::envlist) tl + if b then + make (env,(heads@List.hd envlist)::List.tl envlist,hasbinders) tl + else + make (env,heads::envlist,hasbinders) tl in - make ([],[]) (List.rev pil) + make ([],[],false) (List.rev pil) let rec make_constr_prod_item assoc from forpat = function | GramConstrTerminal tok :: l -> @@ -349,3 +361,8 @@ let _ = { freeze_function = freeze; unfreeze_function = unfreeze; init_function = init } + +let with_grammar_rule_protection f x = + let fs = freeze () in + try let a = f x in unfreeze fs; a + with e -> unfreeze fs; raise e diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli index 1d85c74e..0ac46ded 100644 --- a/parsing/egrammar.mli +++ b/parsing/egrammar.mli @@ -71,3 +71,5 @@ val get_extend_vernac_grammars : val recover_notation_grammar : notation -> (precedence * tolerability list) -> notation_var_internalization_type list * notation_grammar + +val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b diff --git a/parsing/extrawit.ml b/parsing/extrawit.ml index ce734622..0398f0b6 100644 --- a/parsing/extrawit.ml +++ b/parsing/extrawit.ml @@ -15,12 +15,12 @@ open Genarg let tactic_main_level = 5 -let (wit_tactic0,globwit_tactic0,rawwit_tactic0) = create_arg "tactic0" -let (wit_tactic1,globwit_tactic1,rawwit_tactic1) = create_arg "tactic1" -let (wit_tactic2,globwit_tactic2,rawwit_tactic2) = create_arg "tactic2" -let (wit_tactic3,globwit_tactic3,rawwit_tactic3) = create_arg "tactic3" -let (wit_tactic4,globwit_tactic4,rawwit_tactic4) = create_arg "tactic4" -let (wit_tactic5,globwit_tactic5,rawwit_tactic5) = create_arg "tactic5" +let (wit_tactic0,globwit_tactic0,rawwit_tactic0) = create_arg None "tactic0" +let (wit_tactic1,globwit_tactic1,rawwit_tactic1) = create_arg None "tactic1" +let (wit_tactic2,globwit_tactic2,rawwit_tactic2) = create_arg None "tactic2" +let (wit_tactic3,globwit_tactic3,rawwit_tactic3) = create_arg None "tactic3" +let (wit_tactic4,globwit_tactic4,rawwit_tactic4) = create_arg None "tactic4" +let (wit_tactic5,globwit_tactic5,rawwit_tactic5) = create_arg None "tactic5" let wit_tactic = function | 0 -> wit_tactic0 diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 5d5f6e4d..958f59e0 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -31,6 +31,11 @@ let mk_cast = function (c,(_,None)) -> c | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, CastConv (DEFAULTcast, ty)) +let binders_of_names l = + List.map (fun (loc, na) -> + LocalRawAssum ([loc, na], Default Explicit, + CHole (loc, Some (Evd.BinderType na)))) l + let binders_of_lidents l = List.map (fun (loc, id) -> LocalRawAssum ([loc, Name id], Default Glob_term.Explicit, @@ -95,15 +100,21 @@ let impl_ident_head = | _ -> err ()) | _ -> err ()) -let ident_colon = - Gram.Entry.of_parser "ident_colon" +let name_colon = + Gram.Entry.of_parser "name_colon" (fun strm -> match get_tok (stream_nth 0 strm) with | IDENT s -> (match get_tok (stream_nth 1 strm) with | KEYWORD ":" -> stream_njunk 2 strm; - Names.id_of_string s + Name (Names.id_of_string s) + | _ -> err ()) + | KEYWORD "_" -> + (match get_tok (stream_nth 1 strm) with + | KEYWORD ":" -> + stream_njunk 2 strm; + Anonymous | _ -> err ()) | _ -> err ()) @@ -378,8 +389,7 @@ GEXTEND Gram [LocalRawAssum (id::idl,Default Explicit,c)] (* binders factorized with open binder *) | id = name; idl = LIST0 name; bl = binders -> - let t = CHole (loc, Some (Evd.BinderType (snd id))) in - LocalRawAssum (id::idl,Default Explicit,t)::bl + binders_of_names (id::idl) @ bl | id1 = name; ".."; id2 = name -> [LocalRawAssum ([id1;(loc,Name ldots_var);id2], Default Explicit,CHole (loc,None))] @@ -421,8 +431,8 @@ GEXTEND Gram [ [ "!" ; c = operconstr LEVEL "200" -> (loc, Anonymous), true, c | "{"; id = name; "}"; ":" ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" -> id, expl, c - | iid=ident_colon ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" -> - (loc, Name iid), expl, c + | iid=name_colon ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" -> + (loc, iid), expl, c | c = operconstr LEVEL "200" -> (loc, Anonymous), false, c ] ] diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 9abb8cd1..23e7e31b 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -23,11 +23,6 @@ let thm_token = G_vernac.thm_token GEXTEND Gram GLOBAL: command; - destruct_location : - [ [ IDENT "Conclusion" -> Tacexpr.ConclLocation () - | discard = [ IDENT "Discardable" -> true | -> false ]; "Hypothesis" - -> Tacexpr.HypLocation discard ] ] - ; opt_hintbases: [ [ -> [] | ":"; l = LIST1 [id = IDENT -> id ] -> l ] ] @@ -58,9 +53,6 @@ GEXTEND Gram | IDENT "Defined" -> VernacEndProof (Proved (false,None)) | IDENT "Defined"; id=identref -> VernacEndProof (Proved (false,Some (id,None))) - | IDENT "Suspend" -> VernacSuspend - | IDENT "Resume" -> VernacResume None - | IDENT "Resume"; id = identref -> VernacResume (Some id) | IDENT "Restart" -> VernacRestart | IDENT "Undo" -> VernacUndo 1 | IDENT "Undo"; n = natural -> VernacUndo n @@ -68,9 +60,7 @@ GEXTEND Gram | IDENT "Focus" -> VernacFocus None | IDENT "Focus"; n = natural -> VernacFocus (Some n) | IDENT "Unfocus" -> VernacUnfocus - | IDENT "BeginSubproof" -> VernacSubproof None - | IDENT "BeginSubproof"; n = natural -> VernacSubproof (Some n) - | IDENT "EndSubproof" -> VernacEndSubproof + | IDENT "Unfocused" -> VernacUnfocused | IDENT "Show" -> VernacShow (ShowGoal OpenSubgoals) | IDENT "Show"; n = natural -> VernacShow (ShowGoal (NthGoal n)) | IDENT "Show"; IDENT "Goal"; n = string -> @@ -118,14 +108,7 @@ GEXTEND Gram | IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc | IDENT "Extern"; n = natural; c = OPT constr_pattern ; "=>"; tac = tactic -> - HintsExtern (n,c,tac) - | IDENT "Destruct"; - id = ident; ":="; - pri = natural; - dloc = destruct_location; - hyptyp = constr_pattern; - "=>"; tac = tactic -> - HintsDestruct(id,pri,dloc,hyptyp,tac) ] ] + HintsExtern (n,c,tac) ] ] ; constr_body: [ [ ":="; c = lconstr -> c diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index f1b3ffed..34590fb1 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -348,7 +348,7 @@ GEXTEND Gram | IDENT "lazy"; s = strategy_flag -> Lazy s | IDENT "compute"; delta = delta_flag -> Cbv (all_with delta) | IDENT "vm_compute" -> CbvVm - | IDENT "unfold"; ul = LIST1 unfold_occ -> Unfold ul + | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul | IDENT "fold"; cl = LIST1 constr -> Fold cl | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl | s = IDENT -> ExtraRedExpr s ] ] @@ -597,21 +597,18 @@ GEXTEND Gram (* Automation tactic *) | IDENT "trivial"; lems = auto_using; db = hintbases -> - TacTrivial (lems,db) + TacTrivial (Off,lems,db) + | IDENT "info_trivial"; lems = auto_using; db = hintbases -> + TacTrivial (Info,lems,db) + | IDENT "debug"; IDENT "trivial"; lems = auto_using; db = hintbases -> + TacTrivial (Debug,lems,db) + | IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> - TacAuto (n,lems,db) - -(* Obsolete since V8.0 - | IDENT "autotdb"; n = OPT natural -> TacAutoTDB n - | IDENT "cdhyp"; id = identref -> TacDestructHyp (true,id) - | IDENT "dhyp"; id = identref -> TacDestructHyp (false,id) - | IDENT "dconcl" -> TacDestructConcl - | IDENT "superauto"; l = autoargs -> TacSuperAuto l -*) - | IDENT "auto"; IDENT "decomp"; p = OPT natural; - lems = auto_using -> TacDAuto (None,p,lems) - | IDENT "auto"; n = OPT int_or_var; IDENT "decomp"; p = OPT natural; - lems = auto_using -> TacDAuto (n,p,lems) + TacAuto (Off,n,lems,db) + | IDENT "info_auto"; n = OPT int_or_var; lems = auto_using; + db = hintbases -> TacAuto (Info,n,lems,db) + | IDENT "debug"; IDENT "auto"; n = OPT int_or_var; lems = auto_using; + db = hintbases -> TacAuto (Debug,n,lems,db) (* Context management *) | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacClear (true, l) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index ac81786b..333934be 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -143,7 +143,7 @@ let test_plurial_form_types = function (* Gallina declarations *) GEXTEND Gram GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion - typeclass_constraint record_field decl_notation rec_definition; + record_field decl_notation rec_definition; gallina: (* Definition, Theorem, Variable, Axiom, ... *) @@ -656,6 +656,7 @@ GEXTEND Gram | IDENT "clear"; IDENT "implicits" -> [`ClearImplicits] | IDENT "clear"; IDENT "scopes" -> [`ClearScopes] | IDENT "rename" -> [`Rename] + | IDENT "extra"; IDENT "scopes" -> [`ExtraScopes] | IDENT "clear"; IDENT "scopes"; IDENT "and"; IDENT "implicits" -> [`ClearImplicits; `ClearScopes] | IDENT "clear"; IDENT "implicits"; IDENT "and"; IDENT "scopes" -> @@ -927,7 +928,6 @@ GEXTEND Gram (* Resetting *) | IDENT "Reset"; id = identref -> VernacResetName id - | IDENT "Delete"; id = identref -> VernacRemoveName id | IDENT "Reset"; IDENT "Initial" -> VernacResetInitial | IDENT "Back" -> VernacBack 1 | IDENT "Back"; n = natural -> VernacBack n diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml index 4970ca13..fa075536 100644 --- a/parsing/ppconstr.ml +++ b/parsing/ppconstr.ml @@ -219,25 +219,33 @@ let surround_impl k p = | Explicit -> str"(" ++ p ++ str")" | Implicit -> str"{" ++ p ++ str"}" -let surround_binder k p = - match k with - | Default b -> hov 1 (surround_impl b p) - | Generalized (b, b', t) -> - hov 1 (surround_impl b' (surround_impl b p)) - let surround_implicit k p = match k with - | Default Explicit -> p - | Default Implicit -> (str"{" ++ p ++ str"}") - | Generalized (b, b', t) -> - surround_impl b' (surround_impl b p) + | Explicit -> p + | Implicit -> (str"{" ++ p ++ str"}") let pr_binder many pr (nal,k,t) = - match t with - | CHole _ -> prlist_with_sep spc pr_lname nal - | _ -> - let s = prlist_with_sep spc pr_lname nal ++ str" : " ++ pr t in - hov 1 (if many then surround_binder k s else surround_implicit k s) + match k with + | Generalized (b, b', t') -> + assert (b=Implicit); + begin match nal with + |[loc,Anonymous] -> + hov 1 (str"`" ++ (surround_impl b' + ((if t' then str "!" else mt ()) ++ pr t))) + |[loc,Name id] -> + hov 1 (str "`" ++ (surround_impl b' + (pr_lident (loc,id) ++ str " : " ++ + (if t' then str "!" else mt()) ++ pr t))) + |_ -> anomaly "List of generalized binders have alwais one element." + end + | Default b -> + match t with + | CHole _ -> + let s = prlist_with_sep spc pr_lname nal in + hov 1 (surround_implicit b s) + | _ -> + let s = prlist_with_sep spc pr_lname nal ++ str " : " ++ pr t in + hov 1 (if many then surround_impl b s else surround_implicit b s) let pr_binder_among_many pr_c = function | LocalRawAssum (nal,k,t) -> @@ -323,19 +331,27 @@ let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c = pr_opt_type_spc pr t ++ str " :=" ++ pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c -let pr_fixdecl pr prd dangling_with_for ((_,id),(n,ro),bl,t,c) = - let annot = - match ro with - CStructRec -> - if List.length bl > 1 && n <> None then - spc() ++ str "{struct " ++ pr_id (snd (Option.get n)) ++ str"}" - else mt() - | CWfRec c -> - spc () ++ str "{wf " ++ pr lsimple c ++ pr_id (snd (Option.get n)) ++ str"}" - | CMeasureRec (m,r) -> - spc () ++ str "{measure " ++ pr lsimple m ++ pr_id (snd (Option.get n)) ++ - (match r with None -> mt() | Some r -> str" on " ++ pr lsimple r) ++ str"}" - in +let pr_guard_annot pr_aux bl (n,ro) = + match n with + | None -> mt () + | Some (loc, id) -> + match (ro : Topconstr.recursion_order_expr) with + | CStructRec -> + let names_of_binder = function + | LocalRawAssum (nal,_,_) -> nal + | LocalRawDef (_,_) -> [] + in let ids = List.flatten (List.map names_of_binder bl) in + if List.length ids > 1 then + spc() ++ str "{struct " ++ pr_id id ++ str"}" + else mt() + | CWfRec c -> + spc() ++ str "{wf " ++ pr_aux c ++ spc() ++ pr_id id ++ str"}" + | CMeasureRec (m,r) -> + spc() ++ str "{measure " ++ pr_aux m ++ spc() ++ pr_id id++ + (match r with None -> mt() | Some r -> str" on " ++ pr_aux r) ++ str"}" + +let pr_fixdecl pr prd dangling_with_for ((_,id),ro,bl,t,c) = + let annot = pr_guard_annot (pr lsimple) bl ro in pr_recursive_decl pr prd dangling_with_for id bl annot t c let pr_cofixdecl pr prd dangling_with_for ((_,id),bl,t,c) = diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli index f9ed3af0..afcdad3e 100644 --- a/parsing/ppconstr.mli +++ b/parsing/ppconstr.mli @@ -51,12 +51,16 @@ val pr_with_occurrences : ('a -> std_ppcmds) -> 'a with_occurrences -> std_ppcmds val pr_red_expr : ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> - ('a,'b,'c) red_expr_gen -> std_ppcmds + ('a,'b,'c) red_expr_gen -> std_ppcmds val pr_may_eval : ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> ('c -> std_ppcmds) -> ('a,'b,'c) may_eval -> std_ppcmds val pr_glob_sort : glob_sort -> std_ppcmds +val pr_guard_annot : (constr_expr -> std_ppcmds) -> + local_binder list -> + ('a * Names.identifier) option * recursion_order_expr -> + std_ppcmds val pr_binders : local_binder list -> std_ppcmds val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml index 3305acb7..6e13d4e9 100644 --- a/parsing/pptactic.ml +++ b/parsing/pptactic.ml @@ -515,6 +515,11 @@ let pr_auto_using prc = function | l -> spc () ++ hov 2 (str "using" ++ spc () ++ prlist_with_sep pr_comma prc l) +let string_of_debug = function + | Off -> "" + | Debug -> "debug " + | Info -> "info_" + let pr_then () = str ";" let ltop = (5,E) @@ -623,19 +628,14 @@ let rec pr_atom0 = function | TacAssumption -> str "assumption" | TacAnyConstructor (false,None) -> str "constructor" | TacAnyConstructor (true,None) -> str "econstructor" - | TacTrivial ([],Some []) -> str "trivial" - | TacAuto (None,[],Some []) -> str "auto" + | TacTrivial (d,[],Some []) -> str (string_of_debug d ^ "trivial") + | TacAuto (d,None,[],Some []) -> str (string_of_debug d ^ "auto") | TacReflexivity -> str "reflexivity" | TacClear (true,[]) -> str "clear" | t -> str "(" ++ pr_atom1 t ++ str ")" (* Main tactic printer *) and pr_atom1 = function - | TacAutoTDB _ | TacDestructHyp _ | TacDestructConcl - | TacSuperAuto _ | TacExtend (_, - ("GTauto"|"GIntuition"|"TSimplif"| - "LinearIntuition"),_) -> - errorlabstrm "Obsolete V8" (str "Tactic is not ported to V8.0") | TacExtend (loc,s,l) -> pr_with_comments loc (pr_extend 1 s l) | TacAlias (loc,s,l,_) -> @@ -742,17 +742,15 @@ and pr_atom1 = function hov 1 (str "lapply" ++ pr_constrarg c) (* Automation tactics *) - | TacTrivial ([],Some []) as x -> pr_atom0 x - | TacTrivial (lems,db) -> - hov 0 (str "trivial" ++ + | TacTrivial (_,[],Some []) as x -> pr_atom0 x + | TacTrivial (d,lems,db) -> + hov 0 (str (string_of_debug d ^ "trivial") ++ pr_auto_using pr_constr lems ++ pr_hintbases db) - | TacAuto (None,[],Some []) as x -> pr_atom0 x - | TacAuto (n,lems,db) -> - hov 0 (str "auto" ++ pr_opt (pr_or_var int) n ++ + | TacAuto (_,None,[],Some []) as x -> pr_atom0 x + | TacAuto (d,n,lems,db) -> + hov 0 (str (string_of_debug d ^ "auto") ++ + pr_opt (pr_or_var int) n ++ pr_auto_using pr_constr lems ++ pr_hintbases db) - | TacDAuto (n,p,lems) -> - hov 1 (str "auto" ++ pr_opt (pr_or_var int) n ++ str "decomp" ++ - pr_opt int p ++ pr_auto_using pr_constr lems) (* Context management *) | TacClear (true,[]) as t -> pr_atom0 t diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml index c858439e..cf9d4a53 100644 --- a/parsing/ppvernac.ml +++ b/parsing/ppvernac.ml @@ -203,11 +203,7 @@ let pr_hints local db h pr_c pr_pat = let pat = match c with None -> mt () | Some pat -> pr_pat pat in str "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++ spc() ++ pr_raw_tactic tac - | HintsDestruct(name,i,loc,c,tac) -> - str "Destruct " ++ pr_id name ++ str" :=" ++ spc() ++ - hov 0 (int i ++ spc() ++ pr_destruct_location loc ++ spc() ++ - pr_c c ++ str " =>") ++ spc() ++ - pr_raw_tactic tac in + in hov 2 (str"Hint "++pr_locality local ++ pph ++ opth) let pr_with_declaration pr_c = function @@ -292,28 +288,6 @@ let pr_binders_arg = let pr_and_type_binders_arg bl = pr_binders_arg bl -let names_of_binder = function - | LocalRawAssum (nal,_,_) -> nal - | LocalRawDef (_,_) -> [] - -let pr_guard_annot bl (n,ro) = - match n with - | None -> mt () - | Some (loc, id) -> - match (ro : Topconstr.recursion_order_expr) with - | CStructRec -> - let ids = List.flatten (List.map names_of_binder bl) in - if List.length ids > 1 then - spc() ++ str "{struct " ++ pr_id id ++ str"}" - else mt() - | CWfRec c -> - spc() ++ str "{wf " ++ pr_lconstr_expr c ++ spc() ++ - pr_id id ++ str"}" - | CMeasureRec (m,r) -> - spc() ++ str "{measure " ++ pr_lconstr_expr m ++ spc() ++ - pr_id id ++ (match r with None -> mt() | Some r -> str" on " ++ - pr_lconstr_expr r) ++ str"}" - let pr_onescheme (idop,schem) = match schem with | InductionScheme (dep,ind,s) -> @@ -419,7 +393,7 @@ let pr_statement head (id,(bl,c,guard)) = hov 1 (head ++ spc() ++ pr_lident (Option.get id) ++ spc() ++ (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++ - pr_opt (pr_guard_annot bl) guard ++ + pr_opt (pr_guard_annot pr_lconstr_expr bl) guard ++ str":" ++ pr_spc_lconstr c) (**************************************) @@ -462,11 +436,10 @@ let rec pr_vernac = function (* Proof management *) | VernacAbortAll -> str "Abort All" | VernacRestart -> str"Restart" - | VernacSuspend -> str"Suspend" | VernacUnfocus -> str"Unfocus" + | VernacUnfocused -> str"Unfocused" | VernacGoal c -> str"Goal" ++ pr_lconstrarg c | VernacAbort id -> str"Abort" ++ pr_opt pr_lident id - | VernacResume id -> str"Resume" ++ pr_opt pr_lident id | VernacUndo i -> if i=1 then str"Undo" else str"Undo" ++ pr_intarg i | VernacUndoTo i -> str"Undo" ++ spc() ++ str"To" ++ pr_intarg i | VernacBacktrack (i,j,k) -> @@ -493,7 +466,6 @@ let rec pr_vernac = function | VernacCheckGuard -> str"Guarded" (* Resetting *) - | VernacRemoveName id -> str"Remove" ++ spc() ++ pr_lident id | VernacResetName id -> str"Reset" ++ spc() ++ pr_lident id | VernacResetInitial -> str"Reset Initial" | VernacBack i -> if i=1 then str"Back" else str"Back" ++ pr_intarg i @@ -627,7 +599,7 @@ let rec pr_vernac = function let (_,_,_,k,_),_ = List.hd l in match k with Record -> "Record" | Structure -> "Structure" | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive" - | Class b -> if b then "Definitional Class" else "Class" in + | Class _ -> "Class" in hov 1 (pr_oneind key (List.hd l)) ++ (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) @@ -635,10 +607,10 @@ let rec pr_vernac = function | VernacFixpoint recs -> let pr_onerec = function | ((loc,id),ro,bl,type_,def),ntn -> - let annot = pr_guard_annot bl ro in - pr_id id ++ pr_binders_arg bl ++ annot ++ spc() + let annot = pr_guard_annot pr_lconstr_expr bl ro in + pr_id id ++ pr_binders_arg bl ++ annot ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_ - ++ pr_opt (fun def -> str" :=" ++ brk(1,2) ++ pr_lconstr def) def ++ + ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++ prlist (pr_decl_notation pr_constr) ntn in hov 0 (str "Fixpoint" ++ spc() ++ @@ -690,34 +662,23 @@ let rec pr_vernac = function spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2) - -(* | VernacClass (id, par, ar, sup, props) -> *) -(* hov 1 ( *) -(* str"Class" ++ spc () ++ pr_lident id ++ *) -(* (\* prlist_with_sep (spc) (pr_lident_constr (spc() ++ str ":" ++ spc())) par ++ *\) *) -(* pr_and_type_binders_arg par ++ *) -(* (match ar with Some ar -> spc () ++ str":" ++ spc() ++ pr_glob_sort (snd ar) | None -> mt()) ++ *) -(* spc () ++ str":=" ++ spc () ++ *) -(* prlist_with_sep (fun () -> str";" ++ spc()) *) -(* (fun (lid,oc,c) -> pr_lident_constr ((if oc then str" :>" else str" :") ++ spc()) (lid,c)) props ) *) - | VernacInstance (abst,glob, sup, (instid, bk, cl), props, pri) -> hov 1 ( pr_non_locality (not glob) ++ (if abst then str"Declare " else mt ()) ++ - str"Instance" ++ spc () ++ - pr_and_type_binders_arg sup ++ - str"=>" ++ spc () ++ - (match snd instid with Name id -> pr_lident (fst instid, id) ++ spc () ++ str":" ++ spc () | Anonymous -> mt ()) ++ - pr_constr_expr cl ++ spc () ++ + str"Instance" ++ + (match snd instid with Name id -> spc () ++ pr_lident (fst instid, id) ++ spc () | + Anonymous -> mt ()) ++ + pr_and_type_binders_arg sup ++ + str":" ++ spc () ++ + pr_constr_expr cl ++ spc () ++ (match props with | Some p -> spc () ++ str":=" ++ spc () ++ pr_constr_expr p | None -> mt())) | VernacContext l -> hov 1 ( - str"Context" ++ spc () ++ str"[" ++ spc () ++ - pr_and_type_binders_arg l ++ spc () ++ str "]") + str"Context" ++ spc () ++ pr_and_type_binders_arg l) | VernacDeclareInstances (glob, ids) -> @@ -817,8 +778,8 @@ let rec pr_vernac = function pr_hints local dbnames h pr_constr pr_constr_pattern_expr | VernacSyntacticDefinition (id,(ids,c),local,onlyparsing) -> hov 2 - (pr_locality local ++ str"Notation " ++ pr_lident id ++ - prlist_with_sep spc pr_id ids ++ str" :=" ++ pr_constrarg c ++ + (pr_locality local ++ str"Notation " ++ pr_lident id ++ spc () ++ + prlist (fun x -> spc() ++ pr_id x) ids ++ str":=" ++ pr_constrarg c ++ pr_syntax_modifiers (if onlyparsing then [SetOnlyParsing] else [])) | VernacDeclareImplicits (local,q,[]) -> hov 2 (pr_section_locality local ++ str"Implicit Arguments" ++ spc() ++ @@ -852,6 +813,7 @@ let rec pr_vernac = function | `SimplNeverUnfold -> str "simpl never" | `DefaultImplicits -> str "default implicits" | `Rename -> str "rename" + | `ExtraScopes -> str "extra scopes" | `ClearImplicits -> str "clear implicits" | `ClearScopes -> str "clear scopes") mods) @@ -978,9 +940,9 @@ let rec pr_vernac = function | Star -> str"*" | Plus -> str"+" end ++ spc() - | VernacSubproof None -> str "BeginSubproof" + | VernacSubproof None -> str "{" | VernacSubproof (Some i) -> str "BeginSubproof " ++ pr_int i - | VernacEndSubproof -> str "EndSubproof" + | VernacEndSubproof -> str "}" and pr_extend s cl = let pr_arg a = diff --git a/parsing/printer.ml b/parsing/printer.ml index 0b9ce918..5352e0b7 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -35,13 +35,19 @@ let delayed_emacs_cmd s = (**********************************************************************) (** Terms *) - (* [at_top] means ids of env must be avoided in bound variables *) -let pr_constr_core at_top env t = - pr_constr_expr (extern_constr at_top env t) -let pr_lconstr_core at_top env t = - pr_lconstr_expr (extern_constr at_top env t) +(* [goal_concl_style] means that all names of goal/section variables + and all names of rel variables (if any) in the given env and all short + names of global definitions of the current module must be avoided while + printing bound variables. + Otherwise, short names of global definitions are printed qualified + and only names of goal/section variables and rel names that do + _not_ occur in the scope of the binder to be printed are avoided. *) + +let pr_constr_core goal_concl_style env t = + pr_constr_expr (extern_constr goal_concl_style env t) +let pr_lconstr_core goal_concl_style env t = + pr_lconstr_expr (extern_constr goal_concl_style env t) -let pr_lconstr_env_at_top env = pr_lconstr_core true env let pr_lconstr_env env = pr_lconstr_core false env let pr_constr_env env = pr_constr_core false env @@ -68,12 +74,12 @@ let pr_lconstr_under_binders_env = pr_constr_under_binders_env_gen pr_lconstr_en let pr_constr_under_binders c = pr_constr_under_binders_env (Global.env()) c let pr_lconstr_under_binders c = pr_lconstr_under_binders_env (Global.env()) c -let pr_type_core at_top env t = - pr_constr_expr (extern_type at_top env t) -let pr_ltype_core at_top env t = - pr_lconstr_expr (extern_type at_top env t) +let pr_type_core goal_concl_style env t = + pr_constr_expr (extern_type goal_concl_style env t) +let pr_ltype_core goal_concl_style env t = + pr_lconstr_expr (extern_type goal_concl_style env t) -let pr_ltype_env_at_top env = pr_ltype_core true env +let pr_goal_concl_style_env env = pr_ltype_core true env let pr_ltype_env env = pr_ltype_core false env let pr_type_env env = pr_type_core false env @@ -262,7 +268,7 @@ let default_pr_goal gs = let preamb,thesis,penv,pc = mt (), mt (), pr_context_of env, - pr_ltype_env_at_top env (Goal.V82.concl sigma g) + pr_goal_concl_style_env env (Goal.V82.concl sigma g) in preamb ++ str" " ++ hv 0 (penv ++ fnl () ++ @@ -279,7 +285,7 @@ let pr_goal_tag g = let pr_concl n sigma g = let (g,sigma) = Goal.V82.nf_evar sigma g in let env = Goal.V82.env sigma g in - let pc = pr_ltype_env_at_top env (Goal.V82.concl sigma g) in + let pc = pr_goal_concl_style_env env (Goal.V82.concl sigma g) in str (emacs_str "") ++ str "subgoal " ++ int n ++ pr_goal_tag g ++ str " is:" ++ cut () ++ str" " ++ pc @@ -363,7 +369,8 @@ let default_pr_subgoals close_cmd sigma seeds = function let pei = pr_evars_int 1 exl in (str "No more subgoals but non-instantiated existential " ++ str "variables:" ++ fnl () ++ (hov 0 pei) - ++ emacs_print_dependent_evars sigma seeds) + ++ emacs_print_dependent_evars sigma seeds ++ fnl () ++ + str "You can use Grab Existential Variables.") end | [g] -> let pg = default_pr_goal { it = g ; sigma = sigma } in @@ -424,7 +431,7 @@ let pr_open_subgoals () = begin match bgoals with | [] -> pr_subgoals None sigma seeds goals | _ -> pr_subgoals None bsigma seeds bgoals ++ fnl () ++ fnl () ++ - str"This subproof is complete, but there are still unfocused goals:" + str"This subproof is complete, but there are still unfocused goals." ++ fnl () (* spiwack: to stay compatible with the proof general and coqide, I use print the message after the goal. It would be better to have something like: diff --git a/parsing/printer.mli b/parsing/printer.mli index 2d437c20..bbc3a6ca 100644 --- a/parsing/printer.mli +++ b/parsing/printer.mli @@ -26,7 +26,6 @@ open Tacexpr (** Terms *) val pr_lconstr_env : env -> constr -> std_ppcmds -val pr_lconstr_env_at_top : env -> constr -> std_ppcmds val pr_lconstr : constr -> std_ppcmds val pr_constr_env : env -> constr -> std_ppcmds @@ -44,7 +43,7 @@ val pr_constr_under_binders : constr_under_binders -> std_ppcmds val pr_lconstr_under_binders_env : env -> constr_under_binders -> std_ppcmds val pr_lconstr_under_binders : constr_under_binders -> std_ppcmds -val pr_ltype_env_at_top : env -> types -> std_ppcmds +val pr_goal_concl_style_env : env -> types -> std_ppcmds val pr_ltype_env : env -> types -> std_ppcmds val pr_ltype : types -> std_ppcmds diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4 index 7df97a07..6e3b3f35 100644 --- a/parsing/q_coqast.ml4 +++ b/parsing/q_coqast.ml4 @@ -273,6 +273,11 @@ let mlexpr_of_message_token = function | Tacexpr.MsgInt n -> <:expr< Tacexpr.MsgInt $mlexpr_of_int n$ >> | Tacexpr.MsgIdent id -> <:expr< Tacexpr.MsgIdent $mlexpr_of_hyp id$ >> +let mlexpr_of_debug = function + | Tacexpr.Off -> <:expr< Tacexpr.Off >> + | Tacexpr.Debug -> <:expr< Tacexpr.Debug >> + | Tacexpr.Info -> <:expr< Tacexpr.Info >> + let rec mlexpr_of_atomic_tactic = function (* Basic tactics *) | Tacexpr.TacIntroPattern pl -> @@ -399,15 +404,17 @@ let rec mlexpr_of_atomic_tactic = function | Tacexpr.TacTransitivity c -> <:expr< Tacexpr.TacTransitivity $mlexpr_of_option mlexpr_of_constr c$ >> (* Automation tactics *) - | Tacexpr.TacAuto (n,lems,l) -> + | Tacexpr.TacAuto (debug,n,lems,l) -> + let d = mlexpr_of_debug debug in let n = mlexpr_of_option (mlexpr_of_or_var mlexpr_of_int) n in let lems = mlexpr_of_list mlexpr_of_constr lems in let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in - <:expr< Tacexpr.TacAuto $n$ $lems$ $l$ >> - | Tacexpr.TacTrivial (lems,l) -> + <:expr< Tacexpr.TacAuto $d$ $n$ $lems$ $l$ >> + | Tacexpr.TacTrivial (debug,lems,l) -> + let d = mlexpr_of_debug debug in let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in let lems = mlexpr_of_list mlexpr_of_constr lems in - <:expr< Tacexpr.TacTrivial $lems$ $l$ >> + <:expr< Tacexpr.TacTrivial $d$ $lems$ $l$ >> | _ -> failwith "Quotation of atomic tactic expressions: TODO" diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4 index 2fe1fdda..05fdba42 100644 --- a/parsing/tacextend.ml4 +++ b/parsing/tacextend.ml4 @@ -119,20 +119,42 @@ let make_one_printing_rule se (pt,e) = let make_printing_rule se = mlexpr_of_list (make_one_printing_rule se) -let rec contains_epsilon = function - | List0ArgType _ -> true - | List1ArgType t -> contains_epsilon t - | OptArgType _ -> true - | PairArgType(t1,t2) -> contains_epsilon t1 && contains_epsilon t2 - | ExtraArgType("hintbases") -> true - | _ -> false -let is_atomic = function - | GramTerminal s :: l when - List.for_all (function - GramTerminal _ -> false - | GramNonTerminal(_,t,_,_) -> contains_epsilon t) l - -> [s] - | _ -> [] +let rec possibly_empty_subentries loc = function + | [] -> [] + | (s,prodsl) :: l -> + let rec aux = function + | [] -> (false,<:expr< None >>) + | prods :: rest -> + try + let l = List.map (function + | GramNonTerminal(_,(List0ArgType _| + OptArgType _| + ExtraArgType _ as t),_,_)-> + (* This possibly parses epsilon *) + let rawwit = make_rawwit loc t in + <:expr< match Genarg.default_empty_value $rawwit$ with + [ None -> failwith "" + | Some v -> + Tacinterp.intern_genarg Tacinterp.fully_empty_glob_sign + (Genarg.in_gen $rawwit$ v) ] >> + | GramTerminal _ | GramNonTerminal(_,_,_,_) -> + (* This does not parse epsilon (this Exit is static time) *) + raise Exit) prods in + if has_extraarg prods then + (true,<:expr< try Some $mlexpr_of_list (fun x -> x) l$ + with [ Failure "" -> $snd (aux rest)$ ] >>) + else + (true, <:expr< Some $mlexpr_of_list (fun x -> x) l$ >>) + with Exit -> aux rest in + let (nonempty,v) = aux prodsl in + if nonempty then (s,v) :: possibly_empty_subentries loc l + else possibly_empty_subentries loc l + +let possibly_atomic loc prods = + let l = list_map_filter (function + | GramTerminal s :: l, _ -> Some (s,l) + | _ -> None) prods in + possibly_empty_subentries loc (list_factorize_left l) let declare_tactic loc s cl = let se = mlexpr_of_string s in @@ -151,17 +173,20 @@ let declare_tactic loc s cl = in let hidden = if List.length cl = 1 then List.map hide_tac cl else [] in let atomic_tactics = - mlexpr_of_list mlexpr_of_string - (List.flatten (List.map (fun (al,_) -> is_atomic al) cl)) in + mlexpr_of_list (mlexpr_of_pair mlexpr_of_string (fun x -> x)) + (possibly_atomic loc cl) in declare_str_items loc (hidden @ [ <:str_item< do { try let _=Tacinterp.add_tactic $se$ $make_fun_clauses loc s cl$ in List.iter - (fun s -> Tacinterp.add_primitive_tactic s + (fun (s,l) -> match l with + [ Some l -> + Tacinterp.add_primitive_tactic s (Tacexpr.TacAtom($default_loc$, - Tacexpr.TacExtend($default_loc$,s,[])))) + Tacexpr.TacExtend($default_loc$,$se$,l))) + | None -> () ]) $atomic_tactics$ with e -> Pp.pp (Errors.print e); Egrammar.extend_tactic_grammar $se$ $gl$; diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 27def8cc..362f6a61 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -29,7 +29,7 @@ let pr_goal gs = (str " *** Declarative Mode ***" ++ fnl ()++fnl ()), (str "thesis := " ++ fnl ()), Printer.pr_context_of env, - Printer.pr_ltype_env_at_top env (Goal.V82.concl sigma g) + Printer.pr_goal_concl_style_env env (Goal.V82.concl sigma g) in preamb ++ str" " ++ hv 0 (penv ++ fnl () ++ @@ -103,7 +103,7 @@ let proof_instr = Gram.entry_create "proofmode:instr" (* [Genarg.create_arg] creates a new embedding into Genarg. *) let (wit_proof_instr,globwit_proof_instr,rawwit_proof_instr) = - Genarg.create_arg "proof_instr" + Genarg.create_arg None "proof_instr" let _ = Tacinterp.add_interp_genarg "proof_instr" begin begin fun e x -> (* declares the globalisation function *) @@ -111,6 +111,7 @@ let _ = Tacinterp.add_interp_genarg "proof_instr" (Decl_interp.intern_proof_instr e (Genarg.out_gen rawwit_proof_instr x)) end, begin fun ist gl x -> (* declares the interpretation function *) + Tacmach.project gl , Genarg.in_gen wit_proof_instr (interp_proof_instr ist gl (Genarg.out_gen globwit_proof_instr x)) end, diff --git a/plugins/dp/Dp.v b/plugins/dp/Dp.v deleted file mode 100644 index 1b66c334..00000000 --- a/plugins/dp/Dp.v +++ /dev/null @@ -1,118 +0,0 @@ -(* Calls to external decision procedures *) - -Require Export ZArith. -Require Export Classical. - -(* Zenon *) - -(* Copyright 2004 INRIA *) -Lemma zenon_nottrue : - (~True -> False). -Proof. tauto. Qed. - -Lemma zenon_noteq : forall (T : Type) (t : T), - ((t <> t) -> False). -Proof. tauto. Qed. - -Lemma zenon_and : forall P Q : Prop, - (P -> Q -> False) -> (P /\ Q -> False). -Proof. tauto. Qed. - -Lemma zenon_or : forall P Q : Prop, - (P -> False) -> (Q -> False) -> (P \/ Q -> False). -Proof. tauto. Qed. - -Lemma zenon_imply : forall P Q : Prop, - (~P -> False) -> (Q -> False) -> ((P -> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_equiv : forall P Q : Prop, - (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notand : forall P Q : Prop, - (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notor : forall P Q : Prop, - (~P -> ~Q -> False) -> (~(P \/ Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notimply : forall P Q : Prop, - (P -> ~Q -> False) -> (~(P -> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notequiv : forall P Q : Prop, - (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_ex : forall (T : Type) (P : T -> Prop), - (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T), - ((P t) -> False) -> ((forall x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T), - (~(P t) -> False) -> (~(exists x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_notall : forall (T : Type) (P : T -> Prop), - (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False). -Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed. - -Lemma zenon_equal_base : forall (T : Type) (f : T), f = f. -Proof. auto. Qed. - -Lemma zenon_equal_step : - forall (S T : Type) (fa fb : S -> T) (a b : S), - (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)). -Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed. - -Lemma zenon_pnotp : forall P Q : Prop, - (P = Q) -> (P -> ~Q -> False). -Proof. intros P Q Ha. rewrite Ha. auto. Qed. - -Lemma zenon_notequal : forall (T : Type) (a b : T), - (a = b) -> (a <> b -> False). -Proof. auto. Qed. - -Ltac zenon_intro id := - intro id || let nid := fresh in (intro nid; clear nid) -. - -Definition zenon_and_s := fun P Q a b => zenon_and P Q b a. -Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a. -Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a. -Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a. -Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a. -Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a. -Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a. -Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a. -Definition zenon_ex_s := fun T P a b => zenon_ex T P b a. -Definition zenon_notall_s := fun T P a b => zenon_notall T P b a. - -Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b. -Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x. - -(* Ergo *) - -Set Implicit Arguments. -Section congr. - Variable t:Type. -Lemma ergo_eq_concat_1 : - forall (P:t -> Prop) (x y:t), - P x -> x = y -> P y. -Proof. - intros; subst; auto. -Qed. - -Lemma ergo_eq_concat_2 : - forall (P:t -> t -> Prop) (x1 x2 y1 y2:t), - P x1 x2 -> x1 = y1 -> x2 = y2 -> P y1 y2. -Proof. - intros; subst; auto. -Qed. - -End congr. diff --git a/plugins/dp/TODO b/plugins/dp/TODO deleted file mode 100644 index 44349e21..00000000 --- a/plugins/dp/TODO +++ /dev/null @@ -1,24 +0,0 @@ - -TODO ----- - -- axiomes pour les prédicats récursifs comme - - Fixpoint even (n:nat) : Prop := - match n with - O => True - | S O => False - | S (S p) => even p - end. - - ou encore In sur les listes du module Coq List. - -- discriminate - -- inversion (Set et Prop) - - -BUGS ----- - - diff --git a/plugins/dp/dp.ml b/plugins/dp/dp.ml deleted file mode 100644 index 837195e4..00000000 --- a/plugins/dp/dp.ml +++ /dev/null @@ -1,1133 +0,0 @@ -(* Authors: Nicolas Ayache and Jean-Christophe Filliâtre *) -(* Tactics to call decision procedures *) - -(* Works in two steps: - - - first the Coq context and the current goal are translated in - Polymorphic First-Order Logic (see fol.mli in this directory) - - - then the resulting query is passed to the Why tool that translates - it to the syntax of the selected prover (Simplify, CVC Lite, haRVey, - Zenon) -*) - -open Util -open Pp -open Libobject -open Summary -open Term -open Tacmach -open Tactics -open Tacticals -open Fol -open Names -open Nameops -open Namegen -open Coqlib -open Hipattern -open Libnames -open Declarations -open Dp_why - -let debug = ref false -let set_debug b = debug := b -let trace = ref false -let set_trace b = trace := b -let timeout = ref 10 -let set_timeout n = timeout := n - -let dp_timeout_obj : int -> obj = - declare_object - {(default_object "Dp_timeout") with - cache_function = (fun (_,x) -> set_timeout x); - load_function = (fun _ (_,x) -> set_timeout x)} - -let dp_timeout x = Lib.add_anonymous_leaf (dp_timeout_obj x) - -let dp_debug_obj : bool -> obj = - declare_object - {(default_object "Dp_debug") with - cache_function = (fun (_,x) -> set_debug x); - load_function = (fun _ (_,x) -> set_debug x)} - -let dp_debug x = Lib.add_anonymous_leaf (dp_debug_obj x) - -let dp_trace_obj : bool -> obj = - declare_object - {(default_object "Dp_trace") with - cache_function = (fun (_,x) -> set_trace x); - load_function = (fun _ (_,x) -> set_trace x)} - -let dp_trace x = Lib.add_anonymous_leaf (dp_trace_obj x) - -let logic_dir = ["Coq";"Logic";"Decidable"] -let coq_modules = - init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules - @ [["Coq"; "ZArith"; "BinInt"]; - ["Coq"; "Reals"; "Rdefinitions"]; - ["Coq"; "Reals"; "Raxioms";]; - ["Coq"; "Reals"; "Rbasic_fun";]; - ["Coq"; "Reals"; "R_sqrt";]; - ["Coq"; "Reals"; "Rfunctions";]] - @ [["Coq"; "omega"; "OmegaLemmas"]] - -let constant = gen_constant_in_modules "dp" coq_modules - -(* integers constants and operations *) -let coq_Z = lazy (constant "Z") -let coq_Zplus = lazy (constant "Zplus") -let coq_Zmult = lazy (constant "Zmult") -let coq_Zopp = lazy (constant "Zopp") -let coq_Zminus = lazy (constant "Zminus") -let coq_Zdiv = lazy (constant "Zdiv") -let coq_Zs = lazy (constant "Zs") -let coq_Zgt = lazy (constant "Zgt") -let coq_Zle = lazy (constant "Zle") -let coq_Zge = lazy (constant "Zge") -let coq_Zlt = lazy (constant "Zlt") -let coq_Z0 = lazy (constant "Z0") -let coq_Zpos = lazy (constant "Zpos") -let coq_Zneg = lazy (constant "Zneg") -let coq_xH = lazy (constant "xH") -let coq_xI = lazy (constant "xI") -let coq_xO = lazy (constant "xO") -let coq_iff = lazy (constant "iff") - -(* real constants and operations *) -let coq_R = lazy (constant "R") -let coq_R0 = lazy (constant "R0") -let coq_R1 = lazy (constant "R1") -let coq_Rgt = lazy (constant "Rgt") -let coq_Rle = lazy (constant "Rle") -let coq_Rge = lazy (constant "Rge") -let coq_Rlt = lazy (constant "Rlt") -let coq_Rplus = lazy (constant "Rplus") -let coq_Rmult = lazy (constant "Rmult") -let coq_Ropp = lazy (constant "Ropp") -let coq_Rminus = lazy (constant "Rminus") -let coq_Rdiv = lazy (constant "Rdiv") -let coq_powerRZ = lazy (constant "powerRZ") - -(* not Prop typed expressions *) -exception NotProp - -(* not first-order expressions *) -exception NotFO - -(* Renaming of Coq globals *) - -let global_names = Hashtbl.create 97 -let used_names = Hashtbl.create 97 - -let rename_global r = - try - Hashtbl.find global_names r - with Not_found -> - let rec loop id = - if Hashtbl.mem used_names id then - loop (lift_subscript id) - else begin - Hashtbl.add used_names id (); - let s = string_of_id id in - Hashtbl.add global_names r s; - s - end - in - loop (Nametab.basename_of_global r) - -let foralls = - List.fold_right - (fun (x,t) p -> Forall (x, t, p)) - -let fresh_var = function - | Anonymous -> rename_global (VarRef (id_of_string "x")) - | Name x -> rename_global (VarRef x) - -(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of - env names, and returns the new variables together with the new - environment *) -let coq_rename_vars env vars = - let avoid = ref (Termops.ids_of_named_context (Environ.named_context env)) in - List.fold_right - (fun (na,t) (newvars, newenv) -> - let id = next_name_away na !avoid in - avoid := id :: !avoid; - id :: newvars, Environ.push_named (id, None, t) newenv) - vars ([],env) - -(* extract the prenex type quantifications i.e. - type_quantifiers env (A1:Set)...(Ak:Set)t = A1...An, (env+Ai), t *) -let decomp_type_quantifiers env t = - let rec loop vars t = match kind_of_term t with - | Prod (n, a, t) when is_Set a || is_Type a -> - loop ((n,a) :: vars) t - | _ -> - let vars, env = coq_rename_vars env vars in - let t = substl (List.map mkVar vars) t in - List.rev vars, env, t - in - loop [] t - -(* same thing with lambda binders (for axiomatize body) *) -let decomp_type_lambdas env t = - let rec loop vars t = match kind_of_term t with - | Lambda (n, a, t) when is_Set a || is_Type a -> - loop ((n,a) :: vars) t - | _ -> - let vars, env = coq_rename_vars env vars in - let t = substl (List.map mkVar vars) t in - List.rev vars, env, t - in - loop [] t - -let decompose_arrows = - let rec arrows_rec l c = match kind_of_term c with - | Prod (_,t,c) when not (Termops.dependent (mkRel 1) c) -> arrows_rec (t :: l) c - | Cast (c,_,_) -> arrows_rec l c - | _ -> List.rev l, c - in - arrows_rec [] - -let rec eta_expanse t vars env i = - assert (i >= 0); - if i = 0 then - t, vars, env - else - match kind_of_term (Typing.type_of env Evd.empty t) with - | Prod (n, a, b) when not (Termops.dependent (mkRel 1) b) -> - let avoid = Termops.ids_of_named_context (Environ.named_context env) in - let id = next_name_away n avoid in - let env' = Environ.push_named (id, None, a) env in - let t' = mkApp (t, [| mkVar id |]) in - eta_expanse t' (id :: vars) env' (pred i) - | _ -> - assert false - -let rec skip_k_args k cl = match k, cl with - | 0, _ -> cl - | _, _ :: cl -> skip_k_args (k-1) cl - | _, [] -> raise NotFO - -(* Coq global references *) - -type global = Gnot_fo | Gfo of Fol.decl - -let globals = ref Refmap.empty -let globals_stack = ref [] - -(* synchronization *) -let () = - Summary.declare_summary "Dp globals" - { Summary.freeze_function = (fun () -> !globals, !globals_stack); - Summary.unfreeze_function = - (fun (g,s) -> globals := g; globals_stack := s); - Summary.init_function = (fun () -> ()) } - -let add_global r d = globals := Refmap.add r d !globals -let mem_global r = Refmap.mem r !globals -let lookup_global r = match Refmap.find r !globals with - | Gnot_fo -> raise NotFO - | Gfo d -> d - -let locals = Hashtbl.create 97 - -let lookup_local r = match Hashtbl.find locals r with - | Gnot_fo -> raise NotFO - | Gfo d -> d - -let iter_all_constructors i f = - let _, oib = Global.lookup_inductive i in - Array.iteri - (fun j tj -> f j (mkConstruct (i, j+1))) - oib.mind_nf_lc - - -(* injection c [t1,...,tn] adds the injection axiom - forall x1:t1,...,xn:tn,y1:t1,...,yn:tn. - c(x1,...,xn)=c(y1,...,yn) -> x1=y1 /\ ... /\ xn=yn *) - -let injection c l = - let i = ref 0 in - let var s = incr i; id_of_string (s ^ string_of_int !i) in - let xl = List.map (fun t -> rename_global (VarRef (var "x")), t) l in - i := 0; - let yl = List.map (fun t -> rename_global (VarRef (var "y")), t) l in - let f = - List.fold_right2 - (fun (x,_) (y,_) p -> And (Fatom (Eq (App (x,[]),App (y,[]))), p)) - xl yl True - in - let vars = List.map (fun (x,_) -> App(x,[])) in - let f = Imp (Fatom (Eq (App (c, vars xl), App (c, vars yl))), f) in - let foralls = List.fold_right (fun (x,t) p -> Forall (x, t, p)) in - let f = foralls xl (foralls yl f) in - let ax = Axiom ("injection_" ^ c, f) in - globals_stack := ax :: !globals_stack - -(* rec_names_for c [|n1;...;nk|] builds the list of constant names for - identifiers n1...nk with the same path as c, if they exist; otherwise - raises Not_found *) -let rec_names_for c = - let mp,dp,_ = Names.repr_con c in - array_map_to_list - (function - | Name id -> - let c' = Names.make_con mp dp (label_of_id id) in - ignore (Global.lookup_constant c'); - msgnl (Printer.pr_constr (mkConst c')); - c' - | Anonymous -> - raise Not_found) - -(* abstraction tables *) - -let term_abstractions = Hashtbl.create 97 - -let new_abstraction = - let r = ref 0 in fun () -> incr r; "abstraction_" ^ string_of_int !r - -(* Arithmetic constants *) - -exception NotArithConstant - -(* translates a closed Coq term p:positive into a FOL term of type int *) - -let big_two = Big_int.succ_big_int Big_int.unit_big_int - -let rec tr_positive p = match kind_of_term p with - | Term.Construct _ when p = Lazy.force coq_xH -> - Big_int.unit_big_int - | Term.App (f, [|a|]) when f = Lazy.force coq_xI -> -(* - Plus (Mult (Cst 2, tr_positive a), Cst 1) -*) - Big_int.succ_big_int (Big_int.mult_big_int big_two (tr_positive a)) - | Term.App (f, [|a|]) when f = Lazy.force coq_xO -> -(* - Mult (Cst 2, tr_positive a) -*) - Big_int.mult_big_int big_two (tr_positive a) - | Term.Cast (p, _, _) -> - tr_positive p - | _ -> - raise NotArithConstant - -(* translates a closed Coq term t:Z or R into a FOL term of type int or real *) -let rec tr_arith_constant t = match kind_of_term t with - | Term.Construct _ when t = Lazy.force coq_Z0 -> - Cst Big_int.zero_big_int - | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos -> - Cst (tr_positive a) - | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg -> - Cst (Big_int.minus_big_int (tr_positive a)) - | Term.Const _ when t = Lazy.force coq_R0 -> - RCst Big_int.zero_big_int - | Term.Const _ when t = Lazy.force coq_R1 -> - RCst Big_int.unit_big_int - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus -> - let ta = tr_arith_constant a in - let tb = tr_arith_constant b in - begin match ta,tb with - | RCst na, RCst nb -> RCst (Big_int.add_big_int na nb) - | _ -> raise NotArithConstant - end - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult -> - let ta = tr_arith_constant a in - let tb = tr_arith_constant b in - begin match ta,tb with - | RCst na, RCst nb -> RCst (Big_int.mult_big_int na nb) - | _ -> raise NotArithConstant - end - | Term.App (f, [|a;b|]) when f = Lazy.force coq_powerRZ -> - tr_powerRZ a b - | Term.Cast (t, _, _) -> - tr_arith_constant t - | _ -> - raise NotArithConstant - -(* translates a constant of the form (powerRZ 2 int_constant) *) -and tr_powerRZ a b = - (* checking first that a is (R1 + R1) *) - match kind_of_term a with - | Term.App (f, [|c;d|]) when f = Lazy.force coq_Rplus -> - begin - match kind_of_term c,kind_of_term d with - | Term.Const _, Term.Const _ - when c = Lazy.force coq_R1 && d = Lazy.force coq_R1 -> - begin - match tr_arith_constant b with - | Cst n -> Power2 n - | _ -> raise NotArithConstant - end - | _ -> raise NotArithConstant - end - | _ -> raise NotArithConstant - - -(* translate a Coq term t:Set into a FOL type expression; - tv = list of type variables *) -and tr_type tv env t = - let t = Reductionops.nf_betadeltaiota env Evd.empty t in - if t = Lazy.force coq_Z then - Tid ("int", []) - else if t = Lazy.force coq_R then - Tid ("real", []) - else match kind_of_term t with - | Var x when List.mem x tv -> - Tvar (string_of_id x) - | _ -> - let f, cl = decompose_app t in - begin try - let r = global_of_constr f in - match tr_global env r with - | DeclType (id, k) -> - assert (k = List.length cl); (* since t:Set *) - Tid (id, List.map (tr_type tv env) cl) - | _ -> - raise NotFO - with - | Not_found -> - raise NotFO - | NotFO -> - (* we need to abstract some part of (f cl) *) - (*TODO*) - raise NotFO - end - -and make_term_abstraction tv env c = - let ty = Typing.type_of env Evd.empty c in - let id = new_abstraction () in - match tr_decl env id ty with - | DeclFun (id,_,_,_) as _d -> - raise NotFO - (* [CM 07/09/2009] deactivated because it generates - unbound identifiers 'abstraction_<number>' - begin try - Hashtbl.find term_abstractions c - with Not_found -> - Hashtbl.add term_abstractions c id; - globals_stack := d :: !globals_stack; - id - end - *) - | _ -> - raise NotFO - -(* translate a Coq declaration id:ty in a FOL declaration, that is either - - a type declaration : DeclType (id, n) where n:int is the type arity - - a function declaration : DeclFun (id, tl, t) ; that includes constants - - a predicate declaration : DeclPred (id, tl) - - an axiom : Axiom (id, p) - *) -and tr_decl env id ty = - let tv, env, t = decomp_type_quantifiers env ty in - if is_Set t || is_Type t then - DeclType (id, List.length tv) - else if is_Prop t then - DeclPred (id, List.length tv, []) - else - let s = Typing.type_of env Evd.empty t in - if is_Prop s then - Axiom (id, tr_formula tv [] env t) - else - let l, t = decompose_arrows t in - let l = List.map (tr_type tv env) l in - if is_Prop t then - DeclPred(id, List.length tv, l) - else - let s = Typing.type_of env Evd.empty t in - if is_Set s || is_Type s then - DeclFun (id, List.length tv, l, tr_type tv env t) - else - raise NotFO - -(* tr_global(r) = tr_decl(id(r),typeof(r)) + a cache mechanism *) -and tr_global env r = match r with - | VarRef id -> - lookup_local id - | r -> - try - lookup_global r - with Not_found -> - try - let ty = Global.type_of_global r in - let id = rename_global r in - let d = tr_decl env id ty in - (* r can be already declared if it is a constructor *) - if not (mem_global r) then begin - add_global r (Gfo d); - globals_stack := d :: !globals_stack - end; - begin try axiomatize_body env r id d with NotFO -> () end; - d - with NotFO -> - add_global r Gnot_fo; - raise NotFO - -and axiomatize_body env r id d = match r with - | VarRef _ -> - assert false - | ConstRef c -> - begin match body_of_constant (Global.lookup_constant c) with - | Some b -> - let b = force b in - let axioms = - (match d with - | DeclPred (id, _, []) -> - let tv, env, b = decomp_type_lambdas env b in - let value = tr_formula tv [] env b in - [id, Iff (Fatom (Pred (id, [])), value)] - | DeclFun (id, _, [], _) -> - let tv, env, b = decomp_type_lambdas env b in - let value = tr_term tv [] env b in - [id, Fatom (Eq (Fol.App (id, []), value))] - | DeclFun (id, _, l, _) | DeclPred (id, _, l) -> - (*Format.eprintf "axiomatize_body %S@." id;*) - let b = match kind_of_term b with - (* a single recursive function *) - | Fix (_, (_,_,[|b|])) -> - subst1 (mkConst c) b - (* mutually recursive functions *) - | Fix ((_,i), (names,_,bodies)) -> - (* we only deal with named functions *) - begin try - let l = rec_names_for c names in - substl (List.rev_map mkConst l) bodies.(i) - with Not_found -> - b - end - | _ -> - b - in - let tv, env, b = decomp_type_lambdas env b in - let vars, t = decompose_lam b in - let n = List.length l in - let k = List.length vars in - assert (k <= n); - let vars, env = coq_rename_vars env vars in - let t = substl (List.map mkVar vars) t in - let t, vars, env = eta_expanse t vars env (n-k) in - let vars = List.rev vars in - let bv = vars in - let vars = List.map (fun x -> string_of_id x) vars in - let fol_var x = Fol.App (x, []) in - let fol_vars = List.map fol_var vars in - let vars = List.combine vars l in - begin match d with - | DeclFun (_, _, _, ty) -> - begin match kind_of_term t with - | Case (ci, _, e, br) -> - equations_for_case env id vars tv bv ci e br - | _ -> - let t = tr_term tv bv env t in - let ax = - add_proof (Fun_def (id, vars, ty, t)) - in - let p = Fatom (Eq (App (id, fol_vars), t)) in - [ax, foralls vars p] - end - | DeclPred _ -> - let value = tr_formula tv bv env t in - let p = Iff (Fatom (Pred (id, fol_vars)), value) in - [id, foralls vars p] - | _ -> - assert false - end - | DeclType _ -> - raise NotFO - | Axiom _ -> assert false) - in - let axioms = List.map (fun (id,ax) -> Axiom (id, ax)) axioms in - globals_stack := axioms @ !globals_stack - | None -> - () (* Coq axiom *) - end - | IndRef i -> - iter_all_constructors i - (fun _ c -> - let rc = global_of_constr c in - try - begin match tr_global env rc with - | DeclFun (_, _, [], _) -> () - | DeclFun (idc, _, al, _) -> injection idc al - | _ -> () - end - with NotFO -> - ()) - | _ -> () - -and equations_for_case env id vars tv bv ci e br = match kind_of_term e with - | Var x when List.exists (fun (y, _) -> string_of_id x = y) vars -> - let eqs = ref [] in - iter_all_constructors ci.ci_ind - (fun j cj -> - try - let cjr = global_of_constr cj in - begin match tr_global env cjr with - | DeclFun (idc, _, l, _) -> - let b = br.(j) in - let rec_vars, b = decompose_lam b in - let rec_vars, env = coq_rename_vars env rec_vars in - let coq_rec_vars = List.map mkVar rec_vars in - let b = substl coq_rec_vars b in - let rec_vars = List.rev rec_vars in - let coq_rec_term = applist (cj, List.rev coq_rec_vars) in - let b = replace_vars [x, coq_rec_term] b in - let bv = bv @ rec_vars in - let rec_vars = List.map string_of_id rec_vars in - let fol_var x = Fol.App (x, []) in - let fol_rec_vars = List.map fol_var rec_vars in - let fol_rec_term = App (idc, fol_rec_vars) in - let rec_vars = List.combine rec_vars l in - let fol_vars = List.map fst vars in - let fol_vars = List.map fol_var fol_vars in - let fol_vars = List.map (fun y -> match y with - | App (id, _) -> - if id = string_of_id x - then fol_rec_term - else y - | _ -> y) - fol_vars in - let vars = vars @ rec_vars in - let rec remove l e = match l with - | [] -> [] - | (y, t)::l' -> if y = string_of_id e then l' - else (y, t)::(remove l' e) in - let vars = remove vars x in - let p = - Fatom (Eq (App (id, fol_vars), - tr_term tv bv env b)) - in - eqs := (id ^ "_" ^ idc, foralls vars p) :: !eqs - | _ -> - assert false end - with NotFO -> - ()); - !eqs - | _ -> - raise NotFO - -(* assumption: t:T:Set *) -and tr_term tv bv env t = - try - tr_arith_constant t - with NotArithConstant -> - match kind_of_term t with - (* binary operations on integers *) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zplus -> - Plus (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zminus -> - Moins (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zmult -> - Mult (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zdiv -> - Div (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a|]) when f = Lazy.force coq_Zopp -> - Opp (tr_term tv bv env a) - (* binary operations on reals *) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus -> - Plus (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rminus -> - Moins (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult -> - Mult (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rdiv -> - Div (tr_term tv bv env a, tr_term tv bv env b) - | Term.Var id when List.mem id bv -> - App (string_of_id id, []) - | _ -> - let f, cl = decompose_app t in - begin try - let r = global_of_constr f in - match tr_global env r with - | DeclFun (s, k, _, _) -> - let cl = skip_k_args k cl in - Fol.App (s, List.map (tr_term tv bv env) cl) - | _ -> - raise NotFO - with - | Not_found -> - raise NotFO - | NotFO -> (* we need to abstract some part of (f cl) *) - let rec abstract app = function - | [] -> - Fol.App (make_term_abstraction tv env app, []) - | x :: l as args -> - begin try - let s = make_term_abstraction tv env app in - Fol.App (s, List.map (tr_term tv bv env) args) - with NotFO -> - abstract (applist (app, [x])) l - end - in - let app,l = match cl with - | x :: l -> applist (f, [x]), l | [] -> raise NotFO - in - abstract app l - end - -and quantifiers n a b tv bv env = - let vars, env = coq_rename_vars env [n,a] in - let id = match vars with [x] -> x | _ -> assert false in - let b = subst1 (mkVar id) b in - let t = tr_type tv env a in - let bv = id :: bv in - id, t, bv, env, b - -(* assumption: f is of type Prop *) -and tr_formula tv bv env f = - let c, args = decompose_app f in - match kind_of_term c, args with - | Var id, [] -> - Fatom (Pred (rename_global (VarRef id), [])) - | _, [t;a;b] when c = build_coq_eq () -> - let ty = Typing.type_of env Evd.empty t in - if is_Set ty || is_Type ty then - let _ = tr_type tv env t in - Fatom (Eq (tr_term tv bv env a, tr_term tv bv env b)) - else - raise NotFO - (* comparisons on integers *) - | _, [a;b] when c = Lazy.force coq_Zle -> - Fatom (Le (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Zlt -> - Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Zge -> - Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Zgt -> - Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b)) - (* comparisons on reals *) - | _, [a;b] when c = Lazy.force coq_Rle -> - Fatom (Le (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Rlt -> - Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Rge -> - Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Rgt -> - Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b)) - | _, [] when c = build_coq_False () -> - False - | _, [] when c = build_coq_True () -> - True - | _, [a] when c = build_coq_not () -> - Not (tr_formula tv bv env a) - | _, [a;b] when c = build_coq_and () -> - And (tr_formula tv bv env a, tr_formula tv bv env b) - | _, [a;b] when c = build_coq_or () -> - Or (tr_formula tv bv env a, tr_formula tv bv env b) - | _, [a;b] when c = Lazy.force coq_iff -> - Iff (tr_formula tv bv env a, tr_formula tv bv env b) - | Prod (n, a, b), _ -> - if is_Prop (Typing.type_of env Evd.empty a) then - Imp (tr_formula tv bv env a, tr_formula tv bv env b) - else - let id, t, bv, env, b = quantifiers n a b tv bv env in - Forall (string_of_id id, t, tr_formula tv bv env b) - | _, [_; a] when c = build_coq_ex () -> - begin match kind_of_term a with - | Lambda(n, a, b) -> - let id, t, bv, env, b = quantifiers n a b tv bv env in - Exists (string_of_id id, t, tr_formula tv bv env b) - | _ -> - (* unusual case of the shape (ex p) *) - raise NotFO (* TODO: we could eta-expanse *) - end - | _ -> - begin try - let r = global_of_constr c in - match tr_global env r with - | DeclPred (s, k, _) -> - let args = skip_k_args k args in - Fatom (Pred (s, List.map (tr_term tv bv env) args)) - | _ -> - raise NotFO - with Not_found -> - raise NotFO - end - - -let tr_goal gl = - Hashtbl.clear locals; - let tr_one_hyp (id, ty) = - try - let s = rename_global (VarRef id) in - let d = tr_decl (pf_env gl) s ty in - Hashtbl.add locals id (Gfo d); - d - with NotFO -> - Hashtbl.add locals id Gnot_fo; - raise NotFO - in - let hyps = - List.fold_right - (fun h acc -> try tr_one_hyp h :: acc with NotFO -> acc) - (pf_hyps_types gl) [] - in - let c = tr_formula [] [] (pf_env gl) (pf_concl gl) in - let hyps = List.rev_append !globals_stack (List.rev hyps) in - hyps, c - - -type prover = Simplify | Ergo | Yices | CVCLite | Harvey | Zenon | Gwhy | CVC3 | Z3 - -let remove_files = List.iter (fun f -> try Sys.remove f with _ -> ()) - -let sprintf = Format.sprintf - -let file_contents f = - let buf = Buffer.create 1024 in - try - let c = open_in f in - begin try - while true do - let s = input_line c in Buffer.add_string buf s; - Buffer.add_char buf '\n' - done; - assert false - with End_of_file -> - close_in c; - Buffer.contents buf - end - with _ -> - sprintf "(cannot open %s)" f - -let timeout_sys_command cmd = - if !debug then Format.eprintf "command line: %s@." cmd; - let out = Filename.temp_file "out" "" in - let cmd = sprintf "why-cpulimit %d %s > %s 2>&1" !timeout cmd out in - let ret = Sys.command cmd in - if !debug then - Format.eprintf "Output file %s:@.%s@." out (file_contents out); - ret, out - -let timeout_or_failure c cmd out = - if c = 152 then - Timeout - else - Failure - (sprintf "command %s failed with output:\n%s " cmd (file_contents out)) - -let call_prover ?(opt="") file = - if !debug then Format.eprintf "calling prover on %s@." file; - let out = Filename.temp_file "out" "" in - let cmd = - sprintf "why-dp -timeout %d -batch %s > %s 2>&1" !timeout file out in - match Sys.command cmd with - 0 -> Valid None - | 1 -> Failure (sprintf "could not run why-dp\n%s" (file_contents out)) - | 2 -> Invalid - | 3 -> DontKnow - | 4 -> Timeout - | 5 -> Failure (sprintf "prover failed:\n%s" (file_contents out)) - | n -> Failure (sprintf "Unknown exit status of why-dp: %d" n) - -let prelude_files = ref ([] : string list) - -let set_prelude l = prelude_files := l - -let dp_prelude_obj : string list -> obj = - declare_object - {(default_object "Dp_prelude") with - cache_function = (fun (_,x) -> set_prelude x); - load_function = (fun _ (_,x) -> set_prelude x)} - -let dp_prelude x = Lib.add_anonymous_leaf (dp_prelude_obj x) - -let why_files f = String.concat " " (!prelude_files @ [f]) - -let call_simplify fwhy = - let cmd = - sprintf "why --simplify %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fsx = Filename.chop_suffix fwhy ".why" ^ "_why.sx" in -(* - let cmd = - sprintf "why-cpulimit %d Simplify %s > out 2>&1 && grep -q -w Valid out" - !timeout fsx - in - let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout - in -*) - let r = call_prover fsx in - if not !debug then remove_files [fwhy; fsx]; - r - -let call_ergo fwhy = - let cmd = sprintf "why --alt-ergo %s" (why_files fwhy) in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fwhy = Filename.chop_suffix fwhy ".why" ^ "_why.why" in - (*let ftrace = Filename.temp_file "ergo_trace" "" in*) - (*NB: why-dp can't handle -cctrace - let cmd = - if !trace then - sprintf "alt-ergo -cctrace %s %s" ftrace fwhy - - else - sprintf "alt-ergo %s" fwhy - in*) - let r = call_prover fwhy in - if not !debug then remove_files [fwhy; (*out*)]; - r - - -let call_zenon fwhy = - let cmd = - sprintf "why --no-zenon-prelude --zenon %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in -(* why-dp won't let us having coqterm... - let out = Filename.temp_file "dp_out" "" in - let cmd = - sprintf "timeout %d zenon -ocoqterm %s > %s 2>&1" !timeout fznn out - in - let c = Sys.command cmd in - if not !debug then remove_files [fwhy; fznn]; - if c = 137 then - Timeout - else begin - if c <> 0 then anomaly ("command failed: " ^ cmd); - if Sys.command (sprintf "grep -q -w Error %s" out) = 0 then - error "Zenon failed"; - let c = Sys.command (sprintf "grep -q PROOF-FOUND %s" out) in - if c = 0 then Valid (Some out) else Invalid - end - *) - let r = call_prover fznn in - if not !debug then remove_files [fwhy; fznn]; - r - -let call_smt ~smt fwhy = - let cmd = - sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in - let opt = "-smt-solver " ^ smt in - let r = call_prover ~opt fsmt in - if not !debug then remove_files [fwhy; fsmt]; - r - -(* -let call_yices fwhy = - let cmd = - sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in - let cmd = - sprintf "why-cpulimit %d yices -pc 0 -smt %s > out 2>&1 && grep -q -w unsat out" - !timeout fsmt - in - let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout - in - if not !debug then remove_files [fwhy; fsmt]; - r - -let call_cvc3 fwhy = - let cmd = - sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in - let cmd = - sprintf "why-cpulimit %d cvc3 -lang smt %s > out 2>&1 && grep -q -w unsat out" - !timeout fsmt - in - let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout - in - if not !debug then remove_files [fwhy; fsmt]; - r -*) - -let call_cvcl fwhy = - let cmd = - sprintf "why --cvcl --encoding sstrat %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fcvc = Filename.chop_suffix fwhy ".why" ^ "_why.cvc" in -(* - let cmd = - sprintf "timeout %d cvcl < %s > out 2>&1 && grep -q -w Valid out" - !timeout fcvc - in - let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout - in -*) - let r = call_prover fcvc in - if not !debug then remove_files [fwhy; fcvc]; - r - -let call_harvey fwhy = - let cmd = - sprintf "why --harvey --encoding strat %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let frv = Filename.chop_suffix fwhy ".why" ^ "_why.rv" in -(* - let out = Sys.command (sprintf "rvc -e -t %s > /dev/null 2>&1" frv) in - if out <> 0 then anomaly ("call to rvc -e -t " ^ frv ^ " failed"); - let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in - let outf = Filename.temp_file "rv" ".out" in - let out = - Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1" - !timeout f outf) - in - let r = - if out <> 0 then - Timeout - else - let cmd = - sprintf "grep \"Proof obligation in\" %s | grep -q \"is valid\"" outf - in - if Sys.command cmd = 0 then Valid None else Invalid - in - if not !debug then remove_files [fwhy; frv; outf]; -*) - let r = call_prover frv in - if not !debug then remove_files [fwhy; frv]; - r - -let call_gwhy fwhy = - let cmd = sprintf "gwhy %s" (why_files fwhy) in - if Sys.command cmd <> 0 then ignore (Sys.command (sprintf "emacs %s" fwhy)); - NoAnswer - -let ergo_proof_from_file f gl = - let s = - let buf = Buffer.create 1024 in - let c = open_in f in - try - while true do Buffer.add_string buf (input_line c) done; assert false - with End_of_file -> - close_in c; - Buffer.contents buf - in - let parsed_constr = Pcoq.parse_string Pcoq.Constr.constr s in - let t = Constrintern.interp_constr (project gl) (pf_env gl) parsed_constr in - exact_check t gl - -let call_prover prover q = - let fwhy = Filename.temp_file "coq_dp" ".why" in - Dp_why.output_file fwhy q; - match prover with - | Simplify -> call_simplify fwhy - | Ergo -> call_ergo fwhy - | CVC3 -> call_smt ~smt:"cvc3" fwhy - | Yices -> call_smt ~smt:"yices" fwhy - | Z3 -> call_smt ~smt:"z3" fwhy - | Zenon -> call_zenon fwhy - | CVCLite -> call_cvcl fwhy - | Harvey -> call_harvey fwhy - | Gwhy -> call_gwhy fwhy - -let dp prover gl = - Coqlib.check_required_library ["Coq";"ZArith";"ZArith"]; - let concl_type = pf_type_of gl (pf_concl gl) in - if not (is_Prop concl_type) then error "Conclusion is not a Prop"; - try - let q = tr_goal gl in - begin match call_prover prover q with - | Valid (Some f) when prover = Zenon -> Dp_zenon.proof_from_file f gl - | Valid (Some f) when prover = Ergo -> ergo_proof_from_file f gl - | Valid _ -> Tactics.admit_as_an_axiom gl - | Invalid -> error "Invalid" - | DontKnow -> error "Don't know" - | Timeout -> error "Timeout" - | Failure s -> error s - | NoAnswer -> Tacticals.tclIDTAC gl - end - with NotFO -> - error "Not a first order goal" - - -let simplify = tclTHEN intros (dp Simplify) -let ergo = tclTHEN intros (dp Ergo) -let cvc3 = tclTHEN intros (dp CVC3) -let yices = tclTHEN intros (dp Yices) -let z3 = tclTHEN intros (dp Z3) -let cvc_lite = tclTHEN intros (dp CVCLite) -let harvey = dp Harvey -let zenon = tclTHEN intros (dp Zenon) -let gwhy = tclTHEN intros (dp Gwhy) - -let dp_hint l = - let env = Global.env () in - let one_hint (qid,r) = - if not (mem_global r) then begin - let ty = Global.type_of_global r in - let s = Typing.type_of env Evd.empty ty in - if is_Prop s then - try - let id = rename_global r in - let tv, env, ty = decomp_type_quantifiers env ty in - let d = Axiom (id, tr_formula tv [] env ty) in - add_global r (Gfo d); - globals_stack := d :: !globals_stack - with NotFO -> - add_global r Gnot_fo; - msg_warning - (pr_reference qid ++ - str " ignored (not a first order proposition)") - else begin - add_global r Gnot_fo; - msg_warning - (pr_reference qid ++ str " ignored (not a proposition)") - end - end - in - List.iter one_hint (List.map (fun qid -> qid, Nametab.global qid) l) - -let dp_hint_obj : reference list -> obj = - declare_object - {(default_object "Dp_hint") with - cache_function = (fun (_,l) -> dp_hint l); - load_function = (fun _ (_,l) -> dp_hint l)} - -let dp_hint l = Lib.add_anonymous_leaf (dp_hint_obj l) - -let dp_predefined qid s = - let r = Nametab.global qid in - let ty = Global.type_of_global r in - let env = Global.env () in - let id = rename_global r in - try - let d = match tr_decl env id ty with - | DeclType (_, n) -> DeclType (s, n) - | DeclFun (_, n, tyl, ty) -> DeclFun (s, n, tyl, ty) - | DeclPred (_, n, tyl) -> DeclPred (s, n, tyl) - | Axiom _ as d -> d - in - match d with - | Axiom _ -> msg_warning (str " ignored (axiom)") - | d -> add_global r (Gfo d) - with NotFO -> - msg_warning (str " ignored (not a first order declaration)") - -let dp_predefined_obj : reference * string -> obj = - declare_object - {(default_object "Dp_predefined") with - cache_function = (fun (_,(id,s)) -> dp_predefined id s); - load_function = (fun _ (_,(id,s)) -> dp_predefined id s)} - -let dp_predefined id s = Lib.add_anonymous_leaf (dp_predefined_obj (id,s)) - -let _ = declare_summary "Dp options" - { freeze_function = - (fun () -> !debug, !trace, !timeout, !prelude_files); - unfreeze_function = - (fun (d,tr,tm,pr) -> - debug := d; trace := tr; timeout := tm; prelude_files := pr); - init_function = - (fun () -> - debug := false; trace := false; timeout := 10; - prelude_files := []) } diff --git a/plugins/dp/dp.mli b/plugins/dp/dp.mli deleted file mode 100644 index f40f8688..00000000 --- a/plugins/dp/dp.mli +++ /dev/null @@ -1,20 +0,0 @@ - -open Libnames -open Proof_type - -val simplify : tactic -val ergo : tactic -val cvc3 : tactic -val yices : tactic -val cvc_lite : tactic -val harvey : tactic -val zenon : tactic -val gwhy : tactic -val z3: tactic - -val dp_hint : reference list -> unit -val dp_timeout : int -> unit -val dp_debug : bool -> unit -val dp_trace : bool -> unit -val dp_prelude : string list -> unit -val dp_predefined : reference -> string -> unit diff --git a/plugins/dp/dp_plugin.mllib b/plugins/dp/dp_plugin.mllib deleted file mode 100644 index 63252d6a..00000000 --- a/plugins/dp/dp_plugin.mllib +++ /dev/null @@ -1,5 +0,0 @@ -Dp_why -Dp_zenon -Dp -G_dp -Dp_plugin_mod diff --git a/plugins/dp/dp_why.ml b/plugins/dp/dp_why.ml deleted file mode 100644 index 199c3087..00000000 --- a/plugins/dp/dp_why.ml +++ /dev/null @@ -1,185 +0,0 @@ - -(* Pretty-print PFOL (see fol.mli) in Why syntax *) - -open Format -open Fol - -type proof = - | Immediate of Term.constr - | Fun_def of string * (string * typ) list * typ * term - -let proofs = Hashtbl.create 97 -let proof_name = - let r = ref 0 in fun () -> incr r; "dp_axiom__" ^ string_of_int !r - -let add_proof pr = let n = proof_name () in Hashtbl.add proofs n pr; n - -let find_proof = Hashtbl.find proofs - -let rec print_list sep print fmt = function - | [] -> () - | [x] -> print fmt x - | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r - -let space fmt () = fprintf fmt "@ " -let comma fmt () = fprintf fmt ",@ " - -let is_why_keyword = - let h = Hashtbl.create 17 in - List.iter - (fun s -> Hashtbl.add h s ()) - ["absurd"; "and"; "array"; "as"; "assert"; "axiom"; "begin"; - "bool"; "do"; "done"; "else"; "end"; "exception"; "exists"; - "external"; "false"; "for"; "forall"; "fun"; "function"; "goal"; - "if"; "in"; "int"; "invariant"; "label"; "let"; "logic"; "not"; - "of"; "or"; "parameter"; "predicate"; "prop"; "raise"; "raises"; - "reads"; "real"; "rec"; "ref"; "returns"; "then"; "true"; "try"; - "type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ]; - Hashtbl.mem h - -let ident fmt s = - if is_why_keyword s then fprintf fmt "coq__%s" s else fprintf fmt "%s" s - -let rec print_typ fmt = function - | Tvar x -> fprintf fmt "'%a" ident x - | Tid ("int", []) -> fprintf fmt "int" - | Tid ("real", []) -> fprintf fmt "real" - | Tid (x, []) -> fprintf fmt "%a" ident x - | Tid (x, [t]) -> fprintf fmt "%a %a" print_typ t ident x - | Tid (x,tl) -> fprintf fmt "(%a) %a" (print_list comma print_typ) tl ident x - -let print_arg fmt (id,typ) = fprintf fmt "%a: %a" ident id print_typ typ - -let rec print_term fmt = function - | Cst n -> - fprintf fmt "%s" (Big_int.string_of_big_int n) - | RCst s -> - fprintf fmt "%s.0" (Big_int.string_of_big_int s) - | Power2 n -> - fprintf fmt "0x1p%s" (Big_int.string_of_big_int n) - | Plus (a, b) -> - fprintf fmt "@[(%a +@ %a)@]" print_term a print_term b - | Moins (a, b) -> - fprintf fmt "@[(%a -@ %a)@]" print_term a print_term b - | Mult (a, b) -> - fprintf fmt "@[(%a *@ %a)@]" print_term a print_term b - | Div (a, b) -> - fprintf fmt "@[(%a /@ %a)@]" print_term a print_term b - | Opp (a) -> - fprintf fmt "@[(-@ %a)@]" print_term a - | App (id, []) -> - fprintf fmt "%a" ident id - | App (id, tl) -> - fprintf fmt "@[%a(%a)@]" ident id print_terms tl - -and print_terms fmt tl = - print_list comma print_term fmt tl - -let rec print_predicate fmt p = - let pp = print_predicate in - match p with - | True -> - fprintf fmt "true" - | False -> - fprintf fmt "false" - | Fatom (Eq (a, b)) -> - fprintf fmt "@[(%a =@ %a)@]" print_term a print_term b - | Fatom (Le (a, b)) -> - fprintf fmt "@[(%a <=@ %a)@]" print_term a print_term b - | Fatom (Lt (a, b))-> - fprintf fmt "@[(%a <@ %a)@]" print_term a print_term b - | Fatom (Ge (a, b)) -> - fprintf fmt "@[(%a >=@ %a)@]" print_term a print_term b - | Fatom (Gt (a, b)) -> - fprintf fmt "@[(%a >@ %a)@]" print_term a print_term b - | Fatom (Pred (id, [])) -> - fprintf fmt "%a" ident id - | Fatom (Pred (id, tl)) -> - fprintf fmt "@[%a(%a)@]" ident id print_terms tl - | Imp (a, b) -> - fprintf fmt "@[(%a ->@ %a)@]" pp a pp b - | Iff (a, b) -> - fprintf fmt "@[(%a <->@ %a)@]" pp a pp b - | And (a, b) -> - fprintf fmt "@[(%a and@ %a)@]" pp a pp b - | Or (a, b) -> - fprintf fmt "@[(%a or@ %a)@]" pp a pp b - | Not a -> - fprintf fmt "@[(not@ %a)@]" pp a - | Forall (id, t, p) -> - fprintf fmt "@[(forall %a:%a.@ %a)@]" ident id print_typ t pp p - | Exists (id, t, p) -> - fprintf fmt "@[(exists %a:%a.@ %a)@]" ident id print_typ t pp p - -let rec remove_iff args = function - Forall (id,t,p) -> remove_iff ((id,t)::args) p - | Iff(_,b) -> List.rev args, b - | _ -> raise Not_found - -let print_query fmt (decls,concl) = - let find_declared_preds l = - function - DeclPred (id,_,args) -> (id,args) :: l - | _ -> l - in - let find_defined_preds declared l = function - Axiom(id,f) -> - (try - let _decl = List.assoc id declared in - (id,remove_iff [] f)::l - with Not_found -> l) - | _ -> l - in - let declared_preds = - List.fold_left find_declared_preds [] decls in - let defined_preds = - List.fold_left (find_defined_preds declared_preds) [] decls - in - let print_dtype = function - | DeclType (id, 0) -> - fprintf fmt "@[type %a@]@\n@\n" ident id - | DeclType (id, 1) -> - fprintf fmt "@[type 'a %a@]@\n@\n" ident id - | DeclType (id, n) -> - fprintf fmt "@[type ("; - for i = 1 to n do - fprintf fmt "'a%d" i; if i < n then fprintf fmt ", " - done; - fprintf fmt ") %a@]@\n@\n" ident id - | DeclFun _ | DeclPred _ | Axiom _ -> - () - in - let print_dvar_dpred = function - | DeclFun (id, _, [], t) -> - fprintf fmt "@[logic %a : -> %a@]@\n@\n" ident id print_typ t - | DeclFun (id, _, l, t) -> - fprintf fmt "@[logic %a : %a -> %a@]@\n@\n" - ident id (print_list comma print_typ) l print_typ t - | DeclPred (id, _, []) when not (List.mem_assoc id defined_preds) -> - fprintf fmt "@[logic %a : -> prop @]@\n@\n" ident id - | DeclPred (id, _, l) when not (List.mem_assoc id defined_preds) -> - fprintf fmt "@[logic %a : %a -> prop@]@\n@\n" - ident id (print_list comma print_typ) l - | DeclType _ | Axiom _ | DeclPred _ -> - () - in - let print_assert = function - | Axiom(id,_) when List.mem_assoc id defined_preds -> - let args, def = List.assoc id defined_preds in - fprintf fmt "@[predicate %a(%a) =@\n%a@]@\n" ident id - (print_list comma print_arg) args print_predicate def - | Axiom (id, f) -> - fprintf fmt "@[<hov 2>axiom %a:@ %a@]@\n@\n" ident id print_predicate f - | DeclType _ | DeclFun _ | DeclPred _ -> - () - in - List.iter print_dtype decls; - List.iter print_dvar_dpred decls; - List.iter print_assert decls; - fprintf fmt "@[<hov 2>goal coq___goal: %a@]" print_predicate concl - -let output_file f q = - let c = open_out f in - let fmt = formatter_of_out_channel c in - fprintf fmt "@[%a@]@." print_query q; - close_out c diff --git a/plugins/dp/dp_why.mli b/plugins/dp/dp_why.mli deleted file mode 100644 index 0efa24a2..00000000 --- a/plugins/dp/dp_why.mli +++ /dev/null @@ -1,17 +0,0 @@ - -open Fol - -(* generation of the Why file *) - -val output_file : string -> query -> unit - -(* table to translate the proofs back to Coq (used in dp_zenon) *) - -type proof = - | Immediate of Term.constr - | Fun_def of string * (string * typ) list * typ * term - -val add_proof : proof -> string -val find_proof : string -> proof - - diff --git a/plugins/dp/dp_zenon.mli b/plugins/dp/dp_zenon.mli deleted file mode 100644 index 0a727d1f..00000000 --- a/plugins/dp/dp_zenon.mli +++ /dev/null @@ -1,7 +0,0 @@ - -open Fol - -val set_debug : bool -> unit - -val proof_from_file : string -> Proof_type.tactic - diff --git a/plugins/dp/dp_zenon.mll b/plugins/dp/dp_zenon.mll deleted file mode 100644 index 949e91e3..00000000 --- a/plugins/dp/dp_zenon.mll +++ /dev/null @@ -1,189 +0,0 @@ - -{ - - open Lexing - open Pp - open Util - open Names - open Tacmach - open Dp_why - open Tactics - open Tacticals - - let debug = ref false - let set_debug b = debug := b - - let buf = Buffer.create 1024 - - let string_of_global env ref = - Libnames.string_of_qualid (Nametab.shortest_qualid_of_global env ref) - - let axioms = ref [] - - (* we cannot interpret the terms as we read them (since some lemmas - may need other lemmas to be already interpreted) *) - type lemma = { l_id : string; l_type : string; l_proof : string } - type zenon_proof = lemma list * string - -} - -let ident = ['a'-'z' 'A'-'Z' '_' '0'-'9' '\'']+ -let space = [' ' '\t' '\r'] - -rule start = parse -| "(* BEGIN-PROOF *)" "\n" { scan lexbuf } -| _ { start lexbuf } -| eof { anomaly "malformed Zenon proof term" } - -(* here we read the lemmas and the main proof term; - meanwhile we maintain the set of axioms that were used *) - -and scan = parse -| "Let" space (ident as id) space* ":" - { let t = read_coq_term lexbuf in - let p = read_lemma_proof lexbuf in - let l,pr = scan lexbuf in - { l_id = id; l_type = t; l_proof = p } :: l, pr } -| "Definition theorem:" - { let t = read_main_proof lexbuf in [], t } -| _ | eof - { anomaly "malformed Zenon proof term" } - -and read_coq_term = parse -| "." "\n" - { let s = Buffer.contents buf in Buffer.clear buf; s } -| "coq__" (ident as id) (* a Why keyword renamed *) - { Buffer.add_string buf id; read_coq_term lexbuf } -| ("dp_axiom__" ['0'-'9']+) as id - { axioms := id :: !axioms; Buffer.add_string buf id; read_coq_term lexbuf } -| _ as c - { Buffer.add_char buf c; read_coq_term lexbuf } -| eof - { anomaly "malformed Zenon proof term" } - -and read_lemma_proof = parse -| "Proof" space - { read_coq_term lexbuf } -| _ | eof - { anomaly "malformed Zenon proof term" } - -(* skip the main proof statement and then read its term *) -and read_main_proof = parse -| ":=" "\n" - { read_coq_term lexbuf } -| _ - { read_main_proof lexbuf } -| eof - { anomaly "malformed Zenon proof term" } - - -{ - - let read_zenon_proof f = - Buffer.clear buf; - let c = open_in f in - let lb = from_channel c in - let p = start lb in - close_in c; - if not !debug then begin try Sys.remove f with _ -> () end; - p - - let constr_of_string gl s = - let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in - Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s) - - (* we are lazy here: we build strings containing Coq terms using a *) - (* pretty-printer Fol -> Coq *) - module Coq = struct - open Format - open Fol - - let rec print_list sep print fmt = function - | [] -> () - | [x] -> print fmt x - | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r - - let space fmt () = fprintf fmt "@ " - let comma fmt () = fprintf fmt ",@ " - - let rec print_typ fmt = function - | Tvar x -> fprintf fmt "%s" x - | Tid ("int", []) -> fprintf fmt "Z" - | Tid (x, []) -> fprintf fmt "%s" x - | Tid (x, [t]) -> fprintf fmt "(%s %a)" x print_typ t - | Tid (x,tl) -> - fprintf fmt "(%s %a)" x (print_list comma print_typ) tl - - let rec print_term fmt = function - | Cst n -> - fprintf fmt "%s" (Big_int.string_of_big_int n) - | RCst s -> - fprintf fmt "%s" (Big_int.string_of_big_int s) - | Power2 n -> - fprintf fmt "@[(powerRZ 2 %s)@]" (Big_int.string_of_big_int n) - - (* TODO: bug, it might be operations on reals *) - | Plus (a, b) -> - fprintf fmt "@[(Zplus %a %a)@]" print_term a print_term b - | Moins (a, b) -> - fprintf fmt "@[(Zminus %a %a)@]" print_term a print_term b - | Mult (a, b) -> - fprintf fmt "@[(Zmult %a %a)@]" print_term a print_term b - | Div (a, b) -> - fprintf fmt "@[(Zdiv %a %a)@]" print_term a print_term b - | Opp (a) -> - fprintf fmt "@[(Zopp %a)@]" print_term a - | App (id, []) -> - fprintf fmt "%s" id - | App (id, tl) -> - fprintf fmt "@[(%s %a)@]" id print_terms tl - - and print_terms fmt tl = - print_list space print_term fmt tl - - (* builds the text for "forall vars, f vars = t" *) - let fun_def_axiom f vars t = - let binder fmt (x,t) = fprintf fmt "(%s: %a)" x print_typ t in - fprintf str_formatter - "@[(forall %a, %s %a = %a)@]@." - (print_list space binder) vars f - (print_list space (fun fmt (x,_) -> pp_print_string fmt x)) vars - print_term t; - flush_str_formatter () - - end - - let prove_axiom id = match Dp_why.find_proof id with - | Immediate t -> - exact_check t - | Fun_def (f, vars, ty, t) -> - tclTHENS - (fun gl -> - let s = Coq.fun_def_axiom f vars t in - if !debug then Format.eprintf "axiom fun def = %s@." s; - let c = constr_of_string gl s in - assert_tac (Name (id_of_string id)) c gl) - [tclTHEN intros reflexivity; tclIDTAC] - - let exact_string s gl = - let c = constr_of_string gl s in - exact_check c gl - - let interp_zenon_proof (ll,p) = - let interp_lemma l gl = - let ty = constr_of_string gl l.l_type in - tclTHENS - (assert_tac (Name (id_of_string l.l_id)) ty) - [exact_string l.l_proof; tclIDTAC] - gl - in - tclTHEN (tclMAP interp_lemma ll) (exact_string p) - - let proof_from_file f = - axioms := []; - msgnl (str "proof_from_file " ++ str f); - let zp = read_zenon_proof f in - msgnl (str "proof term is " ++ str (snd zp)); - tclTHEN (tclMAP prove_axiom !axioms) (interp_zenon_proof zp) - -} diff --git a/plugins/dp/fol.mli b/plugins/dp/fol.mli deleted file mode 100644 index 4fb763a6..00000000 --- a/plugins/dp/fol.mli +++ /dev/null @@ -1,58 +0,0 @@ - -(* Polymorphic First-Order Logic (that is Why's input logic) *) - -type typ = - | Tvar of string - | Tid of string * typ list - -type term = - | Cst of Big_int.big_int - | RCst of Big_int.big_int - | Power2 of Big_int.big_int - | Plus of term * term - | Moins of term * term - | Mult of term * term - | Div of term * term - | Opp of term - | App of string * term list - -and atom = - | Eq of term * term - | Le of term * term - | Lt of term * term - | Ge of term * term - | Gt of term * term - | Pred of string * term list - -and form = - | Fatom of atom - | Imp of form * form - | Iff of form * form - | And of form * form - | Or of form * form - | Not of form - | Forall of string * typ * form - | Exists of string * typ * form - | True - | False - -(* the integer indicates the number of type variables *) -type decl = - | DeclType of string * int - | DeclFun of string * int * typ list * typ - | DeclPred of string * int * typ list - | Axiom of string * form - -type query = decl list * form - - -(* prover result *) - -type prover_answer = - | Valid of string option - | Invalid - | DontKnow - | Timeout - | NoAnswer - | Failure of string - diff --git a/plugins/dp/g_dp.ml4 b/plugins/dp/g_dp.ml4 deleted file mode 100644 index 001ccce8..00000000 --- a/plugins/dp/g_dp.ml4 +++ /dev/null @@ -1,77 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -open Dp - -TACTIC EXTEND Simplify - [ "simplify" ] -> [ simplify ] -END - -TACTIC EXTEND Ergo - [ "ergo" ] -> [ ergo ] -END - -TACTIC EXTEND Yices - [ "yices" ] -> [ yices ] -END - -TACTIC EXTEND CVC3 - [ "cvc3" ] -> [ cvc3 ] -END - -TACTIC EXTEND Z3 - [ "z3" ] -> [ z3 ] -END - -TACTIC EXTEND CVCLite - [ "cvcl" ] -> [ cvc_lite ] -END - -TACTIC EXTEND Harvey - [ "harvey" ] -> [ harvey ] -END - -TACTIC EXTEND Zenon - [ "zenon" ] -> [ zenon ] -END - -TACTIC EXTEND Gwhy - [ "gwhy" ] -> [ gwhy ] -END - -(* should be part of basic tactics syntax *) -TACTIC EXTEND admit - [ "admit" ] -> [ Tactics.admit_as_an_axiom ] -END - -VERNAC COMMAND EXTEND Dp_hint - [ "Dp_hint" ne_global_list(l) ] -> [ dp_hint l ] -END - -VERNAC COMMAND EXTEND Dp_timeout -| [ "Dp_timeout" natural(n) ] -> [ dp_timeout n ] -END - -VERNAC COMMAND EXTEND Dp_prelude -| [ "Dp_prelude" string_list(l) ] -> [ dp_prelude l ] -END - -VERNAC COMMAND EXTEND Dp_predefined -| [ "Dp_predefined" global(g) "=>" string(s) ] -> [ dp_predefined g s ] -END - -VERNAC COMMAND EXTEND Dp_debug -| [ "Dp_debug" ] -> [ dp_debug true; Dp_zenon.set_debug true ] -END - -VERNAC COMMAND EXTEND Dp_trace -| [ "Dp_trace" ] -> [ dp_trace true ] -END - diff --git a/plugins/dp/test2.v b/plugins/dp/test2.v deleted file mode 100644 index ce660052..00000000 --- a/plugins/dp/test2.v +++ /dev/null @@ -1,80 +0,0 @@ -Require Import ZArith. -Require Import Classical. -Require Import List. - -Open Scope list_scope. -Open Scope Z_scope. - -Dp_debug. -Dp_timeout 3. -Require Export zenon. - -Definition neg (z:Z) : Z := match z with - | Z0 => Z0 - | Zpos p => Zneg p - | Zneg p => Zpos p - end. - -Goal forall z, neg (neg z) = z. - Admitted. - -Open Scope nat_scope. -Print plus. - -Goal forall x, x+0=x. - induction x; ergo. - (* simplify resoud le premier, pas le second *) - Admitted. - -Goal 1::2::3::nil = 1::2::(1+2)::nil. - zenon. - Admitted. - -Definition T := nat. -Parameter fct : T -> nat. -Goal fct O = O. - Admitted. - -Fixpoint even (n:nat) : Prop := - match n with - O => True - | S O => False - | S (S p) => even p - end. - -Goal even 4%nat. - try zenon. - Admitted. - -Definition p (A B:Set) (a:A) (b:B) : list (A*B) := cons (a,b) nil. - -Definition head := -fun (A : Set) (l : list A) => -match l with -| nil => None (A:=A) -| x :: _ => Some x -end. - -Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1. - -Admitted. - -(* -BUG avec head prédéfini : manque eta-expansion sur A:Set - -Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1. - -Print value. -Print Some. - -zenon. -*) - -Inductive IN (A:Set) : A -> list A -> Prop := - | IN1 : forall x l, IN A x (x::l) - | IN2: forall x l, IN A x l -> forall y, IN A x (y::l). -Arguments IN [A] _ _. - -Goal forall x, forall (l:list nat), IN x l -> IN x (1%nat::l). - zenon. -Print In. diff --git a/plugins/dp/tests.v b/plugins/dp/tests.v deleted file mode 100644 index dc85d2ee..00000000 --- a/plugins/dp/tests.v +++ /dev/null @@ -1,300 +0,0 @@ - -Require Import ZArith. -Require Import Classical. -Require Export Reals. - - -(* real numbers *) - -Lemma real_expr: (0 <= 9 * 4)%R. -ergo. -Qed. - -Lemma powerRZ_translation: (powerRZ 2 15 < powerRZ 2 17)%R. -ergo. -Qed. - -Dp_debug. -Dp_timeout 3. - -(* module renamings *) - -Module M. - Parameter t : Set. -End M. - -Lemma test_module_0 : forall x:M.t, x=x. -ergo. -Qed. - -Module N := M. - -Lemma test_module_renaming_0 : forall x:N.t, x=x. -ergo. -Qed. - -Dp_predefined M.t => "int". - -Lemma test_module_renaming_1 : forall x:N.t, x=x. -ergo. -Qed. - -(* Coq lists *) - -Require Export List. - -Lemma test_pol_0 : forall l:list nat, l=l. -ergo. -Qed. - -Parameter nlist: list nat -> Prop. - -Lemma poly_1 : forall l, nlist l -> True. -intros. -simplify. -Qed. - -(* user lists *) - -Inductive list (A:Set) : Set := -| nil : list A -| cons: forall a:A, list A -> list A. - -Fixpoint app (A:Set) (l m:list A) {struct l} : list A := -match l with -| nil => m -| cons a l1 => cons A a (app A l1 m) -end. - -Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True. -intros; ergo. -Qed. - -(* polymorphism *) -Require Import List. - -Inductive mylist (A:Set) : Set := - mynil : mylist A -| mycons : forall a:A, mylist A -> mylist A. - -Parameter my_nlist: mylist nat -> Prop. - - Goal forall l, my_nlist l -> True. - intros. - simplify. -Qed. - -(* First example with the 0 and the equality translated *) - -Goal 0 = 0. -simplify. -Qed. - -(* Examples in the Propositional Calculus - and theory of equality *) - -Parameter A C : Prop. - -Goal A -> A. -simplify. -Qed. - - -Goal A -> (A \/ C). - -simplify. -Qed. - - -Parameter x y z : Z. - -Goal x = y -> y = z -> x = z. -ergo. -Qed. - - -Goal ((((A -> C) -> A) -> A) -> C) -> C. - -ergo. -Qed. - -(* Arithmetic *) -Open Scope Z_scope. - -Goal 1 + 1 = 2. -yices. -Qed. - - -Goal 2*x + 10 = 18 -> x = 4. - -simplify. -Qed. - - -(* Universal quantifier *) - -Goal (forall (x y : Z), x = y) -> 0=1. -try zenon. -ergo. -Qed. - -Goal forall (x: nat), (x + 0 = x)%nat. - -induction x0; ergo. -Qed. - - -(* No decision procedure can solve this problem - Goal forall (x a b : Z), a * x + b = 0 -> x = - b/a. -*) - - -(* Functions definitions *) - -Definition fst (x y : Z) : Z := x. - -Goal forall (g : Z -> Z) (x y : Z), g (fst x y) = g x. - -simplify. -Qed. - - -(* Eta-expansion example *) - -Definition snd_of_3 (x y z : Z) : Z := y. - -Definition f : Z -> Z -> Z := snd_of_3 0. - -Goal forall (x y z z1 : Z), snd_of_3 x y z = f y z1. - -simplify. -Qed. - - -(* Inductive types definitions - call to dp/injection function *) - -Inductive even : Z -> Prop := -| even_0 : even 0 -| even_plus2 : forall z : Z, even z -> even (z + 2). - - -(* Simplify and Zenon can't prove this goal before the timeout - unlike CVC Lite *) - -Goal even 4. -ergo. -Qed. - - -Definition skip_z (z : Z) (n : nat) := n. - -Definition skip_z1 := skip_z. - -Goal forall (z : Z) (n : nat), skip_z z n = skip_z1 z n. -yices. -Qed. - - -(* Axioms definitions and dp_hint *) - -Parameter add : nat -> nat -> nat. -Axiom add_0 : forall (n : nat), add 0%nat n = n. -Axiom add_S : forall (n1 n2 : nat), add (S n1) n2 = S (add n1 n2). - -Dp_hint add_0. -Dp_hint add_S. - -(* Simplify can't prove this goal before the timeout - unlike zenon *) - -Goal forall n : nat, add n 0 = n. -induction n ; yices. -Qed. - - -Definition pred (n : nat) : nat := match n with - | 0%nat => 0%nat - | S n' => n' -end. - -Goal forall n : nat, n <> 0%nat -> pred (S n) <> 0%nat. -yices. -(*zenon.*) -Qed. - - -Fixpoint plus (n m : nat) {struct n} : nat := - match n with - | 0%nat => m - | S n' => S (plus n' m) -end. - -Goal forall n : nat, plus n 0%nat = n. - -induction n; ergo. -Qed. - - -(* Mutually recursive functions *) - -Fixpoint even_b (n : nat) : bool := match n with - | O => true - | S m => odd_b m -end -with odd_b (n : nat) : bool := match n with - | O => false - | S m => even_b m -end. - -Goal even_b (S (S O)) = true. -ergo. -(* -simplify. -zenon. -*) -Qed. - - -(* sorts issues *) - -Parameter foo : Set. -Parameter ff : nat -> foo -> foo -> nat. -Parameter g : foo -> foo. -Goal (forall x:foo, ff 0 x x = O) -> forall y, ff 0 (g y) (g y) = O. -yices. -(*zenon.*) -Qed. - - - -(* abstractions *) - -Parameter poly_f : forall A:Set, A->A. - -Goal forall x:nat, poly_f nat x = poly_f nat x. -ergo. -(*zenon.*) -Qed. - - - -(* Anonymous mutually recursive functions : no equations are produced - -Definition mrf := - fix even2 (n : nat) : bool := match n with - | O => true - | S m => odd2 m - end - with odd2 (n : nat) : bool := match n with - | O => false - | S m => even2 m - end for even. - - Thus this goal is unsolvable - -Goal mrf (S (S O)) = true. - -zenon. - -*) diff --git a/plugins/dp/vo.itarget b/plugins/dp/vo.itarget deleted file mode 100644 index 4d282709..00000000 --- a/plugins/dp/vo.itarget +++ /dev/null @@ -1 +0,0 @@ -Dp.vo diff --git a/plugins/dp/zenon.v b/plugins/dp/zenon.v deleted file mode 100644 index 89028c4f..00000000 --- a/plugins/dp/zenon.v +++ /dev/null @@ -1,92 +0,0 @@ -(* Copyright 2004 INRIA *) -Require Export Classical. - -Lemma zenon_nottrue : - (~True -> False). -Proof. tauto. Qed. - -Lemma zenon_noteq : forall (T : Type) (t : T), - ((t <> t) -> False). -Proof. tauto. Qed. - -Lemma zenon_and : forall P Q : Prop, - (P -> Q -> False) -> (P /\ Q -> False). -Proof. tauto. Qed. - -Lemma zenon_or : forall P Q : Prop, - (P -> False) -> (Q -> False) -> (P \/ Q -> False). -Proof. tauto. Qed. - -Lemma zenon_imply : forall P Q : Prop, - (~P -> False) -> (Q -> False) -> ((P -> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_equiv : forall P Q : Prop, - (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notand : forall P Q : Prop, - (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notor : forall P Q : Prop, - (~P -> ~Q -> False) -> (~(P \/ Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notimply : forall P Q : Prop, - (P -> ~Q -> False) -> (~(P -> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notequiv : forall P Q : Prop, - (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_ex : forall (T : Type) (P : T -> Prop), - (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T), - ((P t) -> False) -> ((forall x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T), - (~(P t) -> False) -> (~(exists x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_notall : forall (T : Type) (P : T -> Prop), - (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False). -Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed. - -Lemma zenon_equal_base : forall (T : Type) (f : T), f = f. -Proof. auto. Qed. - -Lemma zenon_equal_step : - forall (S T : Type) (fa fb : S -> T) (a b : S), - (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)). -Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed. - -Lemma zenon_pnotp : forall P Q : Prop, - (P = Q) -> (P -> ~Q -> False). -Proof. intros P Q Ha. rewrite Ha. auto. Qed. - -Lemma zenon_notequal : forall (T : Type) (a b : T), - (a = b) -> (a <> b -> False). -Proof. auto. Qed. - -Ltac zenon_intro id := - intro id || let nid := fresh in (intro nid; clear nid) -. - -Definition zenon_and_s := fun P Q a b => zenon_and P Q b a. -Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a. -Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a. -Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a. -Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a. -Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a. -Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a. -Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a. -Definition zenon_ex_s := fun T P a b => zenon_ex T P b a. -Definition zenon_notall_s := fun T P a b => zenon_notall T P b a. - -Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b. -Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x. diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 73062328..83ebb139 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -155,7 +155,9 @@ let factor_fix env l cb msb = function | (l,SFBconst cb') -> let check' = check_fix env cb' (j+1) in - if not (fst check = fst check' && prec_declaration_equal (snd check) (snd check')) then raise Impossible; + if not (fst check = fst check' && + prec_declaration_equal (snd check) (snd check')) + then raise Impossible; labels.(j+1) <- l; | _ -> raise Impossible) msb'; labels, recd, msb'' @@ -196,13 +198,14 @@ let rec msid_of_seb = function | SEBwith (seb,_) -> msid_of_seb seb | _ -> assert false -let env_for_mtb_with env mp seb idl = +let env_for_mtb_with_def env mp seb idl = let sig_b = match seb with | SEBstruct(sig_b) -> sig_b | _ -> assert false in let l = label_of_id (List.hd idl) in - let before = fst (list_split_when (fun (l',_) -> l=l') sig_b) in + let spot = function (l',SFBconst _) -> l = l' | _ -> false in + let before = fst (list_split_when spot sig_b) in Modops.add_signature mp before empty_delta_resolver env (* From a [structure_body] (i.e. a list of [structure_field_body]) @@ -241,7 +244,7 @@ let rec extract_sfb_spec env mp = function and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with | SEBident mp -> Visit.add_mp_all mp; MTident mp | SEBwith(seb',With_definition_body(idl,cb))-> - let env' = env_for_mtb_with env (msid_of_seb seb') seb idl in + let env' = env_for_mtb_with_def env (msid_of_seb seb') seb idl in let mt = extract_seb_spec env mp1 (seb,seb') in (match extract_with_type env' cb with (* cb peut contenir des kn *) | None -> mt diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 9e8dd828..4e0dbcab 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -194,6 +194,15 @@ let signature_of_structure s = (*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *) +let is_modular = function + | SEdecl _ -> false + | SEmodule _ | SEmodtype _ -> true + +let rec search_structure l m = function + | [] -> raise Not_found + | (lab,d)::_ when lab=l && is_modular d = m -> d + | _::fields -> search_structure l m fields + let get_decl_in_structure r struc = try let base_mp,ll = labels_of_ref r in @@ -202,7 +211,7 @@ let get_decl_in_structure r struc = let rec go ll sel = match ll with | [] -> assert false | l :: ll -> - match List.assoc l sel with + match search_structure l (ll<>[]) sel with | SEdecl d -> d | SEmodtype m -> assert false | SEmodule m -> diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 4a38c48d..034dc3c2 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -134,8 +134,6 @@ TACTIC EXTEND firstorder | [ "firstorder" tactic_opt(t) firstorder_using(l) "with" ne_preident_list(l') ] -> [ gen_ground_tac true (Option.map eval_tactic t) l l' ] -| [ "firstorder" tactic_opt(t) ] -> - [ gen_ground_tac true (Option.map eval_tactic t) [] [] ] END TACTIC EXTEND gintuition diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 1d1e4a2a..33d77568 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1371,7 +1371,7 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic = (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) (* rewrite *) (* ) *) - Eauto.gen_eauto false (false,5) [] (Some []) + Eauto.gen_eauto (false,5) [] (Some []) ] gls @@ -1449,7 +1449,6 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = ( tclCOMPLETE( Eauto.eauto_with_bases - false (true,5) [Evd.empty,Lazy.force refl_equal] [Auto.Hint_db.empty empty_transparent_state false] diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 123399d5..06abb8ce 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -154,7 +154,7 @@ type 'a function_rec_definition_loc_argtype = ((Vernacexpr.fixpoint_expr * Verna let (wit_function_rec_definition_loc : Genarg.tlevel function_rec_definition_loc_argtype), (globwit_function_rec_definition_loc : Genarg.glevel function_rec_definition_loc_argtype), (rawwit_function_rec_definition_loc : Genarg.rlevel function_rec_definition_loc_argtype) = - Genarg.create_arg "function_rec_definition_loc" + Genarg.create_arg None "function_rec_definition_loc" VERNAC COMMAND EXTEND Function ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] -> [ diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 0b04a572..95ca86c2 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -588,15 +588,15 @@ let rec reflexivity_with_destruct_cases g = ) in (tclFIRST - [ reflexivity; - tclTHEN (tclPROGRESS discr_inject) (destruct_case ()); + [ observe_tac "reflexivity_with_destruct_cases : reflexivity" reflexivity; + observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); (* We reach this point ONLY if the same value is matched (at least) two times along binding path. In this case, either we have a discriminable hypothesis and we are done, either at least an injectable one and we do the injection before continuing *) - tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases + observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases) ]) g @@ -752,6 +752,7 @@ let do_save () = Lemmas.save_named false *) let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = + let previous_state = States.freeze () in let funs = Array.of_list funs and graphs = Array.of_list graphs in let funs_constr = Array.map mkConst funs in try @@ -793,22 +794,21 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g Array.iteri (fun i f_as_constant -> let f_id = id_of_label (con_label f_as_constant) in - Lemmas.start_proof - (*i The next call to mk_correct_id is valid since we are constructing the lemma + (*i The next call to mk_correct_id is valid since we are constructing the lemma Ensures by: obvious - i*) - (mk_correct_id f_id) + i*) + let lem_id = mk_correct_id f_id in + Lemmas.start_proof lem_id (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) (fst lemmas_types_infos.(i)) (fun _ _ -> ()); - Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i)); + Pfedit.by + (observe_tac ("prove correctness ("^(string_of_id f_id)^")") + (proving_tac i)); do_save (); let finfo = find_Function_infos f_as_constant in - update_Function - {finfo with - correctness_lemma = Some (destConst (Constrintern.global_reference (mk_correct_id f_id))) - } - + let lem_cst = destConst (Constrintern.global_reference lem_id) in + update_Function {finfo with correctness_lemma = Some lem_cst} ) funs; let lemmas_types_infos = @@ -845,34 +845,27 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g Array.iteri (fun i f_as_constant -> let f_id = id_of_label (con_label f_as_constant) in - Lemmas.start_proof - (*i The next call to mk_complete_id is valid since we are constructing the lemma + (*i The next call to mk_complete_id is valid since we are constructing the lemma Ensures by: obvious - i*) - (mk_complete_id f_id) + i*) + let lem_id = mk_complete_id f_id in + Lemmas.start_proof lem_id (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) (fst lemmas_types_infos.(i)) (fun _ _ -> ()); - Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i)); + Pfedit.by + (observe_tac ("prove completeness ("^(string_of_id f_id)^")") + (proving_tac i)); do_save (); let finfo = find_Function_infos f_as_constant in - update_Function - {finfo with - completeness_lemma = Some (destConst (Constrintern.global_reference (mk_complete_id f_id))) - } + let lem_cst = destConst (Constrintern.global_reference lem_id) in + update_Function {finfo with completeness_lemma = Some lem_cst} ) funs; with e -> (* In case of problem, we reset all the lemmas *) - (*i The next call to mk_correct_id is valid since we are erasing the lemmas - Ensures by: obvious - i*) - let first_lemma_id = - let f_id = id_of_label (con_label funs.(0)) in - - mk_correct_id f_id - in - ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ()); + Pfedit.delete_all_proofs (); + States.unfreeze previous_state; raise e diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 55ebd31b..3355300e 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -48,7 +48,8 @@ open Genarg let compute_renamed_type gls c = - rename_bound_vars_as_displayed [] (pf_type_of gls c) + rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) [] + (pf_type_of gls c) let qed () = Lemmas.save_named true let defined () = Lemmas.save_named false @@ -232,18 +233,19 @@ let rec (find_call_occs : int -> int -> constr -> constr -> | Rel(v) -> if v > nb_lam then error "find_call_occs : Rel" else ((fun l -> expr),[]) | Var(_) when eq_constr expr f -> errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function") | Var(id) -> (fun l -> expr), [] - | Meta(_) -> error "find_call_occs : Meta" - | Evar(_) -> error "find_call_occs : Evar" + | Meta(_) -> error "Found a metavariable. Can not treat such a term" + | Evar(_) -> error "Found an evar. Can not treat such a term" | Sort(_) -> (fun l -> expr), [] | Cast(b,_,_) -> find_call_occs nb_arg nb_lam f b - | Prod(_,_,_) -> error "find_call_occs : Prod" + | Prod(na,t,b) -> + error "Found a product. Can not treat such a term" | Lambda(na,t,b) -> begin match find_call_occs nb_arg (succ nb_lam) f b with | _, [] -> (* Lambda are authorized as long as they do not contain recursives calls *) (fun l -> expr),[] - | _ -> error "find_call_occs : Lambda" + | _ -> error "Found a lambda which body contains a recursive call. Such terms are not allowed" end | LetIn(na,v,t,b) -> begin @@ -254,7 +256,7 @@ let rec (find_call_occs : int -> int -> constr -> constr -> ((fun l -> mkLetIn(na,v,t,cf l)),l) | (cf,(_::_ as l)),(_,[]) -> ((fun l -> mkLetIn(na,cf l,t,b)), l) - | _ -> error "find_call_occs : LetIn" + | _ -> error "Found a letin with recursive calls in both variable value and body. Such terms are not allowed." end | Const(_) -> (fun l -> expr), [] | Ind(_) -> (fun l -> expr), [] @@ -263,8 +265,8 @@ let rec (find_call_occs : int -> int -> constr -> constr -> (match find_call_occs nb_arg nb_lam f a with cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args) | _ -> (fun l -> expr),[]) - | Fix(_) -> error "find_call_occs : Fix" - | CoFix(_) -> error "find_call_occs : CoFix";; + | Fix(_) -> error "Found a local fixpoint. Can not treat such a term" + | CoFix(_) -> error "Found a local cofixpoint : CoFix";; let coq_constant s = Coqlib.gen_constant_in_modules "RecursiveDefinition" @@ -896,6 +898,20 @@ let build_and_l l = let conj_constr = coq_conj () in let mk_and p1 p2 = Term.mkApp(and_constr,[|p1;p2|]) in + let rec is_well_founded t = + match kind_of_term t with + | Prod(_,_,t') -> is_well_founded t' + | App(_,_) -> + let (f,_) = decompose_app t in + eq_constr f (well_founded ()) + | _ -> assert false + in + let compare t1 t2 = + let b1,b2= is_well_founded t1,is_well_founded t2 in + if (b1&&b2) || not (b1 || b2) then 0 + else if b1 && not b2 then 1 else -1 + in + let l = List.sort compare l in let rec f = function | [] -> failwith "empty list of subgoals!" | [p] -> p,tclIDTAC,1 @@ -1006,7 +1022,6 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) e_assumption; Eauto.eauto_with_bases - false (true,5) [Evd.empty,delayed_force refl_equal] [Auto.Hint_db.empty empty_transparent_state false] @@ -1378,6 +1393,7 @@ let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : unit = + let previous_label = Lib.current_command_label () in let function_type = interp_constr Evd.empty (Global.env()) type_of_f in let env = push_named (function_name,None,function_type) (Global.env()) in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) @@ -1429,7 +1445,6 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num then pperrnl (str "Cannot create equation Lemma " ++ Errors.print e) else anomaly "Cannot create equation Lemma" ; -(* ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); *) stop := true; end end; @@ -1461,10 +1476,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num hook with e -> begin - ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); -(* anomaly "Cannot create termination Lemma" *) + (try ignore (Backtrack.backto previous_label) with _ -> ()); + (* anomaly "Cannot create termination Lemma" *) raise e end - - - diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 1ad49bb8..8b7ee55b 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -895,7 +895,9 @@ struct let parse_expr parse_constant parse_exp ops_spec env term = if debug then (Pp.pp (Pp.str "parse_expr: "); - Pp.pp_flush ();Pp.pp (Printer.prterm term); Pp.pp_flush ()); + Pp.pp (Printer.prterm term); + Pp.pp (Pp.str "\n"); + Pp.pp_flush ()); (* let constant_or_variable env term = @@ -991,8 +993,12 @@ struct else raise ParseError | App(op,args) -> begin - try - (assoc_const op rconst_assoc) (rconstant args.(0)) (rconstant args.(1)) + try + (* the evaluation order is important in the following *) + let f = assoc_const op rconst_assoc in + let a = rconstant args.(0) in + let b = rconstant args.(1) in + f a b with ParseError -> match op with @@ -1009,10 +1015,12 @@ struct if debug then (Pp.pp_flush (); Pp.pp (Pp.str "rconstant: "); - Pp.pp (Printer.prterm term); Pp.pp_flush ()); + Pp.pp (Printer.prterm term); + Pp.pp (Pp.str "\n"); + Pp.pp_flush ()); let res = rconstant term in if debug then - (Printf.printf "rconstant -> %a" pp_Rcst res ; flush stdout) ; + (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; res @@ -1052,6 +1060,7 @@ struct then (Pp.pp_flush (); Pp.pp (Pp.str "parse_arith: "); Pp.pp (Printer.prterm cstr); + Pp.pp (Pp.str "\n"); Pp.pp_flush ()); match kind_of_term cstr with | App(op,args) -> diff --git a/plugins/nsatz/nsatz.ml4 b/plugins/nsatz/nsatz.ml4 index e48643b4..a317307e 100644 --- a/plugins/nsatz/nsatz.ml4 +++ b/plugins/nsatz/nsatz.ml4 @@ -474,7 +474,7 @@ let remove_zeros zero lci = done; !lcr) lr in - info ("unuseful spolynomials: " + info ("useless spolynomials: " ^string_of_int (m-List.length lr)^"\n"); info ("useful spolynomials: " ^string_of_int (List.length lr)^"\n"); diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget index 04cbdccb..787995ed 100644 --- a/plugins/pluginsbyte.itarget +++ b/plugins/pluginsbyte.itarget @@ -8,7 +8,6 @@ fourier/fourier_plugin.cma romega/romega_plugin.cma omega/omega_plugin.cma micromega/micromega_plugin.cma -dp/dp_plugin.cma xml/xml_plugin.cma subtac/subtac_plugin.cma ring/ring_plugin.cma diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget index bbadfe69..bd3cec01 100644 --- a/plugins/pluginsdyn.itarget +++ b/plugins/pluginsdyn.itarget @@ -8,7 +8,6 @@ fourier/fourier_plugin.cmxs romega/romega_plugin.cmxs omega/omega_plugin.cmxs micromega/micromega_plugin.cmxs -dp/dp_plugin.cmxs xml/xml_plugin.cmxs subtac/subtac_plugin.cmxs ring/ring_plugin.cmxs diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget index 74b3f527..5264ba37 100644 --- a/plugins/pluginsopt.itarget +++ b/plugins/pluginsopt.itarget @@ -8,7 +8,6 @@ fourier/fourier_plugin.cmxa romega/romega_plugin.cmxa omega/omega_plugin.cmxa micromega/micromega_plugin.cmxa -dp/dp_plugin.cmxa xml/xml_plugin.cmxa subtac/subtac_plugin.cmxa ring/ring_plugin.cmxa diff --git a/plugins/pluginsvo.itarget b/plugins/pluginsvo.itarget index db56534c..bab15ad0 100644 --- a/plugins/pluginsvo.itarget +++ b/plugins/pluginsvo.itarget @@ -1,4 +1,3 @@ -dp/vo.otarget field/vo.otarget fourier/vo.otarget funind/vo.otarget @@ -10,4 +9,4 @@ ring/vo.otarget romega/vo.otarget rtauto/vo.otarget setoid_ring/vo.otarget -extraction/vo.otarget
\ No newline at end of file +extraction/vo.otarget diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index d773b153..576f7d4e 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -509,8 +509,8 @@ let pp_gl gl= cut () ++ let pp = function - Incomplete(gl,ctx) -> msgnl (pp_gl gl) - | _ -> msg (str "<complete>") + Incomplete(gl,ctx) -> pp_gl gl ++ fnl () + | _ -> str "<complete>" let pp_info () = let count_info = diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli index b236aa72..275e94cd 100644 --- a/plugins/rtauto/proof_search.mli +++ b/plugins/rtauto/proof_search.mli @@ -38,7 +38,7 @@ val branching: state -> state list val success: state -> bool -val pp: state -> unit +val pp: state -> Pp.std_ppcmds val pr_form : form -> unit diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml index 5ed335d0..f4d8b769 100644 --- a/plugins/subtac/eterm.ml +++ b/plugins/subtac/eterm.ml @@ -132,18 +132,29 @@ let rec chop_product n t = | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None | _ -> None -let evar_dependencies evm ev = +let evars_of_evar_info evi = + Intset.union (Evarutil.evars_of_term evi.evar_concl) + (Intset.union + (match evi.evar_body with + | Evar_empty -> Intset.empty + | Evar_defined b -> Evarutil.evars_of_term b) + (Evarutil.evars_of_named_context (evar_filtered_context evi))) + +let evar_dependencies evm oev = let one_step deps = Intset.fold (fun ev s -> let evi = Evd.find evm ev in - Intset.union (Evarutil.evars_of_evar_info evi) s) + let deps' = evars_of_evar_info evi in + if Intset.mem oev deps' then + raise (Invalid_argument ("Ill-formed evar map: cycle detected for evar " ^ string_of_int oev)) + else Intset.union deps' s) deps deps in let rec aux deps = let deps' = one_step deps in if Intset.equal deps deps' then deps else aux deps' - in aux (Intset.singleton ev) + in aux (Intset.singleton oev) let move_after (id, ev, deps as obl) l = let rec aux restdeps = function diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4 index ca1240e5..6a131d39 100644 --- a/plugins/subtac/g_subtac.ml4 +++ b/plugins/subtac/g_subtac.ml4 @@ -75,14 +75,14 @@ type 'a gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a) Genarg.abstra let (wit_subtac_gallina_loc : Genarg.tlevel gallina_loc_argtype), (globwit_subtac_gallina_loc : Genarg.glevel gallina_loc_argtype), (rawwit_subtac_gallina_loc : Genarg.rlevel gallina_loc_argtype) = - Genarg.create_arg "subtac_gallina_loc" + Genarg.create_arg None "subtac_gallina_loc" type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type let (wit_subtac_withtac : Genarg.tlevel withtac_argtype), (globwit_subtac_withtac : Genarg.glevel withtac_argtype), (rawwit_subtac_withtac : Genarg.rlevel withtac_argtype) = - Genarg.create_arg "subtac_withtac" + Genarg.create_arg None "subtac_withtac" VERNAC COMMAND EXTEND Subtac [ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ] diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml index 710149ae..d626396f 100644 --- a/plugins/subtac/subtac.ml +++ b/plugins/subtac/subtac.ml @@ -82,11 +82,9 @@ let start_proof_com env isevars sopt kind (bl,t) hook = Impargs.declare_manual_implicits (loc = Local) gr ~enriching:true [imps]; hook loc gr) -let print_subgoals () = Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () - let start_proof_and_print env isevars idopt k t hook = start_proof_com env isevars idopt k t hook; - print_subgoals () + Vernacentries.print_subgoals () let _ = Detyping.set_detype_anonymous (fun loc n -> GVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n))) diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml index 368d8bac..16d4e21e 100644 --- a/plugins/subtac/subtac_cases.ml +++ b/plugins/subtac/subtac_cases.ml @@ -1845,7 +1845,7 @@ let build_dependent_signature env evars avoid tomatchs arsign = refl_arg :: refl_args, pred slift, (Name id, b, t) :: argsign')) - (env, 0, [], [], slift, []) args argsign + (env, neqs, [], [], slift, []) args argsign in let eq = mk_JMeq (lift (nargeqs + slift) appt) diff --git a/plugins/subtac/subtac_classes.ml b/plugins/subtac/subtac_classes.ml index c08dd16d..6b3fe718 100644 --- a/plugins/subtac/subtac_classes.ml +++ b/plugins/subtac/subtac_classes.ml @@ -52,7 +52,7 @@ let type_ctx_instance evars env ctx inst subst = | None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l | Some b -> substl subst b, l in - evars := resolve_typeclasses ~onlyargs:true ~fail:true env !evars; + evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars; let d = na, Some c', t' in aux (c' :: subst, d :: instctx) l ctx | [] -> subst @@ -107,9 +107,10 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in Namegen.next_global_ident_away i (Termops.ids_of_context env) in + evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars; + let ctx = Evarutil.nf_rel_context_evar !evars ctx + and ctx' = Evarutil.nf_rel_context_evar !evars ctx' in let env' = push_rel_context ctx env in - evars := Evarutil.nf_evar_map !evars; - evars := resolve_typeclasses ~onlyargs:false ~fail:true env !evars; let sigma = !evars in let subst = List.map (Evarutil.nf_evar sigma) subst in let props = @@ -157,6 +158,8 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst) in evars := Evarutil.nf_evar_map !evars; + evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars; + evars := resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:false env !evars; let term, termtype = match subst with | Inl subst -> diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml index 74f31a90..eb29bd04 100644 --- a/plugins/subtac/subtac_coercion.ml +++ b/plugins/subtac/subtac_coercion.ml @@ -27,6 +27,9 @@ open Subtac_errors open Eterm open Pp +let app_opt env evars f t = + whd_betaiota !evars (app_opt f t) + let pair_of_array a = (a.(0), a.(1)) let make_name s = Name (id_of_string s) @@ -80,7 +83,8 @@ module Coercion = struct | Type _, Prop Null -> Prop Null | _, Type _ -> s2 - let hnf env isevars c = whd_betadeltaiota env ( !isevars) c + let hnf env isevars c = whd_betadeltaiota env isevars c + let hnf_nodelta env evars c = whd_betaiota evars c let lift_args n sign = let rec liftrec k = function @@ -90,15 +94,16 @@ module Coercion = struct liftrec (List.length sign) sign let rec mu env isevars t = - let isevars = ref isevars in let rec aux v = - let v = hnf env isevars v in + let v = hnf env !isevars v in match disc_subset v with Some (u, p) -> let f, ct = aux u in + let p = hnf env !isevars p in (Some (fun x -> - app_opt f (mkApp ((delayed_force sig_).proj1, - [| u; p; x |]))), + app_opt env isevars + f (mkApp ((delayed_force sig_).proj1, + [| u; p; x |]))), ct) | None -> (None, v) in aux t @@ -106,9 +111,8 @@ module Coercion = struct and coerce loc env isevars (x : Term.constr) (y : Term.constr) : (Term.constr -> Term.constr) option = - let x = nf_evar ( !isevars) x and y = nf_evar ( !isevars) y in let rec coerce_unify env x y = - let x = hnf env isevars x and y = hnf env isevars y in + let x = hnf env !isevars x and y = hnf env !isevars y in try isevars := the_conv_x_leq env x y !isevars; None @@ -167,7 +171,7 @@ module Coercion = struct let env' = push_rel (name', None, a') env in let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) - let coec1 = app_opt c1 (mkRel 1) in + let coec1 = app_opt env' isevars c1 (mkRel 1) in (* env, x : a' |- c1[x] : lift 1 a *) let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in (* env, x : a' |- c2 : b[c1[x]/x]] > b' *) @@ -177,7 +181,7 @@ module Coercion = struct Some (fun f -> mkLambda (name', a', - app_opt c2 + app_opt env' isevars c2 (mkApp (Term.lift 1 f, [| coec1 |]))))) | App (c, l), App (c', l') -> @@ -220,9 +224,9 @@ module Coercion = struct Some (fun x -> let x, y = - app_opt c1 (mkApp (existS.proj1, + app_opt env' isevars c1 (mkApp (existS.proj1, [| a; pb; x |])), - app_opt c2 (mkApp (existS.proj2, + app_opt env' isevars c2 (mkApp (existS.proj2, [| a; pb; x |])) in mkApp (existS.intro, [| a'; pb'; x ; y |])) @@ -240,9 +244,9 @@ module Coercion = struct Some (fun x -> let x, y = - app_opt c1 (mkApp (prod.proj1, + app_opt env isevars c1 (mkApp (prod.proj1, [| a; b; x |])), - app_opt c2 (mkApp (prod.proj2, + app_opt env isevars c2 (mkApp (prod.proj2, [| a; b; x |])) in mkApp (prod.intro, [| a'; b'; x ; y |])) @@ -276,7 +280,7 @@ module Coercion = struct Some (u, p) -> let c = coerce_unify env u y in let f x = - app_opt c (mkApp ((delayed_force sig_).proj1, + app_opt env isevars c (mkApp ((delayed_force sig_).proj1, [| u; p; x |])) in Some f | None -> @@ -285,7 +289,7 @@ module Coercion = struct let c = coerce_unify env x u in Some (fun x -> - let cx = app_opt c x in + let cx = app_opt env isevars c x in let evar = make_existential loc env isevars (mkApp (p, [| cx |])) in (mkApp @@ -300,7 +304,8 @@ module Coercion = struct let coerce_itf loc env isevars v t c1 = let evars = ref isevars in let coercion = coerce loc env evars t c1 in - !evars, Option.map (app_opt coercion) v + let t = Option.map (app_opt env evars coercion) v in + !evars, t (* Taken from pretyping/coercion.ml *) @@ -354,34 +359,36 @@ module Coercion = struct with _ -> anomaly "apply_coercion" let inh_app_fun env isevars j = - let t = whd_betadeltaiota env ( isevars) j.uj_type in + let isevars = ref isevars in + let t = hnf env !isevars j.uj_type in match kind_of_term t with - | Prod (_,_,_) -> (isevars,j) - | Evar ev when not (is_defined_evar isevars ev) -> - let (isevars',t) = define_evar_as_product isevars ev in + | Prod (_,_,_) -> (!isevars,j) + | Evar ev when not (is_defined_evar !isevars ev) -> + let (isevars',t) = define_evar_as_product !isevars ev in (isevars',{ uj_val = j.uj_val; uj_type = t }) | _ -> (try let t,p = - lookup_path_to_fun_from env ( isevars) j.uj_type in - (isevars,apply_coercion env ( isevars) p j t) + lookup_path_to_fun_from env !isevars j.uj_type in + (!isevars,apply_coercion env !isevars p j t) with Not_found -> try let coercef, t = mu env isevars t in - (isevars, { uj_val = app_opt coercef j.uj_val; uj_type = t }) + let res = { uj_val = app_opt env isevars coercef j.uj_val; uj_type = t } in + (!isevars, res) with NoSubtacCoercion | NoCoercion -> - (isevars,j)) + (!isevars,j)) let inh_tosort_force loc env isevars j = try let t,p = lookup_path_to_sort_from env ( isevars) j.uj_type in let j1 = apply_coercion env ( isevars) p j t in - (isevars,type_judgment env (j_nf_evar ( isevars) j1)) + (isevars, type_judgment env (j_nf_evar ( isevars) j1)) with Not_found -> error_not_a_type_loc loc env ( isevars) j let inh_coerce_to_sort loc env isevars j = - let typ = whd_betadeltaiota env ( isevars) j.uj_type in + let typ = hnf env isevars j.uj_type in match kind_of_term typ with | Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s }) | Evar ev when not (is_defined_evar isevars ev) -> @@ -391,15 +398,19 @@ module Coercion = struct inh_tosort_force loc env isevars j let inh_coerce_to_base loc env isevars j = - let typ = whd_betadeltaiota env ( isevars) j.uj_type in + let isevars = ref isevars in + let typ = hnf env !isevars j.uj_type in let ct, typ' = mu env isevars typ in - isevars, { uj_val = app_opt ct j.uj_val; - uj_type = typ' } + let res = + { uj_val = app_opt env isevars ct j.uj_val; + uj_type = typ' } + in !isevars, res let inh_coerce_to_prod loc env isevars t = - let typ = whd_betadeltaiota env ( isevars) (snd t) in + let isevars = ref isevars in + let typ = hnf env !isevars (snd t) in let _, typ' = mu env isevars typ in - isevars, (fst t, typ') + !isevars, (fst t, typ') let inh_coerce_to_fail env evd rigidonly v t c1 = if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t) @@ -452,23 +463,23 @@ module Coercion = struct (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) = match n with - None -> - let (evd', val') = - try - inh_conv_coerce_to_fail loc env evd rigidonly - (Some (nf_evar evd cj.uj_val)) - (nf_evar evd cj.uj_type) (nf_evar evd t) - with NoCoercion -> - let sigma = evd in - try - coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t - with NoSubtacCoercion -> - error_actual_type_loc loc env sigma cj t - in - let val' = match val' with Some v -> v | None -> assert(false) in - (evd',{ uj_val = val'; uj_type = t }) - | Some (init, cur) -> - (evd, cj) + | None -> + let cj = { cj with uj_type = hnf_nodelta env evd cj.uj_type } + and t = hnf_nodelta env evd t in + let (evd', val') = + try + inh_conv_coerce_to_fail loc env evd rigidonly + (Some cj.uj_val) cj.uj_type t + with NoCoercion -> + (try + coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t + with NoSubtacCoercion -> + error_actual_type_loc loc env evd cj t) + in + let val' = match val' with Some v -> v | None -> assert(false) in + (evd',{ uj_val = val'; uj_type = t }) + | Some (init, cur) -> + (evd, cj) let inh_conv_coerce_to = inh_conv_coerce_to_gen false let inh_conv_coerce_rigid_to = inh_conv_coerce_to_gen true diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml index ecae6759..ced390aa 100644 --- a/plugins/subtac/subtac_command.ml +++ b/plugins/subtac/subtac_command.ml @@ -458,7 +458,7 @@ let interp_recursive fixkind l = (* Instantiate evars and check all are resolved *) let evd = Evarconv.consider_remaining_unif_problems env_rec !evdref in let evd = Typeclasses.resolve_typeclasses - ~onlyargs:true ~split:true ~fail:false env_rec evd + ~filter:Typeclasses.no_goals ~split:true ~fail:false env_rec evd in let evd = Evarutil.nf_evar_map evd in let fixdefs = List.map (nf_evar evd) fixdefs in diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml index 64d9f72c..6a5878b3 100644 --- a/plugins/subtac/subtac_obligations.ml +++ b/plugins/subtac/subtac_obligations.ml @@ -445,12 +445,12 @@ let deps_remaining obls deps = else x :: acc) deps [] -let has_dependencies obls n = - let res = ref false in +let dependencies obls n = + let res = ref Intset.empty in Array.iteri (fun i obl -> if i <> n && Intset.mem n obl.obl_deps then - res := true) + res := Intset.add i !res) obls; !res @@ -502,8 +502,9 @@ let rec solve_obligation prg num tac = in match res with | Remain n when n > 0 -> - if has_dependencies obls num then - ignore(auto_solve_obligations (Some prg.prg_name) None) + let deps = dependencies obls num in + if deps <> Intset.empty then + ignore(auto_solve_obligations (Some prg.prg_name) None ~oblset:deps) | _ -> ()); trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); @@ -553,14 +554,18 @@ and solve_obligation_by_tac prg obls i tac = | Util.Anomaly _ as e -> raise e | e -> false -and solve_prg_obligations prg tac = +and solve_prg_obligations prg ?oblset tac = let obls, rem = prg.prg_obligations in let rem = ref rem in let obls' = Array.copy obls in + let p = match oblset with + | None -> (fun _ -> true) + | Some s -> (fun i -> Intset.mem i s) + in let _ = Array.iteri (fun i x -> - if solve_obligation_by_tac prg obls' i tac then - decr rem) + if p i && solve_obligation_by_tac prg obls' i tac then + decr rem) obls' in update_obls prg obls' !rem @@ -582,9 +587,9 @@ and try_solve_obligation n prg tac = and try_solve_obligations n tac = try ignore (solve_obligations n tac) with NoObligations _ -> () -and auto_solve_obligations n tac : progress = +and auto_solve_obligations n ?oblset tac : progress = Flags.if_verbose msgnl (str "Solving obligations automatically..."); - try solve_prg_obligations (get_prog_err n) tac with NoObligations _ -> Dependent + try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent open Pp let show_obligations_of_prg ?(msg=true) prg = diff --git a/plugins/subtac/subtac_pretyping.ml b/plugins/subtac/subtac_pretyping.ml index 7c0d1232..e56fa4f5 100644 --- a/plugins/subtac/subtac_pretyping.ml +++ b/plugins/subtac/subtac_pretyping.ml @@ -67,8 +67,8 @@ let interp env isevars c tycon = let _ = isevars := Evarutil.nf_evar_map !isevars in let evd = consider_remaining_unif_problems env !isevars in (* let unevd = undefined_evars evd in *) - let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:true ~fail:true env evd in - let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:false ~split:true ~fail:false env unevd' in + let unevd' = Typeclasses.resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~split:true ~fail:true env evd in + let unevd' = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~split:true ~fail:false env unevd' in let evm = unevd' in isevars := unevd'; nf_evar evm j.uj_val, nf_evar evm j.uj_type diff --git a/plugins/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml index d5d427c7..9a4e1883 100644 --- a/plugins/subtac/subtac_pretyping_F.ml +++ b/plugins/subtac/subtac_pretyping_F.ml @@ -88,7 +88,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (* coerce to tycon if any *) let inh_conv_coerce_to_tycon loc env evdref j = function - | None -> j_nf_evar !evdref j + | None -> j | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) evdref j t let push_rels vars env = List.fold_right push_rel vars env @@ -323,7 +323,9 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct else tycon in match ty with - | Some (_, t) when Subtac_coercion.disc_subset t = None -> ty + | Some (_, t) -> + if Subtac_coercion.disc_subset (whd_betadeltaiota env !evdref t) = None then ty + else None | _ -> None in let fj = pretype ftycon env evdref lvar f in @@ -340,13 +342,12 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct Coercion.inh_conv_coerces_to loc env !evdref resty ty) tycon; let evd, (_, _, tycon) = split_tycon loc env !evdref tycon in evdref := evd; - let hj = pretype (mk_tycon (nf_evar !evdref c1)) env evdref lvar c in + let hj = pretype (mk_tycon c1) env evdref lvar c in let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in - let typ' = nf_evar !evdref typ in apply_rec env (n+1) - { uj_val = nf_evar !evdref value; - uj_type = nf_evar !evdref typ' } - (Option.map (fun (abs, c) -> abs, nf_evar !evdref c) tycon) rest + { uj_val = value; + uj_type = typ } + (Option.map (fun (abs, c) -> abs, c) tycon) rest | _ -> let hj = pretype empty_tycon env evdref lvar c in @@ -354,9 +355,9 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (join_loc floc argloc) env !evdref resj [hj] in - let resj = j_nf_evar !evdref (apply_rec env 1 fj ftycon args) in + let resj = apply_rec env 1 fj ftycon args in let resj = - match kind_of_term resj.uj_val with + match kind_of_term (whd_evar !evdref resj.uj_val) with | App (f,args) when isInd f or isConst f -> let sigma = !evdref in let c = mkApp (f,Array.map (whd_evar sigma) args) in @@ -508,10 +509,9 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in let pred = nf_evar !evdref pred in let p = nf_evar !evdref p in - (* msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*) let f cs b = let n = rel_context_length cs.cs_args in - let pi = lift n pred in (* liftn n 2 pred ? *) + let pi = lift n pred in let pi = beta_applist (pi, [build_dependent_constructor cs]) in let csgn = if not !allow_anonymous_refs then @@ -525,7 +525,6 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct cs.cs_args in let env_c = push_rels csgn env in -(* msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *) let bj = pretype (mk_tycon pi) env_c evdref lvar b in it_mkLambda_or_LetIn bj.uj_val cs.cs_args in let b1 = f cstrs.(0) b1 in @@ -551,8 +550,6 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | CastConv (k,t) -> let tj = pretype_type empty_valcon env evdref lvar t in let cj = pretype (mk_tycon tj.utj_val) env evdref lvar c in - (* User Casts are for helping pretyping, experimentally not to be kept*) - (* ... except for Correctness *) let v = mkCast (cj.uj_val, k, tj.utj_val) in { uj_val = v; uj_type = tj.utj_val } in @@ -600,9 +597,9 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct in if resolve_classes then (try - evdref := Typeclasses.resolve_typeclasses ~onlyargs:true + evdref := Typeclasses.resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~split:true ~fail:true env !evdref; - evdref := Typeclasses.resolve_typeclasses ~onlyargs:false + evdref := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~split:true ~fail:false env !evdref with e -> if fail_evar then raise e else ()); evdref := consider_remaining_unif_problems env !evdref; @@ -647,8 +644,8 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let understand_type sigma env c = snd (ise_pretype_gen true false true sigma env ([],[]) IsType c) - let understand_ltac expand_evar sigma env lvar kind c = - ise_pretype_gen expand_evar false true sigma env lvar kind c + let understand_ltac ?(resolve_classes=false) expand_evar sigma env lvar kind c = + ise_pretype_gen expand_evar false resolve_classes sigma env lvar kind c let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c = ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml index 28bbdd35..fbb44811 100644 --- a/plugins/subtac/subtac_utils.ml +++ b/plugins/subtac/subtac_utils.ml @@ -161,12 +161,11 @@ let print_args env args = Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "") let make_existential loc ?(opaque = Define true) env isevars c = - let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c in - let (key, args) = destEvar evar in - (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++ - print_args env args ++ str " for type: "++ - my_print_constr env c) with _ -> ()); - evar + Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c + +let no_goals_or_obligations = function + | GoalEvar | QuestionMark _ -> false + | _ -> true let make_existential_expr loc env c = let key = Evarutil.new_untyped_evar () in diff --git a/plugins/subtac/subtac_utils.mli b/plugins/subtac/subtac_utils.mli index de96cc60..112b1795 100644 --- a/plugins/subtac/subtac_utils.mli +++ b/plugins/subtac/subtac_utils.mli @@ -82,6 +82,7 @@ val app_opt : ('a -> 'a) option -> 'a -> 'a val print_args : env -> constr array -> std_ppcmds val make_existential : loc -> ?opaque:obligation_definition_status -> env -> evar_map ref -> types -> constr +val no_goals_or_obligations : Typeclasses.evar_filter val make_existential_expr : loc -> 'a -> 'b -> constr_expr val string_of_hole_kind : hole_kind -> string val evars_of_term : evar_map -> evar_map -> constr -> evar_map diff --git a/plugins/xml/dumptree.ml4 b/plugins/xml/dumptree.ml4 index 3c3e54fa..56ce7ef2 100644 --- a/plugins/xml/dumptree.ml4 +++ b/plugins/xml/dumptree.ml4 @@ -107,7 +107,7 @@ let pr_context_xml env = let pr_subgoal_metas_xml metas env= let pr_one (meta, typ) = - fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_ltype_env_at_top env typ) ++ + fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_goal_concl_style_env env typ) ++ str "\"/>" in List.fold_left (++) (mt ()) (List.map pr_one metas) @@ -117,7 +117,7 @@ let pr_goal_xml sigma g = let env = try Goal.V82.unfiltered_env sigma g with _ -> empty_env in if Decl_mode.try_get_info sigma g = None then (hov 2 (str "<goal>" ++ fnl () ++ str "<concl type=\"" ++ - xmlstream (pr_ltype_env_at_top env (Goal.V82.concl sigma g)) ++ + xmlstream (pr_goal_concl_style_env env (Goal.V82.concl sigma g)) ++ str "\"/>" ++ (pr_context_xml env)) ++ fnl () ++ str "</goal>") diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 8963ea5e..9ed28f8b 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -77,8 +77,9 @@ let rec list_try_compile f = function | [] -> anomaly "try_find_f" | h::t -> try f h - with UserError _ | TypeError _ | PretypeError _ - | Loc.Exc_located (_,(UserError _ | TypeError _ | PretypeError _)) -> + with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ + | Loc.Exc_located + (_, (UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _)) -> list_try_compile f t let force_name = diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 553c9127..bfa0034f 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -110,7 +110,7 @@ module Default = struct let saturate_evd env evd = Typeclasses.resolve_typeclasses - ~onlyargs:true ~split:true ~fail:false env evd + ~filter:Typeclasses.no_goals ~split:true ~fail:false env evd (* appliquer le chemin de coercions p à hj *) let apply_coercion env sigma p hj typ_cl = diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index c194a0f2..aae003b8 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -532,7 +532,7 @@ and detype_eqn isgoal avoid env constr construct_nargs branch = buildrec [] [] avoid env construct_nargs branch and detype_binder isgoal bk avoid env na ty c = - let flag = if isgoal then RenamingForGoal else (RenamingElsewhereFor c) in + let flag = if isgoal then RenamingForGoal else RenamingElsewhereFor (env,c) in let na',avoid' = if bk = BLetIn then compute_displayed_let_name_in flag avoid na c else compute_displayed_name_in flag avoid na c in @@ -552,9 +552,11 @@ let rec detype_rel_context where avoid env sign = | None -> na,avoid | Some c -> if b<>None then - compute_displayed_let_name_in (RenamingElsewhereFor c) avoid na c + compute_displayed_let_name_in + (RenamingElsewhereFor (env,c)) avoid na c else - compute_displayed_name_in (RenamingElsewhereFor c) avoid na c in + compute_displayed_name_in + (RenamingElsewhereFor (env,c)) avoid na c in let b = Option.map (detype false avoid env) b in let t = detype false avoid env t in (na',Explicit,b,t) :: aux avoid' (add_name na' env) rest diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 04f86e70..fa45f6fb 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -195,7 +195,7 @@ let rec evar_conv_x ts env evd pbty term1 term2 = evar_eqappr_x ts env evd pbty (decompose_app term1) (decompose_app term2) -and evar_eqappr_x ?(rhs_is_stuck_proj = false) +and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = (* Evar must be undefined since we have flushed evars *) match (flex_kind_of_term term1 l1, flex_kind_of_term term2 l2) with @@ -324,13 +324,25 @@ and evar_eqappr_x ?(rhs_is_stuck_proj = false) (* heuristic: unfold second argument first, exception made if the first argument is a beta-redex (expand a constant only if necessary) or the second argument is potentially - usable as a canonical projection *) - let rhs_is_stuck_proj = - rhs_is_stuck_proj || is_open_canonical_projection env i appr2 in - if isLambda flex1 || rhs_is_stuck_proj then + usable as a canonical projection or canonical value *) + let rec is_unnamed (hd, args) = match kind_of_term hd with + | (Var _|Construct _|Ind _|Const _|Prod _|Sort _) -> false + | (Case _|Fix _|CoFix _|Meta _|Rel _)-> true + | Evar _ -> false (* immediate solution without Canon Struct *) + | Lambda _ -> assert(args = []); true + | LetIn (_,b,_,c) -> + is_unnamed (evar_apprec ts env i args (subst1 b c)) + | App _| Cast _ -> assert false in + let rhs_is_stuck_and_unnamed () = + match eval_flexible_term ts env flex2 with + | None -> false + | Some v2 -> is_unnamed (evar_apprec ts env i l2 v2) in + let rhs_is_already_stuck = + rhs_is_already_stuck || rhs_is_stuck_and_unnamed () in + if isLambda flex1 || rhs_is_already_stuck then match eval_flexible_term ts env flex1 with | Some v1 -> - evar_eqappr_x ~rhs_is_stuck_proj + evar_eqappr_x ~rhs_is_already_stuck ts env i pbty (evar_apprec ts env i l1 v1) appr2 | None -> match eval_flexible_term ts env flex2 with @@ -544,7 +556,7 @@ and conv_record trs env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) (fun i -> evar_conv_x trs env i CONV c1 (applist (c,(List.rev ks)))); (fun i -> ise_list2 i (fun i -> evar_conv_x trs env i CONV) ts ts1)] -(* getting rid of the optional argument rhs_is_stuck_proj *) +(* getting rid of the optional argument rhs_is_already_stuck *) let evar_eqappr_x ts env evd pbty appr1 appr2 = evar_eqappr_x ts env evd pbty appr1 appr2 @@ -582,17 +594,19 @@ let apply_on_subterm f c t = in applyrec (0,c) t -let filter_possible_projections c args = +let filter_possible_projections c ty ctxt args = let fv1 = free_rels c in let fv2 = collect_vars c in - List.map (fun a -> + let tyvars = collect_vars ty in + List.map2 (fun (id,_,_) a -> a == c || (* Here we make an approximation, for instance, we could also be *) (* interested in finding a term u convertible to c such that a occurs *) (* in u *) isRel a && Intset.mem (destRel a) fv1 || - isVar a && Idset.mem (destVar a) fv2) - args + isVar a && Idset.mem (destVar a) fv2 || + Idset.mem id tyvars) + ctxt args let initial_evar_data evi = let ids = List.map pi1 (evar_context evi) in @@ -629,16 +643,17 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = let instance = List.map mkVar (List.map pi1 ctxt) in let rec make_subst = function - | (id,_,t)::ctxt, c::l, occs::occsl when isVarId id c -> + | (id,_,t)::ctxt', c::l, occs::occsl when isVarId id c -> if occs<>None then error "Cannot force abstraction on identity instance." else - make_subst (ctxt,l,occsl) - | (id,_,t)::ctxt, c::l, occs::occsl -> + make_subst (ctxt',l,occsl) + | (id,_,t)::ctxt', c::l, occs::occsl -> let evs = ref [] in - let filter = List.map2 (&&) filter (filter_possible_projections c args) in let ty = Retyping.get_type_of env_rhs evd c in - (id,t,c,ty,evs,filter,occs) :: make_subst (ctxt,l,occsl) + let filter' = filter_possible_projections c ty ctxt args in + let filter = List.map2 (&&) filter filter' in + (id,t,c,ty,evs,filter,occs) :: make_subst (ctxt',l,occsl) | [], [], [] -> [] | _ -> anomaly "Signature, instance and occurrences list do not match" in @@ -724,6 +739,12 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = (* The typical kind of constraint coming from pattern-matching return type inference *) choose_less_dependent_instance evk2 evd term1 args2, true + | Evar (evk1,args1), Evar (evk2,args2) when evk1 = evk2 -> + let f env evd pbty x y = (evd,is_trans_fconv pbty ts env evd x y) in + solve_refl ~can_drop:true f env evd evk1 args1 args2, true + | Evar ev1, Evar ev2 -> + solve_evar_evar ~force:true + (evar_define (evar_conv_x ts)) (evar_conv_x ts) env evd ev1 ev2, true | Evar ev1,_ when List.length l1 <= List.length l2 -> (* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *) (* and otherwise second-order matching *) @@ -753,7 +774,52 @@ let check_problems_are_solved env evd = | (pbty,env,t1,t2)::_ -> Pretype_errors.error_cannot_unify env evd (t1, t2) | _ -> () +let max_undefined_with_candidates evd = + (* If evar were ordered with highest index first, fold_undefined + would be going decreasingly and we could use fold_undefined to + find the undefined evar of maximum index (alternatively, + max_bindings from ocaml 3.12 could be used); instead we traverse + the whole map *) + let l = Evd.fold_undefined + (fun evk ev_info evars -> + match ev_info.evar_candidates with + | None -> evars + | Some l -> (evk,ev_info,l)::evars) evd [] in + match l with + | [] -> None + | a::l -> Some (list_last (a::l)) + +let rec solve_unconstrained_evars_with_canditates evd = + (* max_undefined is supposed to return the most recent, hence + possibly most dependent evar *) + match max_undefined_with_candidates evd with + | None -> evd + | Some (evk,ev_info,l) -> + let rec aux = function + | [] -> error "Unsolvable existential variables." + | a::l -> + try + let conv_algo = evar_conv_x full_transparent_state in + let evd = check_evar_instance evd evk a conv_algo in + let evd = Evd.define evk a evd in + let evd,b = reconsider_conv_pbs conv_algo evd in + if b then solve_unconstrained_evars_with_canditates evd + else aux l + with e when Pretype_errors.precatchable_exception e -> + aux l in + (* List.rev is there to favor most dependent solutions *) + (* and favor progress when used with the refine tactics *) + let evd = aux (List.rev l) in + solve_unconstrained_evars_with_canditates evd + +let solve_unconstrained_impossible_cases evd = + Evd.fold_undefined (fun evk ev_info evd' -> + match ev_info.evar_source with + | _,ImpossibleCase -> Evd.define evk (j_type (coq_unit_judge ())) evd' + | _ -> evd') evd evd + let consider_remaining_unif_problems ?(ts=full_transparent_state) env evd = + let evd = solve_unconstrained_evars_with_canditates evd in let (evd,pbs) = extract_all_conv_pbs evd in let heuristic_solved_evd = List.fold_left (fun evd (pbty,env,t1,t2) -> @@ -761,14 +827,7 @@ let consider_remaining_unif_problems ?(ts=full_transparent_state) env evd = if b then evd' else Pretype_errors.error_cannot_unify env evd (t1, t2)) evd pbs in check_problems_are_solved env heuristic_solved_evd; - Evd.fold_undefined (fun ev ev_info evd' -> match ev_info.evar_source with - |_,ImpossibleCase -> - Evd.define ev (j_type (coq_unit_judge ())) evd' - |_ -> - match ev_info.evar_candidates with - | Some (a::l) -> Evd.define ev a evd' - | Some [] -> error "Unsolvable existential variables" - | None -> evd') heuristic_solved_evd heuristic_solved_evd + solve_unconstrained_impossible_cases heuristic_solved_evd (* Main entry points *) @@ -782,12 +841,12 @@ let the_conv_x_leq ?(ts=full_transparent_state) env t1 t2 evd = (evd', true) -> evd' | _ -> raise Reduction.NotConvertible -let e_conv ?(ts=full_transparent_state) env evd t1 t2 = - match evar_conv_x ts env !evd CONV t1 t2 with - (evd',true) -> evd := evd'; true +let e_conv ?(ts=full_transparent_state) env evdref t1 t2 = + match evar_conv_x ts env !evdref CONV t1 t2 with + (evd',true) -> evdref := evd'; true | _ -> false -let e_cumul ?(ts=full_transparent_state) env evd t1 t2 = - match evar_conv_x ts env !evd CUMUL t1 t2 with - (evd',true) -> evd := evd'; true +let e_cumul ?(ts=full_transparent_state) env evdref t1 t2 = + match evar_conv_x ts env !evdref CUMUL t1 t2 with + (evd',true) -> evdref := evd'; true | _ -> false diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 7d66bee0..689fab50 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -21,8 +21,11 @@ open Reductionops open Pretype_errors open Retyping -(* Expanding existential variables *) -(* 1- flush_and_check_evars fails if an existential is undefined *) +(****************************************************) +(* Expanding/testing/exposing existential variables *) +(****************************************************) + +(* flush_and_check_evars fails if an existential is undefined *) exception Uninstantiated_evar of existential_key @@ -71,6 +74,77 @@ let nf_evars_undefined evm = let nf_evar_map evd = Evd.evars_reset_evd (nf_evars evd) evd let nf_evar_map_undefined evd = Evd.evars_reset_evd (nf_evars_undefined evd) evd +(*-------------------*) +(* Auxiliary functions for the conversion algorithms modulo evars + *) + +let has_undefined_evars_or_sorts evd t = + let rec has_ev t = + match kind_of_term t with + | Evar (ev,args) -> + (match evar_body (Evd.find evd ev) with + | Evar_defined c -> + has_ev c; Array.iter has_ev args + | Evar_empty -> + raise NotInstantiatedEvar) + | Sort s when is_sort_variable evd s -> raise Not_found + | _ -> iter_constr has_ev t in + try let _ = has_ev t in false + with (Not_found | NotInstantiatedEvar) -> true + +let is_ground_term evd t = + not (has_undefined_evars_or_sorts evd t) + +let is_ground_env evd env = + let is_ground_decl = function + (_,Some b,_) -> is_ground_term evd b + | _ -> true in + List.for_all is_ground_decl (rel_context env) && + List.for_all is_ground_decl (named_context env) +(* Memoization is safe since evar_map and environ are applicative + structures *) +let is_ground_env = memo1_2 is_ground_env + +(* Return the head evar if any *) + +exception NoHeadEvar + +let head_evar = + let rec hrec c = match kind_of_term c with + | Evar (evk,_) -> evk + | Case (_,_,c,_) -> hrec c + | App (c,_) -> hrec c + | Cast (c,_,_) -> hrec c + | _ -> raise NoHeadEvar + in + hrec + +(* Expand head evar if any (currently consider only applications but I + guess it should consider Case too) *) + +let whd_head_evar_stack sigma c = + let rec whrec (c, l as s) = + match kind_of_term c with + | Evar (evk,args as ev) when Evd.is_defined sigma evk + -> whrec (existential_value sigma ev, l) + | Cast (c,_,_) -> whrec (c, l) + | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l) + | _ -> s + in + whrec (c, []) + +let whd_head_evar sigma c = applist (whd_head_evar_stack sigma c) + +let noccur_evar evd evk c = + let rec occur_rec c = match kind_of_term c with + | Evar (evk',_ as ev') -> + (match safe_evar_value evd ev' with + | Some c -> occur_rec c + | None -> if evk = evk' then raise Occur) + | _ -> iter_constr occur_rec c + in + try occur_rec c; true with Occur -> false + (**********************) (* Creating new metas *) (**********************) @@ -125,6 +199,19 @@ let evars_to_metas sigma (emap, c) = let emap = nf_evar_map_undefined emap in let sigma',emap' = push_dependent_evars sigma emap in let sigma',emap' = push_duplicated_evars sigma' emap' c in + (* if an evar has been instantiated in [emap] (as part of typing [c]) + then it is instantiated in [sigma]. *) + let repair_evars sigma emap = + fold_undefined begin fun ev _ sigma' -> + try + let info = find emap ev in + match evar_body info with + | Evar_empty -> sigma' + | Evar_defined body -> define ev body sigma' + with Not_found -> sigma' + end sigma sigma + in + let sigma' = repair_evars sigma' emap in let change_exist evar = let ty = nf_betaiota emap (existential_type emap evar) in let n = new_meta() in @@ -141,6 +228,18 @@ let non_instantiated sigma = let listev = Evd.undefined_list sigma in List.map (fun (ev,evi) -> (ev,nf_evar_info sigma evi)) listev +(************************) +(* Manipulating filters *) +(************************) + +let apply_subfilter filter subfilter = + fst (List.fold_right (fun oldb (l,filter) -> + if oldb then List.hd filter::l,List.tl filter else (false::l,filter)) + filter ([], List.rev subfilter)) + +let extract_subfilter initial_filter refined_filter = + snd (list_filter2 (fun b1 b2 -> b1) (initial_filter,refined_filter)) + (**********************) (* Creating new evars *) (**********************) @@ -158,14 +257,153 @@ let new_untyped_evar = * functional operations on evar sets * *------------------------------------*) -let new_evar_instance sign evd typ ?(src=(dummy_loc,InternalHole)) ?filter ?candidates instance = - assert - (let ctxt = named_context_of_val sign in - list_distinct (ids_of_named_context ctxt)); +(* [push_rel_context_to_named_context] builds the defining context and the + * initial instance of an evar. If the evar is to be used in context + * + * Gamma = a1 ... an xp ... x1 + * \- named part -/ \- de Bruijn part -/ + * + * then the x1...xp are turned into variables so that the evar is declared in + * context + * + * a1 ... an xp ... x1 + * \----------- named part ------------/ + * + * but used applied to the initial instance "a1 ... an Rel(p) ... Rel(1)" + * so that ev[a1:=a1 ... an:=an xp:=Rel(p) ... x1:=Rel(1)] is correctly typed + * in context Gamma. + * + * Remark 1: The instance is reverted in practice (i.e. Rel(1) comes first) + * Remark 2: If some of the ai or xj are definitions, we keep them in the + * instance. This is necessary so that no unfolding of local definitions + * happens when inferring implicit arguments (consider e.g. the problem + * "x:nat; x':=x; f:forall y, y=y -> Prop |- f _ (refl_equal x')" which + * produces the equation "?y[x,x']=?y[x,x']" =? "x'=x'": we want + * the hole to be instantiated by x', not by x (which would have been + * the case in [invert_definition] if x' had disappeared from the instance). + * Note that at any time, if, in some context env, the instance of + * declaration x:A is t and the instance of definition x':=phi(x) is u, then + * we have the property that u and phi(t) are convertible in env. + *) + +let push_rel_context_to_named_context env typ = + (* compute the instances relative to the named context and rel_context *) + let ids = List.map pi1 (named_context env) in + let inst_vars = List.map mkVar ids in + let inst_rels = List.rev (rel_list 0 (nb_rel env)) in + (* move the rel context to a named context and extend the named instance *) + (* with vars of the rel context *) + (* We do keep the instances corresponding to local definition (see above) *) + let (subst, _, env) = + Sign.fold_rel_context + (fun (na,c,t) (subst, avoid, env) -> + let id = next_name_away na avoid in + let d = (id,Option.map (substl subst) c,substl subst t) in + (mkVar id :: subst, id::avoid, push_named d env)) + (rel_context env) ~init:([], ids, env) in + (named_context_val env, substl subst typ, inst_rels@inst_vars, subst) + +(*------------------------------------* + * Entry points to define new evars * + *------------------------------------*) + +let default_source = (dummy_loc,InternalHole) + +let new_pure_evar evd sign ?(src=default_source) ?filter ?candidates typ = let newevk = new_untyped_evar() in - let evd = evar_declare sign newevk typ ~src:src ?filter ?candidates evd in + let evd = evar_declare sign newevk typ ~src ?filter ?candidates evd in + (evd,newevk) + +let new_evar_instance sign evd typ ?src ?filter ?candidates instance = + assert (not !Flags.debug || + list_distinct (ids_of_named_context (named_context_of_val sign))); + let evd,newevk = new_pure_evar evd sign ?src ?filter ?candidates typ in (evd,mkEvar (newevk,Array.of_list instance)) +(* [new_evar] declares a new existential in an env env with type typ *) +(* Converting the env into the sign of the evar to define *) + +let new_evar evd env ?src ?filter ?candidates typ = + let sign,typ',instance,subst = push_rel_context_to_named_context env typ in + let candidates = Option.map (List.map (substl subst)) candidates in + let instance = + match filter with + | None -> instance + | Some filter -> list_filter_with filter instance in + new_evar_instance sign evd typ' ?src ?filter ?candidates instance + +let new_type_evar ?src ?filter evd env = + let evd', s = new_sort_variable evd in + new_evar evd' env ?src ?filter (mkSort s) + + (* The same using side-effect *) +let e_new_evar evdref env ?(src=(dummy_loc,InternalHole)) ?filter ?candidates ty = + let (evd',ev) = new_evar !evdref env ~src:src ?filter ?candidates ty in + evdref := evd'; + ev + +(*------------------------------------* + * Restricting existing evars * + *------------------------------------*) + +let restrict_evar_key evd evk filter candidates = + if filter = None && candidates = None then + evd,evk + else + let evi = Evd.find_undefined evd evk in + let oldfilter = evar_filter evi in + if filter = Some oldfilter && candidates = None then + evd,evk + else + let filter = + match filter with + | None -> evar_filter evi + | Some filter -> filter in + let candidates = + match candidates with None -> evi.evar_candidates | _ -> candidates in + let ccl = evi.evar_concl in + let sign = evar_hyps evi in + let src = evi.evar_source in + let evd,newevk = new_pure_evar evd sign ccl ~src ~filter ?candidates in + let ctxt = snd (list_filter2 (fun b c -> b) (filter,evar_context evi)) in + let id_inst = Array.of_list (List.map (fun (id,_,_) -> mkVar id) ctxt) in + Evd.define evk (mkEvar(newevk,id_inst)) evd,newevk + +(* Restrict an applied evar and returns its restriction in the same context *) +let restrict_applied_evar evd (evk,argsv) filter candidates = + let evd,newevk = restrict_evar_key evd evk filter candidates in + let newargsv = match filter with + | None -> (* optim *) argsv + | Some filter -> + let evi = Evd.find evd evk in + let subfilter = extract_subfilter (evar_filter evi) filter in + array_filter_with subfilter argsv in + evd,(newevk,newargsv) + +(* Restrict an evar in the current evar_map *) +let restrict_evar evd evk filter candidates = + fst (restrict_evar_key evd evk filter candidates) + +(* Restrict an evar in the current evar_map *) +let restrict_instance evd evk filter argsv = + match filter with None -> argsv | Some filter -> + let evi = Evd.find evd evk in + array_filter_with (extract_subfilter (evar_filter evi) filter) argsv + +(* This assumes an evar with identity instance and generalizes it over only + the De Bruijn part of the context *) +let generalize_evar_over_rels sigma (ev,args) = + let evi = Evd.find sigma ev in + let sign = named_context_of_val evi.evar_hyps in + List.fold_left2 + (fun (c,inst as x) a d -> + if isRel a then (mkNamedProd_or_LetIn d c,a::inst) else x) + (evi.evar_concl,[]) (Array.to_list args) sign + +(***************************************) +(* Managing chains of local definitons *) +(***************************************) + (* Expand rels and vars that are bound to other rels or vars so that dependencies in variables are canonically associated to the most ancient variable in its family of aliased variables *) @@ -209,6 +447,12 @@ let make_alias_map env = let rel_aliases = compute_rel_aliases var_aliases (rel_context env) in (var_aliases,rel_aliases) +let lift_aliases n (var_aliases,rel_aliases as aliases) = + if n = 0 then aliases else + (var_aliases, + Intmap.fold (fun p l -> Intmap.add (p+n) (List.map (lift n) l)) + rel_aliases Intmap.empty) + let get_alias_chain_of aliases x = match kind_of_term x with | Rel n -> (try Intmap.find n (snd aliases) with Not_found -> []) | Var id -> (try Idmap.find id (fst aliases) with Not_found -> []) @@ -250,6 +494,11 @@ let extend_alias (_,b,_) (var_aliases,rel_aliases) = | None -> rel_aliases in (var_aliases, rel_aliases) +let expand_alias_once aliases x = + match get_alias_chain_of aliases x with + | [] -> None + | l -> Some (list_last l) + let rec expansions_of_var aliases x = match get_alias_chain_of aliases x with | [] -> [x] @@ -272,15 +521,25 @@ 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 Intset.empty and acc2 = ref Idset.empty in - let rec frec (aliases,depth) c = match kind_of_term c with - | Rel _ | Var _ -> + let cache_rel = ref Intset.empty and cache_var = ref Idset.empty in + let is_in_cache depth = function + | Rel n -> Intset.mem (n-depth) !cache_rel + | Var s -> Idset.mem s !cache_var + | _ -> false in + let put_in_cache depth = function + | Rel n -> cache_rel := Intset.add (n-depth) !cache_rel + | Var s -> cache_var := Idset.add s !cache_var + | _ -> () in + let rec frec (aliases,depth) c = + match kind_of_term c with + | 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 - (match kind_of_term c with + match kind_of_term c with | Var id -> acc2 := Idset.add id !acc2 | Rel n -> if n >= depth+1 then acc1 := Intset.add (n-depth) !acc1 - | _ -> - (* not optimal: would need sharing if alias occurs more than once *) - frec (aliases,depth) c) + | _ -> frec (aliases,depth) c end | Const _ | Ind _ | Construct _ -> acc2 := List.fold_right Idset.add (vars_of_global (Global.env()) c) !acc2 | _ -> @@ -291,259 +550,9 @@ let free_vars_and_rels_up_alias_expansion aliases c = frec (aliases,0) c; (!acc1,!acc2) -(* Knowing that [Gamma |- ev : T] and that [ev] is applied to [args], - * [make_projectable_subst ev args] builds the substitution [Gamma:=args]. - * If a variable and an alias of it are bound to the same instance, we skip - * the alias (we just use eq_constr -- instead of conv --, since anyway, - * only instances that are variables -- or evars -- are later considered; - * morever, we can bet that similar instances came at some time from - * the very same substitution. The removal of aliased duplicates is - * useful to ensure the uniqueness of a projection. -*) - -let make_projectable_subst aliases sigma evi args = - let sign = evar_filtered_context evi in - let evar_aliases = compute_var_aliases sign in - let (_,full_subst,cstr_subst) = - List.fold_right - (fun (id,b,c) (args,all,cstrs) -> - match b,args with - | None, a::rest -> - let a = whd_evar sigma a in - let cstrs = - let a',args = decompose_app_vect a in - match kind_of_term a' with - | Construct cstr -> - let l = try Constrmap.find cstr cstrs with Not_found -> [] in - Constrmap.add cstr ((args,id)::l) cstrs - | _ -> cstrs in - (rest,Idmap.add id [a,normalize_alias_opt aliases a,id] all,cstrs) - | Some c, a::rest -> - let a = whd_evar sigma a in - (match kind_of_term c with - | Var id' -> - let idc = normalize_alias_var evar_aliases id' in - let sub = try Idmap.find idc all with Not_found -> [] in - if List.exists (fun (c,_,_) -> eq_constr a c) sub then - (rest,all,cstrs) - else - (rest, - Idmap.add idc ((a,normalize_alias_opt aliases a,id)::sub) all, - cstrs) - | _ -> - (rest,Idmap.add id [a,normalize_alias_opt aliases a,id] all,cstrs)) - | _ -> anomaly "Instance does not match its signature") - sign (array_rev_to_list args,Idmap.empty,Constrmap.empty) in - (full_subst,cstr_subst) - -let make_pure_subst evi args = - snd (List.fold_right - (fun (id,b,c) (args,l) -> - match args with - | a::rest -> (rest, (id,a)::l) - | _ -> anomaly "Instance does not match its signature") - (evar_filtered_context evi) (array_rev_to_list args,[])) - -(* [push_rel_context_to_named_context] builds the defining context and the - * initial instance of an evar. If the evar is to be used in context - * - * Gamma = a1 ... an xp ... x1 - * \- named part -/ \- de Bruijn part -/ - * - * then the x1...xp are turned into variables so that the evar is declared in - * context - * - * a1 ... an xp ... x1 - * \----------- named part ------------/ - * - * but used applied to the initial instance "a1 ... an Rel(p) ... Rel(1)" - * so that ev[a1:=a1 ... an:=an xp:=Rel(p) ... x1:=Rel(1)] is correctly typed - * in context Gamma. - * - * Remark 1: The instance is reverted in practice (i.e. Rel(1) comes first) - * Remark 2: If some of the ai or xj are definitions, we keep them in the - * instance. This is necessary so that no unfolding of local definitions - * happens when inferring implicit arguments (consider e.g. the problem - * "x:nat; x':=x; f:forall y, y=y -> Prop |- f _ (refl_equal x')" which - * produces the equation "?y[x,x']=?y[x,x']" =? "x'=x'": we want - * the hole to be instantiated by x', not by x (which would have been - * the case in [invert_definition] if x' had disappeared from the instance). - * Note that at any time, if, in some context env, the instance of - * declaration x:A is t and the instance of definition x':=phi(x) is u, then - * we have the property that u and phi(t) are convertible in env. - *) - -let push_rel_context_to_named_context env typ = - (* compute the instances relative to the named context and rel_context *) - let ids = List.map pi1 (named_context env) in - let inst_vars = List.map mkVar ids in - let inst_rels = List.rev (rel_list 0 (nb_rel env)) in - (* move the rel context to a named context and extend the named instance *) - (* with vars of the rel context *) - (* We do keep the instances corresponding to local definition (see above) *) - let (subst, _, env) = - Sign.fold_rel_context - (fun (na,c,t) (subst, avoid, env) -> - let id = next_name_away na avoid in - let d = (id,Option.map (substl subst) c,substl subst t) in - (mkVar id :: subst, id::avoid, push_named d env)) - (rel_context env) ~init:([], ids, env) in - (named_context_val env, substl subst typ, inst_rels@inst_vars, subst) - -(* [new_evar] declares a new existential in an env env with type typ *) -(* Converting the env into the sign of the evar to define *) - -let new_evar evd env ?(src=(dummy_loc,InternalHole)) ?filter ?candidates typ = - let sign,typ',instance,subst = push_rel_context_to_named_context env typ in - let candidates = Option.map (List.map (substl subst)) candidates in - let instance = - match filter with - | None -> instance - | Some filter -> snd (list_filter2 (fun b c -> b) (filter,instance)) in - new_evar_instance sign evd typ' ~src:src ?filter ?candidates instance - - (* The same using side-effect *) -let e_new_evar evdref env ?(src=(dummy_loc,InternalHole)) ?filter ?candidates ty = - let (evd',ev) = new_evar !evdref env ~src:src ?filter ?candidates ty in - evdref := evd'; - ev - -(* This assumes an evar with identity instance and generalizes it over only - the de Bruijn part of the context *) -let generalize_evar_over_rels sigma (ev,args) = - let evi = Evd.find sigma ev in - let sign = named_context_of_val evi.evar_hyps in - List.fold_left2 - (fun (c,inst as x) a d -> - if isRel a then (mkNamedProd_or_LetIn d c,a::inst) else x) - (evi.evar_concl,[]) (Array.to_list args) sign - -(*------------------------------------* - * operations on the evar constraints * - *------------------------------------*) - -exception IllTypedFilter - -let check_restricted_occur evd refine env filter constr = - let filter = Array.of_list filter in - let rec aux k c = - let c = whd_evar evd c in - match kind_of_term c with - | Var id -> - let idx = list_try_find_i (fun i (id', _, _) -> if id' = id then i else raise (Failure "")) 0 env in - if not filter.(idx) - then if refine then - (filter.(idx) <- true; c) - else raise IllTypedFilter - else c - | _ -> map_constr_with_binders succ aux k c - in - let res = aux 0 constr in - Array.to_list filter, res - -(* We have a unification problem Σ; Γ |- ?e[u1..uq] = t : s where ?e is not yet - * declared in Σ but yet known to be declarable in some context x1:T1..xq:Tq. - * [define_evar_from_virtual_equation ... Γ Σ t (x1:T1..xq:Tq) .. (u1..uq) (x1..xq)] - * declares x1:T1..xq:Tq |- ?e : s such that ?e[u1..uq] = t holds. - *) - -let define_evar_from_virtual_equation define_fun env evd t_in_env sign filter inst_in_env - inst_in_sign = - let ty_t_in_env = Retyping.get_type_of env evd t_in_env in - let evd,evar_in_env = new_evar_instance sign evd ty_t_in_env ~filter inst_in_env in - let t_in_env = whd_evar evd t_in_env in - let evd = define_fun env evd (destEvar evar_in_env) t_in_env in - let evar_in_sign = mkEvar (fst (destEvar evar_in_env), Array.of_list inst_in_sign) in - (evd,whd_evar evd evar_in_sign) - -(* We have x1..xq |- ?e1 : Ï„ and had to solve something like - * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some - * ?e2[v1..vn], hence flexible. We had to go through k binders and now - * virtually have x1..xq, y1'..yk' | ?e1' : Ï„' and the equation - * Γ, y1..yk |- ?e1'[u1..uq y1..yk] = c. - * [materialize_evar Γ evd k (?e1[u1..uq]) Ï„'] extends Σ with the declaration - * of ?e1' and returns both its instance ?e1'[x1..xq y1..yk] in an extension - * of the context of e1 so that e1 can be instantiated by - * (...\y1' ... \yk' ... ?e1'[x1..xq y1'..yk']), - * and the instance ?e1'[u1..uq y1..yk] so that the remaining equation - * ?e1'[u1..uq y1..yk] = c can be registered - * - * Note that, because invert_definition does not check types, we need to - * guess the types of y1'..yn' by inverting the types of y1..yn along the - * substitution u1..uq. - *) - -let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = - let evi1 = Evd.find_undefined evd evk1 in - let env1,rel_sign = env_rel_context_chop k env in - let sign1 = evar_hyps evi1 in - let filter1 = evar_filter evi1 in - let ids1 = List.map pi1 (named_context_of_val sign1) in - let inst_in_sign = - List.map mkVar (snd (list_filter2 (fun b id -> b) (filter1,ids1))) in - let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) = - List.fold_right (fun (na,b,t_in_env as d) (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) -> - match b with - | None -> - let id = next_name_away na avoid in - let evd,t_in_sign = - define_evar_from_virtual_equation define_fun env evd t_in_env - sign filter inst_in_env inst_in_sign in - (push_named_context_val (id,None,t_in_sign) sign,true::filter, - (mkRel 1)::(List.map (lift 1) inst_in_env),(mkVar id)::inst_in_sign, - push_rel d env,evd,id::avoid) - | Some b -> - (sign,filter,inst_in_env,inst_in_sign, - push_rel d env,evd,avoid)) - rel_sign - (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,ids1) - in - let evd,ev2ty_in_sign = - define_evar_from_virtual_equation define_fun env evd ty_in_env - sign2 filter2 inst2_in_env inst2_in_sign in - let evd,ev2_in_sign = - new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 inst2_in_sign in - let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in - (evd, ev2_in_sign, ev2_in_env) - -let subfilter env ccl filter newfilter args = - let vars = collect_vars ccl in - let (filter, _, _, newargs) = - List.fold_left2 - (fun (filter, newl, args, newargs) oldf (n, _, _) -> - if oldf then - let a, oldargs = match args with hd :: tl -> hd, tl | _ -> assert false in - if Idset.mem n vars then - (oldf :: filter, List.tl newl, oldargs, a :: newargs) - else if List.hd newl then (true :: filter, List.tl newl, oldargs, a :: newargs) - else (false :: filter, List.tl newl, oldargs, newargs) - else (oldf :: filter, newl, args, newargs)) - ([], newfilter, args, []) filter env - in List.rev filter, List.rev newargs - -let restrict_upon_filter ?(refine=false) evd evi evk p args = - let filter = evar_filter evi in - let newfilter = List.map p args in - let env = evar_unfiltered_env evi in - let ccl = nf_evar evd evi.evar_concl in - let newfilter, newargs = - subfilter (named_context env) ccl filter newfilter args - in - if newfilter <> filter then - let (evd,newev) = new_evar evd env ~src:(evar_source evk evd) - ~filter:newfilter ccl in - let evd = Evd.define evk newev evd in - evd,fst (destEvar newev), newargs - else - evd,evk,args - -let collect_vars c = - let rec collrec acc c = - match kind_of_term c with - | Var id -> list_add_set id acc - | _ -> fold_constr collrec acc c - in - collrec [] c +(************************************) +(* Removing a dependency in an evar *) +(************************************) type clear_dependency_error = | OccurHypInSimpleClause of identifier option @@ -590,7 +599,7 @@ let rec check_and_clear_in_constr evdref err ids c = (* Check if some id to clear occurs in the instance a of rid in ev and remember the dependency *) match - List.filter (fun id -> List.mem id ids) (collect_vars a) + List.filter (fun id -> List.mem id ids) (Idset.elements (collect_vars a)) with | id :: _ -> (hy,ar,(rid,id)::ri) | _ -> @@ -655,6 +664,255 @@ let clear_hyps_in_evi evdref hyps concl ids = in (nhyps,nconcl) +(********************************) +(* Managing pattern-unification *) +(********************************) + +let rec expand_and_check_vars aliases = function + | [] -> [] + | a::l when isRel a or isVar a -> + let a = expansion_of_var aliases a in + if isRel a or isVar a then a :: expand_and_check_vars aliases l + else raise Exit + | _ -> + raise Exit + +module Constrhash = Hashtbl.Make + (struct type t = constr + let equal = eq_constr + let hash = hash_constr + end) + +let rec constr_list_distinct l = + let visited = Constrhash.create 23 in + let rec loop = function + | h::t -> + if Constrhash.mem visited h then false + else (Constrhash.add visited h h; loop t) + | [] -> true + in loop l + +let get_actual_deps aliases l t = + if occur_meta_or_existential t then + (* Probably no restrictions on allowed vars in presence of evars *) + 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 + List.filter (fun c -> + match kind_of_term c with + | Var id -> Idset.mem id fv_ids + | Rel n -> Intset.mem n fv_rels + | _ -> assert false) l + +let remove_instance_local_defs evd evk args = + let evi = Evd.find evd evk in + let rec aux = function + | (_,Some _,_)::sign, a::args -> aux (sign,args) + | (_,None,_)::sign, a::args -> a::aux (sign,args) + | [], [] -> [] + | _ -> assert false in + aux (evar_filtered_context evi, args) + +(* Check if an applied evar "?X[args] l" is a Miller's pattern *) + +let find_unification_pattern_args env l t = + if List.for_all (fun x -> isRel x || isVar x) l (* common failure case *) then + let aliases = make_alias_map env in + match (try Some (expand_and_check_vars aliases l) with Exit -> None) with + | Some l as x when constr_list_distinct (get_actual_deps aliases l t) -> x + | _ -> None + else + None + +let is_unification_pattern_meta env nb m l t = + (* Variables from context and rels > nb are implicitly all there *) + (* so we need to be a rel <= nb *) + if List.for_all (fun x -> isRel x && destRel x <= nb) l then + match find_unification_pattern_args env l t with + | Some _ as x when not (dependent (mkMeta m) t) -> x + | _ -> None + else + None + +let is_unification_pattern_evar env evd (evk,args) l t = + if List.for_all (fun x -> isRel x || isVar x) l & noccur_evar evd evk t then + let args = remove_instance_local_defs evd evk (Array.to_list args) in + let n = List.length args in + match find_unification_pattern_args env (args @ l) t with + | Some l -> Some (list_skipn n l) + | _ -> None + else + None + +let is_unification_pattern_pure_evar env evd (evk,args) t = + is_unification_pattern_evar env evd (evk,args) [] t <> None + +let is_unification_pattern (env,nb) evd f l t = + match kind_of_term f with + | Meta m -> is_unification_pattern_meta env nb m l t + | Evar ev -> is_unification_pattern_evar env evd ev l t + | _ -> None + +(* From a unification problem "?X l = c", build "\x1...xn.(term1 l2)" + (pattern unification). It is assumed that l is made of rel's that + are distinct and not bound to aliases. *) +(* It is also assumed that c does not contain metas because metas + *implicitly* depend on Vars but lambda abstraction will not reflect this + dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should + return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *) +let solve_pattern_eqn env l c = + let c' = List.fold_right (fun a c -> + let c' = subst_term (lift 1 a) (lift 1 c) in + match kind_of_term a with + (* Rem: if [a] links to a let-in, do as if it were an assumption *) + | Rel n -> + let d = map_rel_declaration (lift n) (lookup_rel n env) in + mkLambda_or_LetIn d c' + | Var id -> + let d = lookup_named id env in mkNamedLambda_or_LetIn d c' + | _ -> assert false) + l c in + (* Warning: we may miss some opportunity to eta-reduce more since c' + is not in normal form *) + whd_eta c' + +(*****************************************) +(* Refining/solving unification problems *) +(*****************************************) + +(* Knowing that [Gamma |- ev : T] and that [ev] is applied to [args], + * [make_projectable_subst ev args] builds the substitution [Gamma:=args]. + * If a variable and an alias of it are bound to the same instance, we skip + * the alias (we just use eq_constr -- instead of conv --, since anyway, + * only instances that are variables -- or evars -- are later considered; + * morever, we can bet that similar instances came at some time from + * the very same substitution. The removal of aliased duplicates is + * useful to ensure the uniqueness of a projection. +*) + +let make_projectable_subst aliases sigma evi args = + let sign = evar_filtered_context evi in + let evar_aliases = compute_var_aliases sign in + let (_,full_subst,cstr_subst) = + List.fold_right + (fun (id,b,c) (args,all,cstrs) -> + match b,args with + | None, a::rest -> + let a = whd_evar sigma a in + let cstrs = + let a',args = decompose_app_vect a in + match kind_of_term a' with + | Construct cstr -> + let l = try Constrmap.find cstr cstrs with Not_found -> [] in + Constrmap.add cstr ((args,id)::l) cstrs + | _ -> cstrs in + (rest,Idmap.add id [a,normalize_alias_opt aliases a,id] all,cstrs) + | Some c, a::rest -> + let a = whd_evar sigma a in + (match kind_of_term c with + | Var id' -> + let idc = normalize_alias_var evar_aliases id' in + let sub = try Idmap.find idc all with Not_found -> [] in + if List.exists (fun (c,_,_) -> eq_constr a c) sub then + (rest,all,cstrs) + else + (rest, + Idmap.add idc ((a,normalize_alias_opt aliases a,id)::sub) all, + cstrs) + | _ -> + (rest,Idmap.add id [a,normalize_alias_opt aliases a,id] all,cstrs)) + | _ -> anomaly "Instance does not match its signature") + sign (array_rev_to_list args,Idmap.empty,Constrmap.empty) in + (full_subst,cstr_subst) + +let make_pure_subst evi args = + snd (List.fold_right + (fun (id,b,c) (args,l) -> + match args with + | a::rest -> (rest, (id,a)::l) + | _ -> anomaly "Instance does not match its signature") + (evar_filtered_context evi) (array_rev_to_list args,[])) + +(*------------------------------------* + * operations on the evar constraints * + *------------------------------------*) + +(* We have a unification problem Σ; Γ |- ?e[u1..uq] = t : s where ?e is not yet + * declared in Σ but yet known to be declarable in some context x1:T1..xq:Tq. + * [define_evar_from_virtual_equation ... Γ Σ t (x1:T1..xq:Tq) .. (u1..uq) (x1..xq)] + * declares x1:T1..xq:Tq |- ?e : s such that ?e[u1..uq] = t holds. + *) + +let define_evar_from_virtual_equation define_fun env evd t_in_env sign filter inst_in_env = + let ty_t_in_env = Retyping.get_type_of env evd t_in_env in + let evd,evar_in_env = new_evar_instance sign evd ty_t_in_env ~filter inst_in_env in + let t_in_env = whd_evar evd t_in_env in + let evd = define_fun env evd (destEvar evar_in_env) t_in_env in + let ids = List.map pi1 (named_context_of_val sign) in + let inst_in_sign = List.map mkVar (list_filter_with filter ids) in + let evar_in_sign = mkEvar (fst (destEvar evar_in_env), Array.of_list inst_in_sign) in + (evd,whd_evar evd evar_in_sign) + +(* We have x1..xq |- ?e1 : Ï„ and had to solve something like + * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some + * ?e2[v1..vn], hence flexible. We had to go through k binders and now + * virtually have x1..xq, y1'..yk' | ?e1' : Ï„' and the equation + * Γ, y1..yk |- ?e1'[u1..uq y1..yk] = c. + * [materialize_evar Γ evd k (?e1[u1..uq]) Ï„'] extends Σ with the declaration + * of ?e1' and returns both its instance ?e1'[x1..xq y1..yk] in an extension + * of the context of e1 so that e1 can be instantiated by + * (...\y1' ... \yk' ... ?e1'[x1..xq y1'..yk']), + * and the instance ?e1'[u1..uq y1..yk] so that the remaining equation + * ?e1'[u1..uq y1..yk] = c can be registered + * + * Note that, because invert_definition does not check types, we need to + * guess the types of y1'..yn' by inverting the types of y1..yn along the + * substitution u1..uq. + *) + +let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = + let evi1 = Evd.find_undefined evd evk1 in + let env1,rel_sign = env_rel_context_chop k env in + let sign1 = evar_hyps evi1 in + let filter1 = evar_filter evi1 in + let ids1 = List.map pi1 (named_context_of_val sign1) in + let inst_in_sign = List.map mkVar (list_filter_with filter1 ids1) in + let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) = + List.fold_right (fun (na,b,t_in_env as d) (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) -> + let id = next_name_away na avoid in + let evd,t_in_sign = + define_evar_from_virtual_equation define_fun env evd t_in_env + sign filter inst_in_env in + let evd,b_in_sign = match b with + | None -> evd,None + | Some b -> + let evd,b = define_evar_from_virtual_equation define_fun env evd b + sign filter inst_in_env in + evd,Some b in + (push_named_context_val (id,b_in_sign,t_in_sign) sign,true::filter, + (mkRel 1)::(List.map (lift 1) inst_in_env), + (mkRel 1)::(List.map (lift 1) inst_in_sign), + push_rel d env,evd,id::avoid)) + rel_sign + (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,ids1) + in + let evd,ev2ty_in_sign = + define_evar_from_virtual_equation define_fun env evd ty_in_env + sign2 filter2 inst2_in_env in + let evd,ev2_in_sign = + new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 inst2_in_sign in + let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in + (evd, ev2_in_sign, ev2_in_env) + +let restrict_upon_filter evd evk p args = + let newfilter = List.map p args in + if List.for_all (fun id -> id) newfilter then + None + else + let oldfullfilter = evar_filter (Evd.find_undefined evd evk) in + Some (apply_subfilter oldfullfilter newfilter) + (* Inverting constructors in instances (common when inferring type of match) *) let find_projectable_constructor env evd cstr k args cstr_subst = @@ -702,13 +960,13 @@ let find_projectable_constructor env evd cstr k args cstr_subst = * [make_projectable_subst]) *) -exception NotUnique -exception NotUniqueInType of types - type evar_projection = | ProjectVar | ProjectEvar of existential * evar_info * identifier * evar_projection +exception NotUnique +exception NotUniqueInType of (identifier * evar_projection) list + let rec assoc_up_to_alias sigma aliases y yc = function | [] -> raise Not_found | (c,cc,id)::l -> @@ -828,30 +1086,34 @@ type projectibility_status = | CannotInvert | Invertible of projectibility_kind -let invert_arg_from_subst aliases k sigma subst_in_env c_in_env_extended_with_k_binders = +let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders = let effects = ref [] in let rec aux k t = - let t = whd_evar sigma t in + let t = whd_evar evd t in match kind_of_term t with - | Rel i when i>k -> - project_with_effects aliases sigma effects (mkRel (i-k)) subst_in_env - | Var id -> - project_with_effects aliases sigma effects t subst_in_env - | _ -> - map_constr_with_binders succ aux k t in + | Rel i when i>k0+k -> aux' k (mkRel (i-k)) + | Var id -> aux' k t + | _ -> map_constr_with_binders succ aux k t + and aux' k t = + try project_with_effects aliases evd effects t subst_in_env_extended_with_k_binders + with Not_found -> + match expand_alias_once aliases t with + | None -> raise Not_found + | Some c -> aux k c in try - let c = aux k c_in_env_extended_with_k_binders in + let c = aux 0 c_in_env_extended_with_k_binders in Invertible (UniqueProjection (c,!effects)) with | Not_found -> CannotInvert | NotUnique -> Invertible NoUniqueProjection -let invert_arg aliases k sigma evk subst_in_env c_in_env_extended_with_k_binders = - let res = invert_arg_from_subst aliases k sigma subst_in_env c_in_env_extended_with_k_binders in +let invert_arg evd aliases k evk subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders = + let res = invert_arg_from_subst evd aliases k subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders in match res with - | Invertible (UniqueProjection (c,_)) when occur_evar evk c -> CannotInvert - | _ -> res - + | Invertible (UniqueProjection (c,_)) when not (noccur_evar evd evk c) -> + CannotInvert + | _ -> + res let effective_projections = map_succeed (function Invertible c -> c | _ -> failwith"") @@ -863,12 +1125,34 @@ let instance_of_projection f env t evd projs = | UniqueProjection (c,effects) -> (List.fold_left (do_projection_effects f env ty) evd effects, c) -let filter_of_projection = function CannotInvert -> false | _ -> true +exception NotEnoughInformationToInvert + +let extract_unique_projections projs = + List.map (function + | Invertible (UniqueProjection (c,_)) -> c + | _ -> + (* For instance, there are evars with non-invertible arguments and *) + (* we cannot arbitrarily restrict these evars before knowing if there *) + (* will really be used; it can also be due to some argument *) + (* (typically a rel) that is not inversible and that cannot be *) + (* inverted either because it is needed for typing the conclusion *) + (* of the evar to project *) + raise NotEnoughInformationToInvert) projs + +let extract_candidates sols = + try + Some + (List.map (function (id,ProjectVar) -> mkVar id | _ -> raise Exit) sols) + with Exit -> + None + +let filter_of_projection = function Invertible _ -> true | _ -> false -let filter_along f projs v = - let l = Array.to_list v in - let _,l = list_filter2 (fun b c -> f b) (projs,l) in - Array.of_list l +let invert_invertible_arg evd aliases k (evk,argsv) args' = + let evi = Evd.find_undefined evd evk in + let subst,_ = make_projectable_subst aliases evd evi argsv in + let projs = array_map_to_list (invert_arg evd aliases k evk subst) args' in + Array.of_list (extract_unique_projections projs) (* Redefines an evar with a smaller context (i.e. it may depend on less * variables) such that c becomes closed. @@ -883,7 +1167,27 @@ let filter_along f projs v = * such that "hyps' |- ?e : T" *) -let restrict_hyps ?(refine=false) evd evk filter = +let filter_candidates evd evk filter candidates = + let evi = Evd.find_undefined evd evk in + let candidates = match candidates with + | None -> evi.evar_candidates + | Some _ -> candidates in + match candidates,filter with + | None,_ | _, None -> candidates + | Some l, Some filter -> + let ids = List.map pi1 (list_filter_with filter (evar_context evi)) in + Some (List.filter (fun a -> + list_subset (Idset.elements (collect_vars a)) ids) l) + +let closure_of_filter evd evk filter = + let evi = Evd.find_undefined evd evk in + let vars = collect_vars (evar_concl evi) in + let ids = List.map pi1 (evar_context evi) in + let test id b = b || Idset.mem id vars in + let newfilter = List.map2 test ids filter in + if newfilter = evar_filter evi then None else Some newfilter + +let restrict_hyps evd evk filter candidates = (* What to do with dependencies? Assume we have x:A, y:B(x), z:C(x,y) |- ?e:T(x,y,z) and restrict on y. - If y is in a non-erasable position in C(x,y) (i.e. it is not below an @@ -894,66 +1198,75 @@ let restrict_hyps ?(refine=false) evd evk filter = interest for this early detection in practice is not obvious. We let it for future work. In any case, thanks to the use of filters, the whole (unrestricted) context remains consistent. *) - let evi = Evd.find evd evk in - let env = evar_unfiltered_env evi in - let oldfilter = evar_filter evi in - let filter,_ = List.fold_right (fun oldb (l,filter) -> - if oldb then List.hd filter::l,List.tl filter else (false::l,filter)) - oldfilter ([], List.rev filter) in - let filter, ccl = check_restricted_occur evd refine (named_context env) filter evi.evar_concl in - (env,evar_source evk evd,filter,ccl) - -let do_restrict_hyps evd evk projs = - let filter = List.map filter_of_projection projs in - if List.for_all (fun x -> x) filter then - evd,evk - else - let env,src,filter,ccl = restrict_hyps evd evk filter in - if List.for_all (fun x -> x) filter then - evd,evk - else - let evd,nc = new_evar evd env ~src ~filter ccl in - let evd = Evd.define evk nc evd in - let evk',_ = destEvar nc in - evd,evk' - -(* [postpone_evar_term] postpones an equation of the form ?e[σ] = c *) - -let postpone_evar_term env evd (evk,argsv) rhs = - assert (isVar rhs or isRel rhs); + let candidates = filter_candidates evd evk (Some filter) candidates in + let typablefilter = closure_of_filter evd evk filter in + (typablefilter,candidates) + +exception EvarSolvedWhileRestricting of evar_map * constr + +let do_restrict_hyps evd (evk,args as ev) filter candidates = + let filter,candidates = match filter with + | None -> None,candidates + | Some filter -> restrict_hyps evd evk filter candidates in + match candidates,filter with + | Some [], _ -> error "Not solvable." + | Some [nc],_ -> + let evd = Evd.define evk nc evd in + raise (EvarSolvedWhileRestricting (evd,whd_evar evd (mkEvar ev))) + | None, None -> evd,ev + | _ -> restrict_applied_evar evd ev filter candidates + +(* [postpone_non_unique_projection] postpones equation of the form ?e[?] = c *) +(* ?e is assumed to have no candidates *) + +let postpone_non_unique_projection env evd (evk,argsv as ev) sols rhs = let rhs = expand_vars_in_term env rhs in - let evi = Evd.find evd evk in - let evd,evk,args = - restrict_upon_filter evd evi evk - (* Keep only variables that depends in rhs *) + let filter = + restrict_upon_filter evd evk + (* Keep only variables that occur in rhs *) (* This is not safe: is the variable is a local def, its body *) (* may contain references to variables that are removed, leading to *) (* a ill-formed context. We would actually need a notion of filter *) (* that says that the body is hidden. Note that expand_vars_in_term *) (* expands only rels and vars aliases, not rels or vars bound to an *) (* arbitrary complex term *) - (fun a -> not (isRel a || isVar a) || dependent a rhs) + (fun a -> not (isRel a || isVar a) + || dependent a rhs || List.exists (fun (id,_) -> isVarId id a) sols) (Array.to_list argsv) in - let args = Array.of_list args in - let pb = (Reduction.CONV,env,mkEvar(evk,args),rhs) in - Evd.add_conv_pb pb evd + let filter = match filter with + | None -> None + | Some filter -> closure_of_filter evd evk filter in + let candidates = extract_candidates sols in + if candidates <> None then + restrict_evar evd evk filter candidates + else + (* We made an approximation by not expanding a local definition *) + let evd,ev = restrict_applied_evar evd ev filter None in + let pb = (Reduction.CONV,env,mkEvar ev,rhs) in + Evd.add_conv_pb pb evd -(* [postpone_evar_evar] postpones an equation of the form ?e1[σ1] = ?e2[σ2] *) +(* [postpone_evar_evar] postpones an equation of the form ?e1[?1] = ?e2[?2] *) -let postpone_evar_evar env evd projs1 (evk1,args1) projs2 (evk2,args2) = +let postpone_evar_evar f env evd filter1 ev1 filter2 ev2 = (* Leave an equation between (restrictions of) ev1 andv ev2 *) - let args1' = filter_along filter_of_projection projs1 args1 in - let evd,evk1' = do_restrict_hyps evd evk1 projs1 in - let args2' = filter_along filter_of_projection projs2 args2 in - let evd,evk2' = do_restrict_hyps evd evk2 projs2 in - let pb = (Reduction.CONV,env,mkEvar(evk1',args1'),mkEvar (evk2',args2')) in - add_conv_pb pb evd + try + let evd,ev1' = do_restrict_hyps evd ev1 filter1 None in + try + let evd,ev2' = do_restrict_hyps evd ev2 filter2 None in + add_conv_pb (Reduction.CONV,env,mkEvar ev1',mkEvar ev2') evd + with EvarSolvedWhileRestricting (evd,ev2) -> + (* ev2 solved on the fly *) + f env evd ev1' ev2 + with EvarSolvedWhileRestricting (evd,ev1) -> + (* ev1 solved on the fly *) + f env evd ev2 ev1 (* [solve_evar_evar f Γ Σ ?e1[u1..un] ?e2[v1..vp]] applies an heuristic * to solve the equation Σ; Γ ⊢ ?e1[u1..un] = ?e2[v1..vp]: * - if there are at most one φj for each vj s.t. vj = φj(u1..un), - * we first restrict ?2 to the subset v_k1..v_kq of the vj that are - * inversible and we set ?1[x1..xn] := ?2[φk1(x1..xn)..φkp(x1..xn)] + * we first restrict ?e2 to the subset v_k1..v_kq of the vj that are + * inversible and we set ?e1[x1..xn] := ?e2[φk1(x1..xn)..φkp(x1..xn)] + * (this is a case of pattern-unification) * - symmetrically if there are at most one ψj for each uj s.t. * uj = ψj(v1..vp), * - otherwise, each position i s.t. ui does not occur in v1..vp has to @@ -971,55 +1284,139 @@ let are_canonical_instances args1 args2 env = let n2 = Array.length args2 in let rec aux n = function | (id,_,c)::sign - when n < n1 && isVar args1.(n) && destVar args1.(n) = id && eq_constr args1.(n) args2.(n) -> + when n < n1 && isVarId id args1.(n) && isVarId id args2.(n) -> aux (n+1) sign | [] -> let rec aux2 n = n = n1 || - (isRel args1.(n) && destRel args1.(n) = n1-n && - isRel args2.(n) && destRel args2.(n) = n1-n && aux2 (n+1)) + (isRelN (n1-n) args1.(n) && isRelN (n1-n) args2.(n) && aux2 (n+1)) in aux2 n | _ -> false in n1 = n2 & aux 0 (named_context env) -exception CannotProject of projectibility_status list +let filter_compatible_candidates conv_algo env evd evi args rhs c = + let c' = instantiate_evar (evar_filtered_context evi) c args in + let evd, b = conv_algo env evd Reduction.CONV rhs c' in + if b then Some (c,evd) else None + +exception DoesNotPreserveCandidateRestriction + +let restrict_candidates conv_algo env evd filter1 (evk1,argsv1) (evk2,argsv2) = + let evi1 = Evd.find evd evk1 in + let evi2 = Evd.find evd evk2 in + let cand1 = filter_candidates evd evk1 filter1 None in + let cand2 = evi2.evar_candidates in + match cand1, cand2 with + | _, None -> cand1 + | None, Some _ -> raise DoesNotPreserveCandidateRestriction + | Some l1, Some l2 -> + let args1 = Array.to_list argsv1 in + let args2 = Array.to_list argsv2 in + let l1' = List.filter (fun c1 -> + let c1' = instantiate_evar (evar_filtered_context evi1) c1 args1 in + List.filter (fun c2 -> + (filter_compatible_candidates conv_algo env evd evi2 args2 c1' c2 + <> None)) l2 <> []) l1 in + if List.length l1 = List.length l1' then None else Some l1' + +exception CannotProject of bool list option + +(* Assume that FV(?n[x1:=t1..xn:=tn]) belongs to some set U. + Can ?n be instantiated by a term u depending essentially on xi such that the + FV(u[x1:=t1..xn:=tn]) are in the set U? + - If ti is a variable, it has to be in U. + - If ti is a constructor, its parameters cannot be erased even if u + matches on it, so we have to discard ti if the parameters + contain variables not in U. + - If ti is rigid, we have to discard it if it contains variables in U. + + Note: when restricting as part of an equation ?n[x1:=t1..xn:=tn] = ?m[...] + then, occurrences of ?m in the ti can be seen, like variables, as occurrences + of subterms to eventually discard so as to be allowed to keep ti. +*) -let is_variable_subst args = - array_for_all (fun c -> isRel c || isVar c) args +let rec is_constrainable_in k (ev,(fv_rels,fv_ids) as g) t = + let f,args = decompose_app_vect t in + match kind_of_term f with + | Construct (ind,_) -> + let nparams = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in + let params,_ = array_chop nparams args in + array_for_all (is_constrainable_in k g) params + | Ind _ -> array_for_all (is_constrainable_in k g) args + | Prod (_,t1,t2) -> is_constrainable_in k g t1 && is_constrainable_in k g t2 + | Evar (ev',_) -> ev' <> ev (*If ev' needed, one may also try to restrict it*) + | Var id -> Idset.mem id fv_ids + | Rel n -> n <= k || Intset.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 -> Idset.mem id fv_ids + | Rel n -> n <= k || Intset.mem n fv_rels + | _ -> is_constrainable_in 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 evd evk2) (Array.to_list 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 evd evk1) (Array.to_list 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 + +exception EvarSolvedOnTheFly of evar_map * constr + +let project_evar_on_evar g env evd aliases k2 (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) + (Array.to_list argsv1) in + (* Only try pruning on variable substitutions, postpone otherwise. *) + (* Rules out non-linear instances. *) + if is_unification_pattern_pure_evar env evd ev2 (mkEvar ev1) then + try + let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in + let evd,(evk1',args1) = do_restrict_hyps evd ev1 filter1 candidates1 in + evd,mkEvar (evk1',invert_invertible_arg evd aliases k2 ev2 args1) + with + | EvarSolvedWhileRestricting (evd,ev1) -> + raise (EvarSolvedOnTheFly (evd,ev1)) + | DoesNotPreserveCandidateRestriction | NotEnoughInformationToInvert -> + raise (CannotProject filter1) + else + raise (CannotProject filter1) -let solve_evar_evar_l2r f env evd (evk1,args1) (evk2,args2 as ev2) = - let aliases = make_alias_map env in - let subst,_ = make_projectable_subst aliases evd (Evd.find evd evk2) args2 in +let solve_evar_evar_l2r f g env evd aliases ev1 (evk2,_ as ev2) = + try + let evd,body = project_evar_on_evar g env evd aliases 0 ev1 ev2 in + Evd.define evk2 body evd + with EvarSolvedOnTheFly (evd,c) -> + f env evd ev2 c + +let solve_evar_evar ?(force=false) f g env evd (evk1,args1 as ev1) (evk2,args2 as ev2) = if are_canonical_instances args1 args2 env then (* If instances are canonical, we solve the problem in linear time *) let sign = evar_filtered_context (Evd.find evd evk2) in - let subst = List.map (fun (id,_,_) -> mkVar id) sign in - Evd.define evk2 (mkEvar(evk1,Array.of_list subst)) evd + let id_inst = list_map_to_array (fun (id,_,_) -> mkVar id) sign in + Evd.define evk2 (mkEvar(evk1,id_inst)) evd else - (* Only try pruning on variable substitutions, postpone otherwise. *) - if is_variable_subst args1 && is_variable_subst args2 then - let proj1 = array_map_to_list (invert_arg aliases 0 evd evk2 subst) args1 in - try - (* Instantiate ev2 with (a restriction of) ev1 if uniquely projectable. - Rules out non-linear instances. *) - let proj1' = effective_projections proj1 in - let evd,args1' = - list_fold_map (instance_of_projection f env (mkEvar ev2)) evd proj1' in - let evd,evk1' = do_restrict_hyps evd evk1 proj1 in - Evd.define evk2 (mkEvar(evk1',Array.of_list args1')) evd - with NotUnique -> raise (CannotProject proj1) - else raise IllTypedFilter - -let solve_evar_evar f env evd ev1 ev2 = - try - try solve_evar_evar_l2r f env evd ev1 ev2 - with CannotProject projs1 -> - try solve_evar_evar_l2r f env evd ev2 ev1 - with CannotProject projs2 -> - postpone_evar_evar env evd projs1 ev1 projs2 ev2 - with IllTypedFilter -> - let pb = (Reduction.CONV,env,mkEvar(ev1),mkEvar (ev2)) in - add_conv_pb pb evd + let evd,ev1,ev2 = + (* 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 else (evd,ev1,ev2) in + let aliases = make_alias_map env in + try solve_evar_evar_l2r f g env evd aliases ev1 ev2 + with CannotProject filter1 -> + try solve_evar_evar_l2r f g env evd aliases ev2 ev1 + with CannotProject filter2 -> + postpone_evar_evar f env evd filter1 ev1 filter2 ev2 type conv_fun = env -> evar_map -> conv_pb -> constr -> constr -> evar_map * bool @@ -1037,24 +1434,32 @@ let check_evar_instance evd evk1 body conv_algo = user_err_loc (fst (evar_source evk1 evd),"", str "Unable to find a well-typed instantiation") -(* Solve pbs (?i x1..xn) = (?i y1..yn) which arises often in fixpoint - * definitions. We try to unify the xi with the yi pairwise. The pairs - * that don't unify are discarded (i.e. ?i is redefined so that it does not +(* Solve pbs ?e[t1..tn] = ?e[u1..un] which arise often in fixpoint + * definitions. We try to unify the ti with the ui pairwise. The pairs + * that don't unify are discarded (i.e. ?e is redefined so that it does not * depend on these args). *) -let solve_refl conv_algo env evd evk argsv1 argsv2 = +let solve_refl ?(can_drop=false) conv_algo env evd evk argsv1 argsv2 = if array_equal eq_constr argsv1 argsv2 then evd else - let evi = Evd.find_undefined evd evk in (* Filter and restrict if needed *) - let evd,evk,args = - restrict_upon_filter evd evi evk + let untypedfilter = + restrict_upon_filter evd evk (fun (a1,a2) -> snd (conv_algo env evd Reduction.CONV a1 a2)) (List.combine (Array.to_list argsv1) (Array.to_list argsv2)) in + let candidates = filter_candidates evd evk untypedfilter None in + let filter = match untypedfilter with + | None -> None + | Some filter -> closure_of_filter evd evk filter in + let evd,ev1 = restrict_applied_evar evd (evk,argsv1) filter candidates in + if fst ev1 = evk & can_drop then (* No refinement *) evd else + (* either progress, or not allowed to drop, e.g. to preserve possibly *) + (* informative equations such as ?e[x:=?y]=?e[x:=?y'] where we don't know *) + (* if e can depend on x until ?y is not resolved, or, conversely, we *) + (* don't know if ?y has to be unified with ?y, until e is resolved *) + let argsv2 = restrict_instance evd evk filter argsv2 in + let ev2 = (fst ev1,argsv2) in (* Leave a unification problem *) - let args1,args2 = List.split args in - let argsv1 = Array.of_list args1 and argsv2 = Array.of_list args2 in - let pb = (Reduction.CONV,env,mkEvar(evk,argsv1),mkEvar(evk,argsv2)) in - Evd.add_conv_pb pb evd + Evd.add_conv_pb (Reduction.CONV,env,mkEvar ev1,mkEvar ev2) evd (* If the evar can be instantiated by a finite set of candidates known in advance, we check which of them apply *) @@ -1067,23 +1472,15 @@ let solve_candidates conv_algo env evd (evk,argsv as ev) rhs = match evi.evar_candidates with | None -> raise NoCandidates | Some l -> - let l' = list_map_filter (fun c -> - let c' = instantiate_evar (evar_filtered_context evi) c args in - let evd, b = conv_algo env evd Reduction.CONV c' rhs in - if b then Some (c,evd) else None) l in + let l' = + list_map_filter + (filter_compatible_candidates conv_algo env evd evi args rhs) l in match l' with | [] -> error_cannot_unify env evd (mkEvar ev, rhs) | [c,evd] -> Evd.define evk c evd | l when List.length l < List.length l' -> let candidates = List.map fst l in - let filter = evar_filter evi in - let sign = evar_hyps evi in - let ids = List.map pi1 (named_context_of_val sign) in - let inst_in_sign = - List.map mkVar (snd (list_filter2 (fun b id -> b) (filter,ids))) in - let evd,evar = new_evar_instance (evar_hyps evi) evd (evar_concl evi) - ~filter ~candidates inst_in_sign in - Evd.define evk evar evd + restrict_evar evd evk None (Some candidates) | l -> evd (* We try to instantiate the evar assuming the body won't depend @@ -1110,7 +1507,7 @@ let solve_candidates conv_algo env evd (evk,argsv as ev) rhs = *) exception NotInvertibleUsingOurAlgorithm of constr -exception NotEnoughInformationToProgress +exception NotEnoughInformationToProgress of (identifier * evar_projection) list exception OccurCheckIn of evar_map * constr let rec invert_definition conv_algo choose env evd (evk,argsv as ev) rhs = @@ -1129,8 +1526,7 @@ let rec invert_definition conv_algo choose env evd (evk,argsv as ev) rhs = | [] -> raise Not_found | [id,p] -> (mkVar id, p) | (id,p)::_::_ -> - if choose then (mkVar id, p) - else raise (NotUniqueInType(find_solution_type (evar_env evi) sols)) + if choose then (mkVar id, p) else raise (NotUniqueInType sols) in let ty = lazy (Retyping.get_type_of env !evdref t) in let evd = do_projection_effects (evar_define conv_algo) env ty !evdref p in @@ -1138,64 +1534,77 @@ let rec invert_definition conv_algo choose env evd (evk,argsv as ev) rhs = c with | Not_found -> raise (NotInvertibleUsingOurAlgorithm t) - | NotUniqueInType ty -> - if not !progress then raise NotEnoughInformationToProgress; + | NotUniqueInType sols -> + if not !progress then + raise (NotEnoughInformationToProgress sols); (* No unique projection but still restrict to where it is possible *) (* materializing is necessary, but is restricting useful? *) + let ty = find_solution_type (evar_env evi) sols in let sign = evar_filtered_context evi in let ty' = instantiate_evar sign ty (Array.to_list argsv) in - let (evd,_,ev') = + let (evd,evar,(evk',argsv' as ev')) = materialize_evar (evar_define conv_algo) env !evdref 0 ev ty' in let ts = expansions_of_var aliases t in let test c = isEvar c or List.mem c ts in - let filter = array_map_to_list test argsv in - let evarenv,src,filter,_ = restrict_hyps ~refine:true evd (fst ev') filter in - let args' = filter_along (fun x -> x) filter argsv in - let evd,evar = new_evar !evdref evarenv ~src ~filter ty in - let evk',_ = destEvar evar in - let pb = (Reduction.CONV,env,mkEvar(evk',args'),t) in - evdref := Evd.add_conv_pb pb evd; + let filter = array_map_to_list test argsv' in + let filter = apply_subfilter (evar_filter (Evd.find_undefined evd evk)) filter in + + let filter = closure_of_filter evd evk' filter in + let candidates = extract_candidates sols in + let evd = + if candidates <> None then restrict_evar evd evk' filter candidates + else + let evd,ev'' = restrict_applied_evar evd ev' filter None in + Evd.add_conv_pb (Reduction.CONV,env,mkEvar ev'',t) evd in + evdref := evd; evar in let rec imitate (env',k as envk) t = let t = whd_evar !evdref t in match kind_of_term t with - | Rel i when i>k -> project_variable (mkRel (i-k)) - | Var id -> project_variable t + | Rel i when i>k -> + (match pi2 (Environ.lookup_rel (i-k) env') with + | None -> project_variable (mkRel (i-k)) + | Some b -> + try project_variable (mkRel (i-k)) + with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i b)) + | Var id -> + (match pi2 (Environ.lookup_named id env') with + | None -> project_variable t + | Some b -> + try project_variable t + with NotInvertibleUsingOurAlgorithm _ -> imitate envk b) | Evar (evk',args' as ev') -> if evk = evk' then raise (OccurCheckIn (evd,rhs)); (* Evar/Evar problem (but left evar is virtual) *) - let projs' = - array_map_to_list - (invert_arg_from_subst aliases k !evdref subst) args' - in - (try - (* Try to project (a restriction of) the right evar *) - let eprojs' = effective_projections projs' in - let evd,args' = - list_fold_map (instance_of_projection (evar_define conv_algo) env' t) - !evdref eprojs' in - let evd,evk' = do_restrict_hyps evd evk' projs' in - evdref := evd; - mkEvar (evk',Array.of_list args') - with NotUnique | IllTypedFilter -> - assert !progress; - (* Make the virtual left evar real *) - let ty = get_type_of env' !evdref t in - let (evd,evar'',ev'') = + 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 ev' ev in + evdref := evd; + body + with + | EvarSolvedOnTheFly (evd,t) -> evdref:=evd; imitate envk t + | CannotProject filter' -> + assert !progress; + (* Make the virtual left evar real *) + let ty = get_type_of env' !evdref t in + let (evd,evar'',ev'') = materialize_evar (evar_define conv_algo) env' !evdref k ev ty in - (try - let evd = - (* Try to project (a restriction of) the left evar ... *) - try solve_evar_evar_l2r (evar_define conv_algo) env' evd ev'' ev' - with CannotProject projs'' -> - (* ... or postpone the problem *) - postpone_evar_evar env' evd projs'' ev'' projs' ev' - in - evdref := evd; - evar'' - with IllTypedFilter -> raise (NotInvertibleUsingOurAlgorithm t))) + 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 ev'' ev' in + Evd.define evk' body evd + with + | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *) + | CannotProject filter'' -> + (* ... or postpone the problem *) + postpone_evar_evar (evar_define conv_algo) env' evd filter'' ev'' filter' ev' in + evdref := evd; + evar'') | _ -> + progress := true; match let c,args = decompose_app_vect t in match kind_of_term c with @@ -1205,16 +1614,30 @@ let rec invert_definition conv_algo choose env evd (evk,argsv as ev) rhs = (* possible inversions; we do not treat overlap with a possible *) (* alternative inversion of the subterms of the constructor, etc)*) (match find_projectable_constructor env evd cstr k args cstr_subst with - | [id] -> Some (mkVar id) + | _::_ as l -> Some (List.map mkVar l) | _ -> None) | _ -> None with - | Some c -> c + | Some l -> + let ty = get_type_of env' !evdref t in + let candidates = + try + let t = + map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) + imitate envk t in + t::l + with _ -> l in + (match candidates with + | [x] -> x + | _ -> + let (evd,evar'',ev'') = + materialize_evar (evar_define conv_algo) env' !evdref k ev ty in + evdref := restrict_evar evd (fst ev'') None (Some candidates); + evar'') | None -> - progress := true; (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *) - map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) - imitate envk t in + map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) + imitate envk t in let rhs = whd_beta evd rhs (* heuristic *) in let body = imitate (env,0) rhs in @@ -1230,8 +1653,11 @@ let rec invert_definition conv_algo choose env evd (evk,argsv as ev) rhs = and evar_define conv_algo ?(choose=false) env evd (evk,argsv as ev) rhs = match kind_of_term rhs with | Evar (evk2,argsv2 as ev2) -> - if evk = evk2 then solve_refl conv_algo env evd evk argsv argsv2 - else solve_evar_evar (evar_define conv_algo) env evd ev ev2 + if evk = evk2 then + solve_refl ~can_drop:choose conv_algo env evd evk argsv argsv2 + else + solve_evar_evar ~force:choose + (evar_define conv_algo) conv_algo env evd ev ev2 | _ -> try solve_candidates conv_algo env evd ev rhs with NoCandidates -> @@ -1262,8 +1688,8 @@ and evar_define conv_algo ?(choose=false) env evd (evk,argsv as ev) rhs = let evd' = Evd.define evk body evd' in check_evar_instance evd' evk body conv_algo with - | NotEnoughInformationToProgress -> - postpone_evar_term env evd ev rhs + | NotEnoughInformationToProgress sols -> + postpone_non_unique_projection env evd ev sols rhs | NotInvertibleUsingOurAlgorithm t -> error_not_clean env evd evk t (evar_source evk evd) | OccurCheckIn (evd,rhs) -> @@ -1277,173 +1703,6 @@ and evar_define conv_algo ?(choose=false) env evd (evk,argsv as ev) rhs = | _ -> error_occur_check env evd evk rhs -(*-------------------*) -(* Auxiliary functions for the conversion algorithms modulo evars - *) - -let has_undefined_evars_or_sorts evd t = - let rec has_ev t = - match kind_of_term t with - | Evar (ev,args) -> - (match evar_body (Evd.find evd ev) with - | Evar_defined c -> - has_ev c; Array.iter has_ev args - | Evar_empty -> - raise NotInstantiatedEvar) - | Sort s when is_sort_variable evd s -> raise Not_found - | _ -> iter_constr has_ev t in - try let _ = has_ev t in false - with (Not_found | NotInstantiatedEvar) -> true - -let is_ground_term evd t = - not (has_undefined_evars_or_sorts evd t) - -let is_ground_env evd env = - let is_ground_decl = function - (_,Some b,_) -> is_ground_term evd b - | _ -> true in - List.for_all is_ground_decl (rel_context env) && - List.for_all is_ground_decl (named_context env) -(* Memoization is safe since evar_map and environ are applicative - structures *) -let is_ground_env = memo1_2 is_ground_env - -(* Return the head evar if any *) - -exception NoHeadEvar - -let head_evar = - let rec hrec c = match kind_of_term c with - | Evar (evk,_) -> evk - | Case (_,_,c,_) -> hrec c - | App (c,_) -> hrec c - | Cast (c,_,_) -> hrec c - | _ -> raise NoHeadEvar - in - hrec - -(* Expand head evar if any (currently consider only applications but I - guess it should consider Case too) *) - -let whd_head_evar_stack sigma c = - let rec whrec (c, l as s) = - match kind_of_term c with - | Evar (evk,args as ev) when Evd.is_defined sigma evk - -> whrec (existential_value sigma ev, l) - | Cast (c,_,_) -> whrec (c, l) - | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l) - | _ -> s - in - whrec (c, []) - -let whd_head_evar sigma c = applist (whd_head_evar_stack sigma c) - -let rec expand_and_check_vars aliases = function - | [] -> [] - | a::l when isRel a or isVar a -> - let a = expansion_of_var aliases a in - if isRel a or isVar a then a :: expand_and_check_vars aliases l - else raise Exit - | _ -> - raise Exit - -module Constrhash = Hashtbl.Make - (struct type t = constr - let equal = eq_constr - let hash = hash_constr - end) - -let rec constr_list_distinct l = - let visited = Constrhash.create 23 in - let rec loop = function - | h::t -> - if Constrhash.mem visited h then false - else (Constrhash.add visited h h; loop t) - | [] -> true - in loop l - -let get_actual_deps aliases l t = - if occur_meta_or_existential t then - (* Probably no restrictions on allowed vars in presence of evars *) - 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 - List.filter (fun c -> - match kind_of_term c with - | Var id -> Idset.mem id fv_ids - | Rel n -> Intset.mem n fv_rels - | _ -> assert false) l - -let remove_instance_local_defs evd evk args = - let evi = Evd.find evd evk in - let rec aux = function - | (_,Some _,_)::sign, a::args -> aux (sign,args) - | (_,None,_)::sign, a::args -> a::aux (sign,args) - | [], [] -> [] - | _ -> assert false in - aux (evar_filtered_context evi, args) - -(* Check if an applied evar "?X[args] l" is a Miller's pattern *) - -let find_unification_pattern_args env l t = - if List.for_all (fun x -> isRel x || isVar x) l (* common failure case *) then - let aliases = make_alias_map env in - match (try Some (expand_and_check_vars aliases l) with Exit -> None) with - | Some l as x when constr_list_distinct (get_actual_deps aliases l t) -> x - | _ -> None - else - None - -let is_unification_pattern_meta env nb m l t = - (* Variables from context and rels > nb are implicitly all there *) - (* so we need to be a rel <= nb *) - if List.for_all (fun x -> isRel x && destRel x <= nb) l then - match find_unification_pattern_args env l t with - | Some _ as x when not (dependent (mkMeta m) t) -> x - | _ -> None - else - None - -let is_unification_pattern_evar env evd (evk,args) l t = - if List.for_all (fun x -> isRel x || isVar x) l (* common failure case *) then - let args = remove_instance_local_defs evd evk (Array.to_list args) in - let n = List.length args in - match find_unification_pattern_args env (args @ l) t with - | Some l when not (occur_evar evk t) -> Some (list_skipn n l) - | _ -> None - else - None - -let is_unification_pattern (env,nb) evd f l t = - match kind_of_term f with - | Meta m -> is_unification_pattern_meta env nb m l t - | Evar ev -> is_unification_pattern_evar env evd ev l t - | _ -> None - -(* From a unification problem "?X l = c", build "\x1...xn.(term1 l2)" - (pattern unification). It is assumed that l is made of rel's that - are distinct and not bound to aliases. *) -(* It is also assumed that c does not contain metas because metas - *implicitly* depend on Vars but lambda abstraction will not reflect this - dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should - return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *) -let solve_pattern_eqn env l c = - let c' = List.fold_right (fun a c -> - let c' = subst_term (lift 1 a) (lift 1 c) in - match kind_of_term a with - (* Rem: if [a] links to a let-in, do as if it were an assumption *) - | Rel n -> - let d = map_rel_declaration (lift n) (lookup_rel n env) in - mkLambda_or_LetIn d c' - | Var id -> - let d = lookup_named id env in mkNamedLambda_or_LetIn d c' - | _ -> assert false) - l c in - (* Warning: we may miss some opportunity to eta-reduce more since c' - is not in normal form *) - whd_eta c' - (* This code (i.e. solve_pb, etc.) takes a unification * problem, and tries to solve it. If it solves it, then it removes * all the conversion problems, and re-runs conversion on each one, in @@ -1624,7 +1883,9 @@ let check_evars env initial_sigma sigma c = open Glob_term +(****************************************) (* Operations on value/type constraints *) +(****************************************) type type_constraint_type = (int * int) option * constr type type_constraint = type_constraint_type option @@ -1664,10 +1925,6 @@ let empty_valcon = None let mk_valcon c = Some c -let new_type_evar ?src ?filter evd env = - let evd', s = new_sort_variable evd in - new_evar evd' env ?src ?filter (mkSort s) - let idx = id_of_string "x" (* Refining an evar to a product *) diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index 61f503c7..d3f6845c 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -84,8 +84,12 @@ val whd_head_evar : evar_map -> constr -> constr val is_ground_term : evar_map -> constr -> bool val is_ground_env : evar_map -> env -> bool -val solve_refl : conv_fun -> env -> evar_map -> +val solve_refl : ?can_drop:bool -> conv_fun -> env -> evar_map -> existential_key -> constr array -> constr array -> evar_map +val solve_evar_evar : ?force:bool -> + (env -> evar_map -> existential -> constr -> evar_map) -> conv_fun -> + env -> evar_map -> existential -> existential -> evar_map + val solve_simple_eqn : conv_fun -> ?choose:bool -> env -> evar_map -> bool option * existential * constr -> evar_map * bool val reconsider_conv_pbs : conv_fun -> evar_map -> evar_map * bool diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 5d6ca2ca..3cfad524 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -778,10 +778,18 @@ let pr_evar_info evi = | Evar_empty -> mt () | Evar_defined c -> spc() ++ str"=> " ++ print_constr c in + let candidates = + match evi.evar_body, evi.evar_candidates with + | Evar_empty, Some l -> + spc () ++ str "{" ++ + prlist_with_sep (fun () -> str "|") print_constr l ++ str "}" + | _ -> + mt () + in let src = str "(" ++ pr_evar_source (snd evi.evar_source) ++ str ")" in hov 2 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]" ++ - spc() ++ src) + candidates ++ spc() ++ src) let compute_evar_dependency_graph (sigma:evar_map) = (* Compute the map binding ev to the evars whose body depends on ev *) diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 55c54f2c..194880e2 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -147,6 +147,8 @@ val is_empty : evar_map -> bool there are uninstantiated evars in [sigma]. *) val has_undefined : evar_map -> bool +(** [add sigma ev info] adds [ev] with evar info [info] in sigma. + Precondition: ev must not preexist in [sigma]. *) val add : evar_map -> evar -> evar_info -> evar_map val find : evar_map -> evar -> evar_info diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 15fd226f..0b59fc40 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -392,21 +392,6 @@ let arity_of_case_predicate env (ind,params) dep k = (* Inferring the sort of parameters of a polymorphic inductive type knowing the sort of the conclusion *) -(* Check if u (sort of a parameter) appears in the sort of the - inductive (is). This is done by trying to enforce u > u' >= is - in the empty univ graph. If an inconsistency appears, then - is depends on u. *) -let is_constrained is u = - try - let u' = fresh_local_univ() in - let _ = - merge_constraints - (enforce_geq u (super u') - (enforce_geq u' is empty_constraint)) - initial_universes in - false - with UniverseInconsistency _ -> true - (* Compute the inductive argument types: replace the sorts that appear in the type of the inductive by the sort of the conclusion, and the other ones by fresh universes. *) @@ -418,7 +403,9 @@ let rec instantiate_universes env scl is = function | (na,None,ty)::sign, Some u::exp -> let ctx,_ = Reduction.dest_arity env ty in let s = - if is_constrained is u then + (* Does the sort of parameter [u] appear in (or equal) + the sort of inductive [is] ? *) + if univ_depends u is then scl (* constrained sort: replace by scl *) else (* unconstriained sort: replace by fresh universe *) diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml index 2ad2f351..23af7a63 100644 --- a/pretyping/namegen.ml +++ b/pretyping/namegen.ml @@ -53,7 +53,7 @@ let is_global id = let is_constructor id = try match locate (qualid_of_ident id) with - | ConstructRef _ as ref -> not (is_imported_ref ref) + | ConstructRef _ -> true | _ -> false with Not_found -> false @@ -232,22 +232,27 @@ let make_all_name_different env = looks for name of same base with lower available subscript beyond current subscript *) -let visibly_occur_id id c = - let rec occur c = match kind_of_term c with +let occur_rel p env id = + try lookup_name_of_rel p env = Name id + with Not_found -> false (* Unbound indice : may happen in debug *) + +let visibly_occur_id id (nenv,c) = + let rec occur n c = match kind_of_term c with | Const _ | Ind _ | Construct _ | Var _ when shortest_qualid_of_global Idset.empty (global_of_constr c) = qualid_of_ident id -> raise Occur - | _ -> iter_constr occur c + | Rel p when p>n & occur_rel (p-n) nenv id -> raise Occur + | _ -> iter_constr_with_binders succ occur n c in - try occur c; false + try occur 1 c; false with Occur -> true | Not_found -> false (* Happens when a global is not in the env *) -let next_ident_away_for_default_printing t id avoid = - let bad id = List.mem id avoid or visibly_occur_id id t in +let next_ident_away_for_default_printing env_t id avoid = + let bad id = List.mem id avoid or visibly_occur_id id env_t in next_ident_away_from id bad -let next_name_away_for_default_printing t na avoid = +let next_name_away_for_default_printing env_t na avoid = let id = match na with | Name id -> id | Anonymous -> @@ -255,7 +260,7 @@ let next_name_away_for_default_printing t na avoid = (* taken into account by the function compute_displayed_name_in; *) (* just in case, invent a valid name *) id_of_string "H" in - next_ident_away_for_default_printing t id avoid + next_ident_away_for_default_printing env_t id avoid (**********************************************************************) (* Displaying terms avoiding bound variables clashes *) @@ -278,13 +283,13 @@ let next_name_away_for_default_printing t na avoid = type renaming_flags = | RenamingForCasesPattern | RenamingForGoal - | RenamingElsewhereFor of constr + | RenamingElsewhereFor of (name list * constr) let next_name_for_display flags = match flags with | RenamingForCasesPattern -> next_name_away_in_cases_pattern | RenamingForGoal -> next_name_away_in_goal - | RenamingElsewhereFor t -> next_name_away_for_default_printing t + | RenamingElsewhereFor env_t -> next_name_away_for_default_printing env_t (* Remark: Anonymous var may be dependent in Evar's contexts *) let compute_displayed_name_in flags avoid na c = @@ -306,16 +311,20 @@ let compute_displayed_let_name_in flags avoid na c = let fresh_id = next_name_for_display flags na avoid in (Name fresh_id, fresh_id::avoid) -let rec rename_bound_vars_as_displayed avoid c = - let rec rename avoid c = +let rec rename_bound_vars_as_displayed avoid env c = + let rec rename avoid env c = match kind_of_term c with | Prod (na,c1,c2) -> - let na',avoid' = compute_displayed_name_in (RenamingElsewhereFor c2) avoid na c2 in - mkProd (na', c1, rename avoid' c2) + let na',avoid' = + compute_displayed_name_in + (RenamingElsewhereFor (env,c2)) avoid na c2 in + mkProd (na', c1, rename avoid' (add_name na' env) c2) | LetIn (na,c1,t,c2) -> - let na',avoid' = compute_displayed_let_name_in (RenamingElsewhereFor c2) avoid na c2 in - mkLetIn (na',c1,t, rename avoid' c2) - | Cast (c,k,t) -> mkCast (rename avoid c, k,t) + let na',avoid' = + compute_displayed_let_name_in + (RenamingElsewhereFor (env,c2)) avoid na c2 in + mkLetIn (na',c1,t, rename avoid' (add_name na' env) c2) + | Cast (c,k,t) -> mkCast (rename avoid env c, k,t) | _ -> c in - rename avoid c + rename avoid env c diff --git a/pretyping/namegen.mli b/pretyping/namegen.mli index 637cbf64..6ca03146 100644 --- a/pretyping/namegen.mli +++ b/pretyping/namegen.mli @@ -70,7 +70,7 @@ val set_reserved_typed_name : (types -> name) -> unit type renaming_flags = | RenamingForCasesPattern (** avoid only global constructors *) | RenamingForGoal (** avoid all globals (as in intro) *) - | RenamingElsewhereFor of constr + | RenamingElsewhereFor of (name list * constr) val make_all_name_different : env -> env @@ -80,4 +80,5 @@ val compute_and_force_displayed_name_in : renaming_flags -> identifier list -> name -> constr -> name * identifier list val compute_displayed_let_name_in : renaming_flags -> identifier list -> name -> constr -> name * identifier list -val rename_bound_vars_as_displayed : identifier list -> types -> types +val rename_bound_vars_as_displayed : + identifier list -> name list -> types -> types diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 901936f3..d0c9df51 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -104,7 +104,7 @@ let interp_elimination_sort = function let resolve_evars env evdref fail_evar resolve_classes = if resolve_classes then - evdref := (Typeclasses.resolve_typeclasses ~onlyargs:false + evdref := (Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:true ~fail:fail_evar env !evdref); (* Resolve eagerly, potentially making wrong choices *) evdref := (try consider_remaining_unif_problems @@ -160,13 +160,14 @@ sig In [understand_ltac expand_evars sigma env ltac_env constraint c], + resolve_classes : launch typeclass resolution after typechecking. expand_evars : expand inferred evars by their value if any sigma : initial set of existential variables (typically dependent subgoals) ltac_env : partial substitution of variables (used for the tactic language) constraint : tell if interpreted as a possibly constrained term or a type *) - val understand_ltac : + val understand_ltac : ?resolve_classes:bool -> bool -> evar_map -> env -> ltac_var_map -> typing_constraint -> glob_constr -> pure_open_constr @@ -762,8 +763,8 @@ module Pretyping_F (Coercion : Coercion.S) = struct let understand_type sigma env c = snd (ise_pretype_gen true true true sigma env ([],[]) IsType c) - let understand_ltac expand_evar sigma env lvar kind c = - ise_pretype_gen expand_evar false false sigma env lvar kind c + let understand_ltac ?(resolve_classes=false) expand_evar sigma env lvar kind c = + ise_pretype_gen expand_evar false resolve_classes sigma env lvar kind c let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c = ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 47b3ec87..b79e9489 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -58,13 +58,14 @@ sig In [understand_ltac expand_evars sigma env ltac_env constraint c], + resolve_classes : launch typeclass resolution after typechecking. expand_evars : expand inferred evars by their value if any sigma : initial set of existential variables (typically dependent subgoals) ltac_env : partial substitution of variables (used for the tactic language) constraint : tell if interpreted as a possibly constrained term or a type *) - val understand_ltac : + val understand_ltac : ?resolve_classes:bool -> bool -> evar_map -> env -> ltac_var_map -> typing_constraint -> glob_constr -> pure_open_constr diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index fc35e2d3..6a26027c 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -576,7 +576,6 @@ let inSimplBehaviour = declare_object { (default_object "SIMPLBEHAVIOUR") with let set_simpl_behaviour local r (recargs, nargs, flags as req) = let nargs = if List.mem `SimplNeverUnfold flags then max_int else nargs in - let nargs = List.fold_left max nargs recargs in let behaviour = { b_nargs = nargs; b_recargs = recargs; b_dont_expose_case = List.mem `SimplDontExposeCase flags } in @@ -610,10 +609,11 @@ let dont_expose_case r = let rec red_elim_const env sigma ref largs = let nargs = stack_args_size largs in - let largs, unfold_anyway = + let largs, unfold_anyway, unfold_nonelim = match recargs ref with - | None -> largs, false + | None -> largs, false, false | Some (_,n) when nargs < n -> raise Redelimination + | Some (x::l,_) when nargs <= List.fold_left max x l -> raise Redelimination | Some (l,n) -> List.fold_left (fun stack i -> let arg = stack_nth stack i in @@ -621,7 +621,8 @@ let rec red_elim_const env sigma ref largs = match kind_of_term (fst rarg) with | Construct _ -> stack_assign stack i (app_stack rarg) | _ -> raise Redelimination) - largs l, n >= 0 && l = [] && nargs >= n in + largs l, n >= 0 && l = [] && nargs >= n, + n >= 0 && l <> [] && nargs >= n in try match reference_eval sigma env ref with | EliminationCases n when nargs >= n -> let c = reference_value sigma env ref in @@ -651,6 +652,9 @@ let rec red_elim_const env sigma ref largs = (match reduce_fix_use_function env sigma f whfun (destFix d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta sigma c, rest)) + | NotAnElimination when unfold_nonelim -> + let c = reference_value sigma env ref in + whd_betaiotazeta sigma (app_stack (c, largs)), empty_stack | _ -> raise Redelimination with Redelimination when unfold_anyway -> let c = reference_value sigma env ref in diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index e85f174e..4471e68d 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -450,12 +450,6 @@ let is_instance = function is_class (IndRef ind) | _ -> false -let is_implicit_arg k = - 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 @@ -473,26 +467,36 @@ let is_resolvable evi = assert (evi.evar_body = Evar_empty); Option.default true (resolvable.get evi.evar_extra) -let mark_unresolvable_undef evi = - let t = resolvable.set false evi.evar_extra in +let mark_resolvability_undef b evi = + let t = resolvable.set b evi.evar_extra in { evi with evar_extra = t } -let mark_unresolvable evi = +let mark_resolvability b evi = assert (evi.evar_body = Evar_empty); - mark_unresolvable_undef evi + mark_resolvability_undef b evi + +let mark_unresolvable evi = mark_resolvability false evi +let mark_resolvable evi = mark_resolvability true evi -let mark_unresolvables sigma = +let mark_resolvability b sigma = Evd.fold_undefined (fun ev evi evs -> - Evd.add evs ev (mark_unresolvable_undef evi)) + Evd.add evs ev (mark_resolvability_undef b evi)) sigma (Evd.defined_evars sigma) +let mark_unresolvables sigma = mark_resolvability false sigma + let has_typeclasses evd = Evd.fold_undefined (fun ev evi has -> has || - (is_class_evar evd evi && is_resolvable evi)) + (is_resolvable evi && is_class_evar evd evi)) evd false let solve_instanciations_problem = ref (fun _ _ _ _ _ -> assert false) -let resolve_typeclasses ?(onlyargs=false) ?(split=true) ?(fail=true) env evd = +type evar_filter = hole_kind -> bool + +let no_goals = function GoalEvar -> false | _ -> true +let all_evars _ = true + +let resolve_typeclasses ?(filter=no_goals) ?(split=true) ?(fail=true) env evd = if not (has_typeclasses evd) then evd - else !solve_instanciations_problem env evd onlyargs split fail + else !solve_instanciations_problem env evd filter split fail diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index 74ccaf83..4e6081e2 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -71,8 +71,6 @@ val instance_impl : instance -> global_reference val is_class : global_reference -> bool val is_instance : global_reference -> bool -val is_implicit_arg : hole_kind -> bool - (** Returns the term and type for the given instance of the parameters and fields of the type class. *) @@ -83,10 +81,16 @@ val instance_constructor : typeclass -> constr list -> constr option * types val is_resolvable : evar_info -> bool val mark_unresolvable : evar_info -> evar_info +val mark_resolvable : evar_info -> evar_info val mark_unresolvables : evar_map -> evar_map val is_class_evar : evar_map -> evar_info -> bool -val resolve_typeclasses : ?onlyargs:bool -> ?split:bool -> ?fail:bool -> +(** Filter which evars to consider for resolution. *) +type evar_filter = hole_kind -> bool +val no_goals : evar_filter +val all_evars : evar_filter + +val resolve_typeclasses : ?filter:evar_filter -> ?split:bool -> ?fail:bool -> env -> evar_map -> evar_map val resolve_one_typeclass : env -> evar_map -> types -> open_constr @@ -101,7 +105,7 @@ val register_remove_instance_hint : (global_reference -> unit) -> unit val add_instance_hint : constr -> bool -> int option -> unit val remove_instance_hint : global_reference -> unit -val solve_instanciations_problem : (env -> evar_map -> bool -> bool -> bool -> evar_map) ref +val solve_instanciations_problem : (env -> evar_map -> evar_filter -> bool -> bool -> evar_map) ref val solve_instanciation_problem : (env -> evar_map -> types -> open_constr) ref val declare_instance : int option -> bool -> global_reference -> unit diff --git a/pretyping/unification.ml b/pretyping/unification.ml index e6fa6eec..eaa83146 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -966,7 +966,7 @@ let check_types env flags (sigma,_,_ as subst) m n = let try_resolve_typeclasses env evd flags m n = if flags.resolve_evars then - try Typeclasses.resolve_typeclasses ~onlyargs:false ~split:false + try Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:false ~fail:true env evd with e when Typeclasses_errors.unsatisfiable_exception e -> error_cannot_unify env evd (m, n) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index fad2e6f0..ac3df714 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -109,7 +109,7 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p = a 0) et les lambda correspondant aux realargs *) let build_one_branch i cty = let typi = type_constructor mind mib cty params in - let decl,indapp = Term.decompose_prod typi in + let decl,indapp = decompose_prod_assum typi in let ind,cargs = find_rectype_a env indapp in let nparams = Array.length params in let carity = snd (rtbl.(i)) in @@ -193,11 +193,8 @@ and nf_stk env c t stk = let bsw = branch_of_switch (nb_rel env) sw in let mkbranch i (n,v) = let decl,codom = btypes.(i) in - let env = - List.fold_right - (fun (name,t) env -> push_rel (name,None,t) env) decl env in - let b = nf_val env v codom in - compose_lam decl b + let b = nf_val (push_rel_context decl env) v codom in + it_mkLambda_or_LetIn b decl in let branchs = Array.mapi mkbranch bsw in let tcase = build_case_type dep p realargs c in diff --git a/proofs/clenv.ml b/proofs/clenv.ml index d06c6f2e..b98101e0 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -500,8 +500,8 @@ let make_clenv_binding_gen hyps_only n env sigma (c,t) = function let clause = mk_clenv_from_env env sigma n (c,t) in clenv_constrain_dep_args hyps_only largs clause | ExplicitBindings lbind -> - let clause = mk_clenv_from_env env sigma n - (c,rename_bound_vars_as_displayed [] t) + let clause = mk_clenv_from_env env sigma n + (c,rename_bound_vars_as_displayed [] [] t) in clenv_match_args lbind clause | NoBindings -> mk_clenv_from_env env sigma n (c,t) diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 36268de1..6fa95dc8 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -40,7 +40,7 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = error "Instantiate called on already-defined evar"; let env = Evd.evar_env evi in let sigma',typed_c = - try Pretyping.Default.understand_ltac true sigma env ltac_var + try Pretyping.Default.understand_ltac ~resolve_classes:true true sigma env ltac_var (Pretyping.OfType (Some evi.evar_concl)) rawc with _ -> let loc = Glob_term.loc_of_glob_constr rawc in diff --git a/proofs/goal.ml b/proofs/goal.ml index 1542267e..eeaba76e 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -163,8 +163,8 @@ module Refinable = struct (* spiwack: it is not very fine grain since it solves all typeclasses holes, not only those containing the current goal, or a given term. But it seems to fit our needs so far. *) - let resolve_typeclasses ?onlyargs ?split ?(fail=false) () env rdefs _ _ = - rdefs:=Typeclasses.resolve_typeclasses ?onlyargs ?split ~fail env !rdefs; + let resolve_typeclasses ?filter ?split ?(fail=false) () env rdefs _ _ = + rdefs:=Typeclasses.resolve_typeclasses ?filter ?split ~fail env !rdefs; () @@ -563,7 +563,7 @@ module V82 = struct let new_sigma = Evd.add Evd.empty evk new_evi in { Evd.it = build evk ; sigma = new_sigma } - (* Used by the typeclasses *) + (* Used by the compatibility layer and typeclasses *) let nf_evar sigma gl = let evi = content sigma gl in let evi = Evarutil.nf_evar_info sigma evi in diff --git a/proofs/goal.mli b/proofs/goal.mli index e9d23065..50709555 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -72,7 +72,7 @@ module Refinable : sig (* [with_type c typ] constrains term [c] to have type [typ]. *) val with_type : Term.constr -> Term.types -> Term.constr sensitive - val resolve_typeclasses : ?onlyargs:bool -> ?split:bool -> ?fail:bool -> unit -> unit sensitive + val resolve_typeclasses : ?filter:(Evd.hole_kind -> bool) -> ?split:bool -> ?fail:bool -> unit -> unit sensitive (* [constr_of_raw h check_type resolve_classes] is a pretyping function. @@ -234,7 +234,7 @@ module V82 : sig (* Used for congruence closure *) val new_goal_with : Evd.evar_map -> goal -> Environ.named_context_val -> goal Evd.sigma - (* Used by the typeclasses *) + (* Used by the compatibility layer and typeclasses *) val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map (* Goal represented as a type, doesn't take into account section variables *) diff --git a/proofs/logic.ml b/proofs/logic.ml index a363c6bb..5babd03a 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -685,12 +685,8 @@ let prim_refiner r sigma goal = ([gl], sigma) | Change_evars -> - (* spiwack: a priori [Change_evars] is now devoid of operational content. - The new proof engine keeping the evar_map up to date at all time. - As a compatibility mesure I leave the rule. - It is possible that my assumption is wrong and some uses of - [Change_evars] are not subsumed by the new engine. In which - case something has to be done here. (Feb. 2010) *) + (* Normalises evars in goals. Used by instantiate. *) + let (goal,sigma) = Goal.V82.nf_evar sigma goal in ([goal],sigma) (************************************************************************) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 3d507f35..6ac0b553 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -35,8 +35,10 @@ let delete_proof = Proof_global.discard let delete_current_proof = Proof_global.discard_current let delete_all_proofs = Proof_global.discard_all -let undo n = +let undo n = let p = Proof_global.give_me_the_proof () in + let d = Proof.V82.depth p in + if n >= d then raise Proof.EmptyUndoStack; for i = 1 to n do Proof.undo p done @@ -64,15 +66,7 @@ let start_proof id str hyps c ?init_tac ?compute_guard hook = Proof_global.start_proof id str goals ?compute_guard hook; Option.iter Proof_global.run_tactic init_tac -let restart_proof () = - let p = Proof_global.give_me_the_proof () in - try while true do - Proof.undo p - done with Proof.EmptyUndoStack -> () - -let resume_last_proof () = Proof_global.resume_last () -let resume_proof (_,id) = Proof_global.resume id -let suspend_proof () = Proof_global.suspend () +let restart_proof () = undo_todepth 1 let cook_proof hook = let prf = Proof_global.give_me_the_proof () in diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 7297b975..5d45ea7c 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -85,24 +85,6 @@ val start_proof : val restart_proof : unit -> unit (** {6 ... } *) -(** [resume_last_proof ()] focus on the last unfocused proof or fails - if there is no suspended proofs *) - -val resume_last_proof : unit -> unit - -(** [resume_proof name] focuses on the proof of name [name] or - raises [NoSuchProof] if no proof has name [name]. - - It doesn't [suspend_proof ()] before. *) - -val resume_proof : identifier located -> unit - -(** [suspend_proof ()] unfocuses the current focused proof or - failed with [UserError] if no proof is currently focused *) - -val suspend_proof : unit -> unit - -(** {6 ... } *) (** [cook_proof opacity] turns the current proof (assumed completed) into a constant with its name, kind and possible hook (see [start_proof]); it fails if there is no current proof of if it is not completed; @@ -143,7 +125,9 @@ val current_proof_statement : val get_current_proof_name : unit -> identifier -(** [get_all_proof_names ()] returns the list of all pending proof names *) +(** [get_all_proof_names ()] returns the list of all pending proof names. + The first name is the current proof, the other names may come in + any order. *) val get_all_proof_names : unit -> identifier list diff --git a/proofs/proof.ml b/proofs/proof.ml index 72730495..996a895f 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -35,12 +35,12 @@ type _focus_kind = int type 'a focus_kind = _focus_kind type focus_info = Obj.t type unfocusable = - | Cannot + | Cannot of exn | Loose | Strict type _focus_condition = (_focus_kind -> Proofview.proofview -> unfocusable) * - (_focus_kind -> focus_info -> focus_info) + (_focus_kind -> bool) type 'a focus_condition = _focus_condition let next_kind = ref 0 @@ -49,13 +49,8 @@ let new_focus_kind () = incr next_kind; r -(* Auxiliary function to define conditions: - [check kind1 kind2 inf] returns [inf] if [kind1] and [kind2] match. - Otherwise it raises [CheckNext] *) -exception CheckNext -(* no handler: confined to this module. *) -let check kind1 kind2 inf = - if kind1=kind2 then inf else raise CheckNext +(* Auxiliary function to define conditions. *) +let check kind1 kind2 = kind1=kind2 (* To be authorized to unfocus one must meet the condition prescribed by the action which focused.*) @@ -68,40 +63,55 @@ module Cond = struct (* first attempt at an algebra of condition *) (* semantics: - [Cannot] means that the condition is not met - - [Strict] that the condition is meant - - [Loose] that the condition is not quite meant + - [Strict] that the condition is met + - [Loose] that the condition is not quite met but authorises to unfocus provided a condition of a previous focus on the stack is (strictly) - met. + met. [Loose] focuses are those, like bullets, + which do not have a closing command and + are hence closed by unfocusing actions unrelated + to their focus_kind. *) - let bool b = + let bool e b = if b then fun _ _ -> Strict - else fun _ _ -> Cannot + else fun _ _ -> Cannot e let loose c k p = match c k p with - | Cannot -> Loose + | Cannot _ -> Loose | c -> c let cloose l c = if l then loose c else c let (&&&) c1 c2 k p= match c1 k p , c2 k p with - | Cannot , _ - | _ , Cannot -> Cannot + | Cannot e , _ + | _ , Cannot e -> Cannot e | Strict, Strict -> Strict | _ , _ -> Loose - let kind k0 k p = bool (k0=k) k p - let pdone k p = bool (Proofview.finished p) k p + let kind e k0 k p = bool e (k0=k) k p + let pdone e k p = bool e (Proofview.finished p) k p +end + + +(* Unfocus command. + Fails if the proof is not focused. *) +exception CannotUnfocusThisWay +let _ = Errors.register_handler begin function + | CannotUnfocusThisWay -> + Util.error "This proof is focused, but cannot be unfocused this way" + | _ -> raise Errors.Unhandled end open Cond -let no_cond ~loose_end k0 = - cloose loose_end (kind k0) -let no_cond ?(loose_end=false) k = no_cond ~loose_end k , check k +let no_cond_gen e ~loose_end k0 = + cloose loose_end (kind e k0) +let no_cond_gen e ?(loose_end=false) k = no_cond_gen e ~loose_end k , check k +let no_cond ?loose_end = no_cond_gen CannotUnfocusThisWay ?loose_end (* [done_cond] checks that the unfocusing command uses the right [focus_kind] and that the focused proofview is complete. *) -let done_cond ~loose_end k0 = - (cloose loose_end (kind k0)) &&& pdone -let done_cond ?(loose_end=false) k = done_cond ~loose_end k , check k +let done_cond_gen e ~loose_end k0 = + (cloose loose_end (kind e k0)) &&& pdone e +let done_cond_gen e ?(loose_end=false) k = done_cond_gen e ~loose_end k , check k +let done_cond ?loose_end = done_cond_gen CannotUnfocusThisWay ?loose_end (* Subpart of the type of proofs. It contains the parts of the proof which @@ -249,13 +259,13 @@ let save pr = push_undo (save_state pr) pr (* This function restores a state, presumably from the top of the undo stack. *) -let restore_state save pr = +let restore_state save pr = match save with | State save -> pr.state <- save | Effect undo -> undo () (* Interpretes the Undo command. *) -let undo pr = +let undo pr = (* On a single line, since the effects commute *) restore_state (pop_undo pr) pr @@ -309,20 +319,11 @@ let focus cond inf i pr = save pr; _focus cond (Obj.repr inf) i i pr -(* Unfocus command. - Fails if the proof is not focused. *) -exception CannotUnfocusThisWay -let _ = Errors.register_handler begin function - | CannotUnfocusThisWay -> - Util.error "This proof is focused, but cannot be unfocused this way" - | _ -> raise Errors.Unhandled -end - let rec unfocus kind pr () = let starting_point = save_state pr in let cond = cond_of_focus pr in match fst cond kind pr.state.proofview with - | Cannot -> raise CannotUnfocusThisWay + | Cannot e -> raise e | Strict -> (_unfocus pr; push_undo starting_point pr) @@ -336,34 +337,35 @@ let rec unfocus kind pr () = let unfocus kind pr = transaction pr (unfocus kind pr) - -let get_at_point kind ((_,get),inf,_) = get kind inf + exception NoSuchFocus (* no handler: should not be allowed to reach toplevel. *) -exception GetDone of Obj.t -(* no handler: confined to this module. *) -let get_in_focus_stack kind stack = - try - List.iter begin fun pt -> - try - raise (GetDone (get_at_point kind pt)) - with CheckNext -> () - end stack; - raise NoSuchFocus - with GetDone x -> x +let rec get_in_focus_stack kind stack = + match stack with + | ((_,check),inf,_)::stack -> + if check kind then inf + else get_in_focus_stack kind stack + | [] -> raise NoSuchFocus let get_at_focus kind pr = Obj.magic (get_in_focus_stack kind pr.state.focus_stack) +let is_last_focus kind pr = + let ((_,check),_,_) = List.hd pr.state.focus_stack in + check kind + let no_focused_goal p = Proofview.finished p.state.proofview (*** Proof Creation/Termination ***) +(* [end_of_stack] is unfocused by return to close every loose focus. *) let end_of_stack_kind = new_focus_kind () -let end_of_stack = done_cond end_of_stack_kind +let end_of_stack = done_cond_gen FullyUnfocused end_of_stack_kind + +let unfocused = is_last_focus end_of_stack_kind let start goals = - let pr = + let pr = { state = { proofview = Proofview.init goals ; focus_stack = [] ; intel = Store.empty} ; @@ -445,14 +447,22 @@ module V82 = struct let top_evars p = Proofview.V82.top_evars p.state.proofview - let instantiate_evar n com pr = - let starting_point = save_state pr in - let sp = pr.state.proofview in - try - let new_proofview = Proofview.V82.instantiate_evar n com sp in - pr.state <- { pr.state with proofview = new_proofview }; - push_undo starting_point pr - with e -> - restore_state starting_point pr; - raise e + let grab_evars p = + if not (is_done p) then + raise UnfinishedProof + else + save p; + p.state <- { p.state with proofview = Proofview.V82.grab p.state.proofview } + + + let instantiate_evar n com pr = + let starting_point = save_state pr in + let sp = pr.state.proofview in + try + let new_proofview = Proofview.V82.instantiate_evar n com sp in + pr.state <- { pr.state with proofview = new_proofview }; + push_undo starting_point pr + with e -> + restore_state starting_point pr; + raise e end diff --git a/proofs/proof.mli b/proofs/proof.mli index 12af18f4..715b3341 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -114,12 +114,18 @@ exception CannotUnfocusThisWay is not met. *) val unfocus : 'a focus_kind -> proof -> unit +(* [unfocused p] returns [true] when [p] is fully unfocused. *) +val unfocused : proof -> bool + (* [get_at_focus k] gets the information stored at the closest focus point of kind [k]. Raises [NoSuchFocus] if there is no focus point of kind [k]. *) exception NoSuchFocus val get_at_focus : 'a focus_kind -> proof -> 'a +(* [is_last_focus k] check if the most recent focus is of kind [k] *) +val is_last_focus : 'a focus_kind -> proof -> bool + (* returns [true] if there is no goal under focus. *) val no_focused_goal : proof -> bool @@ -127,8 +133,6 @@ val no_focused_goal : proof -> bool val get_proof_info : proof -> Store.t -val set_proof_info : Store.t -> proof -> unit - (* Sets the section variables assumed by the proof *) val set_used_variables : Sign.section_context -> proof -> unit val get_used_variables : proof -> Sign.section_context option @@ -151,7 +155,7 @@ val run_tactic : Environ.env -> unit Proofview.tactic -> proof -> unit a focusing command and a tactic. Transactions are such that if any of the atomic action fails, the whole transaction fails. - During a transaction, the undo visible undo stack is constituted only + During a transaction, the visible undo stack is constituted only of the actions performed done during the transaction. [transaction p f] can be called on an [f] using, itself, [transaction p].*) @@ -178,6 +182,10 @@ module V82 : sig (* returns the existential variable used to start the proof *) val top_evars : proof -> Evd.evar list + (* Turns the unresolved evars into goals. + Raises [UnfinishedProof] if there are still unsolved goals. *) + val grab_evars : proof -> unit + (* Implements the Existential command *) val instantiate_evar : int -> Topconstr.constr_expr -> proof -> unit end diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 2745270a..ae0f7d12 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -70,12 +70,10 @@ type proof_info = { mode : proof_mode } -(* Invariant: a proof is at most in one of current_proof and suspended. And the - domain of proof_info is the union of that of current_proof and suspended.*) -(* The head of [!current_proof] is the actual current proof, the other ones are to - be resumed when the current proof is closed, aborted or suspended. *) +(* Invariant: the domain of proof_info is current_proof.*) +(* The head of [!current_proof] is the actual current proof, the other ones are + to be resumed when the current proof is closed or aborted. *) let current_proof = ref ([]:nproof list) -let suspended = ref ([] : nproof list) let proof_info = ref (Idmap.empty : proof_info Idmap.t) (* Current proof_mode, for bookkeeping *) @@ -93,7 +91,7 @@ let update_proof_mode () = !current_proof_mode.reset (); current_proof_mode := standard -(* combinators for the current_proof and suspended lists *) +(* combinators for the current_proof lists *) let push a l = l := a::!l; update_proof_mode () @@ -145,8 +143,7 @@ let remove id m = (*** Proof Global manipulation ***) let get_all_proof_names () = - List.map fst !current_proof @ - List.map fst !suspended + List.map fst !current_proof let give_me_the_proof () = snd (find_top current_proof) @@ -160,61 +157,40 @@ let get_current_proof_name () = accessed directly through vernacular commands. Error message should be pushed to external layers, and so we should be able to have a finer control on error message on complex actions. *) -let msg_proofs use_resume = +let msg_proofs () = match get_all_proof_names () with | [] -> (spc () ++ str"(No proof-editing in progress).") | l -> (str"." ++ fnl () ++ str"Proofs currently edited:" ++ spc () ++ - (Util.prlist_with_sep Util.pr_spc Nameops.pr_id l) ++ - str"." ++ - (if use_resume then (fnl () ++ str"Use \"Resume\" first.") - else (mt ())) - ) - + (Util.prlist_with_sep Util.pr_spc Nameops.pr_id l)++ str ".") let there_is_a_proof () = !current_proof <> [] -let there_are_suspended_proofs () = !suspended <> [] -let there_are_pending_proofs () = - there_is_a_proof () || - there_are_suspended_proofs () -let check_no_pending_proof () = +let there_are_pending_proofs () = there_is_a_proof () +let check_no_pending_proof () = if not (there_are_pending_proofs ()) then () else begin Util.error (Pp.string_of_ppcmds - (str"Proof editing in progress" ++ (msg_proofs false) ++ fnl() ++ + (str"Proof editing in progress" ++ msg_proofs () ++ fnl() ++ str"Use \"Abort All\" first or complete proof(s).")) end - -let suspend () = - rotate_top current_proof suspended - -let resume_last () = - rotate_top suspended current_proof - -let resume id = - rotate_find id suspended current_proof - let discard_gen id = - try - ignore (extract id current_proof); - remove id proof_info - with NoSuchProof -> ignore (extract id suspended) + ignore (extract id current_proof); + remove id proof_info let discard (loc,id) = try discard_gen id with NoSuchProof -> Util.user_err_loc - (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs false) + (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs ()) let discard_current () = let (id,_) = extract_top current_proof in remove id proof_info let discard_all () = - current_proof := []; - suspended := []; + current_proof := []; proof_info := Idmap.empty (* [set_proof_mode] sets the proof mode to be used after it's called. It is @@ -239,6 +215,11 @@ let set_proof_mode mn = end pr ; set_proof_mode m id +exception AlreadyExists +let _ = Errors.register_handler begin function + | AlreadyExists -> Util.error "Already editing something of that name." + | _ -> raise Errors.Unhandled +end (* [start_proof s str env t hook tac] starts a proof of name [s] and conclusion [t]; [hook] is optionally a function to be applied at proof end (e.g. to declare the built constructions as a coercion @@ -248,7 +229,11 @@ let set_proof_mode mn = It raises exception [ProofInProgress] if there is a proof being currently edited. *) let start_proof id str goals ?(compute_guard=[]) hook = - (* arnaud: ajouter une vérification pour la présence de id dans le proof_global *) + begin + List.iter begin fun (id_ex,_) -> + if Names.id_ord id id_ex = 0 then raise AlreadyExists + end !current_proof + end; let p = Proof.start goals in add id { strength=str ; compute_guard=compute_guard ; @@ -354,9 +339,14 @@ module Bullet = struct let bullet_kind = (Proof.new_focus_kind () : t list Proof.focus_kind) let bullet_cond = Proof.done_cond ~loose_end:true bullet_kind + (* spiwack: as it is bullets are reset (locally) by *any* non-bullet focusing command + experience will tell if this is the right discipline of if we want to be finer and + reset them only for a choice of bullets. *) let get_bullets pr = - try Proof.get_at_focus bullet_kind pr - with Proof.NoSuchFocus -> [] + if Proof.is_last_focus bullet_kind pr then + Proof.get_at_focus bullet_kind pr + else + [] let has_bullet bul pr = let rec has_bullet = function diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index ed6a60c7..e266d57c 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -69,12 +69,6 @@ val close_proof : unit -> exception NoSuchProof -val suspend : unit -> unit -val resume_last : unit -> unit - -val resume : Names.identifier -> unit -(** @raise NoSuchProof if it doesn't find one. *) - (** Runs a tactic on the current proof. Raises [NoCurrentProof] is there is no current proof. *) val run_tactic : unit Proofview.tactic -> unit diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 0d50d521..4246cc9c 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -475,6 +475,17 @@ module V82 = struct let has_unresolved_evar pv = Evd.has_undefined pv.solution + (* Main function in the implementation of Grab Existential Variables.*) + let grab pv = + let goals = + List.map begin fun (e,_) -> + Goal.build e + end (Evd.undefined_list pv.solution) + in + { pv with comb = goals } + + + (* Returns the open goals of the proofview together with the evar_map to interprete them. *) let goals { comb = comb ; solution = solution } = diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 24da9d77..fe24b54b 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -195,6 +195,11 @@ module V82 : sig val has_unresolved_evar : proofview -> bool + (* Main function in the implementation of Grab Existential Variables. + Resets the proofview's goals so that it contains all unresolved evars + (in chronological order of insertion). *) + val grab : proofview -> proofview + (* Returns the open goals of the proofview together with the evar_map to interprete them. *) val goals : proofview -> Goal.goal list Evd.sigma diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 5cd85547..8901a5a2 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -415,10 +415,6 @@ let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma} let pp_info = ref (fun _ _ _ -> assert false) let set_info_printer f = pp_info := f -let tclINFO (tac : tactic) gls = - msgnl (hov 0 (str "Warning: info is currently not working")); - tac gls - (* Check that holes in arguments have been resolved *) let check_evars env sigma extsigma gl = diff --git a/proofs/refiner.mli b/proofs/refiner.mli index 75fd6d3d..9d3d37c2 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -137,7 +137,6 @@ val tclTIMEOUT : int -> tactic -> tactic val tclWEAK_PROGRESS : tactic -> tactic val tclPROGRESS : tactic -> tactic val tclNOTSAMEGOAL : tactic -> tactic -val tclINFO : tactic -> tactic (** [tclIFTHENELSE tac1 tac2 tac3 gls] first applies [tac1] to [gls] then, if it succeeds, applies [tac2] to the resulting subgoals, diff --git a/proofs/tacexpr.ml b/proofs/tacexpr.ml index b8279b8f..de2e662f 100644 --- a/proofs/tacexpr.ml +++ b/proofs/tacexpr.ml @@ -27,6 +27,8 @@ type split_flag = bool (* true = exists false = split *) type hidden_flag = bool (* true = internal use false = user-level *) type letin_flag = bool (* true = use local def false = use Leibniz *) +type debug = Debug | Info | Off (* for trivial / auto / eauto ... *) + type glob_red_flag = | FBeta | FIota @@ -171,13 +173,8 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_atomic_tactic_expr = | TacLApply of 'constr (* Automation tactics *) - | TacTrivial of 'constr list * string list option - | TacAuto of int or_var option * 'constr list * string list option - | TacAutoTDB of int option - | TacDestructHyp of (bool * identifier located) - | TacDestructConcl - | TacSuperAuto of (int option * reference list * bool * bool) - | TacDAuto of int or_var option * int option * 'constr list + | TacTrivial of debug * 'constr list * string list option + | TacAuto of debug * int or_var option * 'constr list * string list option (* Context management *) | TacClear of bool * 'id list diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 5475daa8..08800902 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -72,14 +72,6 @@ let pf_get_new_ids ids gls = (fun id acc -> (next_ident_away id (acc@avoid))::acc) ids [] -let pf_interp_constr gls c = - let evc = project gls in - Constrintern.interp_constr evc (pf_env gls) c - -let pf_interp_type gls c = - let evc = project gls in - Constrintern.interp_type evc (pf_env gls) c - let pf_global gls id = Constrintern.construct_reference (pf_hyps gls) id let pf_parse_const gls = compose (pf_global gls) id_of_string diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 884a0307..402002de 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -48,9 +48,6 @@ val pf_type_of : goal sigma -> constr -> types val pf_check_type : goal sigma -> constr -> types -> unit val pf_hnf_type_of : goal sigma -> constr -> types -val pf_interp_constr : goal sigma -> Topconstr.constr_expr -> constr -val pf_interp_type : goal sigma -> Topconstr.constr_expr -> types - val pf_get_hyp : goal sigma -> identifier -> named_declaration val pf_get_hyp_typ : goal sigma -> identifier -> types diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index 1c2fb278..b23f361c 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -49,11 +49,12 @@ let db_pr_goal g = (* Prints the commands *) let help () = - msgnl (str "Commands: <Enter>=Continue" ++ fnl() ++ - str " h/?=Help" ++ fnl() ++ - str " r<num>=Run <num> times" ++ fnl() ++ - str " s=Skip" ++ fnl() ++ - str " x=Exit") + msgnl (str "Commands: <Enter> = Continue" ++ fnl() ++ + str " h/? = Help" ++ fnl() ++ + str " r <num> = Run <num> times" ++ fnl() ++ + str " r <string> = Run up to next idtac <string>" ++ fnl() ++ + str " s = Skip" ++ fnl() ++ + str " x = Exit") (* Prints the goal and the command to be executed *) let goal_com g tac = @@ -62,37 +63,62 @@ let goal_com g tac = msg (str "Going to execute:" ++ fnl () ++ !prtac tac ++ fnl ()) end -(* Gives the number of a run command *) +let skipped = ref 0 +let skip = ref 0 +let breakpoint = ref None + +let rec drop_spaces inst i = + if String.length inst > i && inst.[i] = ' ' then drop_spaces inst (i+1) + else i + +let possibly_unquote s = + if String.length s >= 2 & s.[0] = '"' & s.[String.length s - 1] = '"' then + String.sub s 1 (String.length s - 2) + else + s + +(* (Re-)initialize debugger *) +let db_initialize () = + skip:=0;skipped:=0;breakpoint:=None + +(* Gives the number of steps or next breakpoint of a run command *) let run_com inst = if (String.get inst 0)='r' then - let num = int_of_string (String.sub inst 1 ((String.length inst)-1)) in - if num>0 then num - else raise (Invalid_argument "run_com") + let i = drop_spaces inst 1 in + if String.length inst > i then + let s = String.sub inst i (String.length inst - i) in + if inst.[0] >= '0' && inst.[0] <= '9' then + let num = int_of_string s in + if num<0 then raise (Invalid_argument "run_com"); + skip:=num;skipped:=0 + else + breakpoint:=Some (possibly_unquote s) + else + raise (Invalid_argument "run_com") else raise (Invalid_argument "run_com") -let allskip = ref 0 -let skip = ref 0 - (* Prints the run counter *) let run ini = if not ini then + begin for i=1 to 2 do print_char (Char.chr 8);print_char (Char.chr 13) done; - msg (str "Executed expressions: " ++ int (!allskip - !skip) ++ - fnl() ++ fnl()) + msg (str "Executed expressions: " ++ int !skipped ++ fnl() ++ fnl()) + end; + incr skipped (* Prints the prompt *) let rec prompt level = begin msg (fnl () ++ str "TcDebug (" ++ int level ++ str ") > "); flush stdout; - let exit () = skip:=0;allskip:=0;raise Sys.Break in + let exit () = skip:=0;skipped:=0;raise Sys.Break in let inst = try read_line () with End_of_file -> exit () in match inst with - | "" -> true - | "s" -> false + | "" -> DebugOn (level+1) + | "s" -> DebugOff | "x" -> print_char (Char.chr 8); exit () | "h"| "?" -> begin @@ -100,32 +126,34 @@ let rec prompt level = prompt level end | _ -> - (try let ctr=run_com inst in skip:=ctr;allskip:=ctr;run true;true + (try run_com inst;run true;DebugOn (level+1) with Failure _ | Invalid_argument _ -> prompt level) end (* Prints the state and waits for an instruction *) let debug_prompt lev g tac f = (* What to print and to do next *) - let continue = - if !skip = 0 then (goal_com g tac; prompt lev) - else (decr skip; run false; if !skip=0 then allskip:=0; true) in + let newlevel = + if !skip = 0 then + if !breakpoint = None then (goal_com g tac; prompt lev) + else (run false; DebugOn (lev+1)) + else (decr skip; run false; if !skip=0 then skipped:=0; DebugOn (lev+1)) in (* What to execute *) - try f (if continue then DebugOn (lev+1) else DebugOff) + try f newlevel with e -> - skip:=0; allskip:=0; + skip:=0; skipped:=0; if Logic.catchable_exception e then ppnl (str "Level " ++ int lev ++ str ": " ++ !explain_logic_error e); raise e (* Prints a constr *) let db_constr debug env c = - if debug <> DebugOff & !skip = 0 then + if debug <> DebugOff & !skip = 0 & !breakpoint = None then msgnl (str "Evaluated term: " ++ print_constr_env env c) (* Prints the pattern rule *) let db_pattern_rule debug num r = - if debug <> DebugOff & !skip = 0 then + if debug <> DebugOff & !skip = 0 & !breakpoint = None then begin msgnl (str "Pattern rule " ++ int num ++ str ":"); msgnl (str "|" ++ spc () ++ !prmatchrl r) @@ -138,38 +166,38 @@ let hyp_bound = function (* Prints a matched hypothesis *) let db_matched_hyp debug env (id,_,c) ido = - if debug <> DebugOff & !skip = 0 then + if debug <> DebugOff & !skip = 0 & !breakpoint = None then msgnl (str "Hypothesis " ++ str ((Names.string_of_id id)^(hyp_bound ido)^ " has been matched: ") ++ print_constr_env env c) (* Prints the matched conclusion *) let db_matched_concl debug env c = - if debug <> DebugOff & !skip = 0 then + if debug <> DebugOff & !skip = 0 & !breakpoint = None then msgnl (str "Conclusion has been matched: " ++ print_constr_env env c) (* Prints a success message when the goal has been matched *) let db_mc_pattern_success debug = - if debug <> DebugOff & !skip = 0 then + if debug <> DebugOff & !skip = 0 & !breakpoint = None then msgnl (str "The goal has been successfully matched!" ++ fnl() ++ str "Let us execute the right-hand side part..." ++ fnl()) (* Prints a failure message for an hypothesis pattern *) let db_hyp_pattern_failure debug env (na,hyp) = - if debug <> DebugOff & !skip = 0 then + if debug <> DebugOff & !skip = 0 & !breakpoint = None then msgnl (str ("The pattern hypothesis"^(hyp_bound na)^ " cannot match: ") ++ !prmatchpatt env hyp) (* Prints a matching failure message for a rule *) let db_matching_failure debug = - if debug <> DebugOff & !skip = 0 then + if debug <> DebugOff & !skip = 0 & !breakpoint = None then msgnl (str "This rule has failed due to matching errors!" ++ fnl() ++ str "Let us try the next one...") (* Prints an evaluation failure message for a rule *) let db_eval_failure debug s = - if debug <> DebugOff & !skip = 0 then + if debug <> DebugOff & !skip = 0 & !breakpoint = None then let s = str "message \"" ++ s ++ str "\"" in msgnl (str "This rule has failed due to \"Fail\" tactic (" ++ @@ -177,9 +205,20 @@ let db_eval_failure debug s = (* Prints a logic failure message for a rule *) let db_logic_failure debug err = - if debug <> DebugOff & !skip = 0 then + if debug <> DebugOff & !skip = 0 & !breakpoint = None then begin msgnl (!explain_logic_error err); msgnl (str "This rule has failed due to a logic error!" ++ fnl() ++ str "Let us try the next one...") end + +let is_breakpoint brkname s = match brkname, s with + | Some s, MsgString s'::_ -> s = s' + | _ -> false + +let db_breakpoint debug s = + match debug with + | DebugOn lev when s <> [] & is_breakpoint !breakpoint s -> + breakpoint:=None + | _ -> + () diff --git a/proofs/tactic_debug.mli b/proofs/tactic_debug.mli index d96f4c74..62c2359b 100644 --- a/proofs/tactic_debug.mli +++ b/proofs/tactic_debug.mli @@ -34,6 +34,9 @@ type debug_info = val debug_prompt : int -> goal sigma -> glob_tactic_expr -> (debug_info -> 'a) -> 'a +(** Initializes debugger *) +val db_initialize : unit -> unit + (** Prints a constr *) val db_constr : debug_info -> env -> constr -> unit @@ -72,3 +75,7 @@ val explain_logic_error_no_anomaly : (exn -> Pp.std_ppcmds) ref (** Prints a logic failure message for a rule *) val db_logic_failure : debug_info -> exn -> unit + +(** Prints a logic failure message for a rule *) +val db_breakpoint : debug_info -> + identifier Util.located message_token list -> unit diff --git a/scripts/coqc.ml b/scripts/coqc.ml index dfcb9c18..bc4b1321 100644 --- a/scripts/coqc.ml +++ b/scripts/coqc.ml @@ -28,8 +28,6 @@ let image = ref "" (* coqc options *) -let specification = ref false -let keep = ref false let verbose = ref false (* Verifies that a string starts by a letter and do not contain @@ -104,28 +102,21 @@ let parse_args () = let rec parse (cfiles,args) = function | [] -> List.rev cfiles, List.rev args - | "-i" :: rem -> - specification := true ; parse (cfiles,args) rem - | "-t" :: rem -> - keep := true ; parse (cfiles,args) rem | ("-verbose" | "--verbose") :: rem -> verbose := true ; parse (cfiles,args) rem - | "-boot" :: rem -> - Flags.boot := true; - parse (cfiles, "-boot"::args) rem - | "-byte" :: rem -> - binary := "coqtop.byte"; parse (cfiles,args) rem - | "-opt" :: rem -> - binary := "coqtop.opt"; parse (cfiles,args) rem | "-image" :: f :: rem -> image := f; parse (cfiles,args) rem | "-image" :: [] -> usage () + | "-byte" :: rem -> + binary := "coqtop.byte"; parse (cfiles,args) rem + | "-opt" :: rem -> + binary := "coqtop.opt"; parse (cfiles,args) rem | "-libdir" :: _ :: rem -> - print_string "Warning: option -libdir deprecated\n"; flush stdout; + print_string "Warning: option -libdir deprecated and ignored\n"; flush stdout; parse (cfiles,args) rem | ("-db"|"-debugger") :: rem -> - print_string "Warning: option -db/-debugger deprecated\n";flush stdout; + print_string "Warning: option -db/-debugger deprecated and ignored\n";flush stdout; parse (cfiles,args) rem | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () @@ -150,7 +141,7 @@ let parse_args () = | "-R" :: s :: "-as" :: [] -> usage () | "-R" :: s :: t :: rem -> parse (cfiles,t::s::"-R"::args) rem - | ("-notactics"|"-debug"|"-nolib" + | ("-notactics"|"-debug"|"-nolib"|"-boot" |"-batch"|"-nois"|"-noglob"|"-no-glob" |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet" |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit" diff --git a/tactics/auto.ml b/tactics/auto.ml index 93ca89f4..8a0de08b 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -786,8 +786,6 @@ type hints_entry = | HintsTransparencyEntry of evaluable_global_reference list * bool | HintsExternEntry of int * (patvar list * constr_pattern) option * glob_tactic_expr - | HintsDestructEntry of identifier * int * (bool,unit) location * - (patvar list * constr_pattern) * glob_tactic_expr let h = id_of_string "H" @@ -858,9 +856,6 @@ let interp_hints h = let pat = Option.map fp patcom in let tacexp = !forward_intern_tac (match pat with None -> [] | Some (l, _) -> l) tacexp in HintsExternEntry (pri, pat, tacexp) - | HintsDestruct(na,pri,loc,pat,code) -> - let (l,_ as pat) = fp pat in - HintsDestructEntry (na,pri,loc,pat,!forward_intern_tac l code) let add_hints local dbnames0 h = if List.mem "nocore" dbnames0 then @@ -876,10 +871,6 @@ let add_hints local dbnames0 h = add_transparency lhints b local dbnames | HintsExternEntry (pri, pat, tacexp) -> add_externs pri pat tacexp local dbnames - | HintsDestructEntry (na,pri,loc,pat,code) -> - if dbnames0<>[] then - warn (str"Database selection not implemented for destruct hints"); - Dhyp.add_destructor_hint local na loc pat pri code (**************************************************************************) (* Functions for printing the hints *) @@ -887,14 +878,14 @@ let add_hints local dbnames0 h = let pr_autotactic = function - | Res_pf (c,clenv) -> (str"apply " ++ pr_lconstr c) - | ERes_pf (c,clenv) -> (str"eapply " ++ pr_lconstr c) - | Give_exact c -> (str"exact " ++ pr_lconstr c) + | Res_pf (c,clenv) -> (str"apply " ++ pr_constr c) + | ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c) + | Give_exact c -> (str"exact " ++ pr_constr c) | Res_pf_THEN_trivial_fail (c,clenv) -> - (str"apply " ++ pr_lconstr c ++ str" ; trivial") + (str"apply " ++ pr_constr c ++ str" ; trivial") | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) | Extern tac -> - (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac) + (str "(*external*) " ++ Pptactic.pr_glob_tactic (Global.env()) tac) let pr_hint (id, v) = (pr_autotactic v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ()) @@ -1107,6 +1098,131 @@ let conclPattern concl pat tac gl = with PatternMatchingFailure -> error "conclPattern" in !forward_interp_tactic constr_bindings tac gl +(***********************************************************) +(** A debugging / verbosity framework for trivial and auto *) +(***********************************************************) + +(** The following options allow to trigger debugging/verbosity + without having to adapt the scripts. + Note: if Debug and Info are both activated, Debug take precedence. *) + +let global_debug_trivial = ref false +let global_debug_auto = ref false +let global_info_trivial = ref false +let global_info_auto = ref false + +let add_option ls refe = + let _ = Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optdepr = false; + Goptions.optname = String.concat " " ls; + Goptions.optkey = ls; + Goptions.optread = (fun () -> !refe); + Goptions.optwrite = (:=) refe } + in () + +let _ = + add_option ["Debug";"Trivial"] global_debug_trivial; + add_option ["Debug";"Auto"] global_debug_auto; + add_option ["Info";"Trivial"] global_info_trivial; + add_option ["Info";"Auto"] global_info_auto + +let no_dbg () = (Off,0,ref []) + +let mk_trivial_dbg debug = + let d = + if debug = Debug || !global_debug_trivial then Debug + else if debug = Info || !global_info_trivial then Info + else Off + in (d,0,ref []) + +(** Note : we start the debug depth of auto at 1 to distinguish it + for trivial (whose depth is 0). *) + +let mk_auto_dbg debug = + let d = + if debug = Debug || !global_debug_auto then Debug + else if debug = Info || !global_info_auto then Info + else Off + in (d,1,ref []) + +let incr_dbg = function (dbg,depth,trace) -> (dbg,depth+1,trace) + +(** A tracing tactic for debug/info trivial/auto *) + +let tclLOG (dbg,depth,trace) pp tac = + match dbg with + | Off -> tac + | Debug -> + (* For "debug (trivial/auto)", we directly output messages *) + let s = String.make depth '*' in + begin fun gl -> + try + let out = tac gl in + msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); + out + with e -> + msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); + raise e + end + | Info -> + (* For "info (trivial/auto)", we store a log trace *) + begin fun gl -> + try + let out = tac gl in + trace := (depth, Some pp) :: !trace; + out + with e -> + trace := (depth, None) :: !trace; + raise e + end + +(** For info, from the linear trace information, we reconstitute the part + of the proof tree we're interested in. The last executed tactic + comes first in the trace (and it should be a successful one). + [depth] is the root depth of the tree fragment we're visiting. + [keep] means we're in a successful tree fragment (the very last + tactic has been successful). *) + +let rec cleanup_info_trace depth acc = function + | [] -> acc + | (d,Some pp) :: l -> cleanup_info_trace d ((d,pp)::acc) l + | l -> cleanup_info_trace depth acc (erase_subtree depth l) + +and erase_subtree depth = function + | [] -> [] + | (d,_) :: l -> if d = depth then l else erase_subtree depth l + +let pr_info_atom (d,pp) = + msg_debug (str (String.make d ' ') ++ pp () ++ str ".") + +let pr_info_trace = function + | (Info,_,{contents=(d,Some pp)::l}) -> + List.iter pr_info_atom (cleanup_info_trace d [(d,pp)] l) + | _ -> () + +let pr_info_nop = function + | (Info,_,_) -> msg_debug (str "idtac.") + | _ -> () + +let pr_dbg_header = function + | (Off,_,_) -> () + | (Debug,0,_) -> msg_debug (str "(* debug trivial : *)") + | (Debug,_,_) -> msg_debug (str "(* debug auto : *)") + | (Info,0,_) -> msg_debug (str "(* info trivial : *)") + | (Info,_,_) -> msg_debug (str "(* info auto : *)") + +let tclTRY_dbg d tac = + tclORELSE0 + (fun gl -> + pr_dbg_header d; + let out = tac gl in + pr_info_trace d; + out) + (fun gl -> + pr_info_nop d; + tclIDTAC gl) + (**************************************************************************) (* The Trivial tactic *) (**************************************************************************) @@ -1130,17 +1246,20 @@ let exists_evaluable_reference env = function | EvalConstRef _ -> true | EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false -let rec trivial_fail_db mod_delta db_list local_db gl = +let dbg_intro dbg = tclLOG dbg (fun () -> str "intro") intro +let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption + +let rec trivial_fail_db dbg mod_delta db_list local_db gl = let intro_tac = - tclTHEN intro + tclTHEN (dbg_intro dbg) (fun g'-> let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') - in trivial_fail_db mod_delta db_list (Hint_db.add_list hintl local_db) g') + in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list hintl local_db) g') in tclFIRST - (assumption::intro_tac:: - (List.map (fun tac -> tclCOMPLETE tac) - (trivial_resolve mod_delta db_list local_db (pf_concl gl)))) gl + ((dbg_assumption dbg)::intro_tac:: + (List.map tclCOMPLETE + (trivial_resolve dbg mod_delta db_list local_db (pf_concl gl)))) gl and my_find_search_nodelta db_list local_db hdc concl = List.map (fun hint -> (None,hint)) @@ -1181,7 +1300,7 @@ and my_find_search_delta db_list local_db hdc concl = in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) -and tac_of_hint db_list local_db concl (flags, ({pat=p; code=t})) = +and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t})) = let tactic = match t with | Res_pf (c,cl) -> unify_resolve_gen flags (c,cl) @@ -1190,23 +1309,26 @@ and tac_of_hint db_list local_db concl (flags, ({pat=p; code=t})) = | Res_pf_THEN_trivial_fail (c,cl) -> tclTHEN (unify_resolve_gen flags (c,cl)) - (trivial_fail_db (flags <> None) db_list local_db) - | Unfold_nth c -> + (* With "(debug) trivial", we shouldn't end here, and + with "debug auto" we don't display the details of inner trivial *) + (trivial_fail_db (no_dbg ()) (flags <> None) db_list local_db) + | Unfold_nth c -> (fun gl -> if exists_evaluable_reference (pf_env gl) c then tclPROGRESS (h_reduce (Unfold [all_occurrences_expr,c]) onConcl) gl else tclFAIL 0 (str"Unbound reference") gl) | Extern tacast -> conclPattern concl p tacast - in tactic + in + tclLOG dbg (fun () -> pr_autotactic t) tactic -and trivial_resolve mod_delta db_list local_db cl = +and trivial_resolve dbg mod_delta db_list local_db cl = try let head = try let hdconstr,_ = head_constr_bound cl in Some (head_of_constr_reference hdconstr) with Bound -> None in - List.map (tac_of_hint db_list local_db cl) + List.map (tac_of_hint dbg db_list local_db cl) (priority (my_find_search mod_delta db_list local_db head cl)) with Not_found -> [] @@ -1223,255 +1345,126 @@ let make_db_list dbnames = in List.map lookup dbnames -let trivial lems dbnames gl = +let trivial ?(debug=Off) lems dbnames gl = let db_list = make_db_list dbnames in - tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl + let d = mk_trivial_dbg debug in + tclTRY_dbg d + (trivial_fail_db d false db_list (make_local_hint_db false lems gl)) gl -let full_trivial lems gl = +let full_trivial ?(debug=Off) lems gl = let dbnames = Hintdbmap.dom !searchtable in let dbnames = list_remove "v62" dbnames in let db_list = List.map (fun x -> searchtable_map x) dbnames in - tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl + let d = mk_trivial_dbg debug in + tclTRY_dbg d + (trivial_fail_db d false db_list (make_local_hint_db false lems gl)) gl -let gen_trivial lems = function - | None -> full_trivial lems - | Some l -> trivial lems l +let gen_trivial ?(debug=Off) lems = function + | None -> full_trivial ~debug lems + | Some l -> trivial ~debug lems l -let h_trivial lems l = - Refiner.abstract_tactic (TacTrivial (List.map snd lems,l)) - (gen_trivial lems l) +let h_trivial ?(debug=Off) lems l = + Refiner.abstract_tactic (TacTrivial (debug,List.map snd lems,l)) + (gen_trivial ~debug lems l) (**************************************************************************) (* The classical Auto tactic *) (**************************************************************************) -let possible_resolve mod_delta db_list local_db cl = +let possible_resolve dbg mod_delta db_list local_db cl = try let head = try let hdconstr,_ = head_constr_bound cl in Some (head_of_constr_reference hdconstr) with Bound -> None in - List.map (tac_of_hint db_list local_db cl) + List.map (tac_of_hint dbg db_list local_db cl) (my_find_search mod_delta db_list local_db head cl) with Not_found -> [] -let decomp_unary_term_then (id,_,typc) kont1 kont2 gl = +let dbg_case dbg id = + tclLOG dbg (fun () -> str "case " ++ pr_id id) (simplest_case (mkVar id)) + +let decomp_unary_term_then dbg (id,_,typc) kont1 kont2 gl = try let ccl = applist (head_constr typc) in match Hipattern.match_with_conjunction ccl with | Some (_,args) -> - tclTHEN (simplest_case (mkVar id)) (kont1 (List.length args)) gl + tclTHEN (dbg_case dbg id) (kont1 (List.length args)) gl | None -> kont2 gl with UserError _ -> kont2 gl -let decomp_empty_term (id,_,typc) gl = +let decomp_empty_term dbg (id,_,typc) gl = if Hipattern.is_empty_type typc then - simplest_case (mkVar id) gl + dbg_case dbg id gl else errorlabstrm "Auto.decomp_empty_term" (str "Not an empty type.") let extend_local_db gl decl db = Hint_db.add_list (make_resolve_hyp (pf_env gl) (project gl) decl) db -(* Try to decompose hypothesis [decl] into atomic components of a - conjunction with maximum depth [p] (or solve the goal from an - empty type) then call the continuation tactic with hint db extended - with the obtained not-further-decomposable hypotheses *) - -let rec decomp_and_register_decl p kont (id,_,_ as decl) db gl = - if p = 0 then - kont (extend_local_db gl decl db) gl - else - tclORELSE0 - (decomp_empty_term decl) - (decomp_unary_term_then decl (intros_decomp (p-1) kont [] db) - (kont (extend_local_db gl decl db))) gl - -(* Introduce [n] hypotheses, then decompose then with maximum depth [p] and - call the continuation tactic [kont] with the hint db extended - with the so-obtained not-further-decomposable hypotheses *) - -and intros_decomp p kont decls db n = - if n = 0 then - decomp_and_register_decls p kont decls db - else - tclTHEN intro (onLastDecl (fun d -> - (intros_decomp p kont (d::decls) db (n-1)))) - -(* Decompose hypotheses [hyps] with maximum depth [p] and - call the continuation tactic [kont] with the hint db extended - with the so-obtained not-further-decomposable hypotheses *) - -and decomp_and_register_decls p kont decls = - List.fold_left (decomp_and_register_decl p) kont decls +(* Introduce an hypothesis, then call the continuation tactic [kont] + with the hint db extended with the so-obtained hypothesis *) +let intro_register dbg kont db = + tclTHEN (dbg_intro dbg) + (onLastDecl (fun decl gl -> kont (extend_local_db gl decl db) gl)) -(* decomp is an natural number giving an indication on decomposition - of conjunction in hypotheses, 0 corresponds to no decomposition *) (* n is the max depth of search *) (* local_db contains the local Hypotheses *) exception Uplift of tactic list -let search_gen p n mod_delta db_list local_db = - let rec search n local_db = +let search d n mod_delta db_list local_db = + let rec search d n local_db = if n=0 then (fun gl -> error "BOUND 2") else - tclORELSE0 assumption - (tclORELSE0 (intros_decomp p (search n) [] local_db 1) - (fun gl -> tclFIRST - (List.map (fun ntac -> tclTHEN ntac (search (n-1) local_db)) - (possible_resolve mod_delta db_list local_db (pf_concl gl))) gl)) + tclORELSE0 (dbg_assumption d) + (tclORELSE0 (intro_register d (search d n) local_db) + (fun gl -> + let d' = incr_dbg d in + tclFIRST + (List.map + (fun ntac -> tclTHEN ntac (search d' (n-1) local_db)) + (possible_resolve d mod_delta db_list local_db (pf_concl gl))) gl)) in - search n local_db - -let search = search_gen 0 + search d n local_db let default_search_depth = ref 5 -let delta_auto mod_delta n lems dbnames gl = +let delta_auto ?(debug=Off) mod_delta n lems dbnames gl = let db_list = make_db_list dbnames in - tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl + let d = mk_auto_dbg debug in + tclTRY_dbg d + (search d n mod_delta db_list (make_local_hint_db false lems gl)) gl -let auto = delta_auto false +let auto ?(debug=Off) n = delta_auto ~debug false n -let new_auto = delta_auto true +let new_auto ?(debug=Off) n = delta_auto ~debug true n let default_auto = auto !default_search_depth [] [] -let delta_full_auto mod_delta n lems gl = +let delta_full_auto ?(debug=Off) mod_delta n lems gl = let dbnames = Hintdbmap.dom !searchtable in let dbnames = list_remove "v62" dbnames in let db_list = List.map (fun x -> searchtable_map x) dbnames in - tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl + let d = mk_auto_dbg debug in + tclTRY_dbg d + (search d n mod_delta db_list (make_local_hint_db false lems gl)) gl -let full_auto = delta_full_auto false -let new_full_auto = delta_full_auto true +let full_auto ?(debug=Off) n = delta_full_auto ~debug false n +let new_full_auto ?(debug=Off) n = delta_full_auto ~debug true n let default_full_auto gl = full_auto !default_search_depth [] gl -let gen_auto n lems dbnames = +let gen_auto ?(debug=Off) n lems dbnames = let n = match n with None -> !default_search_depth | Some n -> n in match dbnames with - | None -> full_auto n lems - | Some l -> auto n lems l + | None -> full_auto ~debug n lems + | Some l -> auto ~debug n lems l let inj_or_var = Option.map (fun n -> ArgArg n) -let h_auto n lems l = - Refiner.abstract_tactic (TacAuto (inj_or_var n,List.map snd lems,l)) - (gen_auto n lems l) - -(**************************************************************************) -(* The "destructing Auto" from Eduardo *) -(**************************************************************************) - -(* Depth of search after decomposition of hypothesis, by default - one look for an immediate solution *) -let default_search_decomp = ref 20 - -let destruct_auto p lems n gl = - decomp_and_register_decls p (fun local_db gl -> - search_gen p n false (List.map searchtable_map ["core";"extcore"]) - (add_hint_lemmas false lems local_db gl) gl) - (pf_hyps gl) - (Hint_db.empty empty_transparent_state false) - gl - -let dautomatic des_opt lems n = tclTRY (destruct_auto des_opt lems n) - -let dauto (n,p) lems = - let p = match p with Some p -> p | None -> !default_search_decomp in - let n = match n with Some n -> n | None -> !default_search_depth in - dautomatic p lems n - -let default_dauto = dauto (None,None) [] - -let h_dauto (n,p) lems = - Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,List.map snd lems)) - (dauto (n,p) lems) - -(***************************************) -(*** A new formulation of Auto *********) -(***************************************) - -let make_resolve_any_hyp env sigma (id,_,ty) = - let ents = - map_succeed - (fun f -> f (mkVar id,ty)) - [make_exact_entry sigma None; make_apply_entry env sigma (true,true,false) None] - in - ents - -type autoArguments = - | UsingTDB - | Destructing - -let compileAutoArg contac = function - | Destructing -> - (function g -> - let ctx = pf_hyps g in - tclFIRST - (List.map - (fun (id,_,typ) -> - let cl = (strip_prod_assum typ) in - if Hipattern.is_conjunction cl - then - tclTHENSEQ [simplest_elim (mkVar id); clear [id]; contac] - else - tclFAIL 0 (pr_id id ++ str" is not a conjunction")) - ctx) g) - | UsingTDB -> - (tclTHEN - (Tacticals.tryAllHypsAndConcl - (function - | Some id -> Dhyp.h_destructHyp false id - | None -> Dhyp.h_destructConcl)) - contac) - -let compileAutoArgList contac = List.map (compileAutoArg contac) - -let rec super_search n db_list local_db argl gl = - if n = 0 then error "BOUND 2"; - tclFIRST - (assumption - :: - tclTHEN intro - (fun g -> - let hintl = pf_apply make_resolve_any_hyp g (pf_last_hyp g) in - super_search n db_list (Hint_db.add_list hintl local_db) - argl g) - :: - List.map (fun ntac -> - tclTHEN ntac - (super_search (n-1) db_list local_db argl)) - (possible_resolve false db_list local_db (pf_concl gl)) - @ - compileAutoArgList (super_search (n-1) db_list local_db argl) argl) gl - -let search_superauto n to_add argl g = - let sigma = - List.fold_right - (fun (id,c) -> add_named_decl (id, None, pf_type_of g c)) - to_add empty_named_context in - let db0 = list_map_append (make_resolve_hyp (pf_env g) (project g)) sigma in - let db = Hint_db.add_list db0 (make_local_hint_db false [] g) in - super_search n [Hintdbmap.find "core" !searchtable] db argl g - -let superauto n to_add argl = - tclTRY (tclCOMPLETE (search_superauto n to_add argl)) - -let interp_to_add gl r = - let r = locate_global_with_alias (qualid_of_reference r) in - let id = basename_of_global r in - (next_ident_away id (pf_ids_of_hyps gl), constr_of_global r) - -let gen_superauto nopt l a b gl = - let n = match nopt with Some n -> n | None -> !default_search_depth in - let al = (if a then [Destructing] else [])@(if b then [UsingTDB] else []) in - superauto n (List.map (interp_to_add gl) l) al gl - -let h_superauto no l a b = - Refiner.abstract_tactic (TacSuperAuto (no,l,a,b)) (gen_superauto no l a b) - +let h_auto ?(debug=Off) n lems l = + Refiner.abstract_tactic (TacAuto (debug,inj_or_var n,List.map snd lems,l)) + (gen_auto ~debug n lems l) diff --git a/tactics/auto.mli b/tactics/auto.mli index 521c5ed2..87786e5b 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -102,8 +102,6 @@ type hints_entry = | HintsTransparencyEntry of evaluable_global_reference list * bool | HintsExternEntry of int * (patvar list * constr_pattern) option * Tacexpr.glob_tactic_expr - | HintsDestructEntry of identifier * int * (bool,unit) Tacexpr.location * - (patvar list * constr_pattern) * Tacexpr.glob_tactic_expr val searchtable_map : hint_db_name -> hint_db @@ -220,59 +218,51 @@ val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr - val make_db_list : hint_db_name list -> hint_db list -val auto : int -> open_constr list -> hint_db_name list -> tactic +val auto : ?debug:Tacexpr.debug -> + int -> open_constr list -> hint_db_name list -> tactic (** Auto with more delta. *) -val new_auto : int -> open_constr list -> hint_db_name list -> tactic +val new_auto : ?debug:Tacexpr.debug -> + int -> open_constr list -> hint_db_name list -> tactic (** auto with default search depth and with the hint database "core" *) val default_auto : tactic (** auto with all hint databases except the "v62" compatibility database *) -val full_auto : int -> open_constr list -> tactic +val full_auto : ?debug:Tacexpr.debug -> + int -> open_constr list -> tactic (** auto with all hint databases except the "v62" compatibility database and doing delta *) -val new_full_auto : int -> open_constr list -> tactic +val new_full_auto : ?debug:Tacexpr.debug -> + int -> open_constr list -> tactic (** auto with default search depth and with all hint databases except the "v62" compatibility database *) val default_full_auto : tactic (** The generic form of auto (second arg [None] means all bases) *) -val gen_auto : int option -> open_constr list -> hint_db_name list option -> tactic +val gen_auto : ?debug:Tacexpr.debug -> + int option -> open_constr list -> hint_db_name list option -> tactic (** The hidden version of auto *) -val h_auto : int option -> open_constr list -> hint_db_name list option -> tactic +val h_auto : ?debug:Tacexpr.debug -> + int option -> open_constr list -> hint_db_name list option -> tactic (** Trivial *) -val trivial : open_constr list -> hint_db_name list -> tactic -val gen_trivial : open_constr list -> hint_db_name list option -> tactic -val full_trivial : open_constr list -> tactic -val h_trivial : open_constr list -> hint_db_name list option -> tactic -val pr_autotactic : 'a auto_tactic -> Pp.std_ppcmds - -(** {6 The following is not yet up to date -- Papageno. } *) - -(** DAuto *) -val dauto : int option * int option -> open_constr list -> tactic -val default_search_decomp : int ref -val default_dauto : tactic - -val h_dauto : int option * int option -> open_constr list -> tactic +val trivial : ?debug:Tacexpr.debug -> + open_constr list -> hint_db_name list -> tactic +val gen_trivial : ?debug:Tacexpr.debug -> + open_constr list -> hint_db_name list option -> tactic +val full_trivial : ?debug:Tacexpr.debug -> + open_constr list -> tactic +val h_trivial : ?debug:Tacexpr.debug -> + open_constr list -> hint_db_name list option -> tactic -(** SuperAuto *) - -type autoArguments = - | UsingTDB - | Destructing - -(* -val superauto : int -> (identifier * constr) list -> autoArguments list -> tactic -*) +val pr_autotactic : 'a auto_tactic -> Pp.std_ppcmds -val h_superauto : int option -> reference list -> bool -> bool -> tactic +(** Hook for changing the initialization of auto *) val add_auto_init : (unit -> unit) -> unit diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index 42df244d..e063124d 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -634,6 +634,23 @@ let has_undefined p oevd evd = snd (p oevd ev evi)) evd false +(** Revert the resolvability status of evars after resolution, + potentially unprotecting some evars that were set unresolvable + just for this call to resolution. *) + +let revert_resolvability oevd evd = + Evd.fold_undefined + (fun ev evi evm -> + try + if not (Typeclasses.is_resolvable evi) then + let evi' = Evd.find_undefined oevd ev in + if Typeclasses.is_resolvable evi' then + Evd.add evm ev (Typeclasses.mark_resolvable evi) + else evm + else evm + with Not_found -> evm) + evd evd + (** If [do_split] is [true], we try to separate the problem in several components and then solve them separately *) @@ -644,7 +661,7 @@ let resolve_all_evars debug m env p oevd do_split fail = let in_comp comp ev = if do_split then Intset.mem ev comp else true in let rec docomp evd = function - | [] -> evd + | [] -> revert_resolvability oevd evd | comp :: comps -> let p = select_and_update_evars p oevd (in_comp comp) in try @@ -659,24 +676,20 @@ let resolve_all_evars debug m env p oevd do_split fail = docomp evd comps in docomp oevd split -let initial_select_evars onlyargs = - if onlyargs then - (fun evd ev evi -> - Typeclasses.is_implicit_arg (snd (Evd.evar_source ev evd)) - && Typeclasses.is_class_evar evd evi) - else - (fun evd ev evi -> Typeclasses.is_class_evar evd evi) +let initial_select_evars filter evd ev evi = + filter (snd evi.Evd.evar_source) && + Typeclasses.is_class_evar evd evi -let resolve_typeclass_evars debug m env evd onlyargs split fail = +let resolve_typeclass_evars debug m env evd filter split fail = let evd = try Evarconv.consider_remaining_unif_problems ~ts:(Typeclasses.classes_transparent_state ()) env evd with _ -> evd in - resolve_all_evars debug m env (initial_select_evars onlyargs) evd split fail + resolve_all_evars debug m env (initial_select_evars filter) evd split fail -let solve_inst debug depth env evd onlyargs split fail = - resolve_typeclass_evars debug depth env evd onlyargs split fail +let solve_inst debug depth env evd filter split fail = + resolve_typeclass_evars debug depth env evd filter split fail let _ = Typeclasses.solve_instanciations_problem := diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml deleted file mode 100644 index fd924707..00000000 --- a/tactics/dhyp.ml +++ /dev/null @@ -1,359 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(* Chet's comments about this tactic : - - Programmable destruction of hypotheses and conclusions. - - The idea here is that we are going to store patterns. These - patterns look like: - - TYP=<pattern> - SORT=<pattern> - - and from these patterns, we will be able to decide which tactic to - execute. - - For hypotheses, we have a vector of 4 patterns: - - HYP[TYP] HYP[SORT] CONCL[TYP] CONCL[SORT] - - and for conclusions, we have 2: - - CONCL[TYP] CONCL[SORT] - - If the user doesn't supply some of these, they are just replaced - with empties. - - The process of matching goes like this: - - We use a discrimination net to look for matches between the pattern - for HYP[TOP] (CONCL[TOP]) and the type of the chosen hypothesis. - Then, we use this to look for the right tactic to apply, by - matching the rest of the slots. Each match is tried, and if there - is more than one, this fact is reported, and the one with the - lowest priority is taken. The priority is a parameter of the - tactic input. - - The tactic input is an expression to hand to the - tactic-interpreter, and its priority. - - For most tactics, the priority should be the number of subgoals - generated. - - Matching is compatible with second-order matching of sopattern. - - SYNTAX: - - Hint DHyp <hyp-pattern> pri <tac-pattern>. - - and - - Hint DConcl <concl-pattern> pri <tac-pattern>. - - The bindings at the end allow us to transfer information from the - patterns on terms into the patterns on tactics in a safe way - we - will perform second-order normalization and conversion to an AST - before substitution into the tactic-expression. - - WARNING: The binding mechanism is NOT intended to facilitate the - transfer of large amounts of information from the terms to the - tactic. This should be done in a special-purpose tactic. - - *) - -(* - -Example : The tactic "if there is a hypothesis saying that the -successor of some number is smaller than zero, then invert such -hypothesis" is defined in this way: - -Require DHyp. -Hint Destruct Hypothesis less_than_zero (le (S ?) O) 1 - (:tactic:<Inversion $0>). - -Then, the tactic is used like this: - -Goal (le (S O) O) -> False. -Intro H. -DHyp H. -Qed. - -The name "$0" refers to the matching hypothesis --in this case the -hypothesis H. - -Similarly for the conclusion : - -Hint Destruct Conclusion equal_zero (? = ?) 1 (:tactic:<Reflexivity>). - -Goal (plus O O)=O. -DConcl. -Qed. - -The "Discardable" option clears the hypothesis after using it. - -Require DHyp. -Hint Destruct Discardable Hypothesis less_than_zero (le (S ?) O) 1 - (:tactic:<Inversion $0>). - -Goal (n:nat)(le (S n) O) -> False. -Intros n H. -DHyp H. -Qed. --- Eduardo (9/3/97 ) - -*) - -open Pp -open Util -open Names -open Term -open Environ -open Reduction -open Proof_type -open Glob_term -open Tacmach -open Refiner -open Tactics -open Clenv -open Tactics -open Tacticals -open Libobject -open Library -open Pattern -open Matching -open Pcoq -open Tacexpr -open Termops -open Libnames - -(* two patterns - one for the type, and one for the type of the type *) -type destructor_pattern = { - d_typ: constr_pattern; - d_sort: constr_pattern } - -let subst_destructor_pattern subst { d_typ = t; d_sort = s } = - { d_typ = subst_pattern subst t; d_sort = subst_pattern subst s } - -(* hypothesis patterns might need to do matching on the conclusion, too. - * conclusion-patterns only need to do matching on the hypothesis *) -type located_destructor_pattern = - (* discardable, pattern for hyp, pattern for concl *) - (bool * destructor_pattern * destructor_pattern, - (* pattern for concl *) - destructor_pattern) location - -let subst_located_destructor_pattern subst = function - | HypLocation (b,d,d') -> - HypLocation - (b,subst_destructor_pattern subst d, subst_destructor_pattern subst d') - | ConclLocation d -> - ConclLocation (subst_destructor_pattern subst d) - - -type destructor_data = { - d_pat : located_destructor_pattern; - d_pri : int; - d_code : identifier option * glob_tactic_expr (* should be of phylum tactic *) -} - -module Dest_data = struct - type t = destructor_data - let compare = Pervasives.compare - end - -module Nbterm_net = Nbtermdn.Make(Dest_data) - -type t = identifier Nbterm_net.t -type frozen_t = identifier Nbterm_net.frozen_t - -let tactab = (Nbterm_net.create () : t) - -let lookup pat = Nbterm_net.lookup tactab pat - - -let init () = Nbterm_net.empty tactab - -let freeze () = Nbterm_net.freeze tactab -let unfreeze fs = Nbterm_net.unfreeze fs tactab - -let add (na,dd) = - let pat = match dd.d_pat with - | HypLocation(_,p,_) -> p.d_typ - | ConclLocation p -> p.d_typ - in - if Nbterm_net.in_dn tactab na then begin - msgnl (str "Warning [Overriding Destructor Entry " ++ - str (string_of_id na) ++ str"]"); - Nbterm_net.remap tactab na (pat,dd) - end else - Nbterm_net.add tactab (na,(pat,dd)) - -let _ = - Summary.declare_summary "destruct-hyp-concl" - { Summary.freeze_function = freeze; - Summary.unfreeze_function = unfreeze; - Summary.init_function = init } - -let forward_subst_tactic = - ref (fun _ -> failwith "subst_tactic is not installed for DHyp") - -let cache_dd (_,(_,na,dd)) = - try - add (na,dd) - with _ -> - anomalylabstrm "Dhyp.add" - (str"The code which adds destructor hints broke;" ++ spc () ++ - str"this is not supposed to happen") - -let classify_dd (local,_,_ as o) = - if local then Dispose else Substitute o - -let subst_dd (subst,(local,na,dd)) = - (local,na, - { d_pat = subst_located_destructor_pattern subst dd.d_pat; - d_pri = dd.d_pri; - d_code = !forward_subst_tactic subst dd.d_code }) - -let inDD : bool * identifier * destructor_data -> obj = - declare_object {(default_object "DESTRUCT-HYP-CONCL-DATA") with - cache_function = cache_dd; - open_function = (fun i o -> if i=1 then cache_dd o); - subst_function = subst_dd; - classify_function = classify_dd } - -let catch_all_sort_pattern = PMeta(Some (id_of_string "SORT")) -let catch_all_type_pattern = PMeta(Some (id_of_string "TYPE")) - -let add_destructor_hint local na loc (_,pat) pri code = - let code = - begin match loc, code with - | HypLocation _, TacFun ([id],body) -> (id,body) - | ConclLocation _, _ -> (None, code) - | _ -> - errorlabstrm "add_destructor_hint" - (str "The tactic should be a function of the hypothesis name.") end - in - let pat = match loc with - | HypLocation b -> - HypLocation - (b,{d_typ=pat;d_sort=catch_all_sort_pattern}, - {d_typ=catch_all_type_pattern;d_sort=catch_all_sort_pattern}) - | ConclLocation () -> - ConclLocation({d_typ=pat;d_sort=catch_all_sort_pattern}) in - Lib.add_anonymous_leaf - (inDD (local,na,{ d_pat = pat; d_pri=pri; d_code=code })) - -let match_dpat dp cls gls = - let onconcl = cls.concl_occs <> no_occurrences_expr in - match (cls,dp) with - | ({onhyps=lo},HypLocation(_,hypd,concld)) when not onconcl -> - let hl = match lo with - Some l -> l - | None -> List.map (fun id -> ((all_occurrences_expr,id),InHyp)) - (pf_ids_of_hyps gls) in - if not - (List.for_all - (fun ((_,id),hl) -> - let cltyp = pf_get_hyp_typ gls id in - let cl = pf_concl gls in - (hl=InHyp) & - (is_matching hypd.d_typ cltyp) & - (is_matching hypd.d_sort (pf_type_of gls cltyp)) & - (is_matching concld.d_typ cl) & - (is_matching concld.d_sort (pf_type_of gls cl))) - hl) - then error "No match." - | ({onhyps=Some[]},ConclLocation concld) when onconcl -> - let cl = pf_concl gls in - if not - ((is_matching concld.d_typ cl) & - (is_matching concld.d_sort (pf_type_of gls cl))) - then error "No match." - | _ -> error "ApplyDestructor" - -let forward_interp_tactic = - ref (fun _ -> failwith "interp_tactic is not installed for DHyp") - -let set_extern_interp f = forward_interp_tactic := f - -let applyDestructor cls discard dd gls = - match_dpat dd.d_pat cls gls; - let cll = simple_clause_of cls gls in - let tacl = - List.map (fun cl -> - match cl, dd.d_code with - | Some id, (Some x, tac) -> - let arg = - ConstrMayEval(ConstrTerm (GRef(dummy_loc,VarRef id),None)) in - TacLetIn (false, [(dummy_loc, x), arg], tac) - | None, (None, tac) -> tac - | _, (Some _,_) -> error "Destructor expects an hypothesis." - | _, (None,_) -> error "Destructor is for conclusion.") - cll in - let discard_0 = - List.map (fun cl -> - match (cl,dd.d_pat) with - | (Some id,HypLocation(discardable,_,_)) -> - if discard & discardable then thin [id] else tclIDTAC - | (None,ConclLocation _) -> tclIDTAC - | _ -> error "ApplyDestructor" ) cll in - tclTHEN (tclMAP !forward_interp_tactic tacl) (tclTHENLIST discard_0) gls - - -(* [DHyp id gls] - - will take an identifier, get its type, look it up in the - discrimination net, get the destructors stored there, and then try - them in order of priority. *) - -let destructHyp discard id gls = - let hyptyp = pf_get_hyp_typ gls id in - let ddl = List.map snd (lookup hyptyp) in - let sorted_ddl = Sort.list (fun dd1 dd2 -> dd1.d_pri > dd2.d_pri) ddl in - tclFIRST (List.map (applyDestructor (onHyp id) discard) sorted_ddl) gls - -let dHyp id gls = destructHyp false id gls - -let h_destructHyp b id = - abstract_tactic (TacDestructHyp (b,(dummy_loc,id))) (destructHyp b id) - -(* [DConcl gls] - - will take a goal, get its concl, look it up in the - discrimination net, get the destructors stored there, and then try - them in order of priority. *) - -let dConcl gls = - let ddl = List.map snd (lookup (pf_concl gls)) in - let sorted_ddl = Sort.list (fun dd1 dd2 -> dd1.d_pri > dd2.d_pri) ddl in - tclFIRST (List.map (applyDestructor onConcl false) sorted_ddl) gls - -let h_destructConcl = abstract_tactic TacDestructConcl dConcl - -let rec search n = - if n=0 then error "Search has reached zero."; - tclFIRST - [intros; - assumption; - (tclTHEN - (Tacticals.tryAllHypsAndConcl - (function - | Some id -> (dHyp id) - | None -> dConcl )) - (search (n-1)))] - -let auto_tdb n = tclTRY (tclCOMPLETE (search n)) - -let search_depth_tdb = ref(5) - -let depth_tdb = function - | None -> !search_depth_tdb - | Some n -> n - -let h_auto_tdb n = abstract_tactic (TacAutoTDB n) (auto_tdb (depth_tdb n)) diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli deleted file mode 100644 index 1bdeed6a..00000000 --- a/tactics/dhyp.mli +++ /dev/null @@ -1,28 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Names -open Tacmach -open Tacexpr - -(** Programmable destruction of hypotheses and conclusions. *) - -val set_extern_interp : (glob_tactic_expr -> tactic) -> unit - -(* -val dHyp : identifier -> tactic -val dConcl : tactic -*) -val h_destructHyp : bool -> identifier -> tactic -val h_destructConcl : tactic -val h_auto_tdb : int option -> tactic - -val add_destructor_hint : - Vernacexpr.locality_flag -> identifier -> (bool,unit) Tacexpr.location -> - Glob_term.patvar list * Pattern.constr_pattern -> int -> - glob_tactic_expr -> unit diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 9966fb77..a8ce4254 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -27,6 +27,7 @@ open Clenv open Auto open Glob_term open Hiddentac +open Tacexpr let eauto_unif_flags = { auto_unif_flags with Unification.modulo_delta = full_transparent_state } @@ -171,7 +172,14 @@ type search_state = { tacres : goal list sigma; last_tactic : std_ppcmds Lazy.t; dblist : Auto.hint_db list; - localdb : Auto.hint_db list } + localdb : Auto.hint_db list; + prev : prev_search_state +} + +and prev_search_state = (* for info eauto *) + | Unknown + | Init + | State of search_state module SearchProblem = struct @@ -211,6 +219,7 @@ module SearchProblem = struct if s.depth = 0 then [] else + let ps = if s.prev = Unknown then Unknown else State s in let lg = s.tacres in let nbgl = List.length (sig_it lg) in assert (nbgl > 0); @@ -225,7 +234,8 @@ module SearchProblem = struct in List.map (fun (res,pp) -> { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; - localdb = List.tl s.localdb }) l + localdb = List.tl s.localdb; + prev = ps}) l in let intro_tac = List.map @@ -237,7 +247,7 @@ module SearchProblem = struct let ldb = Hint_db.add_list hintl (List.hd s.localdb) in { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; - localdb = ldb :: List.tl s.localdb }) + localdb = ldb :: List.tl s.localdb; prev = ps }) (filter_tactics s.tacres [Tactics.intro,lazy (str "intro")]) in let rec_tacs = @@ -248,73 +258,122 @@ module SearchProblem = struct (fun (lgls as res, pp) -> let nbgl' = List.length (sig_it lgls) in if nbgl' < nbgl then - { depth = s.depth; tacres = res; last_tactic = pp; + { depth = s.depth; tacres = res; last_tactic = pp; prev = ps; dblist = s.dblist; localdb = List.tl s.localdb } else { depth = pred s.depth; tacres = res; - dblist = s.dblist; last_tactic = pp; + dblist = s.dblist; last_tactic = pp; prev = ps; localdb = list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb }) l in List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) - let pp s = - msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++ - (Lazy.force s.last_tactic) ++ str "\n")) + let pp s = hov 0 (str " depth=" ++ int s.depth ++ spc () ++ + (Lazy.force s.last_tactic)) end module Search = Explore.Make(SearchProblem) -let make_initial_state n gl dblist localdb = +(** Utilities for debug eauto / info eauto *) + +let global_debug_eauto = ref false +let global_info_eauto = ref false + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optdepr = false; + Goptions.optname = "Debug Eauto"; + Goptions.optkey = ["Debug";"Eauto"]; + Goptions.optread = (fun () -> !global_debug_eauto); + Goptions.optwrite = (:=) global_debug_eauto } + +let _ = + Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optdepr = false; + Goptions.optname = "Info Eauto"; + Goptions.optkey = ["Info";"Eauto"]; + Goptions.optread = (fun () -> !global_info_eauto); + Goptions.optwrite = (:=) global_info_eauto } + +let mk_eauto_dbg d = + if d = Debug || !global_debug_eauto then Debug + else if d = Info || !global_info_eauto then Info + else Off + +let pr_info_nop = function + | Info -> msg_debug (str "idtac.") + | _ -> () + +let pr_dbg_header = function + | Off -> () + | Debug -> msg_debug (str "(* debug eauto : *)") + | Info -> msg_debug (str "(* info eauto : *)") + +let pr_info dbg s = + if dbg <> Info then () + else + let rec loop s = + match s.prev with + | Unknown | Init -> s.depth + | State sp -> + let mindepth = loop sp in + let indent = String.make (mindepth - sp.depth) ' ' in + msg_debug (str indent ++ Lazy.force s.last_tactic ++ str "."); + mindepth + in + ignore (loop s) + +(** Eauto main code *) + +let make_initial_state dbg n gl dblist localdb = { depth = n; tacres = tclIDTAC gl; last_tactic = lazy (mt()); dblist = dblist; - localdb = [localdb] } - -let e_depth_search debug p db_list local_db gl = - try - let tac = if debug then Search.debug_depth_first else Search.depth_first in - let s = tac (make_initial_state p gl db_list local_db) in - s.tacres - with Not_found -> error "eauto: depth first search failed." - -let e_breadth_search debug n db_list local_db gl = - try - let tac = - if debug then Search.debug_breadth_first else Search.breadth_first - in - let s = tac (make_initial_state n gl db_list local_db) in - s.tacres - with Not_found -> error "eauto: breadth first search failed." + localdb = [localdb]; + prev = if dbg=Info then Init else Unknown; + } let e_search_auto debug (in_depth,p) lems db_list gl = let local_db = make_local_hint_db ~ts:full_transparent_state true lems gl in - if in_depth then - e_depth_search debug p db_list local_db gl - else - e_breadth_search debug p db_list local_db gl + let d = mk_eauto_dbg debug in + let tac = match in_depth,d with + | (true,Debug) -> Search.debug_depth_first + | (true,_) -> Search.depth_first + | (false,Debug) -> Search.debug_breadth_first + | (false,_) -> Search.breadth_first + in + try + pr_dbg_header d; + let s = tac (make_initial_state d p gl db_list local_db) in + pr_info d s; + s.tacres + with Not_found -> + pr_info_nop d; + error "eauto: search failed" open Evd -let eauto_with_bases debug np lems db_list = +let eauto_with_bases ?(debug=Off) np lems db_list = tclTRY (e_search_auto debug np lems db_list) -let eauto debug np lems dbnames = +let eauto ?(debug=Off) np lems dbnames = let db_list = make_db_list dbnames in tclTRY (e_search_auto debug np lems db_list) -let full_eauto debug n lems gl = +let full_eauto ?(debug=Off) n lems gl = let dbnames = current_db_names () in let dbnames = list_remove "v62" dbnames in let db_list = List.map searchtable_map dbnames in tclTRY (e_search_auto debug n lems db_list) gl -let gen_eauto d np lems = function - | None -> full_eauto d np lems - | Some l -> eauto d np lems l +let gen_eauto ?(debug=Off) np lems = function + | None -> full_eauto ~debug np lems + | Some l -> eauto ~debug np lems l let make_depth = function | None -> !default_search_depth @@ -362,7 +421,7 @@ END TACTIC EXTEND eauto | [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ gen_eauto false (make_dimension n p) lems db ] + [ gen_eauto (make_dimension n p) lems db ] END TACTIC EXTEND new_eauto @@ -370,20 +429,25 @@ TACTIC EXTEND new_eauto hintbases(db) ] -> [ match db with | None -> new_full_auto (make_depth n) lems - | Some l -> - new_auto (make_depth n) lems l ] + | Some l -> new_auto (make_depth n) lems l ] END TACTIC EXTEND debug_eauto | [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ gen_eauto true (make_dimension n p) lems db ] + [ gen_eauto ~debug:Debug (make_dimension n p) lems db ] +END + +TACTIC EXTEND info_eauto +| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ gen_eauto ~debug:Info (make_dimension n p) lems db ] END TACTIC EXTEND dfs_eauto | [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ gen_eauto false (true, make_depth p) lems db ] + [ gen_eauto (true, make_depth p) lems db ] END let cons a l = a :: l diff --git a/tactics/eauto.mli b/tactics/eauto.mli index 68ec42f4..5e656139 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -27,11 +27,11 @@ val registered_e_assumption : tactic val e_give_exact : ?flags:Unification.unify_flags -> constr -> tactic -val gen_eauto : bool -> bool * int -> open_constr list -> +val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> open_constr list -> hint_db_name list option -> tactic val eauto_with_bases : - bool -> + ?debug:Tacexpr.debug -> bool * int -> open_constr list -> Auto.hint_db list -> Proof_type.tactic diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index 6a13ac2a..58f07a1b 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -33,23 +33,9 @@ END let pr_orient = pr_orient () () () -let pr_int_list_full _prc _prlc _prt l = - let rec aux = function - | i :: l -> Pp.int i ++ Pp.spc () ++ aux l - | [] -> Pp.mt() - in aux l -ARGUMENT EXTEND int_nelist - PRINTED BY pr_int_list_full - RAW_TYPED AS int list - RAW_PRINTED BY pr_int_list_full - GLOB_TYPED AS int list - GLOB_PRINTED BY pr_int_list_full -| [ integer(x) int_nelist(l) ] -> [x::l] -| [ integer(x) ] -> [ [x] ] -END - -let pr_int_list = pr_int_list_full () () () +let pr_int_list = Util.pr_sequence Pp.int +let pr_int_list_full _prc _prlc _prt l = pr_int_list l open Glob_term @@ -72,6 +58,8 @@ let interp_occs ist gl l = | ArgVar (_,id as locid) -> (try int_list_of_VList (List.assoc id ist.lfun) with Not_found | CannotCoerceTo _ -> [interp_int ist locid]) +let interp_occs ist gl l = + Tacmach.project gl , interp_occs ist gl l let glob_occs ist l = l @@ -93,7 +81,7 @@ ARGUMENT EXTEND occurrences GLOB_TYPED AS occurrences_or_var GLOB_PRINTED BY pr_occurrences -| [ int_nelist(l) ] -> [ ArgArg l ] +| [ ne_integer_list(l) ] -> [ ArgArg l ] | [ var(id) ] -> [ ArgVar id ] END @@ -103,7 +91,7 @@ let pr_gen prc _prlc _prtac c = prc c let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob -let interp_glob ist gl (t,_) = (ist,t) +let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) let glob_glob = Tacinterp.intern_constr @@ -150,6 +138,9 @@ let interp_place ist gl = function ConclLocation () -> ConclLocation () | HypLocation (id,hl) -> HypLocation (interp_hyp ist gl id,hl) +let interp_place ist gl p = + Tacmach.project gl , interp_place ist gl p + let subst_place subst pl = pl ARGUMENT EXTEND hloc @@ -287,13 +278,13 @@ let glob_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause (fun x -> x) (* spiwack argument for the commands of the retroknowledge *) let (wit_r_nat_field, globwit_r_nat_field, rawwit_r_nat_field) = - Genarg.create_arg "r_nat_field" + Genarg.create_arg None "r_nat_field" let (wit_r_n_field, globwit_r_n_field, rawwit_r_n_field) = - Genarg.create_arg "r_n_field" + Genarg.create_arg None "r_n_field" let (wit_r_int31_field, globwit_r_int31_field, rawwit_r_int31_field) = - Genarg.create_arg "r_int31_field" + Genarg.create_arg None "r_int31_field" let (wit_r_field, globwit_r_field, rawwit_r_field) = - Genarg.create_arg "r_field" + Genarg.create_arg None "r_field" (* spiwack: the print functions are incomplete, but I don't know what they are used for *) diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli index 2abca40e..6f466490 100644 --- a/tactics/extraargs.mli +++ b/tactics/extraargs.mli @@ -15,6 +15,7 @@ open Termops open Glob_term val rawwit_orient : bool raw_abstract_argument_type +val globwit_orient : bool glob_abstract_argument_type val wit_orient : bool typed_abstract_argument_type val orient : bool Pcoq.Gram.entry val pr_orient : bool -> Pp.std_ppcmds @@ -39,6 +40,7 @@ val hloc : loc_place Pcoq.Gram.entry val pr_hloc : loc_place -> Pp.std_ppcmds val in_arg_hyp: (Names.identifier Util.located list option * bool) Pcoq.Gram.entry +val globwit_in_arg_hyp : (Names.identifier Util.located list option * bool) glob_abstract_argument_type val rawwit_in_arg_hyp : (Names.identifier Util.located list option * bool) raw_abstract_argument_type val wit_in_arg_hyp : (Names.identifier list option * bool) typed_abstract_argument_type val raw_in_arg_hyp_to_clause : (Names.identifier Util.located list option * bool) -> Tacticals.clause diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index da35edbe..507a1205 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -23,9 +23,13 @@ open Equality open Compat (**********************************************************************) -(* replace, discriminate, injection, simplify_eq *) +(* admit, replace, discriminate, injection, simplify_eq *) (* cutrewrite, dependent rewrite *) +TACTIC EXTEND admit + [ "admit" ] -> [ admit_as_an_axiom ] +END + let replace_in_clause_maybe_by (sigma1,c1) c2 in_hyp tac = Refiner.tclWITHHOLES false (replace_in_clause_maybe_by c1 c2 (glob_in_arg_hyp_to_clause in_hyp)) @@ -761,3 +765,15 @@ TACTIC EXTEND is_hyp | Var _ -> tclIDTAC | _ -> tclFAIL 0 (str "Not a variable or hypothesis") ] END + + +(* Command to grab the evars left unresolved at the end of a proof. *) +(* spiwack: I put it in extratactics because it is somewhat tied with + the semantics of the LCF-style tactics, hence with the classic tactic + mode. *) +VERNAC COMMAND EXTEND GrabEvars +[ "Grab" "Existential" "Variables" ] -> + [ let p = Proof_global.give_me_the_proof () in + Proof.V82.grab_evars p; + Flags.if_verbose (fun () -> Pp.msg (Printer.pr_open_subgoals ())) () ] +END diff --git a/tactics/refine.ml b/tactics/refine.ml index e7f3998a..653d005c 100644 --- a/tactics/refine.ml +++ b/tactics/refine.ml @@ -388,7 +388,7 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = let refine (evd,c) gl = let sigma = project gl in - let evd = Typeclasses.resolve_typeclasses ~onlyargs:true (pf_env gl) evd in + let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals (pf_env gl) evd in let c = Evarutil.nf_evar evd c in let (evd,c) = Evarutil.evars_to_metas sigma (evd,c) in (* Relies on Cast's put on Meta's by evars_to_metas, because it is otherwise diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4 index d297969d..120a76ae 100644 --- a/tactics/rewrite.ml4 +++ b/tactics/rewrite.ml4 @@ -257,7 +257,7 @@ let decompose_applied_relation env sigma flags orig (c,l) left2right = let ctype = Typing.type_of env sigma c' in let find_rel ty = let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c',ty) l in - let (equiv, args) = decompose_app_rel env sigma (Clenv.clenv_type eqclause) in + let (equiv, args) = decompose_app_rel env eqclause.evd (Clenv.clenv_type eqclause) in let c1 = args.(0) and c2 = args.(1) in let ty1, ty2 = Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2 @@ -1343,7 +1343,7 @@ type glob_constr_with_bindings_sign = interp_sign * glob_constr_and_expr with_bi let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge))) let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge)) let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge) -let interp_glob_constr_with_bindings ist gl c = (ist, c) +let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c) let glob_glob_constr_with_bindings ist l = Tacinterp.intern_constr_with_bindings ist l let subst_glob_constr_with_bindings s c = subst_glob_with_bindings s c @@ -1365,7 +1365,7 @@ ARGUMENT EXTEND glob_constr_with_bindings END let _ = - (Genarg.create_arg "strategy" : + (Genarg.create_arg None "strategy" : ((strategy, Genarg.tlevel) Genarg.abstract_argument_type * (strategy, Genarg.glevel) Genarg.abstract_argument_type * (strategy, Genarg.rlevel) Genarg.abstract_argument_type)) @@ -1374,7 +1374,7 @@ let _ = let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>" -let interp_strategy ist gl c = c +let interp_strategy ist gl c = project gl , c let glob_strategy ist l = l let subst_strategy evm l = l @@ -1405,10 +1405,11 @@ ARGUMENT EXTEND rewstrategy TYPED AS strategy | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ Strategies.choice h h' ] | [ "old_hints" preident(h) ] -> [ Strategies.old_hints h ] | [ "hints" preident(h) ] -> [ Strategies.hints h ] - | [ "terms" constr_list(h) ] -> [ fun env avoid t ty cstr evars -> + | [ "terms" constr_list(h) ] -> [ fun env avoid t ty cstr evars -> Strategies.lemmas rewrite_unif_flags (interp_constr_list env (goalevars evars) h) env avoid t ty cstr evars ] - | [ "eval" red_expr(r) ] -> [ fun env avoid t ty cstr evars -> - Strategies.reduce (Tacinterp.interp_redexp env (goalevars evars) r) env avoid t ty cstr evars ] + | [ "eval" red_expr(r) ] -> [ fun env avoid t ty cstr evars -> + let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in + Strategies.reduce r_interp env avoid t ty cstr (sigma,cstrevars evars) ] | [ "fold" constr(c) ] -> [ Strategies.fold c ] END @@ -1425,6 +1426,8 @@ let clsubstitute o c = | Some id when is_tac id -> tclIDTAC | _ -> cl_rewrite_clause c o all_occurrences cl) +open Extraargs + TACTIC EXTEND substitute | [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ clsubstitute o c ] END @@ -1536,7 +1539,7 @@ let declare_relation ?(binders=[]) a aeq n refl symm trans = type 'a binders_argtype = (local_binder list, 'a) Genarg.abstract_argument_type let _, _, rawwit_binders = - (Genarg.create_arg "binders" : + (Genarg.create_arg None "binders" : Genarg.tlevel binders_argtype * Genarg.glevel binders_argtype * Genarg.rlevel binders_argtype) @@ -1867,7 +1870,8 @@ let setoid_proof gl ty fn fallback = let env = pf_env gl in try let rel, args = decompose_app_rel env (project gl) (pf_concl gl) in - let evm, car = project gl, pf_type_of gl args.(0) in + let evm = project gl in + let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in fn env evm car rel gl with e -> try fallback gl diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index a41cd6e7..3efff8fa 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -175,8 +175,8 @@ let _ = "intros", TacIntroPattern []; "assumption", TacAssumption; "cofix", TacCofix None; - "trivial", TacTrivial ([],None); - "auto", TacAuto(None,[],None); + "trivial", TacTrivial (Off,[],None); + "auto", TacAuto(Off,None,[],None); "left", TacLeft(false,NoBindings); "eleft", TacLeft(true,NoBindings); "right", TacRight(false,NoBindings); @@ -254,7 +254,7 @@ type glob_sign = { type interp_genarg_type = (glob_sign -> raw_generic_argument -> glob_generic_argument) * (interp_sign -> goal sigma -> glob_generic_argument -> - typed_generic_argument) * + Evd.evar_map * typed_generic_argument) * (substitution -> glob_generic_argument -> glob_generic_argument) let extragenargtab = @@ -713,17 +713,10 @@ let rec intern_atomic lf ist x = (clause_app (intern_hyp_location ist) cls),b) (* Automation tactics *) - | TacTrivial (lems,l) -> TacTrivial (List.map (intern_constr ist) lems,l) - | TacAuto (n,lems,l) -> - TacAuto (Option.map (intern_or_var ist) n, + | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (intern_constr ist) lems,l) + | TacAuto (d,n,lems,l) -> + TacAuto (d,Option.map (intern_or_var ist) n, List.map (intern_constr ist) lems,l) - | TacAutoTDB n -> TacAutoTDB n - | TacDestructHyp (b,id) -> TacDestructHyp(b,intern_hyp ist id) - | TacDestructConcl -> TacDestructConcl - | TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2) - | TacDAuto (n,p,lems) -> - TacDAuto (Option.map (intern_or_var ist) n,p, - List.map (intern_constr ist) lems) (* Derived basic tactics *) | TacSimpleInductionDestruct (isrec,h) -> @@ -1256,7 +1249,8 @@ let interp_gen kind ist allow_patvar expand_evar fail_evar use_classes env sigma in let trace = push_trace (dloc,LtacConstrInterp (c,vars)) ist.trace in let evdc = - catch_error trace (understand_ltac expand_evar sigma env vars kind) c in + catch_error trace + (understand_ltac ~resolve_classes:use_classes expand_evar sigma env vars kind) c in let (evd,c) = if expand_evar then solve_remaining_evars fail_evar use_classes @@ -1268,7 +1262,7 @@ let interp_gen kind ist allow_patvar expand_evar fail_evar use_classes env sigma (* Interprets a constr; expects evars to be solved *) let interp_constr_gen kind ist env sigma c = - snd (interp_gen kind ist false true true true env sigma c) + interp_gen kind ist false true true true env sigma c let interp_constr = interp_constr_gen (OfType None) @@ -1278,8 +1272,8 @@ let interp_type = interp_constr_gen IsType let interp_open_constr_gen kind ist = interp_gen kind ist false true false false -let interp_open_constr ccl = - interp_open_constr_gen (OfType ccl) +let interp_open_constr ccl ist = + interp_gen (OfType ccl) ist false true false (ccl<>None) let interp_pure_open_constr ist = interp_gen (OfType None) ist false false false false @@ -1317,7 +1311,7 @@ let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = sigma, List.flatten l let interp_constr_list ist env sigma c = - snd (interp_constr_in_compound_list (fun x -> x) (fun x -> x) (fun ist env sigma c -> (Evd.empty, interp_constr ist env sigma c)) ist env sigma c) + interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_constr ist env sigma c let interp_open_constr_list = interp_constr_in_compound_list (fun x -> x) (fun x -> x) @@ -1339,7 +1333,8 @@ let interp_flag ist env red = { red with rConst = List.map (interp_evaluable ist env) red.rConst } let interp_constr_with_occurrences ist sigma env (occs,c) = - (interp_occurrences ist occs, interp_constr ist sigma env c) + let (sigma,c_interp) = interp_constr ist sigma env c in + sigma , (interp_occurrences ist occs, c_interp) let interp_typed_pattern_with_occurrences ist env sigma (occs,c) = let sign,p = interp_typed_pattern ist env sigma c in @@ -1354,36 +1349,48 @@ let interp_constr_with_occurrences_and_name_as_list = (function ((occs,c),Anonymous) when occs = all_occurrences_expr -> c | _ -> raise Not_found) (fun ist env sigma (occ_c,na) -> - sigma, (interp_constr_with_occurrences ist env sigma occ_c, + let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma occ_c in + sigma, (c_interp, interp_fresh_name ist env na)) let interp_red_expr ist sigma env = function - | Unfold l -> Unfold (List.map (interp_unfold ist env) l) - | Fold l -> Fold (List.map (interp_constr ist env sigma) l) - | Cbv f -> Cbv (interp_flag ist env f) - | Lazy f -> Lazy (interp_flag ist env f) + | Unfold l -> sigma , Unfold (List.map (interp_unfold ist env) l) + | Fold l -> + let (sigma,l_interp) = interp_constr_list ist env sigma l in + sigma , Fold l_interp + | Cbv f -> sigma , Cbv (interp_flag ist env f) + | Lazy f -> sigma , Lazy (interp_flag ist env f) | Pattern l -> - Pattern (List.map (interp_constr_with_occurrences ist env sigma) l) + let (sigma,l_interp) = + List.fold_right begin fun c (sigma,acc) -> + let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma c in + sigma , c_interp :: acc + end l (sigma,[]) + in + sigma , Pattern l_interp | Simpl o -> - Simpl(Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) - | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r + sigma , Simpl(Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) + | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> sigma , r let pf_interp_red_expr ist gl = interp_red_expr ist (project gl) (pf_env gl) let interp_may_eval f ist gl = function | ConstrEval (r,c) -> - let redexp = pf_interp_red_expr ist gl r in - pf_reduction_of_red_expr gl redexp (f ist gl c) + let (sigma,redexp) = pf_interp_red_expr ist gl r in + let (sigma,c_interp) = f ist { gl with sigma=sigma } c in + sigma , pf_reduction_of_red_expr gl redexp c_interp | ConstrContext ((loc,s),c) -> (try - let ic = f ist gl c + let (sigma,ic) = f ist gl c and ctxt = constr_of_VConstr_context (List.assoc s ist.lfun) in - subst_meta [special_meta,ic] ctxt + sigma , subst_meta [special_meta,ic] ctxt with | Not_found -> user_err_loc (loc, "interp_may_eval", str "Unbound context identifier" ++ pr_id s ++ str".")) - | ConstrTypeOf c -> pf_type_of gl (f ist gl c) + | ConstrTypeOf c -> + let (sigma,c_interp) = f ist gl c in + sigma , pf_type_of gl c_interp | ConstrTerm c -> try f ist gl c @@ -1394,7 +1401,7 @@ let interp_may_eval f ist gl = function (* Interprets a constr expression possibly to first evaluate *) let interp_constr_may_eval ist gl c = - let csr = + let (sigma,csr) = try interp_may_eval pf_interp_constr ist gl c with e -> @@ -1403,7 +1410,7 @@ let interp_constr_may_eval ist gl c = in begin db_constr ist.debug (pf_env gl) csr; - csr + sigma , csr end let rec message_of_value gl = function @@ -1565,7 +1572,7 @@ let interp_induction_arg ist gl arg = ElimOnIdent (loc,id) else let c = (GVar (loc,id),Some (CRef (Ident (loc,id)))) in - let c = interp_constr ist env sigma c in + let (sigma,c) = interp_constr ist env sigma c in ElimOnConstr (sigma,(c,NoBindings)) (* Associates variables with values and gives the remaining variables and @@ -1725,7 +1732,12 @@ let apply_one_mhyp_context ist env gl lmatch (hypname,patv,pat) lhyps = (* misc *) -let mk_constr_value ist gl c = VConstr ([],pf_interp_constr ist gl c) +let mk_constr_value ist gl c = + let (sigma,c_interp) = pf_interp_constr ist gl c in + sigma,VConstr ([],c_interp) +let mk_open_constr_value ist gl c = + let (sigma,c_interp) = pf_apply (interp_open_constr None ist) gl c in + sigma,VConstr ([],c_interp) let mk_hyp_value ist gl c = VConstr ([],mkVar (interp_hyp ist gl c)) let mk_int_or_var_value ist c = VInteger (interp_int_or_var ist c) @@ -1739,17 +1751,16 @@ let extend_gl_hyps { it=gl ; sigma=sigma } sign = (* Interprets an l-tac expression into a value *) let rec val_interp ist gl (tac:glob_tactic_expr) = - let value_interp ist = match tac with (* Immediate evaluation *) - | TacFun (it,body) -> VFun (ist.trace,ist.lfun,it,body) + | TacFun (it,body) -> project gl , VFun (ist.trace,ist.lfun,it,body) | TacLetIn (true,l,u) -> interp_letrec ist gl l u | TacLetIn (false,l,u) -> interp_letin ist gl l u | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist gl lz lr lmr | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr | TacArg (loc,a) -> interp_tacarg ist gl a (* Delayed evaluation *) - | t -> VFun (ist.trace,ist.lfun,[],t) + | t -> project gl , VFun (ist.trace,ist.lfun,[],t) in check_for_interrupt (); match ist.debug with @@ -1769,7 +1780,9 @@ and eval_tactic ist = function catch_error (push_trace(loc,call)ist.trace) tac gl | TacFun _ | TacLetIn _ -> assert false | TacMatchGoal _ | TacMatch _ -> assert false - | TacId s -> fun gl -> tclIDTAC_MESSAGE (interp_message_nl ist gl s) gl + | TacId s -> fun gl -> + let res = tclIDTAC_MESSAGE (interp_message_nl ist gl s) gl in + db_breakpoint ist.debug s; res | TacFail (n,s) -> fun gl -> tclFAIL (interp_int_or_var ist n) (interp_message ist gl s) gl | TacProgress tac -> tclPROGRESS (interp_tactic ist tac) | TacAbstract (tac,ido) -> @@ -1782,14 +1795,6 @@ and eval_tactic ist = function | TacDo (n,tac) -> tclDO (interp_int_or_var ist n) (interp_tactic ist tac) | TacTimeout (n,tac) -> tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac) | TacTry tac -> tclTRY (interp_tactic ist tac) - | TacInfo tac -> - let t = (interp_tactic ist tac) in - tclINFO - begin - match tac with - TacAtom (_,_) -> t - | _ -> abstract_tactic_expr (TacArg (dloc,Tacexp tac)) t - end | TacRepeat tac -> tclREPEAT (interp_tactic ist tac) | TacOrelse (tac1,tac2) -> tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2) @@ -1797,17 +1802,23 @@ and eval_tactic ist = function | TacSolve l -> tclSOLVE (List.map (interp_tactic ist) l) | TacComplete tac -> tclCOMPLETE (interp_tactic ist tac) | TacArg a -> interp_tactic ist (TacArg a) + | TacInfo tac -> + msg_warning + (str "The general \"info\" tactic is currently not working.\n" ++ + str "Some specific verbose tactics may exist instead, such as\n" ++ + str "info_trivial, info_auto, info_eauto."); + eval_tactic ist tac and force_vrec ist gl = function | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} gl body - | v -> v + | v -> project gl , v and interp_ltac_reference loc' mustbetac ist gl = function | ArgVar (loc,id) -> let v = List.assoc id ist.lfun in - let v = force_vrec ist gl v in + let (sigma,v) = force_vrec ist gl v in let v = propagate_trace ist loc id v in - if mustbetac then coerce_to_tactic loc id v else v + sigma , if mustbetac then coerce_to_tactic loc id v else v | ArgArg (loc,r) -> let ids = extract_ids [] ist.lfun in let loc_info = ((if loc' = dloc then loc else loc'),LtacNameCall r) in @@ -1816,36 +1827,69 @@ and interp_ltac_reference loc' mustbetac ist gl = function trace = push_trace loc_info ist.trace } in val_interp ist gl (lookup r) -and interp_tacarg ist gl = function - | TacVoid -> VVoid - | Reference r -> interp_ltac_reference dloc false ist gl r - | Integer n -> VInteger n - | IntroPattern ipat -> VIntroPattern (snd (interp_intro_pattern ist gl ipat)) - | ConstrMayEval c -> VConstr ([],interp_constr_may_eval ist gl c) - | MetaIdArg (loc,_,id) -> assert false - | TacCall (loc,r,[]) -> interp_ltac_reference loc true ist gl r - | TacCall (loc,f,l) -> - let fv = interp_ltac_reference loc true ist gl f - and largs = List.map (interp_tacarg ist gl) l in - List.iter check_is_value largs; - interp_app loc ist gl fv largs - | TacExternal (loc,com,req,la) -> - interp_external loc ist gl com req (List.map (interp_tacarg ist gl) la) - | TacFreshId l -> - let id = pf_interp_fresh_id ist gl l in - VIntroPattern (IntroIdentifier id) - | Tacexp t -> val_interp ist gl t - | TacDynamic(_,t) -> - let tg = (Dyn.tag t) in - if tg = "tactic" then - val_interp ist gl (tactic_out t ist) - else if tg = "value" then - value_out t - else if tg = "constr" then +and interp_tacarg ist gl arg = + let evdref = ref (project gl) in + let v = match arg with + | TacVoid -> VVoid + | Reference r -> + let (sigma,v) = interp_ltac_reference dloc false ist gl r in + evdref := sigma; + v + | Integer n -> VInteger n + | IntroPattern ipat -> VIntroPattern (snd (interp_intro_pattern ist gl ipat)) + | ConstrMayEval c -> + let (sigma,c_interp) = interp_constr_may_eval ist gl c in + evdref := sigma; + VConstr ([],c_interp) + | MetaIdArg (loc,_,id) -> assert false + | TacCall (loc,r,[]) -> + let (sigma,v) = interp_ltac_reference loc true ist gl r in + evdref := sigma; + v + | TacCall (loc,f,l) -> + let (sigma,fv) = interp_ltac_reference loc true ist gl f in + let (sigma,largs) = + List.fold_right begin fun a (sigma',acc) -> + let (sigma', a_interp) = interp_tacarg ist gl a in + sigma' , a_interp::acc + end l (sigma,[]) + in + List.iter check_is_value largs; + let (sigma,v) = interp_app loc ist { gl with sigma=sigma } fv largs in + evdref:= sigma; + v + | TacExternal (loc,com,req,la) -> + let (sigma,la_interp) = + List.fold_right begin fun a (sigma,acc) -> + let (sigma,a_interp) = interp_tacarg ist {gl with sigma=sigma} a in + sigma , a_interp::acc + end la (project gl,[]) + in + let (sigma,v) = interp_external loc ist { gl with sigma=sigma } com req la_interp in + evdref := sigma; + v + | TacFreshId l -> + let id = pf_interp_fresh_id ist gl l in + VIntroPattern (IntroIdentifier id) + | Tacexp t -> + let (sigma,v) = val_interp ist gl t in + evdref := sigma; + v + | TacDynamic(_,t) -> + let tg = (Dyn.tag t) in + if tg = "tactic" then + let (sigma,v) = val_interp ist gl (tactic_out t ist) in + evdref := sigma; + v + else if tg = "value" then + value_out t + else if tg = "constr" then VConstr ([],constr_out t) - else - anomaly_loc (dloc, "Tacinterp.val_interp", - (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">")) + else + anomaly_loc (dloc, "Tacinterp.val_interp", + (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">")) + in + !evdref , v (* Interprets an application node *) and interp_app loc ist gl fv largs = @@ -1859,19 +1903,20 @@ and interp_app loc ist gl fv largs = (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) -> let (newlfun,lvar,lval)=head_with_value (var,largs) in if lvar=[] then - let v = + let (sigma,v) = try catch_error trace (val_interp {ist with lfun=newlfun@olfun; trace=trace} gl) body with e -> debugging_exception_step ist false e (fun () -> str "evaluation"); raise e in + let gl = { gl with sigma=sigma } in debugging_step ist (fun () -> str"evaluation returns"++fnl()++pr_value (Some (pf_env gl)) v); - if lval=[] then v else interp_app loc ist gl v lval + if lval=[] then sigma,v else interp_app loc ist gl v lval else - VFun(trace,newlfun@olfun,lvar,body) + project gl , VFun(trace,newlfun@olfun,lvar,body) | _ -> user_err_loc (loc, "Tacinterp.interp_app", (str"Illegal tactic application.")) @@ -1894,10 +1939,12 @@ and tactic_of_value ist vle g = (* Evaluation with FailError catching *) and eval_with_fail ist is_lazy goal tac = try - (match val_interp ist goal tac with + let (sigma,v) = val_interp ist goal tac in + sigma , + (match v with | VFun (trace,lfun,[],t) when not is_lazy -> let tac = eval_tactic {ist with lfun=lfun; trace=trace} t in - VRTactic (catch_error trace tac goal) + VRTactic (catch_error trace tac { goal with sigma=sigma }) | a -> a) with | FailError (0,s) | Loc.Exc_located(_, FailError (0,s)) @@ -1919,10 +1966,15 @@ and interp_letrec ist gl llc u = (* Interprets the clauses of a LetIn *) and interp_letin ist gl llc u = - let lve = list_map_left (fun ((_,id),body) -> - let v = interp_tacarg ist gl body in check_is_value v; (id,v)) llc in + let (sigma,lve) = + List.fold_right begin fun ((_,id),body) (sigma,acc) -> + let (sigma,v) = interp_tacarg ist { gl with sigma=sigma } body in + check_is_value v; + sigma, (id,v)::acc + end llc (project gl,[]) + in let ist = { ist with lfun = lve@ist.lfun } in - val_interp ist gl u + val_interp ist { gl with sigma=sigma } u (* Interprets the Match Context expressions *) and interp_match_goal ist goal lz lr lmr = @@ -2015,80 +2067,103 @@ and interp_external loc ist gl com req la = (* Interprets extended tactic generic arguments *) and interp_genarg ist gl x = - match genarg_tag x with - | BoolArgType -> in_gen wit_bool (out_gen globwit_bool x) - | IntArgType -> in_gen wit_int (out_gen globwit_int x) - | IntOrVarArgType -> + let evdref = ref (project gl) in + let rec interp_genarg ist gl x = + let gl = { gl with sigma = !evdref } in + match genarg_tag x with + | BoolArgType -> in_gen wit_bool (out_gen globwit_bool x) + | IntArgType -> in_gen wit_int (out_gen globwit_int x) + | IntOrVarArgType -> in_gen wit_int_or_var (ArgArg (interp_int_or_var ist (out_gen globwit_int_or_var x))) - | StringArgType -> + | StringArgType -> in_gen wit_string (out_gen globwit_string x) - | PreIdentArgType -> + | PreIdentArgType -> in_gen wit_pre_ident (out_gen globwit_pre_ident x) - | IntroPatternArgType -> + | IntroPatternArgType -> in_gen wit_intro_pattern (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x)) - | IdentArgType b -> + | IdentArgType b -> in_gen (wit_ident_gen b) (pf_interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x)) - | VarArgType -> + | VarArgType -> in_gen wit_var (interp_hyp ist gl (out_gen globwit_var x)) - | RefArgType -> + | RefArgType -> in_gen wit_ref (pf_interp_reference ist gl (out_gen globwit_ref x)) - | SortArgType -> + | SortArgType -> + let (sigma,c_interp) = + pf_interp_constr ist gl + (GSort (dloc,out_gen globwit_sort x), None) + in + evdref := sigma; in_gen wit_sort - (destSort - (pf_interp_constr ist gl - (GSort (dloc,out_gen globwit_sort x), None))) - | ConstrArgType -> - in_gen wit_constr (pf_interp_constr ist gl (out_gen globwit_constr x)) - | ConstrMayEvalArgType -> - in_gen wit_constr_may_eval (interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x)) - | QuantHypArgType -> + (destSort c_interp) + | ConstrArgType -> + let (sigma,c_interp) = pf_interp_constr ist gl (out_gen globwit_constr x) in + evdref := sigma; + in_gen wit_constr c_interp + | ConstrMayEvalArgType -> + let (sigma,c_interp) = interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x) in + evdref := sigma; + in_gen wit_constr_may_eval c_interp + | QuantHypArgType -> in_gen wit_quant_hyp (interp_declared_or_quantified_hypothesis ist gl - (out_gen globwit_quant_hyp x)) - | RedExprArgType -> - in_gen wit_red_expr (pf_interp_red_expr ist gl (out_gen globwit_red_expr x)) - | OpenConstrArgType casted -> + (out_gen globwit_quant_hyp x)) + | RedExprArgType -> + let (sigma,r_interp) = pf_interp_red_expr ist gl (out_gen globwit_red_expr x) in + evdref := sigma; + in_gen wit_red_expr r_interp + | OpenConstrArgType casted -> in_gen (wit_open_constr_gen casted) (interp_open_constr (if casted then Some (pf_concl gl) else None) - ist (pf_env gl) (project gl) - (snd (out_gen (globwit_open_constr_gen casted) x))) - | ConstrWithBindingsArgType -> + ist (pf_env gl) (project gl) + (snd (out_gen (globwit_open_constr_gen casted) x))) + | ConstrWithBindingsArgType -> in_gen wit_constr_with_bindings (pack_sigma (interp_constr_with_bindings ist (pf_env gl) (project gl) - (out_gen globwit_constr_with_bindings x))) - | BindingsArgType -> + (out_gen globwit_constr_with_bindings x))) + | BindingsArgType -> in_gen wit_bindings (pack_sigma (interp_bindings ist (pf_env gl) (project gl) (out_gen globwit_bindings x))) - | List0ArgType ConstrArgType -> interp_genarg_constr_list0 ist gl x - | List1ArgType ConstrArgType -> interp_genarg_constr_list1 ist gl x - | List0ArgType VarArgType -> interp_genarg_var_list0 ist gl x - | List1ArgType VarArgType -> interp_genarg_var_list1 ist gl x - | List0ArgType _ -> app_list0 (interp_genarg ist gl) x - | List1ArgType _ -> app_list1 (interp_genarg ist gl) x - | OptArgType _ -> app_opt (interp_genarg ist gl) x - | PairArgType _ -> app_pair (interp_genarg ist gl) (interp_genarg ist gl) x - | ExtraArgType s -> + | List0ArgType ConstrArgType -> + let (sigma,v) = interp_genarg_constr_list0 ist gl x in + evdref := sigma; + v + | List1ArgType ConstrArgType -> + let (sigma,v) = interp_genarg_constr_list1 ist gl x in + evdref := sigma; + v + | List0ArgType VarArgType -> interp_genarg_var_list0 ist gl x + | List1ArgType VarArgType -> interp_genarg_var_list1 ist gl x + | List0ArgType _ -> app_list0 (interp_genarg ist gl) x + | List1ArgType _ -> app_list1 (interp_genarg ist gl) x + | OptArgType _ -> app_opt (interp_genarg ist gl) x + | PairArgType _ -> app_pair (interp_genarg ist gl) (interp_genarg ist gl) x + | ExtraArgType s -> match tactic_genarg_level s with | Some n -> (* Special treatment of tactic arguments *) - in_gen (wit_tactic n) - (TacArg(dloc,valueIn(VFun(ist.trace,ist.lfun,[], - out_gen (globwit_tactic n) x)))) + in_gen (wit_tactic n) + (TacArg(dloc,valueIn(VFun(ist.trace,ist.lfun,[], + out_gen (globwit_tactic n) x)))) | None -> - lookup_interp_genarg s ist gl x + let (sigma,v) = lookup_interp_genarg s ist gl x in + evdref:=sigma; + v + in + let v = interp_genarg ist gl x in + !evdref , v and interp_genarg_constr_list0 ist gl x = let lc = out_gen (wit_list0 globwit_constr) x in - let lc = pf_apply (interp_constr_list ist) gl lc in - in_gen (wit_list0 wit_constr) lc + let (sigma,lc) = pf_apply (interp_constr_list ist) gl lc in + sigma , in_gen (wit_list0 wit_constr) lc and interp_genarg_constr_list1 ist gl x = let lc = out_gen (wit_list1 globwit_constr) x in - let lc = pf_apply (interp_constr_list ist) gl lc in - in_gen (wit_list1 wit_constr) lc + let (sigma,lc) = pf_apply (interp_constr_list ist) gl lc in + sigma , in_gen (wit_list1 wit_constr) lc and interp_genarg_var_list0 ist gl x = let lc = out_gen (wit_list0 globwit_var) x in @@ -2111,10 +2186,10 @@ and interp_match ist g lz constr lmr = with e when is_match_catchable e -> match_next_pattern find_next' () in match_next_pattern (fun () -> match_subterm_gen app c csr) () in - let rec apply_match ist csr = function + let rec apply_match ist sigma csr = let g = { g with sigma=sigma } in function | (All t)::tl -> (try eval_with_fail ist lz g t - with e when is_match_catchable e -> apply_match ist csr tl) + with e when is_match_catchable e -> apply_match ist sigma csr tl) | (Pat ([],Term c,mt))::tl -> (try let lmatch = @@ -2134,31 +2209,31 @@ and interp_match ist g lz constr lmr = raise e with e when is_match_catchable e -> debugging_step ist (fun () -> str "switching to the next rule"); - apply_match ist csr tl) + apply_match ist sigma csr tl) | (Pat ([],Subterm (b,id,c),mt))::tl -> (try apply_match_subterm b ist (id,c) csr mt - with PatternMatchingFailure -> apply_match ist csr tl) + with PatternMatchingFailure -> apply_match ist sigma csr tl) | _ -> errorlabstrm "Tacinterp.apply_match" (str "No matching clauses for match.") in - let csr = + let (sigma,csr) = try interp_ltac_constr ist g constr with e -> debugging_exception_step ist true e (fun () -> str "evaluation of the matched expression"); raise e in - let ilr = read_match_rule (fst (extract_ltac_constr_values ist (pf_env g))) ist (pf_env g) (project g) lmr in + let ilr = read_match_rule (fst (extract_ltac_constr_values ist (pf_env g))) ist (pf_env g) sigma lmr in let res = - try apply_match ist csr ilr with e -> + try apply_match ist sigma csr ilr with e -> debugging_exception_step ist true e (fun () -> str "match expression"); raise e in debugging_step ist (fun () -> - str "match expression returns " ++ pr_value (Some (pf_env g)) res); + str "match expression returns " ++ pr_value (Some (pf_env g)) (snd res)); res (* Interprets tactic expressions : returns a "constr" *) and interp_ltac_constr ist gl e = - let result = + let (sigma, result) = try val_interp ist gl e with Not_found -> debugging_step ist (fun () -> str "evaluation failed for" ++ fnl() ++ @@ -2171,7 +2246,7 @@ and interp_ltac_constr ist gl e = str " has value " ++ fnl() ++ pr_constr_under_binders_env (pf_env gl) cresult); if fst cresult <> [] then raise Not_found; - snd cresult + sigma , snd cresult with Not_found -> errorlabstrm "" (str "Must evaluate to a closed term" ++ fnl() ++ @@ -2204,7 +2279,8 @@ and interp_ltac_constr ist gl e = (* Interprets tactic expressions : returns a "tactic" *) and interp_tactic ist tac gl = - tactic_of_value ist (val_interp ist gl tac) gl + let (sigma,v) = val_interp ist gl tac in + tactic_of_value ist v { gl with sigma=sigma } (* Interprets a primitive tactic *) and interp_atomic ist gl tac = @@ -2219,9 +2295,21 @@ and interp_atomic ist gl tac = h_intro_move (Option.map (interp_fresh_ident ist env) ido) (interp_move_location ist gl hto) | TacAssumption -> h_assumption - | TacExact c -> h_exact (pf_interp_casted_constr ist gl c) - | TacExactNoCheck c -> h_exact_no_check (pf_interp_constr ist gl c) - | TacVmCastNoCheck c -> h_vm_cast_no_check (pf_interp_constr ist gl c) + | TacExact c -> + let (sigma,c_interp) = pf_interp_casted_constr ist gl c in + tclTHEN + (tclEVARS sigma) + (h_exact c_interp) + | TacExactNoCheck c -> + let (sigma,c_interp) = pf_interp_constr ist gl c in + tclTHEN + (tclEVARS sigma) + (h_exact_no_check c_interp) + | TacVmCastNoCheck c -> + let (sigma,c_interp) = pf_interp_constr ist gl c in + tclTHEN + (tclEVARS sigma) + (h_vm_cast_no_check c_interp) | TacApply (a,ev,cb,cl) -> let sigma, l = list_fold_map (interp_open_constr_with_bindings_loc ist env) sigma cb @@ -2235,56 +2323,89 @@ and interp_atomic ist gl tac = 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 tclWITHHOLES ev (h_elim ev cb) sigma cbo - | TacElimType c -> h_elim_type (pf_interp_type ist gl c) + | TacElimType c -> + let (sigma,c_interp) = pf_interp_type ist gl c in + tclTHEN + (tclEVARS sigma) + (h_elim_type c_interp) | TacCase (ev,cb) -> let sigma, cb = interp_constr_with_bindings ist env sigma cb in tclWITHHOLES ev (h_case ev) sigma cb - | TacCaseType c -> h_case_type (pf_interp_type ist gl c) + | TacCaseType c -> + let (sigma,c_interp) = pf_interp_type ist gl c in + tclTHEN + (tclEVARS sigma) + (h_case_type c_interp) | TacFix (idopt,n) -> h_fix (Option.map (interp_fresh_ident ist env) idopt) n | TacMutualFix (b,id,n,l) -> - let f (id,n,c) = (interp_fresh_ident ist env id,n,pf_interp_type ist gl c) - in h_mutual_fix b (interp_fresh_ident ist env id) n (List.map f l) + 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 id,n,c_interp) in + let (sigma,l_interp) = + List.fold_right begin fun c (sigma,acc) -> + let (sigma,c_interp) = f sigma c in + sigma , c_interp::acc + end l (project gl,[]) + in + tclTHEN + (tclEVARS sigma) + (h_mutual_fix b (interp_fresh_ident ist env id) n l_interp) | TacCofix idopt -> h_cofix (Option.map (interp_fresh_ident ist env) idopt) | TacMutualCofix (b,id,l) -> - let f (id,c) = (interp_fresh_ident ist env id,pf_interp_type ist gl c) in - h_mutual_cofix b (interp_fresh_ident ist env id) (List.map f l) - | TacCut c -> h_cut (pf_interp_type ist gl c) + 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 id,c_interp) in + let (sigma,l_interp) = + List.fold_right begin fun c (sigma,acc) -> + let (sigma,c_interp) = f sigma c in + sigma , c_interp::acc + end l (project gl,[]) + in + tclTHEN + (tclEVARS sigma) + (h_mutual_cofix b (interp_fresh_ident ist env id) l_interp) + | TacCut c -> + let (sigma,c_interp) = pf_interp_type ist gl c in + tclTHEN + (tclEVARS sigma) + (h_cut c_interp) | TacAssert (t,ipat,c) -> - let c = (if t=None then interp_constr else interp_type) ist env sigma c in - abstract_tactic (TacAssert (t,ipat,c)) - (Tactics.forward (Option.map (interp_tactic ist) t) - (Option.map (interp_intro_pattern ist gl) ipat) c) + let (sigma,c) = (if t=None then interp_constr else interp_type) ist env sigma c in + tclTHEN + (tclEVARS sigma) + (abstract_tactic (TacAssert (t,ipat,c)) + (Tactics.forward (Option.map (interp_tactic ist) t) + (Option.map (interp_intro_pattern ist gl) ipat) c)) | TacGeneralize cl -> let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in tclWITHHOLES false (h_generalize_gen) sigma cl - | TacGeneralizeDep c -> h_generalize_dep (pf_interp_constr ist gl c) + | TacGeneralizeDep c -> + let (sigma,c_interp) = pf_interp_constr ist gl c in + tclTHEN + (tclEVARS sigma) + (h_generalize_dep c_interp) | TacLetTac (na,c,clp,b) -> let clp = interp_clause ist gl clp in if clp = nowhere then (* We try to fully-typechect the term *) - h_let_tac b (interp_fresh_name ist env na) - (pf_interp_constr ist gl c) clp + let (sigma,c_interp) = pf_interp_constr ist gl c in + tclTHEN + (tclEVARS sigma) + (h_let_tac b (interp_fresh_name ist env na) c_interp clp) else (* We try to keep the pattern structure as much as possible *) h_let_pat_tac b (interp_fresh_name ist env na) (interp_pure_open_constr ist env sigma c) clp (* Automation tactics *) - | TacTrivial (lems,l) -> - Auto.h_trivial + | TacTrivial (debug,lems,l) -> + Auto.h_trivial ~debug (interp_auto_lemmas ist env sigma lems) (Option.map (List.map (interp_hint_base ist)) l) - | TacAuto (n,lems,l) -> - Auto.h_auto (Option.map (interp_int_or_var ist) n) + | TacAuto (debug,n,lems,l) -> + Auto.h_auto ~debug (Option.map (interp_int_or_var ist) n) (interp_auto_lemmas ist env sigma lems) (Option.map (List.map (interp_hint_base ist)) l) - | TacAutoTDB n -> Dhyp.h_auto_tdb n - | TacDestructHyp (b,id) -> Dhyp.h_destructHyp b (interp_hyp ist gl id) - | TacDestructConcl -> Dhyp.h_destructConcl - | TacSuperAuto (n,l,b1,b2) -> Auto.h_superauto n l b1 b2 - | TacDAuto (n,p,lems) -> - Auto.h_dauto (Option.map (interp_int_or_var ist) n,p) - (interp_auto_lemmas ist env sigma lems) (* Derived basic tactics *) | TacSimpleInductionDestruct (isrec,h) -> @@ -2304,15 +2425,30 @@ and interp_atomic ist gl tac = let h1 = interp_quantified_hypothesis ist h1 in let h2 = interp_quantified_hypothesis ist h2 in Elim.h_double_induction h1 h2 - | TacDecomposeAnd c -> Elim.h_decompose_and (pf_interp_constr ist gl c) - | TacDecomposeOr c -> Elim.h_decompose_or (pf_interp_constr ist gl c) + | TacDecomposeAnd c -> + let (sigma,c_interp) = pf_interp_constr ist gl c in + tclTHEN + (tclEVARS sigma) + (Elim.h_decompose_and c_interp) + | TacDecomposeOr c -> + let (sigma,c_interp) = pf_interp_constr ist gl c in + tclTHEN + (tclEVARS sigma) + (Elim.h_decompose_or c_interp) | TacDecompose (l,c) -> let l = List.map (interp_inductive ist) l in - Elim.h_decompose l (pf_interp_constr ist gl c) + let (sigma,c_interp) = pf_interp_constr ist gl c in + tclTHEN + (tclEVARS sigma) + (Elim.h_decompose l c_interp) | TacSpecialize (n,cb) -> let sigma, cb = interp_constr_with_bindings ist env sigma cb in tclWITHHOLES false (h_specialize n) sigma cb - | TacLApply c -> h_lapply (pf_interp_constr ist gl c) + | TacLApply c -> + let (sigma,c_interp) = pf_interp_constr ist gl c in + tclTHEN + (tclEVARS sigma) + (h_lapply c_interp) (* Context management *) | TacClear (b,l) -> h_clear b (interp_hyp_list ist gl l) @@ -2344,27 +2480,48 @@ and interp_atomic ist gl tac = (* Conversion *) | TacReduce (r,cl) -> - h_reduce (pf_interp_red_expr ist gl r) (interp_clause ist gl cl) + let (sigma,r_interp) = pf_interp_red_expr ist gl r in + tclTHEN + (tclEVARS sigma) + (h_reduce r_interp (interp_clause ist gl cl)) | TacChange (None,c,cl) -> - h_change None - (if (cl.onhyps = None or cl.onhyps = Some []) & + let (sigma,c_interp) = + if (cl.onhyps = None or cl.onhyps = Some []) & (cl.concl_occs = all_occurrences_expr or cl.concl_occs = no_occurrences_expr) then pf_interp_type ist gl c - else pf_interp_constr ist gl c) - (interp_clause ist gl cl) + else pf_interp_constr ist gl c + in + tclTHEN + (tclEVARS sigma) + (h_change None c_interp (interp_clause ist gl cl)) | TacChange (Some op,c,cl) -> let sign,op = interp_typed_pattern ist env sigma op in - h_change (Some op) - (try pf_interp_constr ist (extend_gl_hyps gl sign) c - with Not_found | Anomaly _ (* Hack *) -> - errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.")) - (interp_clause ist gl cl) + (* spiwack: (2012/04/18) the evar_map output by pf_interp_constr + is dropped as the evar_map taken as input (from + extend_gl_hyps) is incorrect. This means that evar + instantiated by pf_interp_constr may be lost, there. *) + let (_,c_interp) = + try pf_interp_constr ist (extend_gl_hyps gl sign) c + with Not_found | Anomaly _ (* Hack *) -> + errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") + in + tclTHEN + (tclEVARS sigma) + (h_change (Some op) c_interp (interp_clause ist { gl with sigma=sigma } cl)) (* Equivalence relations *) | TacReflexivity -> h_reflexivity | TacSymmetry c -> h_symmetry (interp_clause ist gl c) - | TacTransitivity c -> h_transitivity (Option.map (pf_interp_constr ist gl) c) + | TacTransitivity c -> + begin match c with + | None -> h_transitivity None + | Some c -> + let (sigma,c_interp) = pf_interp_constr ist gl c in + tclTHEN + (tclEVARS sigma) + (h_transitivity (Some c_interp)) + end (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> @@ -2375,7 +2532,14 @@ and interp_atomic ist gl tac = Equality.general_multi_multi_rewrite ev l cl (Option.map (fun by -> tclCOMPLETE (interp_tactic ist by), Equality.Naive) by) | TacInversion (DepInversion (k,c,ids),hyp) -> - Inv.dinv k (Option.map (pf_interp_constr ist gl) c) + let (sigma,c_interp) = + match c with + | None -> sigma , None + | Some c -> + let (sigma,c_interp) = pf_interp_constr ist gl c in + sigma , Some c_interp + in + Inv.dinv k c_interp (Option.map (interp_intro_pattern ist gl) ids) (interp_declared_or_quantified_hypothesis ist gl hyp) | TacInversion (NonDepInversion (k,idl,ids),hyp) -> @@ -2384,16 +2548,23 @@ and interp_atomic ist gl tac = (interp_hyp_list ist gl idl) (interp_declared_or_quantified_hypothesis ist gl hyp) | TacInversion (InversionUsing (c,idl),hyp) -> + let (sigma,c_interp) = pf_interp_constr ist gl c in Leminv.lemInv_clause (interp_declared_or_quantified_hypothesis ist gl hyp) - (pf_interp_constr ist gl c) + c_interp (interp_hyp_list ist gl idl) (* For extensions *) | TacExtend (loc,opn,l) -> let tac = lookup_tactic opn in - let args = List.map (interp_genarg ist gl) l in + let (sigma,args) = + List.fold_right begin fun a (sigma,acc) -> + let (sigma,a_interp) = interp_genarg ist { gl with sigma=sigma } a in + sigma , a_interp::acc + end l (project gl,[]) + in abstract_extended_tactic opn args (tac args) | TacAlias (loc,s,l,(_,body)) -> fun gl -> + let evdref = ref gl.sigma in let rec f x = match genarg_tag x with | IntArgType -> VInteger (out_gen globwit_int x) @@ -2415,17 +2586,34 @@ and interp_atomic ist gl tac = | SortArgType -> VConstr ([],mkSort (interp_sort (out_gen globwit_sort x))) | ConstrArgType -> - mk_constr_value ist gl (out_gen globwit_constr x) + let (sigma,v) = mk_constr_value ist gl (out_gen globwit_constr x) in + evdref := sigma; + v + | OpenConstrArgType false -> + let (sigma,v) = mk_open_constr_value ist gl (snd (out_gen globwit_open_constr x)) in + evdref := sigma; + v | ConstrMayEvalArgType -> - VConstr - ([],interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x)) + let (sigma,c_interp) = interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x) in + evdref := sigma; + VConstr ([],c_interp) | ExtraArgType s when tactic_genarg_level s <> None -> (* Special treatment of tactic arguments *) - val_interp ist gl + let (sigma,v) = val_interp ist gl (out_gen (globwit_tactic (Option.get (tactic_genarg_level s))) x) + in + evdref := sigma; + v | List0ArgType ConstrArgType -> let wit = wit_list0 globwit_constr in - VList (List.map (mk_constr_value ist gl) (out_gen wit x)) + let (sigma,l_interp) = + List.fold_right begin fun c (sigma,acc) -> + let (sigma,c_interp) = mk_constr_value ist { gl with sigma=sigma } c in + sigma , c_interp::acc + end (out_gen wit x) (project gl,[]) + in + evdref := sigma; + VList (l_interp) | List0ArgType VarArgType -> let wit = wit_list0 globwit_var in VList (List.map (mk_hyp_value ist gl) (out_gen wit x)) @@ -2445,7 +2633,14 @@ and interp_atomic ist gl tac = VList (List.map mk_ipat (out_gen wit x)) | List1ArgType ConstrArgType -> let wit = wit_list1 globwit_constr in - VList (List.map (mk_constr_value ist gl) (out_gen wit x)) + let (sigma, l_interp) = + List.fold_right begin fun c (sigma,acc) -> + let (sigma,c_interp) = mk_constr_value ist { gl with sigma=sigma } c in + sigma , c_interp::acc + end (out_gen wit x) (project gl,[]) + in + evdref:=sigma; + VList l_interp | List1ArgType VarArgType -> let wit = wit_list1 globwit_var in VList (List.map (mk_hyp_value ist gl) (out_gen wit x)) @@ -2469,17 +2664,22 @@ and interp_atomic ist gl tac = | ExtraArgType _ | BindingsArgType | OptArgType _ | PairArgType _ | List0ArgType _ | List1ArgType _ - -> error "This generic type is not supported in alias." + -> error "This argument type is not supported in tactic notations." in let lfun = (List.map (fun (x,c) -> (x,f c)) l)@ist.lfun in let trace = push_trace (loc,LtacNotationCall s) ist.trace in + let gl = { gl with sigma = !evdref } in interp_tactic { ist with lfun=lfun; trace=trace } body gl let make_empty_glob_sign () = { ltacvars = ([],[]); ltacrecvars = []; gsigma = Evd.empty; genv = Global.env() } +let fully_empty_glob_sign = + { ltacvars = ([],[]); ltacrecvars = []; + gsigma = Evd.empty; genv = Environ.empty_env } + (* Initial call for interpretation *) let interp_tac_gen lfun avoid_ids debug t gl = interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; trace=[] } @@ -2488,6 +2688,7 @@ let interp_tac_gen lfun avoid_ids debug t gl = gsigma = project gl; genv = pf_env gl } t) gl let eval_tactic t gls = + db_initialize (); interp_tactic { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] } t gls @@ -2641,13 +2842,8 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacLetTac (id,c,clp,b) -> TacLetTac (id,subst_glob_constr subst c,clp,b) (* Automation tactics *) - | TacTrivial (lems,l) -> TacTrivial (List.map (subst_glob_constr subst) lems,l) - | TacAuto (n,lems,l) -> TacAuto (n,List.map (subst_glob_constr subst) lems,l) - | TacAutoTDB n -> TacAutoTDB n - | TacDestructHyp (b,id) -> TacDestructHyp(b,id) - | TacDestructConcl -> TacDestructConcl - | TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2) - | TacDAuto (n,p,lems) -> TacDAuto (n,p,List.map (subst_glob_constr subst) lems) + | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (subst_glob_constr subst) lems,l) + | TacAuto (d,n,lems,l) -> TacAuto (d,n,List.map (subst_glob_constr subst) lems,l) (* Derived basic tactics *) | TacSimpleInductionDestruct (isrec,h) as x -> x @@ -2991,4 +3187,3 @@ let _ = Auto.set_extern_intern_tac Flags.with_option strict_check (intern_pure_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])})) let _ = Auto.set_extern_subst_tactic subst_tactic -let _ = Dhyp.set_extern_interp eval_tactic diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index d9dc8094..b9fd64f6 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -77,16 +77,18 @@ type glob_sign = { gsigma : Evd.evar_map; genv : Environ.env } +val fully_empty_glob_sign : glob_sign + val add_interp_genarg : string -> (glob_sign -> raw_generic_argument -> glob_generic_argument) * (interp_sign -> goal sigma -> glob_generic_argument -> - typed_generic_argument) * + Evd.evar_map * typed_generic_argument) * (substitution -> glob_generic_argument -> glob_generic_argument) -> unit val interp_genarg : - interp_sign -> goal sigma -> glob_generic_argument -> typed_generic_argument + interp_sign -> goal sigma -> glob_generic_argument -> Evd.evar_map * typed_generic_argument val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument @@ -114,14 +116,14 @@ val subst_glob_with_bindings : substitution -> glob_constr_and_expr Glob_term.with_bindings -> glob_constr_and_expr Glob_term.with_bindings (** Interprets any expression *) -val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value +val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> Evd.evar_map * value (** Interprets an expression that evaluates to a constr *) val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr -> - constr + Evd.evar_map * constr (** Interprets redexp arguments *) -val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> red_expr +val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr (** Interprets tactic expressions *) val interp_tac_gen : (identifier * value) list -> identifier list -> @@ -143,7 +145,7 @@ val eval_tactic : glob_tactic_expr -> tactic val interp : raw_tactic_expr -> tactic -val eval_ltac_constr : goal sigma -> raw_tactic_expr -> constr +val eval_ltac_constr : goal sigma -> raw_tactic_expr -> Evd.evar_map * constr val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 11625cbd..b82f1fca 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -53,7 +53,6 @@ let tclREPEAT_MAIN = Refiner.tclREPEAT_MAIN let tclFIRST = Refiner.tclFIRST let tclSOLVE = Refiner.tclSOLVE let tclTRY = Refiner.tclTRY -let tclINFO = Refiner.tclINFO let tclCOMPLETE = Refiner.tclCOMPLETE let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE let tclFAIL = Refiner.tclFAIL diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index db9ab0c9..c70c13f7 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -45,7 +45,6 @@ val tclREPEAT_MAIN : tactic -> tactic val tclFIRST : tactic list -> tactic val tclSOLVE : tactic list -> tactic val tclTRY : tactic -> tactic -val tclINFO : tactic -> tactic val tclCOMPLETE : tactic -> tactic val tclAT_LEAST_ONCE : tactic -> tactic val tclFAIL : int -> std_ppcmds -> tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 988d9f53..9a2682fd 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -546,7 +546,7 @@ let depth_of_quantified_hypothesis red h gl = str".") let intros_until_gen red h g = - tclDO (depth_of_quantified_hypothesis red h g) intro g + tclDO (depth_of_quantified_hypothesis red h g) (if red then introf else intro) g let intros_until_id id = intros_until_gen true (NamedHyp id) let intros_until_n_gen red n = intros_until_gen red (AnonHyp n) @@ -2498,11 +2498,17 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id gl = tclMAP (fun id -> tclTRY (generalize_dep ~with_let:true (mkVar id))) vars] gl) gl +let rec compare_upto_variables x y = + if (isVar x || isRel x) && (isVar y || isRel y) then true + else compare_constr compare_upto_variables x y + let specialize_eqs id gl = let env = pf_env gl in let ty = pf_get_hyp_typ gl id in let evars = ref (project gl) in - let unif env evars c1 c2 = Evarconv.e_conv env evars c2 c1 in + let unif env evars c1 c2 = + compare_upto_variables c1 c2 && Evarconv.e_conv env evars c1 c2 + in let rec aux in_eqs ctx acc ty = match kind_of_term ty with | Prod (na, t, b) -> diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 333d6a3a..f1324809 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -10,7 +10,6 @@ Elimschemes Tactics Hiddentac Elim -Dhyp Auto Equality Contradiction diff --git a/test-suite/bugs/closed/shouldsucceed/2603.v b/test-suite/bugs/closed/shouldsucceed/2603.v index a556b9bf..371bfdc5 100644 --- a/test-suite/bugs/closed/shouldsucceed/2603.v +++ b/test-suite/bugs/closed/shouldsucceed/2603.v @@ -1,3 +1,18 @@ +(** Namespace of module vs. namescope of definitions/constructors/... + +As noticed by A. Appel in bug #2603, module names and definition +names used to be in the same namespace. But conflict with names +of constructors (or 2nd mutual inductive...) used to not be checked +enough, leading to stange situations. + +- In 8.3pl3 we introduced checks that forbid uniformly the following + situations. + +- For 8.4 we finally managed to make module names and other names + live in two separate namespace, hence allowing all of the following + situations. +*) + Module Type T. End T. @@ -9,10 +24,10 @@ End L. Module M1 : L with Module E:=K. Module E := K. -Fail Inductive t := E. (* Used to be accepted, but End M1 below was failing *) +Inductive t := E. (* Used to be accepted, but End M1 below was failing *) End M1. Module M2 : L with Module E:=K. Inductive t := E. -Fail Module E := K. (* Used to be accepted *) -Fail End M2. (* Used to be accepted *) +Module E := K. (* Used to be accepted *) +End M2. (* Used to be accepted *) diff --git a/test-suite/bugs/closed/shouldsucceed/2732.v b/test-suite/bugs/closed/shouldsucceed/2732.v new file mode 100644 index 00000000..f22a8ccc --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2732.v @@ -0,0 +1,19 @@ +(* Check correct behavior of add_primitive_tactic in TACEXTEND *) + +(* Added also the case of eauto and congruence *) + +Ltac thus H := solve [H]. + +Lemma test: forall n : nat, n <= n. +Proof. + intro. + thus firstorder. + Undo. + thus eauto. +Qed. + +Lemma test2: false = true -> False. +Proof. + intro. + thus congruence. +Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2733.v b/test-suite/bugs/closed/shouldsucceed/2733.v new file mode 100644 index 00000000..fd7bd3bd --- /dev/null +++ b/test-suite/bugs/closed/shouldsucceed/2733.v @@ -0,0 +1,26 @@ +Definition goodid : forall {A} (x: A), A := fun A x => x. +Definition wrongid : forall A (x: A), A := fun {A} x => x. + +Inductive ty := N | B. + +Inductive alt_list : ty -> ty -> Type := + | nil {k} : alt_list k k + | Ncons {k} : nat -> alt_list B k -> alt_list N k + | Bcons {k} : bool -> alt_list N k -> alt_list B k. + +Definition trullynul k {k'} (l : alt_list k k') := +match k,l with + |N,l' => Ncons 0 (Bcons true l') + |B,l' => Bcons true (Ncons 0 l') +end. + +Fixpoint app (P : forall {k k'}, alt_list k k' -> alt_list k k') {t1 t2} (l : alt_list t1 t2) {struct l}: forall {t3}, alt_list t2 t3 -> +alt_list t1 t3 := + match l with + | nil _ => fun _ l2 => P l2 + | Ncons _ n l1 => fun _ l2 => Ncons n (app (@P) l1 l2) + | Bcons _ b l1 => fun _ l2 => Bcons b (app (@P) l1 l2) + end. + +Check (fun {t t'} (l: alt_list t t') => + app trullynul (goodid l) (wrongid _ nil)). diff --git a/test-suite/complexity/autodecomp.v b/test-suite/complexity/autodecomp.v deleted file mode 100644 index 85589ff7..00000000 --- a/test-suite/complexity/autodecomp.v +++ /dev/null @@ -1,11 +0,0 @@ -(* This example used to be in (at least) exponential time in the number of - conjunctive types in the hypotheses before revision 11713 *) -(* Expected time < 1.50s *) - -Goal -True/\True-> -True/\True-> -True/\True-> -False/\False. - -Timeout 5 Time auto decomp. diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index 139f9e99..7c9b1e27 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -91,3 +91,11 @@ The simpl tactic unfolds f when the 5th, 6th and 7th arguments evaluate to a constructor f is transparent 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 "$". +w 3 true = tt + : Prop +The command has indeed failed with message: +=> Error: Extra argument _. diff --git a/test-suite/output/Arguments.v b/test-suite/output/Arguments.v index 3a94f19a..573cfdab 100644 --- a/test-suite/output/Arguments.v +++ b/test-suite/output/Arguments.v @@ -38,3 +38,15 @@ End S1. About f. Arguments f : clear implicits and scopes. About f. +Record r := { pi :> nat -> bool -> unit }. +Notation "$" := 3 (only parsing) : foo_scope. +Notation "$" := true (only parsing) : bar_scope. +Delimit Scope bar_scope with B. +Arguments pi _ _%F _%B. +Check (forall w : r, pi w $ $ = tt). +Fail Check (forall w : r, w $ $ = tt). +Axiom w : r. +Arguments w _%F _%B : extra scopes. +Check (w $ $ = tt). +Fail Arguments w _%F _%B. + diff --git a/test-suite/output/Notations2.out b/test-suite/output/Notations2.out index 47741e43..cf45025e 100644 --- a/test-suite/output/Notations2.out +++ b/test-suite/output/Notations2.out @@ -10,6 +10,8 @@ end : nat let '(a, _, _) := (2, 3, 4) in a : nat +exists myx (y : bool), myx = y + : Prop fun (P : nat -> nat -> Prop) (x : nat) => exists x0, P x x0 : (nat -> nat -> Prop) -> nat -> Prop ∃ n p : nat, n + p = 0 @@ -46,3 +48,7 @@ match n with | plus2 _ :: _ => 2 end : list(nat) -> nat +# x : nat => x + : nat -> nat +# _ : nat => 2 + : nat -> nat diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v index e902a3c2..e53c94ef 100644 --- a/test-suite/output/Notations2.v +++ b/test-suite/output/Notations2.v @@ -25,6 +25,11 @@ Remove Printing Let prod. Check match (0,0,0) with (x,y,z) => x+y+z end. Check let '(a,b,c) := ((2,3),4) in a. +(* Check printing of notations with mixed reserved binders (see bug #2571) *) + +Implicit Type myx : bool. +Check exists myx y, myx = y. + (* Test notation for anonymous functions up to eta-expansion *) Check fun P:nat->nat->Prop => fun x:nat => ex (P x). @@ -83,3 +88,13 @@ Notation "'mylet' f [ x ; .. ; y ] := t 'in' u":= Check mylet f [x;y;z;(a:bool)] := x+y+z+1 in f 0 1 2. *) + +(* Check notations for functional terms which do not necessarily + depend on their parameter *) +(* Old request mentioned again on coq-club 20/1/2012 *) + +Notation "# x : T => t" := (fun x : T => t) + (at level 0, t at level 200, x ident). + +Check # x : nat => x. +Check # _ : nat => 2. diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index 40c786ab..598bb728 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -37,10 +37,11 @@ When applied to no arguments: When applied to 1 argument: Argument A is implicit plus = -fix plus (n m : nat) : nat := match n with - | 0 => m - | S p => S (plus p m) - end +fix plus (n m : nat) {struct n} : nat := + match n with + | 0 => m + | S p => S (plus p m) + end : nat -> nat -> nat Argument scopes are [nat_scope nat_scope] diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v index 745529bf..f445ca8e 100644 --- a/test-suite/success/Cases.v +++ b/test-suite/success/Cases.v @@ -100,7 +100,7 @@ Type (fun x : nat => match x return nat with | x => x end). -Section testlist. +Module Type testlist. Parameter A : Set. Inductive list : Set := | nil : list @@ -119,7 +119,6 @@ Definition titi (a : A) (l : list) := | nil => l | cons b l => l end. -Reset list. End testlist. @@ -913,71 +912,77 @@ Type | LeS n m _ => (S n, S m) end). - +Module Type F_v1. Fixpoint F (n m : nat) (h : Le n m) {struct h} : Le n (S m) := match h in (Le n m) return (Le n (S m)) with | LeO m' => LeO (S m') | LeS n' m' h' => LeS n' (S m') (F n' m' h') end. +End F_v1. -Reset F. - +Module Type F_v2. Fixpoint F (n m : nat) (h : Le n m) {struct h} : Le n (S m) := match h in (Le n m) return (Le n (S m)) with | LeS n m h => LeS n (S m) (F n m h) | LeO m => LeO (S m) end. +End F_v2. (* Rend la longueur de la liste *) -Definition length1 (n : nat) (l : listn n) := + +Module Type L1. +Definition length (n : nat) (l : listn n) := match l return nat with | consn n _ (consn m _ _) => S (S m) | consn n _ _ => 1 | _ => 0 end. +End L1. -Reset length1. -Definition length1 (n : nat) (l : listn n) := +Module Type L1'. +Definition length (n : nat) (l : listn n) := match l with | consn n _ (consn m _ _) => S (S m) | consn n _ _ => 1 | _ => 0 end. +End L1'. - -Definition length2 (n : nat) (l : listn n) := +Module Type L2. +Definition length (n : nat) (l : listn n) := match l return nat with | consn n _ (consn m _ _) => S (S m) | consn n _ _ => S n | _ => 0 end. +End L2. -Reset length2. - -Definition length2 (n : nat) (l : listn n) := +Module Type L2'. +Definition length (n : nat) (l : listn n) := match l with | consn n _ (consn m _ _) => S (S m) | consn n _ _ => S n | _ => 0 end. +End L2'. -Definition length3 (n : nat) (l : listn n) := +Module Type L3. +Definition length (n : nat) (l : listn n) := match l return nat with | consn n _ (consn m _ l) => S n | consn n _ _ => 1 | _ => 0 end. +End L3. - -Reset length3. - -Definition length3 (n : nat) (l : listn n) := +Module Type L3'. +Definition length (n : nat) (l : listn n) := match l with | consn n _ (consn m _ l) => S n | consn n _ _ => 1 | _ => 0 end. - +End L3'. Type match LeO 0 return nat with | LeS n m h => n + m @@ -1256,7 +1261,7 @@ Type match (0, 0) with | (x, y) => (S x, S y) end. - +Module Type test_concat. Parameter concat : forall A : Set, List A -> List A -> List A. @@ -1273,6 +1278,7 @@ Type | _, _ => Nil nat end. +End test_concat. Inductive redexes : Set := | VAR : nat -> redexes @@ -1295,7 +1301,6 @@ Type (fun n : nat => match n with | _ => 0 end). -Reset concat. Parameter concat : forall n : nat, listn n -> forall m : nat, listn m -> listn (n + m). @@ -1383,6 +1388,7 @@ Type (* I.e. to test manipulation of elimination predicate *) (* ===================================================================== *) +Module Type test_term. Parameter LTERM : nat -> Set. Inductive TERM : Type := @@ -1397,7 +1403,8 @@ Type | oper op1 l1, oper op2 l2 => False | _, _ => False end. -Reset LTERM. + +End test_term. @@ -1493,6 +1500,7 @@ Type end. +Module Type ff. Parameter ff : forall n m : nat, n <> m -> S n <> S m. Parameter discr_r : forall n : nat, 0 <> S n. @@ -1505,6 +1513,7 @@ Type | S x => or_intror (S x = 0) (discr_l x) end). +Module Type eqdec. Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m := match n, m return (n = m \/ n <> m) with @@ -1518,7 +1527,9 @@ Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m := end end. -Reset eqdec. +End eqdec. + +Module Type eqdec'. Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m := match n return (forall m : nat, n = m \/ n <> m) with @@ -1540,6 +1551,7 @@ Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m := end end. +End eqdec'. Inductive empty : forall n : nat, listn n -> Prop := intro_empty : empty 0 niln. @@ -1554,7 +1566,10 @@ Type | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y) end). -Reset ff. +End ff. + +Module Type ff'. + Parameter ff : forall n m : nat, n <> m -> S n <> S m. Parameter discr_r : forall n : nat, 0 <> S n. Parameter discr_l : forall n : nat, S n <> 0. @@ -1566,6 +1581,7 @@ Type | S x => or_intror (S x = 0) (discr_l x) end). +Module Type eqdec. Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m := match n, m return (n = m \/ n <> m) with @@ -1578,7 +1594,10 @@ Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m := | or_intror h => or_intror (S x = S y) (ff x y h) end end. -Reset eqdec. + +End eqdec. + +Module Type eqdec'. Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m := match n return (forall m : nat, n = m \/ n <> m) with @@ -1600,6 +1619,8 @@ Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m := end end. +End eqdec'. +End ff'. (* ================================================== *) (* Pour tester parametres *) diff --git a/test-suite/success/CasesDep.v b/test-suite/success/CasesDep.v index d3b7cf3f..bfead53c 100644 --- a/test-suite/success/CasesDep.v +++ b/test-suite/success/CasesDep.v @@ -222,7 +222,7 @@ Definition Dposint := Build_DSetoid Set_of_posint Eq_posint_deci. de l'arite de chaque operateur *) -Section Sig. +Module Sig. Record Signature : Type := {Sigma : DSetoid; Arity : Map (Set_of Sigma) (Set_of Dposint)}. @@ -277,7 +277,7 @@ Type | _, _ => False end. - +Module Type Version1. Definition equalT (t1 t2 : TERM) : Prop := match t1, t2 with @@ -294,12 +294,15 @@ Definition EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) | _, _ => False end. +End Version1. + -Reset equalT. (* ------------------------------------------------------------------*) (* Initial exemple (without patterns) *) (*-------------------------------------------------------------------*) +Module Version2. + Fixpoint equalT (t1 : TERM) : TERM -> Prop := match t1 return (TERM -> Prop) with | var v1 => @@ -347,11 +350,13 @@ Fixpoint equalT (t1 : TERM) : TERM -> Prop := end end. +End Version2. (* ---------------------------------------------------------------- *) (* Version with simple patterns *) (* ---------------------------------------------------------------- *) -Reset equalT. + +Module Version3. Fixpoint equalT (t1 : TERM) : TERM -> Prop := match t1 with @@ -388,8 +393,9 @@ Fixpoint equalT (t1 : TERM) : TERM -> Prop := end end. +End Version3. -Reset equalT. +Module Version4. Fixpoint equalT (t1 : TERM) : TERM -> Prop := match t1 with @@ -423,10 +429,13 @@ Fixpoint equalT (t1 : TERM) : TERM -> Prop := end end. +End Version4. + (* ---------------------------------------------------------------- *) (* Version with multiple patterns *) (* ---------------------------------------------------------------- *) -Reset equalT. + +Module Version5. Fixpoint equalT (t1 t2 : TERM) {struct t1} : Prop := match t1, t2 with @@ -445,6 +454,7 @@ Fixpoint equalT (t1 t2 : TERM) {struct t1} : Prop := | _, _ => False end. +End Version5. (* ------------------------------------------------------------------ *) diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v index a93f8900..071fb957 100644 --- a/test-suite/success/Hints.v +++ b/test-suite/success/Hints.v @@ -16,11 +16,6 @@ Hint Immediate refl_equal sym_equal: foo. Hint Unfold fst sym_equal. Hint Unfold fst sym_equal: foo. -(* What's this stranged syntax ? *) -Hint Destruct h6 := 4 Conclusion (_ <= _) => fun H => apply H. -Hint Destruct h7 := 4 Discardable Hypothesis (_ <= _) => fun H => apply H. -Hint Destruct h8 := 4 Hypothesis (_ <= _) => fun H => apply H. - (* Checks that local names are accepted *) Section A. Remark Refl : forall (A : Set) (x : A), x = x. diff --git a/test-suite/success/Mod_params.v b/test-suite/success/Mod_params.v index 74228bbb..51516166 100644 --- a/test-suite/success/Mod_params.v +++ b/test-suite/success/Mod_params.v @@ -20,59 +20,31 @@ End Q. #trace Nametab.exists_cci;; *) -Module M. -Reset M. -Module M (X: SIG). -Reset M. -Module M (X Y: SIG). -Reset M. -Module M (X: SIG) (Y: SIG). -Reset M. -Module M (X Y: SIG) (Z1 Z: SIG). -Reset M. -Module M (X: SIG) (Y: SIG). -Reset M. -Module M (X Y: SIG) (Z1 Z: SIG). -Reset M. -Module M : SIG. -Reset M. -Module M (X: SIG) : SIG. -Reset M. -Module M (X Y: SIG) : SIG. -Reset M. -Module M (X: SIG) (Y: SIG) : SIG. -Reset M. -Module M (X Y: SIG) (Z1 Z: SIG) : SIG. -Reset M. -Module M (X: SIG) (Y: SIG) : SIG. -Reset M. -Module M (X Y: SIG) (Z1 Z: SIG) : SIG. -Reset M. -Module M := F Q. -Reset M. -Module M (X: FSIG) := X Q. -Reset M. -Module M (X Y: FSIG) := X Q. -Reset M. -Module M (X: FSIG) (Y: SIG) := X Y. -Reset M. -Module M (X Y: FSIG) (Z1 Z: SIG) := X Z. -Reset M. -Module M (X: FSIG) (Y: SIG) := X Y. -Reset M. -Module M (X Y: FSIG) (Z1 Z: SIG) := X Z. -Reset M. -Module M : SIG := F Q. -Reset M. -Module M (X: FSIG) : SIG := X Q. -Reset M. -Module M (X Y: FSIG) : SIG := X Q. -Reset M. -Module M (X: FSIG) (Y: SIG) : SIG := X Y. -Reset M. -Module M (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z. -Reset M. -Module M (X: FSIG) (Y: SIG) : SIG := X Y. -Reset M. -Module M (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z. -Reset M. +Module M01. End M01. +Module M02 (X: SIG). End M02. +Module M03 (X Y: SIG). End M03. +Module M04 (X: SIG) (Y: SIG). End M04. +Module M05 (X Y: SIG) (Z1 Z: SIG). End M05. +Module M06 (X: SIG) (Y: SIG). End M06. +Module M07 (X Y: SIG) (Z1 Z: SIG). End M07. +Module M08 : SIG. End M08. +Module M09 (X: SIG) : SIG. End M09. +Module M10 (X Y: SIG) : SIG. End M10. +Module M11 (X: SIG) (Y: SIG) : SIG. End M11. +Module M12 (X Y: SIG) (Z1 Z: SIG) : SIG. End M12. +Module M13 (X: SIG) (Y: SIG) : SIG. End M13. +Module M14 (X Y: SIG) (Z1 Z: SIG) : SIG. End M14. +Module M15 := F Q. +Module M16 (X: FSIG) := X Q. +Module M17 (X Y: FSIG) := X Q. +Module M18 (X: FSIG) (Y: SIG) := X Y. +Module M19 (X Y: FSIG) (Z1 Z: SIG) := X Z. +Module M20 (X: FSIG) (Y: SIG) := X Y. +Module M21 (X Y: FSIG) (Z1 Z: SIG) := X Z. +Module M22 : SIG := F Q. +Module M23 (X: FSIG) : SIG := X Q. +Module M24 (X Y: FSIG) : SIG := X Q. +Module M25 (X: FSIG) (Y: SIG) : SIG := X Y. +Module M26 (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z. +Module M27 (X: FSIG) (Y: SIG) : SIG := X Y. +Module M28 (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z. diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v index f5f5a9d1..89f11059 100644 --- a/test-suite/success/Notations.v +++ b/test-suite/success/Notations.v @@ -17,10 +17,12 @@ Check (nat |= nat --> nat). (* Check that first non empty definition at an empty level can be of any associativity *) -Definition marker := O. +Module Type v1. Notation "x +1" := (S x) (at level 8, left associativity). -Reset marker. +End v1. +Module Type v2. Notation "x +1" := (S x) (at level 8, right associativity). +End v2. (* Check that empty levels (here 8 and 2 in pattern) are added in the right order *) @@ -86,3 +88,11 @@ Notation "'FOO' x" := (S x) (at level 40). Goal (2 ++++ 3) = 5. reflexivity. Abort. + +(* Check correct failure handling when a non-constructor notation is + used in cases pattern (bug #2724 in 8.3 and 8.4beta) *) + +Notation "'FORALL' x .. y , P" := (forall x, .. (forall y, P) ..) + (at level 200, x binder, y binder, right associativity) : type_scope. + +Fail Check fun x => match x with S (FORALL x, _) => 0 end. diff --git a/test-suite/success/RecTutorial.v b/test-suite/success/RecTutorial.v index 2602c7e3..64048fe2 100644 --- a/test-suite/success/RecTutorial.v +++ b/test-suite/success/RecTutorial.v @@ -1,3 +1,5 @@ +Module Type LocalNat. + Inductive nat : Set := | O : nat | S : nat->nat. @@ -5,7 +7,8 @@ Check nat. Check O. Check S. -Reset nat. +End LocalNat. + Print nat. @@ -477,10 +480,10 @@ Qed. -(* -Check (fun (P:Prop->Prop)(p: ex_Prop P) => +Fail Check (fun (P:Prop->Prop)(p: ex_Prop P) => match p with exP_intro X HX => X end). +(* Error: Incorrect elimination of "p" in the inductive type "ex_Prop", the return type has sort "Type" while it should be @@ -489,12 +492,11 @@ Incorrect elimination of "p" in the inductive type Elimination of an inductive object of sort "Prop" is not allowed on a predicate in sort "Type" because proofs can be eliminated only to build proofs - *) -(* -Check (match prop_inject with (prop_intro P p) => P end). +Fail Check (match prop_inject with (prop_intro p) => p end). +(* Error: Incorrect elimination of "prop_inject" in the inductive type "prop", the return type has sort "Type" while it should be @@ -503,13 +505,12 @@ Incorrect elimination of "prop_inject" in the inductive type Elimination of an inductive object of sort "Prop" is not allowed on a predicate in sort "Type" because proofs can be eliminated only to build proofs - *) Print prop_inject. (* prop_inject = -prop_inject = prop_intro prop (fun H : prop => H) +prop_inject = prop_intro prop : prop *) @@ -520,26 +521,24 @@ Inductive typ : Type := Definition typ_inject: typ. split. exact typ. +Fail Defined. (* -Defined. - Error: Universe Inconsistency. *) Abort. -(* -Inductive aSet : Set := +Fail Inductive aSet : Set := aSet_intro: Set -> aSet. - - +(* User error: Large non-propositional inductive types must be in Type - *) Inductive ex_Set (P : Set -> Prop) : Type := exS_intro : forall X : Set, P X -> ex_Set P. +Module Type Version1. + Inductive comes_from_the_left (P Q:Prop): P \/ Q -> Prop := c1 : forall p, comes_from_the_left P Q (or_introl (A:=P) Q p). @@ -553,21 +552,15 @@ Goal ~(comes_from_the_left _ _ (or_intror True I)). *) Abort. -Reset comes_from_the_left. - -(* +End Version1. - - - - - - Definition comes_from_the_left (P Q:Prop)(H:P \/ Q): Prop := +Fail Definition comes_from_the_left (P Q:Prop)(H:P \/ Q): Prop := match H with | or_introl p => True | or_intror q => False end. +(* Error: Incorrect elimination of "H" in the inductive type "or", the return type has sort "Type" while it should be @@ -576,7 +569,6 @@ Incorrect elimination of "H" in the inductive type Elimination of an inductive object of sort "Prop" is not allowed on a predicate in sort "Type" because proofs can be eliminated only to build proofs - *) Definition comes_from_the_left_sumbool @@ -737,6 +729,7 @@ Fixpoint plus'' (n p:nat) {struct n} : nat := | S m => plus'' m (S p) end. +Module Type even_test_v1. Fixpoint even_test (n:nat) : bool := match n @@ -745,8 +738,9 @@ Fixpoint even_test (n:nat) : bool := | S (S p) => even_test p end. +End even_test_v1. -Reset even_test. +Module even_test_v2. Fixpoint even_test (n:nat) : bool := match n @@ -761,12 +755,8 @@ with odd_test (n:nat) : bool := | S p => even_test p end. - - Eval simpl in even_test. - - Eval simpl in (fun x : nat => even_test x). Eval simpl in (fun x : nat => plus 5 x). @@ -774,6 +764,8 @@ Eval simpl in (fun x : nat => even_test (plus 5 x)). Eval simpl in (fun x : nat => even_test (plus x 5)). +End even_test_v2. + Section Principle_of_Induction. Variable P : nat -> Prop. @@ -866,14 +858,13 @@ Print Acc. Require Import Minus. -(* -Fixpoint div (x y:nat){struct x}: nat := +Fail Fixpoint div (x y:nat){struct x}: nat := if eq_nat_dec x 0 then 0 else if eq_nat_dec y 0 then x else S (div (x-y) y). - +(* Error: Recursive definition of div is ill-formed. In environment @@ -971,19 +962,15 @@ Proof. intros A v;inversion v. Abort. -(* - Lemma Vector.t0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n), - n= 0 -> v = Vnil A. -Toplevel input, characters 40281-40287 -> Lemma Vector.t0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n), n= 0 -> v = Vnil A. -> ^^^^^^ +Fail Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n), + n= 0 -> v = Vector.nil A. +(* Error: In environment A : Set n : nat v : Vector.t A n -e : n = 0 -The term "Vnil A" has type "Vector.t A 0" while it is expected to have type +The term "[]" has type "Vector.t A 0" while it is expected to have type "Vector.t A n" *) Require Import JMeq. diff --git a/test-suite/success/Reset.v b/test-suite/success/Reset.v deleted file mode 100644 index b71ea69d..00000000 --- a/test-suite/success/Reset.v +++ /dev/null @@ -1,7 +0,0 @@ -(* Check Reset Section *) - -Section A. -Definition B := Prop. -End A. - -Reset A. diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v index e3183ef2..d3c76101 100644 --- a/test-suite/success/apply.v +++ b/test-suite/success/apply.v @@ -97,13 +97,14 @@ Qed. (* Check use of unification of bindings types in specialize *) +Module Type Test. Variable P : nat -> Prop. Variable L : forall (l : nat), P l -> P l. Goal P 0 -> True. intros. specialize L with (1:=H). Abort. -Reset P. +End Test. (* Two examples that show that hnf_constr is used when unifying types of bindings (a simplification of a script from Field_Theory) *) @@ -415,3 +416,17 @@ apply mapfuncomp. Abort. End A. + +(* Check "with" clauses refer to names as they are printed *) + +Definition hide p := forall n:nat, p = n. + +Goal forall n, (forall n, n=0) -> hide n -> n=0. +unfold hide. +intros n H H'. +(* H is displayed as (forall n, n=0) *) +apply H with (n:=n). +Undo. +(* H' is displayed as (forall n0, n=n0) *) +apply H' with (n0:=0). +Qed. diff --git a/test-suite/success/coercions.v b/test-suite/success/coercions.v index 001beae7..4292ecb6 100644 --- a/test-suite/success/coercions.v +++ b/test-suite/success/coercions.v @@ -89,3 +89,45 @@ Module A. End A. Import A. Fail Check S true. + +(* Tests after the inheritance condition constraint is relaxed *) + +Inductive list (A : Type) : Type := + nil : list A | cons : A -> list A -> list A. +Inductive vect (A : Type) : nat -> Type := + vnil : vect A 0 | vcons : forall n, A -> vect A n -> vect A (1+n). +Fixpoint size A (l : list A) : nat := match l with nil => 0 | cons _ tl => 1+size _ tl end. + +Section test_non_unif_but_complete. +Fixpoint l2v A (l : list A) : vect A (size A l) := + match l as l return vect A (size A l) with + | nil => vnil A + | cons x xs => vcons A (size A xs) x (l2v A xs) + end. + +Local Coercion l2v : list >-> vect. +Check (fun l : list nat => (l : vect _ _)). + +End test_non_unif_but_complete. + +Section what_we_could_do. +Variables T1 T2 : Type. +Variable c12 : T1 -> T2. + +Class coercion (A B : Type) : Type := cast : A -> B. +Instance atom : coercion T1 T2 := c12. +Instance pair A B C D (c1 : coercion A B) (c2 : coercion C D) : coercion (A * C) (B * D) := + fun x => (c1 (fst x), c2 (snd x)). + +Fixpoint l2v2 {A B} {c : coercion A B} (l : list A) : (vect B (size A l)) := + match l as l return vect B (size A l) with + | nil => vnil B + | cons x xs => vcons _ _ (c x) (l2v2 xs) end. + +Local Coercion l2v2 : list >-> vect. + +(* This shows that there is still something to do to take full profit + of coercions *) +Fail Check (fun l : list (T1 * T1) => (l : vect _ _)). +Check (fun l : list (T1 * T1) => (l2v2 l : vect _ _)). +Section what_we_could_do.
\ No newline at end of file diff --git a/test-suite/success/dependentind.v b/test-suite/success/dependentind.v index fe0165d0..79d12a06 100644 --- a/test-suite/success/dependentind.v +++ b/test-suite/success/dependentind.v @@ -1,5 +1,11 @@ Require Import Coq.Program.Program Coq.Program.Equality. +Goal forall (H: forall n m : nat, n = m -> n = 0) x, x = tt. +intros. +dependent destruction x. +reflexivity. +Qed. + Variable A : Set. Inductive vector : nat -> Type := vnil : vector 0 | vcons : A -> forall {n}, vector n -> vector (S n). @@ -84,6 +90,29 @@ Proof with simpl in * ; eqns ; eauto with lambda. intro. eapply app... Defined. +Lemma weakening_ctx : forall Γ Δ τ, Γ ; Δ ⊢ τ -> + forall Δ', Γ ; Δ' ; Δ ⊢ τ. +Proof with simpl in * ; eqns ; eauto with lambda. + intros Γ Δ τ H. + + dependent induction H. + + destruct Δ as [|Δ τ'']... + induction Δ'... + + destruct Δ as [|Δ τ'']... + induction Δ'... + + destruct Δ as [|Δ τ'']... + apply abs. + specialize (IHterm Γ (empty, τ))... + + apply abs. + specialize (IHterm Γ (Δ, τ'', τ))... + + intro. eapply app... +Defined. + Lemma exchange : forall Γ Δ α β τ, term (Γ, α, β ; Δ) τ -> term (Γ, β, α ; Δ) τ. Proof with simpl in * ; eqns ; eauto. intros until 1. @@ -105,6 +134,8 @@ Proof with simpl in * ; eqns ; eauto. eapply app... Defined. + + (** Example by Andrew Kenedy, uses simplification of the first component of dependent pairs. *) Set Implicit Arguments. diff --git a/test-suite/success/evars.v b/test-suite/success/evars.v index 2f1ec757..e6088091 100644 --- a/test-suite/success/evars.v +++ b/test-suite/success/evars.v @@ -309,3 +309,73 @@ Definition k6 Definition k7 (e:forall P : nat -> Prop, (exists n : nat, let n' := n in P n') -> nat) (j : forall a, exists n : nat, n = a) a (b:=a) := e _ (j b). + +(* An example that uses materialize_evar under binders *) +(* Extracted from bigop.v in the mathematical components library *) + +Section Bigop. + +Variable bigop : forall R I: Type, + R -> (R -> R -> R) -> list I -> (I->Prop) -> (I -> R) -> R. + +Hypothesis eq_bigr : +forall (R : Type) (idx : R) (op : R -> R -> R) + (I : Type) (r : list I) (P : I -> Prop) (F1 F2 : I -> R), + (forall i : I, P i -> F1 i = F2 i) -> + bigop R I idx op r (fun i : I => P i) (fun i : I => F1 i) = idx. + +Hypothesis big_tnth : +forall (R : Type) (idx : R) (op : R -> R -> R) + (I : Type) (r : list I) (P : I -> Prop) (F : I -> R), + bigop R I idx op r (fun i : I => P i) (fun i : I => F i) = idx. + +Hypothesis big_tnth_with_letin : +forall (R : Type) (idx : R) (op : R -> R -> R) + (I : Type) (r : list I) (P : I -> Prop) (F : I -> R), + bigop R I idx op r (fun i : I => let i:=i in P i) (fun i : I => F i) = idx. + +Variable R : Type. +Variable idx : R. +Variable op : R -> R -> R. +Variable I : Type. +Variable J : Type. +Variable rI : list I. +Variable rJ : list J. +Variable xQ : J -> Prop. +Variable P : I -> Prop. +Variable Q : I -> J -> Prop. +Variable F : I -> J -> R. + +(* Check unification under binders *) + +Check (eq_bigr _ _ _ _ _ _ _ _ (fun _ _ => big_tnth _ _ _ _ rI _ _)) + : (bigop R J idx op rJ + (fun j : J => let k:=j in xQ k) + (fun j : J => let k:=j in + bigop R I idx + op rI + (fun i : I => P i /\ Q i k) (fun i : I => let k:=j in F i k))) = idx. + +(* Check also with let-in *) + +Check (eq_bigr _ _ _ _ _ _ _ _ (fun _ _ => big_tnth_with_letin _ _ _ _ rI _ _)) + : (bigop R J idx op rJ + (fun j : J => let k:=j in xQ k) + (fun j : J => let k:=j in + bigop R I idx + op rI + (fun i : I => P i /\ Q i k) (fun i : I => let k:=j in F i k))) = idx. + +End Bigop. + +(* Check the use of (at least) an heuristic to solve problems of the form + "?x[t] = ?y" where ?y occurs in t without easily knowing if ?y can + eventually be erased in t *) + +Section evar_evar_occur. + Variable id : nat -> nat. + Variable f : forall x, id x = 0 -> id x = 0 -> x = 1 /\ x = 2. + Variable g : forall y, id y = 0 /\ id y = 0. + (* Still evars in the resulting type, but constraints should be solved *) + Check match g _ with conj a b => f _ a b end. +End evar_evar_occur. diff --git a/test-suite/success/hyps_inclusion.v b/test-suite/success/hyps_inclusion.v index af81e53d..ebd90a40 100644 --- a/test-suite/success/hyps_inclusion.v +++ b/test-suite/success/hyps_inclusion.v @@ -19,14 +19,16 @@ red in H. (* next tactic was failing wrt bug #1325 because type-checking the goal detected a syntactically different type for the section variable H *) case 0. -Reset A. +Abort. +End A. (* Variant with polymorphic inductive types for bug #1325 *) -Section A. +Section B. Variable H:not True. Inductive I (n:nat) : Type := C : H=H -> I n. Goal I 0. red in H. case 0. -Reset A. +Abort. +End B. diff --git a/test-suite/success/telescope_canonical.v b/test-suite/success/telescope_canonical.v index 8a607c93..73df5ca9 100644 --- a/test-suite/success/telescope_canonical.v +++ b/test-suite/success/telescope_canonical.v @@ -1,12 +1,72 @@ Structure Inner := mkI { is :> Type }. Structure Outer := mkO { os :> Inner }. - Canonical Structure natInner := mkI nat. Canonical Structure natOuter := mkO natInner. - Definition hidden_nat := nat. - Axiom P : forall S : Outer, is (os S) -> Prop. - -Lemma foo (n : hidden_nat) : P _ n. +Lemma test1 (n : hidden_nat) : P _ n. Admitted. + +Structure Pnat := mkP { getp : nat }. +Definition my_getp := getp. +Axiom W : nat -> Prop. + +(* Fix *) +Canonical Structure add1Pnat n := mkP (plus n 1). +Definition test_fix n := (refl_equal _ : W (my_getp _) = W (n + 1)). + +(* Case *) +Definition pred n := match n with 0 => 0 | S m => m end. +Canonical Structure predSS n := mkP (pred n). +Definition test_case x := (refl_equal _ : W (my_getp _) = W (pred x)). +Fail Definition test_case' := (refl_equal _ : W (my_getp _) = W (pred 0)). + +Canonical Structure letPnat' := mkP 0. +Definition letin := (let n := 0 in n). +Definition test4 := (refl_equal _ : W (getp _) = W letin). +Definition test41 := (refl_equal _ : W (my_getp _) = W letin). +Definition letin2 (x : nat) := (let n := x in n). +Canonical Structure letPnat'' x := mkP (letin2 x). +Definition test42 x := (refl_equal _ : W (my_getp _) = W (letin2 x)). +Fail Definition test42' x := (refl_equal _ : W (my_getp _) = W x). + +Structure Morph := mkM { f :> nat -> nat }. +Definition my_f := f. +Axiom Q : (nat -> nat) -> Prop. + +(* Lambda *) +Canonical Structure addMorh x := mkM (plus x). +Definition test_lam x := (refl_equal _ : Q (my_f _) = Q (plus x)). +Definition test_lam' := (refl_equal _ : Q (my_f _) = Q (plus 0)). + +(* Simple tests to justify Sort and Prod as "named". + They are already normal, so they cannot loose their names, + but still... *) +Structure Sot := mkS { T : Type }. +Axiom R : Type -> Prop. +Canonical Structure tsot := mkS (Type). +Definition test_sort := (refl_equal _ : R (T _) = R Type). +Canonical Structure tsot2 := mkS (nat -> nat). +Definition test_prod := (refl_equal _ : R (T _) = R (nat -> nat)). + +(* Var *) +Section Foo. +Variable v : nat. +Definition my_v := v. +Canonical Structure vP := mkP my_v. +Definition test_var := (refl_equal _ : W (getp _) = W my_v). +Canonical Structure vP' := mkP v. +Definition test_var' := (refl_equal _ : W (my_getp _) = W my_v). +End Foo. + +(* Rel *) +Definition test_rel v := (refl_equal _ : W (my_getp _) = W (my_v v)). +Goal True. +pose (x := test_rel 2). +match goal with x := _ : W (my_getp (vP 2)) = _ |- _ => idtac end. +apply I. +Qed. + + + + diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index 24cbc3f9..da1d9e98 100644 --- a/theories/Arith/Div2.v +++ b/theories/Arith/Div2.v @@ -11,7 +11,7 @@ Require Import Plus. Require Import Compare_dec. Require Import Even. -Open Local Scope nat_scope. +Local Open Scope nat_scope. Implicit Type n : nat. @@ -69,24 +69,24 @@ Proof. (* S n *) inversion_clear H. apply even_div2 in H0 as <-. trivial. Qed. -Lemma div2_even : forall n, div2 n = div2 (S n) -> even n -with div2_odd : forall n, S (div2 n) = div2 (S n) -> odd n. +Lemma div2_even n : div2 n = div2 (S n) -> even n +with div2_odd n : S (div2 n) = div2 (S n) -> odd n. Proof. - destruct n; intro H. - (* 0 *) constructor. - (* S n *) constructor. apply div2_odd. rewrite H. trivial. - destruct n; intro H. - (* 0 *) discriminate. - (* S n *) constructor. apply div2_even. injection H as <-. trivial. +{ destruct n; intro H. + - constructor. + - constructor. apply div2_odd. rewrite H. trivial. } +{ destruct n; intro H. + - discriminate. + - constructor. apply div2_even. injection H as <-. trivial. } Qed. Hint Resolve even_div2 div2_even odd_div2 div2_odd: arith. -Lemma even_odd_div2 : - forall n, - (even n <-> div2 n = div2 (S n)) /\ (odd n <-> S (div2 n) = div2 (S n)). +Lemma even_odd_div2 n : + (even n <-> div2 n = div2 (S n)) /\ + (odd n <-> S (div2 n) = div2 (S n)). Proof. - auto decomp using div2_odd, div2_even, odd_div2, even_div2. + split; split; auto using div2_odd, div2_even, odd_div2, even_div2. Qed. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index d1eabcab..9cd0b31b 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -221,7 +221,7 @@ Definition all (A:Type) (P:A -> Prop) := forall x:A, P x. Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..)) (at level 200, x binder, right associativity, - format "'[' 'exists' '/ ' x .. y , '/ ' p ']'") + format "'[' 'exists' '/ ' x .. y , '/ ' p ']'") : type_scope. Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q)) @@ -404,7 +404,7 @@ Definition uniqueness (A:Type) (P:A->Prop) := forall x y, P x -> P y -> x = y. Notation "'exists' ! x .. y , p" := (ex (unique (fun x => .. (ex (unique (fun y => p))) ..))) (at level 200, x binder, right associativity, - format "'[' 'exists' ! '/ ' x .. y , '/ ' p ']'") + format "'[' 'exists' ! '/ ' x .. y , '/ ' p ']'") : type_scope. Lemma unique_existence : forall (A:Type) (P:A->Prop), diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index e929c561..d85f5363 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -19,7 +19,6 @@ Declare ML Module "extraction_plugin". Declare ML Module "decl_mode_plugin". Declare ML Module "cc_plugin". Declare ML Module "ground_plugin". -Declare ML Module "dp_plugin". Declare ML Module "recdef_plugin". Declare ML Module "subtac_plugin". Declare ML Module "xml_plugin". diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 637994b2..5b7afc99 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -60,7 +60,7 @@ Add Printing Let sigT2. (** Projections of [sig] - An element [y] of a subset [{x:A & (P x)}] is the pair of an [a] + An element [y] of a subset [{x:A | (P x)}] is the pair of an [a] of type [A] and of a proof [h] that [a] satisfies [P]. Then [(proj1_sig y)] is the witness [a] and [(proj2_sig y)] is the proof of [(P a)] *) diff --git a/theories/Lists/intro.tex b/theories/Lists/intro.tex index e849967c..d372de8e 100755 --- a/theories/Lists/intro.tex +++ b/theories/Lists/intro.tex @@ -14,7 +14,7 @@ This library includes the following files: sets, implemented as lists. \item {\tt Streams.v} defines the type of infinite lists (streams). It is a - coinductive type. Basic facts are stated and proved. The streams are + co-inductive type. Basic facts are stated and proved. The streams are also polymorphic. \end{itemize} diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index 8d82bc8e..fb7898c6 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -385,7 +385,7 @@ Qed. Lemma subset_types_imp_guarded_rel_choice_iff_rel_choice : ProofIrrelevance -> (GuardedRelationalChoice <-> RelationalChoice). Proof. - auto decomp using + intuition auto using guarded_rel_choice_imp_rel_choice, rel_choice_and_proof_irrel_imp_guarded_rel_choice. Qed. @@ -439,7 +439,7 @@ Corollary fun_choice_and_indep_general_prem_iff_guarded_fun_choice : FunctionalChoiceOnInhabitedSet /\ IndependenceOfGeneralPremises <-> GuardedFunctionalChoice. Proof. - auto decomp using + intuition auto using guarded_fun_choice_imp_indep_of_general_premises, guarded_fun_choice_imp_fun_choice, fun_choice_and_indep_general_prem_imp_guarded_fun_choice. @@ -480,7 +480,7 @@ Corollary fun_choice_and_small_drinker_iff_omniscient_fun_choice : FunctionalChoiceOnInhabitedSet /\ SmallDrinker'sParadox <-> OmniscientFunctionalChoice. Proof. - auto decomp using + intuition auto using omniscient_fun_choice_imp_small_drinker, omniscient_fun_choice_imp_fun_choice, fun_choice_and_small_drinker_imp_omniscient_fun_choice. @@ -547,7 +547,7 @@ Theorem constructive_indefinite_description_and_small_drinker_iff_epsilon : (EpsilonStatement -> SmallDrinker'sParadox * ConstructiveIndefiniteDescription). Proof. - auto decomp using + intuition auto using epsilon_imp_constructive_indefinite_description, constructive_indefinite_description_and_small_drinker_imp_epsilon, epsilon_imp_small_drinker. @@ -689,7 +689,7 @@ Qed. Corollary dep_iff_non_dep_functional_rel_reification : FunctionalRelReification <-> DependentFunctionalRelReification. Proof. - auto decomp using + intuition auto using non_dep_dep_functional_rel_reification, dep_non_dep_functional_rel_reification. Qed. @@ -814,9 +814,9 @@ Corollary fun_reification_descr_computational_excluded_middle_in_prop_context : (forall P:Prop, P \/ ~ P) -> forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C. Proof. - intros FunReify EM C; auto decomp using - constructive_definite_descr_excluded_middle, - (relative_non_contradiction_of_definite_descr (C:=C)). + intros FunReify EM C H. + apply relative_non_contradiction_of_definite_descr; trivial. + auto using constructive_definite_descr_excluded_middle. Qed. (**********************************************************************) diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index bdada486..1e66e2b5 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -13,7 +13,7 @@ It follows the implementation from Ocaml's standard library, All operations given here expect and produce well-balanced trees - (in the ocaml sense: heigths of subtrees shouldn't differ by more + (in the ocaml sense: heights of subtrees shouldn't differ by more than 2), and hence has low complexities (e.g. add is logarithmic in the size of the set). But proving these balancing preservations is in fact not necessary for ensuring correct operational behavior @@ -31,74 +31,41 @@ code after extraction. *) -Require Import MSetInterface ZArith Int. +Require Import MSetInterface MSetGenTree ZArith Int. Set Implicit Arguments. Unset Strict Implicit. -(* for nicer extraction, we create only logical inductive principles *) +(* for nicer extraction, we create inductive principles + only when needed *) Local Unset Elimination Schemes. Local Unset Case Analysis Schemes. (** * Ops : the pure functions *) -Module Ops (Import I:Int)(X:OrderedType) <: WOps X. +Module Ops (Import I:Int)(X:OrderedType) <: MSetInterface.Ops X. Local Open Scope Int_scope. -Local Open Scope lazy_bool_scope. -Definition elt := X.t. -Hint Transparent elt. +(** ** Generic trees instantiated with integer height *) -(** ** Trees +(** We reuse a generic definition of trees where the information + parameter is a [Int.t]. Functions like mem or fold are also + provided by this generic functor. *) - The fourth field of [Node] is the height of the tree *) - -Inductive tree := - | Leaf : tree - | Node : tree -> X.t -> tree -> int -> tree. +Include MSetGenTree.Ops X I. Definition t := tree. -(** ** Basic functions on trees: height and cardinal *) +(** ** Height of trees *) Definition height (s : t) : int := match s with | Leaf => 0 - | Node _ _ _ h => h - end. - -Fixpoint cardinal (s : t) : nat := - match s with - | Leaf => 0%nat - | Node l _ r _ => S (cardinal l + cardinal r) + | Node h _ _ _ => h end. -(** ** Empty Set *) - -Definition empty := Leaf. - -(** ** Emptyness test *) - -Definition is_empty s := - match s with Leaf => true | _ => false end. - -(** ** Membership *) - -(** The [mem] function is deciding membership. It exploits the - binary search tree invariant to achieve logarithmic complexity. *) - -Fixpoint mem x s := - match s with - | Leaf => false - | Node l y r _ => match X.compare x y with - | Lt => mem x l - | Eq => true - | Gt => mem x r - end - end. - (** ** Singleton set *) -Definition singleton x := Node Leaf x Leaf 1. +Definition singleton x := Node 1 Leaf x Leaf. (** ** Helper functions *) @@ -106,7 +73,7 @@ Definition singleton x := Node Leaf x Leaf 1. to be balanced and [|height l - height r| <= 2]. *) Definition create l x r := - Node l x r (max (height l) (height r) + 1). + Node (max (height l) (height r) + 1) l x r. (** [bal l x r] acts as [create], but performs one step of rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) @@ -119,13 +86,13 @@ Definition bal l x r := if gt_le_dec hl (hr+2) then match l with | Leaf => assert_false l x r - | Node ll lx lr _ => + | Node _ ll lx lr => if ge_lt_dec (height ll) (height lr) then create ll lx (create lr x r) else match lr with | Leaf => assert_false l x r - | Node lrl lrx lrr _ => + | Node _ lrl lrx lrr => create (create ll lx lrl) lrx (create lrr x r) end end @@ -133,13 +100,13 @@ Definition bal l x r := if gt_le_dec hr (hl+2) then match r with | Leaf => assert_false l x r - | Node rl rx rr _ => + | Node _ rl rx rr => if ge_lt_dec (height rr) (height rl) then create (create l x rl) rx rr else match rl with | Leaf => assert_false l x r - | Node rll rlx rlr _ => + | Node _ rll rlx rlr => create (create l x rll) rlx (create rlr rx rr) end end @@ -149,11 +116,11 @@ Definition bal l x r := (** ** Insertion *) Fixpoint add x s := match s with - | Leaf => Node Leaf x Leaf 1 - | Node l y r h => + | Leaf => Node 1 Leaf x Leaf + | Node h l y r => match X.compare x y with | Lt => bal (add x l) y r - | Eq => Node l y r h + | Eq => Node h l y r | Gt => bal l y (add x r) end end. @@ -167,10 +134,10 @@ Fixpoint add x s := match s with Fixpoint join l : elt -> t -> t := match l with | Leaf => add - | Node ll lx lr lh => fun x => + | Node lh ll lx lr => fun x => fix join_aux (r:t) : t := match r with - | Leaf => add x l - | Node rl rx rr rh => + | 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 else create l x r @@ -180,14 +147,14 @@ Fixpoint join l : elt -> t -> t := (** ** Extraction of minimum element Morally, [remove_min] is to be applied to a non-empty tree - [t = Node l x r h]. Since we can't deal here with [assert false] + [t = Node h l x r]. 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 r : t*elt := match l with | Leaf => (r,x) - | Node ll lx lr lh => + | Node lh ll lx lr => let (l',m) := remove_min ll lx lr in (bal l' x r, m) end. @@ -201,7 +168,7 @@ Fixpoint remove_min l x r : t*elt := Definition merge s1 s2 := match s1,s2 with | Leaf, _ => s2 | _, Leaf => s1 - | _, Node l2 x2 r2 h2 => + | _, Node _ l2 x2 r2 => let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2' end. @@ -209,34 +176,14 @@ end. Fixpoint remove x s := match s with | Leaf => Leaf - | Node l y r h => + | Node _ l y r => match X.compare x y with | Lt => bal (remove x l) y r | Eq => merge l r - | Gt => bal l y (remove x r) + | Gt => bal l y (remove x r) end end. -(** ** Minimum element *) - -Fixpoint min_elt s := match s with - | Leaf => None - | Node Leaf y _ _ => Some y - | Node l _ _ _ => min_elt l -end. - -(** ** Maximum element *) - -Fixpoint max_elt s := match s with - | Leaf => None - | Node _ y Leaf _ => Some y - | Node _ _ r _ => max_elt r -end. - -(** ** Any element *) - -Definition choose := min_elt. - (** ** Concatenation Same as [merge] but does not assume anything about heights. @@ -246,7 +193,7 @@ Definition concat s1 s2 := match s1, s2 with | Leaf, _ => s2 | _, Leaf => s1 - | _, Node l2 x2 r2 _ => + | _, Node _ l2 x2 r2 => let (s2',m) := remove_min l2 x2 r2 in join s1 m s2' end. @@ -264,7 +211,7 @@ Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). Fixpoint split x s : triple := match s with | Leaf => << Leaf, false, Leaf >> - | Node l y r h => + | Node _ l y r => match X.compare x y with | Lt => let (ll,b,rl) := split x l in << ll, b, join rl y r >> | Eq => << l, true, r >> @@ -277,7 +224,7 @@ Fixpoint split x s : triple := match s with Fixpoint inter s1 s2 := match s1, s2 with | Leaf, _ => Leaf | _, Leaf => Leaf - | Node l1 x1 r1 h1, _ => + | Node _ l1 x1 r1, _ => let (l2',pres,r2') := split x1 s2 in if pres then join (inter l1 l2') x1 (inter r1 r2') else concat (inter l1 l2') (inter r1 r2') @@ -288,7 +235,7 @@ Fixpoint inter s1 s2 := match s1, s2 with Fixpoint diff s1 s2 := match s1, s2 with | Leaf, _ => Leaf | _, Leaf => s1 - | Node l1 x1 r1 h1, _ => + | Node _ l1 x1 r1, _ => let (l2',pres,r2') := split x1 s2 in if pres then concat (diff l1 l2') (diff r1 r2') else join (diff l1 l2') x1 (diff r1 r2') @@ -311,187 +258,36 @@ Fixpoint union s1 s2 := match s1, s2 with | Leaf, _ => s2 | _, Leaf => s1 - | Node l1 x1 r1 h1, _ => + | Node _ l1 x1 r1, _ => let (l2',_,r2') := split x1 s2 in join (union l1 l2') x1 (union r1 r2') end. -(** ** Elements *) - -(** [elements_tree_aux acc t] catenates the elements of [t] in infix - order to the list [acc] *) - -Fixpoint elements_aux (acc : list X.t) (s : t) : list X.t := - match s with - | Leaf => acc - | Node l x r _ => elements_aux (x :: elements_aux acc r) l - end. - -(** then [elements] is an instanciation with an empty [acc] *) - -Definition elements := elements_aux nil. - (** ** Filter *) -Fixpoint filter_acc (f:elt->bool) acc s := match s with - | Leaf => acc - | Node l x r h => - filter_acc f (filter_acc f (if f x then add x acc else acc) l) r +Fixpoint filter (f:elt->bool) s := match s with + | Leaf => Leaf + | Node _ l x r => + let l' := filter f l in + let r' := filter f r in + if f x then join l' x r' else concat l' r' end. -Definition filter f := filter_acc f Leaf. - - (** ** Partition *) -Fixpoint partition_acc (f:elt->bool)(acc : t*t)(s : t) : t*t := +Fixpoint partition (f:elt->bool)(s : t) : t*t := match s with - | Leaf => acc - | Node l x r _ => - let (acct,accf) := acc in - partition_acc f - (partition_acc f - (if f x then (add x acct, accf) else (acct, add x accf)) l) r + | Leaf => (Leaf, Leaf) + | Node _ l x r => + let (l1,l2) := partition f l in + let (r1,r2) := partition f r in + if f x then (join l1 x r1, concat l2 r2) + else (concat l1 r1, join l2 x r2) end. -Definition partition f := partition_acc f (Leaf,Leaf). - -(** ** [for_all] and [exists] *) - -Fixpoint for_all (f:elt->bool) s := match s with - | Leaf => true - | Node l x r _ => f x &&& for_all f l &&& for_all f r -end. - -Fixpoint exists_ (f:elt->bool) s := match s with - | Leaf => false - | Node l x r _ => f x ||| exists_ f l ||| exists_ f r -end. - -(** ** Fold *) - -Fixpoint fold (A : Type) (f : elt -> A -> A)(s : t) : A -> A := - fun a => match s with - | Leaf => a - | Node l x r _ => fold f r (f x (fold f l a)) - end. -Arguments fold [A] f s _. - - -(** ** Subset *) - -(** In ocaml, recursive calls are made on "half-trees" such as - (Node l1 x1 Leaf _) and (Node Leaf x1 r1 _). Instead of these - non-structural calls, we propose here two specialized functions for - these situations. This version should be almost as efficient as - the one of ocaml (closures as arguments may slow things a bit), - it is simply less compact. The exact ocaml version has also been - formalized (thanks to Function+measure), see [ocaml_subset] in - [MSetFullAVL]. - *) - -Fixpoint subsetl (subset_l1:t->bool) x1 s2 : bool := - match s2 with - | Leaf => false - | Node l2 x2 r2 h2 => - match X.compare x1 x2 with - | Eq => subset_l1 l2 - | Lt => subsetl subset_l1 x1 l2 - | Gt => mem x1 r2 &&& subset_l1 s2 - end - end. - -Fixpoint subsetr (subset_r1:t->bool) x1 s2 : bool := - match s2 with - | Leaf => false - | Node l2 x2 r2 h2 => - match X.compare x1 x2 with - | Eq => subset_r1 r2 - | Lt => mem x1 l2 &&& subset_r1 s2 - | Gt => subsetr subset_r1 x1 r2 - end - end. - -Fixpoint subset s1 s2 : bool := match s1, s2 with - | Leaf, _ => true - | Node _ _ _ _, Leaf => false - | Node l1 x1 r1 h1, Node l2 x2 r2 h2 => - match X.compare x1 x2 with - | Eq => subset l1 l2 &&& subset r1 r2 - | Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2 - | Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2 - end - end. - -(** ** A new comparison algorithm suggested by Xavier Leroy - - Transformation in C.P.S. suggested by Benjamin Grégoire. - The original ocaml code (with non-structural recursive calls) - has also been formalized (thanks to Function+measure), see - [ocaml_compare] in [MSetFullAVL]. The following code with - continuations computes dramatically faster in Coq, and - should be almost as efficient after extraction. -*) - -(** Enumeration of the elements of a tree *) - -Inductive enumeration := - | End : enumeration - | More : elt -> t -> enumeration -> enumeration. - - -(** [cons t e] adds the elements of tree [t] on the head of - enumeration [e]. *) - -Fixpoint cons s e : enumeration := - match s with - | Leaf => e - | Node l x r h => cons l (More x r e) - end. - -(** One step of comparison of elements *) - -Definition compare_more x1 (cont:enumeration->comparison) e2 := - match e2 with - | End => Gt - | More x2 r2 e2 => - match X.compare x1 x2 with - | Eq => cont (cons r2 e2) - | Lt => Lt - | Gt => Gt - end - end. - -(** Comparison of left tree, middle element, then right tree *) - -Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := - match s1 with - | Leaf => cont e2 - | Node l1 x1 r1 _ => - compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2 - end. - -(** Initial continuation *) - -Definition compare_end e2 := - match e2 with End => Eq | _ => Lt end. - -(** The complete comparison *) - -Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End). - -(** ** Equality test *) - -Definition equal s1 s2 : bool := - match compare s1 s2 with - | Eq => true - | _ => false - end. - End Ops. - (** * MakeRaw Functor of pure functions + a posteriori proofs of invariant @@ -500,265 +296,47 @@ End Ops. Module MakeRaw (Import I:Int)(X:OrderedType) <: RawSets X. Include Ops I X. -(** * Invariants *) - -(** ** Occurrence in a tree *) - -Inductive InT (x : elt) : tree -> Prop := - | IsRoot : forall l r h y, X.eq x y -> InT x (Node l y r h) - | InLeft : forall l r h y, InT x l -> InT x (Node l y r h) - | InRight : forall l r h y, InT x r -> InT x (Node l y r h). - -Definition In := InT. - -(** ** Some shortcuts *) - -Definition Equal s s' := forall a : elt, InT a s <-> InT a s'. -Definition Subset s s' := forall a : elt, InT a s -> InT a s'. -Definition Empty s := forall a : elt, ~ InT a s. -Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x. -Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x. - -(** ** Binary search trees *) - -(** [lt_tree x s]: all elements in [s] are smaller than [x] - (resp. greater for [gt_tree]) *) - -Definition lt_tree x s := forall y, InT y s -> X.lt y x. -Definition gt_tree x s := forall y, InT y s -> X.lt x y. - -(** [bst t] : [t] is a binary search tree *) - -Inductive bst : tree -> Prop := - | BSLeaf : bst Leaf - | BSNode : forall x l r h, bst l -> bst r -> - lt_tree x l -> gt_tree x r -> bst (Node l x r h). - -(** [bst] is the (decidable) invariant our trees will have to satisfy. *) - -Definition IsOk := bst. - -Class Ok (s:t) : Prop := ok : bst s. - -Instance bst_Ok s (Hs : bst s) : Ok s := { ok := Hs }. - -Fixpoint ltb_tree x s := - match s with - | Leaf => true - | Node l y r _ => - match X.compare x y with - | Gt => ltb_tree x l && ltb_tree x r - | _ => false - end - end. - -Fixpoint gtb_tree x s := - match s with - | Leaf => true - | Node l y r _ => - match X.compare x y with - | Lt => gtb_tree x l && gtb_tree x r - | _ => false - end - end. - -Fixpoint isok s := - match s with - | Leaf => true - | Node l x r _ => isok l && isok r && ltb_tree x l && gtb_tree x r - end. - - -(** * Correctness proofs *) +(** Generic definition of binary-search-trees and proofs of + specifications for generic functions such as mem or fold. *) -Module Import MX := OrderedTypeFacts X. +Include MSetGenTree.Props X I. -(** * Automation and dedicated tactics *) +(** Automation and dedicated tactics *) -Scheme tree_ind := Induction for tree Sort Prop. - -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok. Local Hint Immediate MX.eq_sym. -Local Hint Unfold In lt_tree gt_tree. +Local Hint Unfold In lt_tree gt_tree Ok. Local Hint Constructors InT bst. -Local Hint Unfold Ok. - -Tactic Notation "factornode" ident(l) ident(x) ident(r) ident(h) - "as" ident(s) := - set (s:=Node l x r h) in *; clearbody s; clear l x r h. - -(** Automatic treatment of [Ok] hypothesis *) - -Ltac inv_ok := match goal with - | H:Ok (Node _ _ _ _) |- _ => inversion_clear H; inv_ok - | H:Ok Leaf |- _ => clear H; inv_ok - | H:bst ?x |- _ => change (Ok x) in H; inv_ok - | _ => idtac -end. - -(** A tactic to repeat [inversion_clear] on all hyps of the - form [(f (Node _ _ _ _))] *) - -Ltac is_tree_constr c := - match c with - | Leaf => idtac - | Node _ _ _ _ => idtac - | _ => fail - end. - -Ltac invtree f := - match goal with - | H:f ?s |- _ => is_tree_constr s; inversion_clear H; invtree f - | H:f _ ?s |- _ => is_tree_constr s; inversion_clear H; invtree f - | H:f _ _ ?s |- _ => is_tree_constr s; inversion_clear H; invtree f - | _ => idtac - end. - -Ltac inv := inv_ok; invtree InT. - -Ltac intuition_in := repeat progress (intuition; inv). - -(** Helper tactic concerning order of elements. *) - -Ltac order := match goal with - | U: lt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order - | U: gt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order - | _ => MX.order -end. - - -(** [isok] is indeed a decision procedure for [Ok] *) - -Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true. -Proof. - induction s as [|l IHl y r IHr h]; simpl. - unfold lt_tree; intuition_in. - elim_compare x y. - split; intros; try discriminate. assert (X.lt y x) by auto. order. - split; intros; try discriminate. assert (X.lt y x) by auto. order. - rewrite !andb_true_iff, <-IHl, <-IHr. - unfold lt_tree; intuition_in; order. -Qed. - -Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true. -Proof. - induction s as [|l IHl y r IHr h]; simpl. - unfold gt_tree; intuition_in. - elim_compare x y. - split; intros; try discriminate. assert (X.lt x y) by auto. order. - rewrite !andb_true_iff, <-IHl, <-IHr. - unfold gt_tree; intuition_in; order. - split; intros; try discriminate. assert (X.lt x y) by auto. order. -Qed. - -Lemma isok_iff : forall s, Ok s <-> isok s = true. -Proof. - induction s as [|l IHl y r IHr h]; simpl. - intuition_in. - rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff. - intuition_in. -Qed. - -Instance isok_Ok s : isok s = true -> Ok s | 10. -Proof. intros; apply <- isok_iff; auto. Qed. - - -(** * Basic results about [In], [lt_tree], [gt_tree], [height] *) - -(** [In] is compatible with [X.eq] *) - -Lemma In_1 : - forall s x y, X.eq x y -> InT x s -> InT y s. -Proof. - induction s; simpl; intuition_in; eauto. -Qed. -Local Hint Immediate In_1. - -Instance In_compat : Proper (X.eq==>eq==>iff) InT. -Proof. -apply proper_sym_impl_iff_2; auto with *. -repeat red; intros; subst. apply In_1 with x; auto. -Qed. - -Lemma In_node_iff : - forall l x r h y, - InT y (Node l x r h) <-> InT y l \/ X.eq y x \/ InT y r. -Proof. - intuition_in. -Qed. - -(** Results about [lt_tree] and [gt_tree] *) - -Lemma lt_leaf : forall x : elt, lt_tree x Leaf. -Proof. - red; inversion 1. -Qed. - -Lemma gt_leaf : forall x : elt, gt_tree x Leaf. -Proof. - red; inversion 1. -Qed. - -Lemma lt_tree_node : - forall (x y : elt) (l r : tree) (h : int), - lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y r h). -Proof. - unfold lt_tree; intuition_in; order. -Qed. - -Lemma gt_tree_node : - forall (x y : elt) (l r : tree) (h : int), - gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y r h). -Proof. - unfold gt_tree; intuition_in; order. -Qed. - +Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok. Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. +Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. +Local Hint Resolve elements_spec2. -Lemma lt_tree_not_in : - forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t. -Proof. - intros; intro; order. -Qed. - -Lemma lt_tree_trans : - forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t. -Proof. - eauto. -Qed. +(* Sometimes functional induction will expose too much of + a tree structure. The following tactic allows to factor back + a Node whose internal parts occurs nowhere else. *) -Lemma gt_tree_not_in : - forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t. -Proof. - intros; intro; order. -Qed. +(* TODO: why Ltac instead of Tactic Notation don't work ? why clear ? *) -Lemma gt_tree_trans : - forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t. -Proof. - eauto. -Qed. - -Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. +Tactic Notation "factornode" ident(s) := + try clear s; + match goal with + | |- context [Node ?l ?x ?r ?h] => + set (s:=Node l x r h) in *; clearbody s; clear l x r h + | _ : context [Node ?l ?x ?r ?h] |- _ => + set (s:=Node l x r h) in *; clearbody s; clear l x r h + end. -(** * Inductions principles for some of the set operators *) +(** Inductions principles for some of the set operators *) Functional Scheme bal_ind := Induction for bal Sort Prop. Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. Functional Scheme merge_ind := Induction for merge Sort Prop. -Functional Scheme min_elt_ind := Induction for min_elt Sort Prop. -Functional Scheme max_elt_ind := Induction for max_elt Sort Prop. Functional Scheme concat_ind := Induction for concat Sort Prop. Functional Scheme inter_ind := Induction for inter Sort Prop. Functional Scheme diff_ind := Induction for diff Sort Prop. Functional Scheme union_ind := Induction for union Sort Prop. -Ltac induct s x := - induction s as [|l IHl x' r IHr h]; simpl; intros; - [|elim_compare x x'; intros; inv]. - - -(** * Notations and helper lemma about pairs and triples *) +(** Notations and helper lemma about pairs and triples *) 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. @@ -766,42 +344,9 @@ Notation "t #l" := (t_left t) (at level 9, format "t '#l'") : pair_scope. Notation "t #b" := (t_in t) (at level 9, format "t '#b'") : pair_scope. Notation "t #r" := (t_right t) (at level 9, format "t '#r'") : pair_scope. -Open Local Scope pair_scope. - - -(** * Empty set *) - -Lemma empty_spec : Empty empty. -Proof. - intro; intro. - inversion H. -Qed. - -Instance empty_ok : Ok empty. -Proof. - auto. -Qed. - -(** * Emptyness test *) - -Lemma is_empty_spec : forall s, is_empty s = true <-> Empty s. -Proof. - destruct s as [|r x l h]; simpl; auto. - split; auto. red; red; intros; inv. - split; auto. try discriminate. intro H; elim (H x); auto. -Qed. - -(** * Membership *) - -Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s. -Proof. - split. - induct s x; auto; try discriminate. - induct s x; intuition_in; order. -Qed. - +Local Open Scope pair_scope. -(** * Singleton set *) +(** ** Singleton set *) Lemma singleton_spec : forall x y, InT y (singleton x) <-> X.eq y x. Proof. @@ -813,9 +358,7 @@ Proof. unfold singleton; auto. Qed. - - -(** * Helper functions *) +(** ** Helper functions *) Lemma create_spec : forall l x r y, InT y (create l x r) <-> X.eq y x \/ InT y l \/ InT y r. @@ -846,7 +389,7 @@ Proof. Qed. -(** * Insertion *) +(** ** Insertion *) Lemma add_spec' : forall s x y, InT y (add x s) <-> X.eq y x \/ InT y s. @@ -866,25 +409,25 @@ Proof. Qed. -Open Scope Int_scope. +Local Open Scope Int_scope. -(** * Join *) +(** ** Join *) -(* Function/Functional Scheme can't deal with internal fix. - Let's do its job by hand: *) +(** Function/Functional Scheme can't deal with internal fix. + Let's do its job by hand: *) Ltac join_tac := - intro l; induction l as [| ll _ lx lr Hlr lh]; - [ | intros x r; induction r as [| rl Hrl rx rr _ rh]; unfold join; + 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]; [ match goal with |- context b [ bal ?a ?b ?c] => replace (bal a b c) - with (bal ll lx (join lr x (Node rl rx rr rh))); [ | auto] + with (bal ll lx (join lr x (Node rh rl rx rr))); [ | auto] end | destruct (gt_le_dec rh (lh+2)) as [GT'|LE']; [ match goal with |- context b [ bal ?a ?b ?c] => replace (bal a b c) - with (bal (join (Node ll lx lr lh) x rl) rx rr); [ | auto] + with (bal (join (Node lh ll lx lr) x rl) rx rr); [ | auto] end | ] ] ] ]; intros. @@ -910,10 +453,10 @@ Proof. Qed. -(** * Extraction of minimum element *) +(** ** Extraction of minimum element *) -Lemma remove_min_spec : forall l x r h y, - InT y (Node l x r h) <-> +Lemma remove_min_spec : forall l x r y h, + InT y (Node h l x r) <-> X.eq y (remove_min l x r)#2 \/ InT y (remove_min l x r)#1. Proof. intros l x r; functional induction (remove_min l x r); simpl in *; intros. @@ -921,13 +464,13 @@ Proof. rewrite bal_spec, In_node_iff, IHp, e0; simpl; intuition. Qed. -Instance remove_min_ok l x r : forall h `(Ok (Node l x r h)), +Instance remove_min_ok l x r : forall h `(Ok (Node h l x r)), Ok (remove_min l x r)#1. Proof. functional induction (remove_min l x r); simpl; intros. inv; auto. - assert (O : Ok (Node ll lx lr _x)) by (inv; auto). - assert (L : lt_tree x (Node ll lx lr _x)) by (inv; auto). + assert (O : Ok (Node _x ll lx lr)) by (inv; auto). + assert (L : lt_tree x (Node _x ll lx lr)) by (inv; auto). specialize IHp with (1:=O); rewrite e0 in IHp; auto; simpl in *. apply bal_ok; auto. inv; auto. @@ -936,13 +479,13 @@ Proof. inv; auto. Qed. -Lemma remove_min_gt_tree : forall l x r h `{Ok (Node l x r h)}, +Lemma remove_min_gt_tree : forall l x r h `{Ok (Node h l x r)}, gt_tree (remove_min l x r)#2 (remove_min l x r)#1. Proof. intros l x r; functional induction (remove_min l x r); simpl; intros. inv; auto. - assert (O : Ok (Node ll lx lr _x)) by (inv; auto). - assert (L : lt_tree x (Node ll lx lr _x)) by (inv; auto). + assert (O : Ok (Node _x ll lx lr)) by (inv; auto). + assert (L : lt_tree x (Node _x ll lx lr)) by (inv; auto). specialize IHp with (1:=O); rewrite e0 in IHp; simpl in IHp. intro y; rewrite bal_spec; intuition; specialize (L m); rewrite remove_min_spec, e0 in L; simpl in L; @@ -951,14 +494,13 @@ Qed. Local Hint Resolve remove_min_gt_tree. - -(** * Merging two trees *) +(** ** Merging two trees *) Lemma merge_spec : forall s1 s2 y, InT y (merge s1 s2) <-> InT y s1 \/ InT y s2. Proof. intros s1 s2; functional induction (merge s1 s2); intros; - try factornode _x _x0 _x1 _x2 as s1. + try factornode s1. intuition_in. intuition_in. rewrite bal_spec, remove_min_spec, e1; simpl; intuition. @@ -969,7 +511,7 @@ Instance merge_ok s1 s2 : forall `(Ok s1, Ok s2) Ok (merge s1 s2). Proof. functional induction (merge s1 s2); intros; auto; - try factornode _x _x0 _x1 _x2 as s1. + try factornode s1. apply bal_ok; auto. change s2' with ((s2',m)#1); rewrite <-e1; eauto with *. intros y Hy. @@ -980,7 +522,7 @@ Qed. -(** * Deletion *) +(** ** Deletion *) Lemma remove_spec : forall s x y `{Ok s}, (InT y (remove x s) <-> InT y s /\ ~ X.eq y x). @@ -988,7 +530,7 @@ Proof. induct s x. intuition_in. rewrite merge_spec; intuition; [order|order|intuition_in]. - elim H6; eauto. + elim H2; eauto. rewrite bal_spec, IHl; clear IHl IHr; intuition; [order|order|intuition_in]. rewrite bal_spec, IHr; clear IHl IHr; intuition; [order|order|intuition_in]. Qed. @@ -1008,109 +550,13 @@ Proof. Qed. -(** * Minimum element *) - -Lemma min_elt_spec1 : forall s x, min_elt s = Some x -> InT x s. -Proof. - intro s; functional induction (min_elt s); auto; inversion 1; auto. -Qed. - -Lemma min_elt_spec2 : forall s x y `{Ok s}, - min_elt s = Some x -> InT y s -> ~ X.lt y x. -Proof. - intro s; functional induction (min_elt s); - try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1. - discriminate. - intros x y0 U V W. - inversion V; clear V; subst. - inv; order. - intros; inv; auto. - assert (X.lt x y) by (apply H4; apply min_elt_spec1; auto). - order. - assert (X.lt x1 y) by auto. - assert (~X.lt x1 x) by auto. - order. -Qed. - -Lemma min_elt_spec3 : forall s, min_elt s = None -> Empty s. -Proof. - intro s; functional induction (min_elt s). - red; red; inversion 2. - inversion 1. - intro H0. - destruct (IHo H0 _x2); auto. -Qed. - - - -(** * Maximum element *) - -Lemma max_elt_spec1 : forall s x, max_elt s = Some x -> InT x s. -Proof. - intro s; functional induction (max_elt s); auto; inversion 1; auto. -Qed. - -Lemma max_elt_spec2 : forall s x y `{Ok s}, - max_elt s = Some x -> InT y s -> ~ X.lt x y. -Proof. - intro s; functional induction (max_elt s); - try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1. - discriminate. - intros x y0 U V W. - inversion V; clear V; subst. - inv; order. - intros; inv; auto. - assert (X.lt y x1) by auto. - assert (~ X.lt x x1) by auto. - order. - assert (X.lt y x) by (apply H5; apply max_elt_spec1; auto). - order. -Qed. - -Lemma max_elt_spec3 : forall s, max_elt s = None -> Empty s. -Proof. - intro s; functional induction (max_elt s). - red; auto. - inversion 1. - intros H0; destruct (IHo H0 _x2); auto. -Qed. - - - -(** * Any element *) - -Lemma choose_spec1 : forall s x, choose s = Some x -> InT x s. -Proof. - exact min_elt_spec1. -Qed. - -Lemma choose_spec2 : forall s, choose s = None -> Empty s. -Proof. - exact min_elt_spec3. -Qed. - -Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'}, - choose s = Some x -> choose s' = Some x' -> - Equal s s' -> X.eq x x'. -Proof. - unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H. - assert (~X.lt x x'). - apply min_elt_spec2 with s'; auto. - rewrite <-H; auto using min_elt_spec1. - assert (~X.lt x' x). - apply min_elt_spec2 with s; auto. - rewrite H; auto using min_elt_spec1. - elim_compare x x'; intuition. -Qed. - - -(** * Concatenation *) +(** ** Concatenation *) Lemma concat_spec : forall s1 s2 y, InT y (concat s1 s2) <-> InT y s1 \/ InT y s2. Proof. intros s1 s2; functional induction (concat s1 s2); intros; - try factornode _x _x0 _x1 _x2 as s1. + try factornode s1. intuition_in. intuition_in. rewrite join_spec, remove_min_spec, e1; simpl; intuition. @@ -1121,7 +567,7 @@ Instance concat_ok s1 s2 : forall `(Ok s1, Ok s2) Ok (concat s1 s2). Proof. functional induction (concat s1 s2); intros; auto; - try factornode _x _x0 _x1 _x2 as s1. + try factornode s1. apply join_ok; auto. change (Ok (s2',m)#1); rewrite <-e1; eauto with *. intros y Hy. @@ -1132,7 +578,7 @@ Qed. -(** * Splitting *) +(** ** Splitting *) Lemma split_spec1 : forall s x y `{Ok s}, (InT y (split x s)#l <-> InT y s /\ X.lt y x). @@ -1174,11 +620,11 @@ Lemma split_ok : forall s x `{Ok s}, Ok (split x s)#l /\ Ok (split x s)#r. Proof. induct s x; simpl; auto. specialize (IHl x). - generalize (fun y => @split_spec2 _ x y H1). + generalize (fun y => @split_spec2 l x y _). destruct (split x l); simpl in *; intuition. apply join_ok; auto. intros y; rewrite H; intuition. specialize (IHr x). - generalize (fun y => @split_spec1 _ x y H2). + generalize (fun y => @split_spec1 r x y _). destruct (split x r); simpl in *; intuition. apply join_ok; auto. intros y; rewrite H; intuition. Qed. @@ -1190,7 +636,7 @@ Instance split_ok2 s x `(Ok s) : Ok (split x s)#r. Proof. intros; destruct (@split_ok s x); auto. Qed. -(** * Intersection *) +(** ** Intersection *) Ltac destruct_split := match goal with | H : split ?x ?s = << ?u, ?v, ?w >> |- _ => @@ -1204,23 +650,24 @@ Lemma inter_spec_ok : forall s1 s2 `{Ok s1, Ok s2}, Ok (inter s1 s2) /\ (forall y, InT y (inter s1 s2) <-> InT y s1 /\ InT y s2). Proof. intros s1 s2; functional induction inter s1 s2; intros B1 B2; - [intuition_in|intuition_in | | ]; - factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv; + [intuition_in|intuition_in | | ]; factornode s2; + destruct_split; inv; destruct IHt0 as (IHo1,IHi1), IHt1 as (IHo2,IHi2); auto with *; split; intros. - (* Ok join *) - apply join_ok; auto with *; intro y; rewrite ?IHi1, ?IHi2; intuition. - (* InT join *) - rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in. - setoid_replace y with x1; auto. rewrite <- split_spec3; auto. - (* Ok concat *) - apply concat_ok; auto with *; intros y1 y2; rewrite IHi1, IHi2; intuition; order. - (* InT concat *) - rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; auto. - intuition_in. - absurd (InT x1 s2). - rewrite <- split_spec3; auto; congruence. - setoid_replace x1 with y; auto. + - (* Ok join *) + apply join_ok; auto with *; intro y; rewrite ?IHi1, ?IHi2; intuition. + - (* InT join *) + rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in. + setoid_replace y with x1; auto. rewrite <- split_spec3; auto. + - (* Ok concat *) + apply concat_ok; auto with *; intros y1 y2; rewrite IHi1, IHi2; + intuition; order. + - (* InT concat *) + rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; auto. + intuition_in. + absurd (InT x1 s2). + rewrite <- split_spec3; auto; congruence. + setoid_replace x1 with y; auto. Qed. Lemma inter_spec : forall s1 s2 y `{Ok s1, Ok s2}, @@ -1231,31 +678,31 @@ Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2). Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed. -(** * Difference *) +(** ** Difference *) Lemma diff_spec_ok : forall s1 s2 `{Ok s1, Ok s2}, Ok (diff s1 s2) /\ (forall y, InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2). Proof. intros s1 s2; functional induction diff s1 s2; intros B1 B2; - [intuition_in|intuition_in | | ]; - factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv; + [intuition_in|intuition_in | | ]; factornode s2; + destruct_split; inv; destruct IHt0 as (IHb1,IHi1), IHt1 as (IHb2,IHi2); auto with *; split; intros. - (* Ok concat *) - apply concat_ok; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order. - (* InT concat *) - rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in. - absurd (InT x1 s2). - setoid_replace x1 with y; auto. - rewrite <- split_spec3; auto; congruence. - (* Ok join *) - apply join_ok; auto; intro y; rewrite ?IHi1, ?IHi2; intuition. - (* InT join *) - rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; auto with *. - intuition_in. - absurd (InT x1 s2); auto. - rewrite <- split_spec3; auto; congruence. - setoid_replace x1 with y; auto. + - (* Ok concat *) + apply concat_ok; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order. + - (* InT concat *) + rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in. + absurd (InT x1 s2). + + setoid_replace x1 with y; auto. + + rewrite <- split_spec3; auto; congruence. + - (* Ok join *) + apply join_ok; auto; intro y; rewrite ?IHi1, ?IHi2; intuition. + - (* InT join *) + rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; auto with *. + intuition_in. + absurd (InT x1 s2); auto. + * rewrite <- split_spec3; auto; congruence. + * setoid_replace x1 with y; auto. Qed. Lemma diff_spec : forall s1 s2 y `{Ok s1, Ok s2}, @@ -1266,7 +713,7 @@ Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2). Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed. -(** * Union *) +(** ** Union *) Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2}, (InT y (union s1 s2) <-> InT y s1 \/ InT y s2). @@ -1274,548 +721,90 @@ Proof. intros s1 s2; functional induction union s1 s2; intros y B1 B2. intuition_in. intuition_in. - factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv. + factornode s2; destruct_split; inv. rewrite join_spec, IHt0, IHt1, split_spec1, split_spec2; auto with *. - elim_compare y x1; intuition_in. + destruct (X.compare_spec y x1); intuition_in. Qed. Instance union_ok s1 s2 : forall `(Ok s1, Ok s2), Ok (union s1 s2). Proof. functional induction union s1 s2; intros B1 B2; auto. - factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv. + factornode s2; destruct_split; inv. apply join_ok; auto with *. intro y; rewrite union_spec, split_spec1; intuition_in. intro y; rewrite union_spec, split_spec2; intuition_in. Qed. - -(** * Elements *) - -Lemma elements_spec1' : forall s acc x, - InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc. -Proof. - induction s as [ | l Hl x r Hr h ]; simpl; auto. - intuition. - inversion H0. - intros. - rewrite Hl. - destruct (Hr acc x0); clear Hl Hr. - intuition; inversion_clear H3; intuition. -Qed. - -Lemma elements_spec1 : forall s x, InA X.eq x (elements s) <-> InT x s. -Proof. - intros; generalize (elements_spec1' s nil x); intuition. - inversion_clear H0. -Qed. - -Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc -> - (forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) -> - sort X.lt (elements_aux acc s). -Proof. - induction s as [ | l Hl y r Hr h]; simpl; intuition. - inv. - apply Hl; auto. - constructor. - apply Hr; auto. - eapply InA_InfA; eauto with *. - intros. - destruct (elements_spec1' r acc y0); intuition. - intros. - inversion_clear H. - order. - destruct (elements_spec1' r acc x); intuition eauto. -Qed. - -Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s). -Proof. - intros; unfold elements; apply elements_spec2'; auto. - intros; inversion H0. -Qed. -Local Hint Resolve elements_spec2. - -Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s). -Proof. - intros. eapply SortA_NoDupA; eauto with *. -Qed. - -Lemma elements_aux_cardinal : - forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s). -Proof. - simple induction s; simpl in |- *; intuition. - rewrite <- H. - simpl in |- *. - rewrite <- H0; omega. -Qed. - -Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s). -Proof. - exact (fun s => elements_aux_cardinal s nil). -Qed. - -Definition cardinal_spec (s:t)(Hs:Ok s) := elements_cardinal s. - -Lemma elements_app : - forall s acc, elements_aux acc s = elements s ++ acc. -Proof. - induction s; simpl; intros; auto. - rewrite IHs1, IHs2. - unfold elements; simpl. - rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto. -Qed. - -Lemma elements_node : - forall l x r h acc, - elements l ++ x :: elements r ++ acc = - elements (Node l x r h) ++ acc. -Proof. - unfold elements; simpl; intros; auto. - rewrite !elements_app, <- !app_nil_end, !app_ass; auto. -Qed. - - (** * Filter *) -Lemma filter_spec' : forall s x acc f, - Proper (X.eq==>eq) f -> - (InT x (filter_acc f acc s) <-> InT x acc \/ InT x s /\ f x = true). -Proof. - induction s; simpl; intros. - intuition_in. - rewrite IHs2, IHs1 by (destruct (f t0); auto). - case_eq (f t0); intros. - rewrite add_spec'; auto. - intuition_in. - rewrite (H _ _ H2). - intuition. - intuition_in. - rewrite (H _ _ H2) in H3. - rewrite H0 in H3; discriminate. -Qed. - -Instance filter_ok' : forall s acc f `(Ok s, Ok acc), - Ok (filter_acc f acc s). +Lemma filter_spec : forall s x f, + Proper (X.eq==>Logic.eq) f -> + (InT x (filter f s) <-> InT x s /\ f x = true). Proof. - induction s; simpl; auto. - intros. inv. - destruct (f t0); auto with *. + induction s as [ |h l Hl x0 r Hr]; intros x f Hf; simpl. + - intuition_in. + - case_eq (f x0); intros Hx0. + * rewrite join_spec, Hl, Hr; intuition_in. + now setoid_replace x with x0. + * rewrite concat_spec, Hl, Hr; intuition_in. + assert (f x = f x0) by auto. congruence. Qed. -Lemma filter_spec : forall s x f, - Proper (X.eq==>eq) f -> - (InT x (filter f s) <-> InT x s /\ f x = true). +Lemma filter_weak_spec : forall s x f, + InT x (filter f s) -> InT x s. Proof. - unfold filter; intros; rewrite filter_spec'; intuition_in. + induction s as [ |h l Hl x0 r Hr]; intros x f; simpl. + - trivial. + - destruct (f x0). + * rewrite join_spec; intuition_in; eauto. + * rewrite concat_spec; intuition_in; eauto. Qed. -Instance filter_ok s f `(Ok s) : Ok (filter f s). +Instance filter_ok s f `(H : Ok s) : Ok (filter f s). Proof. - unfold filter; intros; apply filter_ok'; auto. + induction H as [ | h x l r Hl Hfl Hr Hfr Hlt Hgt ]. + - constructor. + - simpl. + assert (lt_tree x (filter f l)) by (eauto using filter_weak_spec). + assert (gt_tree x (filter f r)) by (eauto using filter_weak_spec). + destruct (f x); eauto using concat_ok, join_ok. Qed. (** * Partition *) -Lemma partition_spec1' : forall s acc f, - Proper (X.eq==>eq) f -> forall x : elt, - InT x (partition_acc f acc s)#1 <-> - InT x acc#1 \/ InT x s /\ f x = true. +Lemma partition_spec1' s f : (partition f s)#1 = filter f s. Proof. - induction s; simpl; intros. - intuition_in. - destruct acc as [acct accf]; simpl in *. - rewrite IHs2 by - (destruct (f t0); auto; apply partition_acc_avl_1; simpl; auto). - rewrite IHs1 by (destruct (f t0); simpl; auto). - case_eq (f t0); simpl; intros. - rewrite add_spec'; auto. - intuition_in. - rewrite (H _ _ H2). - intuition. - intuition_in. - rewrite (H _ _ H2) in H3. - rewrite H0 in H3; discriminate. + induction s as [ | h l Hl x r Hr ]; simpl. + - trivial. + - rewrite <- Hl, <- Hr. + now destruct (partition f l), (partition f r), (f x). Qed. -Lemma partition_spec2' : forall s acc f, - Proper (X.eq==>eq) f -> forall x : elt, - InT x (partition_acc f acc s)#2 <-> - InT x acc#2 \/ InT x s /\ f x = false. +Lemma partition_spec2' s f : + (partition f s)#2 = filter (fun x => negb (f x)) s. Proof. - induction s; simpl; intros. - intuition_in. - destruct acc as [acct accf]; simpl in *. - rewrite IHs2 by - (destruct (f t0); auto; apply partition_acc_avl_2; simpl; auto). - rewrite IHs1 by (destruct (f t0); simpl; auto). - case_eq (f t0); simpl; intros. - intuition. - intuition_in. - rewrite (H _ _ H2) in H3. - rewrite H0 in H3; discriminate. - rewrite add_spec'; auto. - intuition_in. - rewrite (H _ _ H2). - intuition. + induction s as [ | h l Hl x r Hr ]; simpl. + - trivial. + - rewrite <- Hl, <- Hr. + now destruct (partition f l), (partition f r), (f x). Qed. -Lemma partition_spec1 : forall s f, - Proper (X.eq==>eq) f -> +Lemma partition_spec1 s f : + Proper (X.eq==>Logic.eq) f -> Equal (partition f s)#1 (filter f s). -Proof. - unfold partition; intros s f P x. - rewrite partition_spec1', filter_spec; simpl; intuition_in. -Qed. +Proof. now rewrite partition_spec1'. Qed. -Lemma partition_spec2 : forall s f, - Proper (X.eq==>eq) f -> +Lemma partition_spec2 s f : + Proper (X.eq==>Logic.eq) f -> Equal (partition f s)#2 (filter (fun x => negb (f x)) s). -Proof. - unfold partition; intros s f P x. - rewrite partition_spec2', filter_spec; simpl; intuition_in. - rewrite H1; auto. - right; split; auto. - rewrite negb_true_iff in H1; auto. - intros u v H; rewrite H; auto. -Qed. - -Instance partition_ok1' : forall s acc f `(Ok s, Ok acc#1), - Ok (partition_acc f acc s)#1. -Proof. - induction s; simpl; auto. - destruct acc as [acct accf]; simpl in *. - intros. inv. - destruct (f t0); auto. - apply IHs2; simpl; auto. - apply IHs1; simpl; auto with *. -Qed. - -Instance partition_ok2' : forall s acc f `(Ok s, Ok acc#2), - Ok (partition_acc f acc s)#2. -Proof. - induction s; simpl; auto. - destruct acc as [acct accf]; simpl in *. - intros. inv. - destruct (f t0); auto. - apply IHs2; simpl; auto. - apply IHs1; simpl; auto with *. -Qed. +Proof. now rewrite partition_spec2'. Qed. Instance partition_ok1 s f `(Ok s) : Ok (partition f s)#1. -Proof. apply partition_ok1'; auto. Qed. +Proof. rewrite partition_spec1'; now apply filter_ok. Qed. Instance partition_ok2 s f `(Ok s) : Ok (partition f s)#2. -Proof. apply partition_ok2'; auto. Qed. - - - -(** * [for_all] and [exists] *) - -Lemma for_all_spec : forall s f, Proper (X.eq==>eq) f -> - (for_all f s = true <-> For_all (fun x => f x = true) s). -Proof. - split. - induction s; simpl; auto; intros; red; intros; inv. - destruct (andb_prop _ _ H0); auto. - destruct (andb_prop _ _ H1); eauto. - apply IHs1; auto. - destruct (andb_prop _ _ H0); auto. - destruct (andb_prop _ _ H1); auto. - apply IHs2; auto. - destruct (andb_prop _ _ H0); auto. - (* <- *) - induction s; simpl; auto. - intros. red in H0. - rewrite IHs1; try red; auto. - rewrite IHs2; try red; auto. - generalize (H0 t0). - destruct (f t0); simpl; auto. -Qed. - -Lemma exists_spec : forall s f, Proper (X.eq==>eq) f -> - (exists_ f s = true <-> Exists (fun x => f x = true) s). -Proof. - split. - induction s; simpl; intros; rewrite <- ?orb_lazy_alt in *. - discriminate. - destruct (orb_true_elim _ _ H0) as [H1|H1]. - destruct (orb_true_elim _ _ H1) as [H2|H2]. - exists t0; auto. - destruct (IHs1 H2); auto; exists x; intuition. - destruct (IHs2 H1); auto; exists x; intuition. - (* <- *) - induction s; simpl; destruct 1 as (x,(U,V)); inv; rewrite <- ?orb_lazy_alt. - rewrite (H _ _ (MX.eq_sym H0)); rewrite V; auto. - apply orb_true_intro; left. - apply orb_true_intro; right; apply IHs1; auto; exists x; auto. - apply orb_true_intro; right; apply IHs2; auto; exists x; auto. -Qed. - - -(** * Fold *) - -Lemma fold_spec' : - forall (A : Type) (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt), - fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i). -Proof. - induction s as [|l IHl x r IHr h]; simpl; intros; auto. - rewrite IHl. - simpl. unfold flip at 2. - apply IHr. -Qed. - -Lemma fold_spec : - forall (s:t) (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (flip f) (elements s) i. -Proof. - unfold elements. - induction s as [|l IHl x r IHr h]; simpl; intros; auto. - rewrite fold_spec'. - rewrite IHr. - simpl; auto. -Qed. - - -(** * Subset *) - -Lemma subsetl_spec : forall subset_l1 l1 x1 h1 s2 - `{Ok (Node l1 x1 Leaf h1), Ok s2}, - (forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) -> - (subsetl subset_l1 x1 s2 = true <-> Subset (Node l1 x1 Leaf h1) s2 ). -Proof. - induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros. - unfold Subset; intuition; try discriminate. - assert (H': InT x1 Leaf) by auto; inversion H'. - specialize (IHl2 H). - specialize (IHr2 H). - inv. - elim_compare x1 x2. - - rewrite H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (X.eq a x2) by order; intuition_in. - assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite IHl2 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto. - rewrite mem_spec; auto. - assert (InT x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order. -Qed. - - -Lemma subsetr_spec : forall subset_r1 r1 x1 h1 s2, - bst (Node Leaf x1 r1 h1) -> bst s2 -> - (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) -> - (subsetr subset_r1 x1 s2 = true <-> Subset (Node Leaf x1 r1 h1) s2). -Proof. - induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros. - unfold Subset; intuition; try discriminate. - assert (H': InT x1 Leaf) by auto; inversion H'. - specialize (IHl2 H). - specialize (IHr2 H). - inv. - elim_compare x1 x2. - - rewrite H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (X.eq a x2) by order; intuition_in. - assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto. - rewrite mem_spec; auto. - assert (InT x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite IHr2 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. -Qed. - -Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2}, - (subset s1 s2 = true <-> Subset s1 s2). -Proof. - induction s1 as [|l1 IHl1 x1 r1 IHr1 h1]; simpl; intros. - unfold Subset; intuition_in. - destruct s2 as [|l2 x2 r2 h2]; simpl; intros. - unfold Subset; intuition_in; try discriminate. - assert (H': InT x1 Leaf) by auto; inversion H'. - inv. - elim_compare x1 x2. - - rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - assert (X.eq a x2) by order; intuition_in. - assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto. - rewrite (@subsetl_spec (subset l1) l1 x1 h1) by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto. - rewrite (@subsetr_spec (subset r1) r1 x1 h1) by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. -Qed. - - -(** * Comparison *) - -(** ** Relations [eq] and [lt] over trees *) - -Module L := MakeListOrdering X. - -Definition eq := Equal. -Instance eq_equiv : Equivalence eq. -Proof. firstorder. Qed. - -Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s'). -Proof. - unfold eq, Equal, L.eq; intros. - setoid_rewrite elements_spec1; firstorder. -Qed. - -Definition lt (s1 s2 : t) : Prop := - exists s1' s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2' - /\ L.lt (elements s1') (elements s2'). - -Instance lt_strorder : StrictOrder lt. -Proof. - split. - intros s (s1 & s2 & B1 & B2 & E1 & E2 & L). - assert (eqlistA X.eq (elements s1) (elements s2)). - apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *. - rewrite <- eq_Leq. transitivity s; auto. symmetry; auto. - rewrite H in L. - apply (StrictOrder_Irreflexive (elements s2)); auto. - intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12) - (s2'' & s3' & B2' & B3 & E2' & E3 & L23). - exists s1', s3'; do 4 (split; trivial). - assert (eqlistA X.eq (elements s2') (elements s2'')). - apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *. - rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto. - transitivity (elements s2'); auto. - rewrite H; auto. -Qed. - -Instance lt_compat : Proper (eq==>eq==>iff) lt. -Proof. - intros s1 s2 E12 s3 s4 E34. split. - intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). - exists s1', s3'; do 2 (split; trivial). - split. transitivity s1; auto. symmetry; auto. - split; auto. transitivity s3; auto. symmetry; auto. - intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). - exists s1', s3'; do 2 (split; trivial). - split. transitivity s2; auto. - split; auto. transitivity s4; auto. -Qed. - - -(** * Proof of the comparison algorithm *) - -(** [flatten_e e] returns the list of elements of [e] i.e. the list - of elements actually compared *) - -Fixpoint flatten_e (e : enumeration) : list elt := match e with - | End => nil - | More x t r => x :: elements t ++ flatten_e r - end. - -Lemma flatten_e_elements : - forall l x r h e, - elements l ++ flatten_e (More x r e) = elements (Node l x r h) ++ flatten_e e. -Proof. - intros; simpl; apply elements_node. -Qed. - -Lemma cons_1 : forall s e, - flatten_e (cons s e) = elements s ++ flatten_e e. -Proof. - induction s; simpl; auto; intros. - rewrite IHs1; apply flatten_e_elements. -Qed. - -(** Correctness of this comparison *) - -Definition Cmp c x y := CompSpec L.eq L.lt x y c. - -Local Hint Unfold Cmp flip. - -Lemma compare_end_Cmp : - forall e2, Cmp (compare_end e2) nil (flatten_e e2). -Proof. - destruct e2; simpl; constructor; auto. reflexivity. -Qed. - -Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, - Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> - Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l) - (flatten_e (More x2 r2 e2)). -Proof. - simpl; intros; elim_compare x1 x2; simpl; red; auto. -Qed. - -Lemma compare_cont_Cmp : forall s1 cont e2 l, - (forall e, Cmp (cont e) l (flatten_e e)) -> - Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2). -Proof. - induction s1 as [|l1 Hl1 x1 r1 Hr1 h1]; simpl; intros; auto. - rewrite <- elements_node; simpl. - apply Hl1; auto. clear e2. intros [|x2 r2 e2]. - simpl; auto. - apply compare_more_Cmp. - rewrite <- cons_1; auto. -Qed. - -Lemma compare_Cmp : forall s1 s2, - Cmp (compare s1 s2) (elements s1) (elements s2). -Proof. - intros; unfold compare. - rewrite (app_nil_end (elements s1)). - replace (elements s2) with (flatten_e (cons s2 End)) by - (rewrite cons_1; simpl; rewrite <- app_nil_end; auto). - apply compare_cont_Cmp; auto. - intros. - apply compare_end_Cmp; auto. -Qed. - -Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2}, - CompSpec eq lt s1 s2 (compare s1 s2). -Proof. - intros. - destruct (compare_Cmp s1 s2); constructor. - rewrite eq_Leq; auto. - intros; exists s1, s2; repeat split; auto. - intros; exists s2, s1; repeat split; auto. -Qed. - - -(** * Equality test *) - -Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2}, - equal s1 s2 = true <-> eq s1 s2. -Proof. -unfold equal; intros s1 s2 B1 B2. -destruct (@compare_spec s1 s2 B1 B2) as [H|H|H]; - split; intros H'; auto; try discriminate. -rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto. -rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto. -Qed. +Proof. rewrite partition_spec2'; now apply filter_ok. Qed. End MakeRaw. diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v new file mode 100644 index 00000000..704ff31b --- /dev/null +++ b/theories/MSets/MSetGenTree.v @@ -0,0 +1,1145 @@ +(***********************************************************************) +(* 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 *) +(***********************************************************************) + +(** * MSetGenTree : sets via generic trees + + This module factorizes common parts in implementations + of finite sets as AVL trees and as Red-Black trees. The nodes + of the trees defined here include an generic information + parameter, that will be the heigth in AVL trees and the color + in Red-Black trees. Without more details here about these + information parameters, trees here are not known to be + well-balanced, but simply binary-search-trees. + + The operations we could define and prove correct here are the + one that do not build non-empty trees, but only analyze them : + + - empty is_empty + - mem + - compare equal subset + - fold cardinal elements + - for_all exists_ + - min_elt max_elt choose +*) + +Require Import Orders OrdersFacts MSetInterface NPeano. +Local Open Scope list_scope. +Local Open Scope lazy_bool_scope. + +(* For nicer extraction, we create induction principles + only when needed *) +Local Unset Elimination Schemes. +Local Unset Case Analysis Schemes. + +Module Type InfoTyp. + Parameter t : Set. +End InfoTyp. + +(** * Ops : the pure functions *) + +Module Type Ops (X:OrderedType)(Info:InfoTyp). + +Definition elt := X.t. +Hint Transparent elt. + +Inductive tree : Type := +| Leaf : tree +| Node : Info.t -> tree -> X.t -> tree -> tree. + +(** ** The empty set and emptyness test *) + +Definition empty := Leaf. + +Definition is_empty t := + match t with + | Leaf => true + | _ => false + end. + +(** ** Membership test *) + +(** The [mem] function is deciding membership. It exploits the + binary search tree invariant to achieve logarithmic complexity. *) + +Fixpoint mem x t := + match t with + | Leaf => false + | Node _ l k r => + match X.compare x k with + | Lt => mem x l + | Eq => true + | Gt => mem x r + end + end. + +(** ** Minimal, maximal, arbitrary elements *) + +Fixpoint min_elt (t : tree) : option elt := + match t with + | Leaf => None + | Node _ Leaf x r => Some x + | Node _ l x r => min_elt l + end. + +Fixpoint max_elt (t : tree) : option elt := + match t with + | Leaf => None + | Node _ l x Leaf => Some x + | Node _ l x r => max_elt r + end. + +Definition choose := min_elt. + +(** ** Iteration on elements *) + +Fixpoint fold {A: Type} (f: elt -> A -> A) (t: tree) (base: A) : A := + match t with + | Leaf => base + | Node _ l x r => fold f r (f x (fold f l base)) + end. + +Fixpoint elements_aux acc s := + match s with + | Leaf => acc + | Node _ l x r => elements_aux (x :: elements_aux acc r) l + end. + +Definition elements := elements_aux nil. + +Fixpoint rev_elements_aux acc s := + match s with + | Leaf => acc + | Node _ l x r => rev_elements_aux (x :: rev_elements_aux acc l) r + end. + +Definition rev_elements := rev_elements_aux nil. + +Fixpoint cardinal (s : tree) : nat := + match s with + | Leaf => 0 + | Node _ l _ r => S (cardinal l + cardinal r) + end. + +Fixpoint maxdepth s := + match s with + | Leaf => 0 + | Node _ l _ r => S (max (maxdepth l) (maxdepth r)) + end. + +Fixpoint mindepth s := + match s with + | Leaf => 0 + | Node _ l _ r => S (min (mindepth l) (mindepth r)) + end. + +(** ** Testing universal or existential properties. *) + +(** We do not use the standard boolean operators of Coq, + but lazy ones. *) + +Fixpoint for_all (f:elt->bool) s := match s with + | Leaf => true + | Node _ l x r => f x &&& for_all f l &&& for_all f r +end. + +Fixpoint exists_ (f:elt->bool) s := match s with + | Leaf => false + | Node _ l x r => f x ||| exists_ f l ||| exists_ f r +end. + +(** ** Comparison of trees *) + +(** The algorithm here has been suggested by Xavier Leroy, + and transformed into c.p.s. by Benjamin Grégoire. + The original ocaml code (with non-structural recursive calls) + has also been formalized (thanks to Function+measure), see + [ocaml_compare] in [MSetFullAVL]. The following code with + continuations computes dramatically faster in Coq, and + should be almost as efficient after extraction. +*) + +(** Enumeration of the elements of a tree. This corresponds + to the "samefringe" notion in the litterature. *) + +Inductive enumeration := + | End : enumeration + | More : elt -> tree -> enumeration -> enumeration. + + +(** [cons t e] adds the elements of tree [t] on the head of + enumeration [e]. *) + +Fixpoint cons s e : enumeration := + match s with + | Leaf => e + | Node _ l x r => cons l (More x r e) + end. + +(** One step of comparison of elements *) + +Definition compare_more x1 (cont:enumeration->comparison) e2 := + match e2 with + | End => Gt + | More x2 r2 e2 => + match X.compare x1 x2 with + | Eq => cont (cons r2 e2) + | Lt => Lt + | Gt => Gt + end + end. + +(** Comparison of left tree, middle element, then right tree *) + +Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := + match s1 with + | Leaf => cont e2 + | Node _ l1 x1 r1 => + compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2 + end. + +(** Initial continuation *) + +Definition compare_end e2 := + match e2 with End => Eq | _ => Lt end. + +(** The complete comparison *) + +Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End). + +Definition equal s1 s2 := + match compare s1 s2 with Eq => true | _ => false end. + +(** ** Subset test *) + +(** In ocaml, recursive calls are made on "half-trees" such as + (Node _ l1 x1 Leaf) and (Node _ Leaf x1 r1). Instead of these + non-structural calls, we propose here two specialized functions + for these situations. This version should be almost as efficient + as the one of ocaml (closures as arguments may slow things a bit), + it is simply less compact. The exact ocaml version has also been + formalized (thanks to Function+measure), see [ocaml_subset] in + [MSetFullAVL]. +*) + +Fixpoint subsetl (subset_l1 : tree -> bool) x1 s2 : bool := + match s2 with + | Leaf => false + | Node _ l2 x2 r2 => + match X.compare x1 x2 with + | Eq => subset_l1 l2 + | Lt => subsetl subset_l1 x1 l2 + | Gt => mem x1 r2 &&& subset_l1 s2 + end + end. + +Fixpoint subsetr (subset_r1 : tree -> bool) x1 s2 : bool := + match s2 with + | Leaf => false + | Node _ l2 x2 r2 => + match X.compare x1 x2 with + | Eq => subset_r1 r2 + | Lt => mem x1 l2 &&& subset_r1 s2 + | Gt => subsetr subset_r1 x1 r2 + end + end. + +Fixpoint subset s1 s2 : bool := match s1, s2 with + | Leaf, _ => true + | Node _ _ _ _, Leaf => false + | Node _ l1 x1 r1, Node _ l2 x2 r2 => + match X.compare x1 x2 with + | Eq => subset l1 l2 &&& subset r1 r2 + | Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2 + | Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2 + end + end. + +End Ops. + +(** * Props : correctness proofs of these generic operations *) + +Module Type Props (X:OrderedType)(Info:InfoTyp)(Import M:Ops X Info). + +(** ** Occurrence in a tree *) + +Inductive InT (x : elt) : tree -> Prop := + | IsRoot : forall c l r y, X.eq x y -> InT x (Node c l y r) + | InLeft : forall c l r y, InT x l -> InT x (Node c l y r) + | InRight : forall c l r y, InT x r -> InT x (Node c l y r). + +Definition In := InT. + +(** ** Some shortcuts *) + +Definition Equal s s' := forall a : elt, InT a s <-> InT a s'. +Definition Subset s s' := forall a : elt, InT a s -> InT a s'. +Definition Empty s := forall a : elt, ~ InT a s. +Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x. +Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x. + +(** ** Binary search trees *) + +(** [lt_tree x s]: all elements in [s] are smaller than [x] + (resp. greater for [gt_tree]) *) + +Definition lt_tree x s := forall y, InT y s -> X.lt y x. +Definition gt_tree x s := forall y, InT y s -> X.lt x y. + +(** [bst t] : [t] is a binary search tree *) + +Inductive bst : tree -> Prop := + | BSLeaf : bst Leaf + | BSNode : forall c x l r, bst l -> bst r -> + lt_tree x l -> gt_tree x r -> bst (Node c l x r). + +(** [bst] is the (decidable) invariant our trees will have to satisfy. *) + +Definition IsOk := bst. + +Class Ok (s:tree) : Prop := ok : bst s. + +Instance bst_Ok s (Hs : bst s) : Ok s := { ok := Hs }. + +Fixpoint ltb_tree x s := + match s with + | Leaf => true + | Node _ l y r => + match X.compare x y with + | Gt => ltb_tree x l && ltb_tree x r + | _ => false + end + end. + +Fixpoint gtb_tree x s := + match s with + | Leaf => true + | Node _ l y r => + match X.compare x y with + | Lt => gtb_tree x l && gtb_tree x r + | _ => false + end + end. + +Fixpoint isok s := + match s with + | Leaf => true + | Node _ l x r => isok l && isok r && ltb_tree x l && gtb_tree x r + end. + + +(** ** Known facts about ordered types *) + +Module Import MX := OrderedTypeFacts X. + +(** ** Automation and dedicated tactics *) + +Scheme tree_ind := Induction for tree Sort Prop. +Scheme bst_ind := Induction for bst Sort Prop. + +Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok. +Local Hint Immediate MX.eq_sym. +Local Hint Unfold In lt_tree gt_tree. +Local Hint Constructors InT bst. +Local Hint Unfold Ok. + +(** Automatic treatment of [Ok] hypothesis *) + +Ltac clear_inversion H := inversion H; clear H; subst. + +Ltac inv_ok := match goal with + | H:Ok (Node _ _ _ _) |- _ => clear_inversion H; inv_ok + | H:Ok Leaf |- _ => clear H; inv_ok + | H:bst ?x |- _ => change (Ok x) in H; inv_ok + | _ => idtac +end. + +(** A tactic to repeat [inversion_clear] on all hyps of the + form [(f (Node _ _ _ _))] *) + +Ltac is_tree_constr c := + match c with + | Leaf => idtac + | Node _ _ _ _ => idtac + | _ => fail + end. + +Ltac invtree f := + match goal with + | H:f ?s |- _ => is_tree_constr s; clear_inversion H; invtree f + | H:f _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f + | H:f _ _ ?s |- _ => is_tree_constr s; clear_inversion H; invtree f + | _ => idtac + end. + +Ltac inv := inv_ok; invtree InT. + +Ltac intuition_in := repeat progress (intuition; inv). + +(** Helper tactic concerning order of elements. *) + +Ltac order := match goal with + | U: lt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order + | U: gt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order + | _ => MX.order +end. + + +(** [isok] is indeed a decision procedure for [Ok] *) + +Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true. +Proof. + induction s as [|c l IHl y r IHr]; simpl. + unfold lt_tree; intuition_in. + elim_compare x y. + split; intros; try discriminate. assert (X.lt y x) by auto. order. + split; intros; try discriminate. assert (X.lt y x) by auto. order. + rewrite !andb_true_iff, <-IHl, <-IHr. + unfold lt_tree; intuition_in; order. +Qed. + +Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true. +Proof. + induction s as [|c l IHl y r IHr]; simpl. + unfold gt_tree; intuition_in. + elim_compare x y. + split; intros; try discriminate. assert (X.lt x y) by auto. order. + rewrite !andb_true_iff, <-IHl, <-IHr. + unfold gt_tree; intuition_in; order. + split; intros; try discriminate. assert (X.lt x y) by auto. order. +Qed. + +Lemma isok_iff : forall s, Ok s <-> isok s = true. +Proof. + induction s as [|c l IHl y r IHr]; simpl. + intuition_in. + rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff. + intuition_in. +Qed. + +Instance isok_Ok s : isok s = true -> Ok s | 10. +Proof. intros; apply <- isok_iff; auto. Qed. + +(** ** Basic results about [In] *) + +Lemma In_1 : + forall s x y, X.eq x y -> InT x s -> InT y s. +Proof. + induction s; simpl; intuition_in; eauto. +Qed. +Local Hint Immediate In_1. + +Instance In_compat : Proper (X.eq==>eq==>iff) InT. +Proof. +apply proper_sym_impl_iff_2; auto with *. +repeat red; intros; subst. apply In_1 with x; auto. +Qed. + +Lemma In_node_iff : + forall c l x r y, + InT y (Node c l x r) <-> InT y l \/ X.eq y x \/ InT y r. +Proof. + intuition_in. +Qed. + +Lemma In_leaf_iff : forall x, InT x Leaf <-> False. +Proof. + intuition_in. +Qed. + +(** Results about [lt_tree] and [gt_tree] *) + +Lemma lt_leaf : forall x : elt, lt_tree x Leaf. +Proof. + red; inversion 1. +Qed. + +Lemma gt_leaf : forall x : elt, gt_tree x Leaf. +Proof. + red; inversion 1. +Qed. + +Lemma lt_tree_node : + forall (x y : elt) (l r : tree) (i : Info.t), + lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node i l y r). +Proof. + unfold lt_tree; intuition_in; order. +Qed. + +Lemma gt_tree_node : + forall (x y : elt) (l r : tree) (i : Info.t), + gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node i l y r). +Proof. + unfold gt_tree; intuition_in; order. +Qed. + +Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. + +Lemma lt_tree_not_in : + forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t. +Proof. + intros; intro; order. +Qed. + +Lemma lt_tree_trans : + forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t. +Proof. + eauto. +Qed. + +Lemma gt_tree_not_in : + forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t. +Proof. + intros; intro; order. +Qed. + +Lemma gt_tree_trans : + forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t. +Proof. + eauto. +Qed. + +Instance lt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) lt_tree. +Proof. + apply proper_sym_impl_iff_2; auto. + intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto. +Qed. + +Instance gt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) gt_tree. +Proof. + apply proper_sym_impl_iff_2; auto. + intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto. +Qed. + +Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. + +Ltac induct s x := + induction s as [|i l IHl x' r IHr]; simpl; intros; + [|elim_compare x x'; intros; inv]. + +Ltac auto_tc := auto with typeclass_instances. + +Ltac ok := + inv; change bst with Ok in *; + match goal with + | |- Ok (Node _ _ _ _) => constructor; auto_tc; ok + | |- lt_tree _ (Node _ _ _ _) => apply lt_tree_node; ok + | |- gt_tree _ (Node _ _ _ _) => apply gt_tree_node; ok + | _ => eauto with typeclass_instances + end. + +(** ** Empty set *) + +Lemma empty_spec : Empty empty. +Proof. + intros x H. inversion H. +Qed. + +Instance empty_ok : Ok empty. +Proof. + auto. +Qed. + +(** ** Emptyness test *) + +Lemma is_empty_spec : forall s, is_empty s = true <-> Empty s. +Proof. + destruct s as [|c r x l]; simpl; auto. + - split; auto. intros _ x H. inv. + - split; auto. try discriminate. intro H; elim (H x); auto. +Qed. + +(** ** Membership *) + +Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s. +Proof. + split. + - induct s x; now auto. + - induct s x; intuition_in; order. +Qed. + +(** ** Minimal and maximal elements *) + +Functional Scheme min_elt_ind := Induction for min_elt Sort Prop. +Functional Scheme max_elt_ind := Induction for max_elt Sort Prop. + +Lemma min_elt_spec1 s x : min_elt s = Some x -> InT x s. +Proof. + functional induction (min_elt s); auto; inversion 1; auto. +Qed. + +Lemma min_elt_spec2 s x y `{Ok s} : + min_elt s = Some x -> InT y s -> ~ X.lt y x. +Proof. + revert y. + functional induction (min_elt s); + try rename _x0 into r; try rename _x2 into l1, _x3 into x1, _x4 into r1. + - discriminate. + - intros y V W. + inversion V; clear V; subst. + inv; order. + - intros; inv; auto. + * assert (X.lt x x0) by (apply H8; apply min_elt_spec1; auto). + order. + * assert (X.lt x1 x0) by auto. + assert (~X.lt x1 x) by auto. + order. +Qed. + +Lemma min_elt_spec3 s : min_elt s = None -> Empty s. +Proof. + functional induction (min_elt s). + red; red; inversion 2. + inversion 1. + intro H0. + destruct (IHo H0 _x3); auto. +Qed. + +Lemma max_elt_spec1 s x : max_elt s = Some x -> InT x s. +Proof. + functional induction (max_elt s); auto; inversion 1; auto. +Qed. + +Lemma max_elt_spec2 s x y `{Ok s} : + max_elt s = Some x -> InT y s -> ~ X.lt x y. +Proof. + revert y. + functional induction (max_elt s); + try rename _x0 into r; try rename _x2 into l1, _x3 into x1, _x4 into r1. + - discriminate. + - intros y V W. + inversion V; clear V; subst. + inv; order. + - intros; inv; auto. + * assert (X.lt x0 x) by (apply H9; apply max_elt_spec1; auto). + order. + * assert (X.lt x0 x1) by auto. + assert (~X.lt x x1) by auto. + order. +Qed. + +Lemma max_elt_spec3 s : max_elt s = None -> Empty s. +Proof. + functional induction (max_elt s). + red; red; inversion 2. + inversion 1. + intro H0. + destruct (IHo H0 _x3); auto. +Qed. + +Lemma choose_spec1 : forall s x, choose s = Some x -> InT x s. +Proof. + exact min_elt_spec1. +Qed. + +Lemma choose_spec2 : forall s, choose s = None -> Empty s. +Proof. + exact min_elt_spec3. +Qed. + +Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'}, + choose s = Some x -> choose s' = Some x' -> + Equal s s' -> X.eq x x'. +Proof. + unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H. + assert (~X.lt x x'). + apply min_elt_spec2 with s'; auto. + rewrite <-H; auto using min_elt_spec1. + assert (~X.lt x' x). + apply min_elt_spec2 with s; auto. + rewrite H; auto using min_elt_spec1. + elim_compare x x'; intuition. +Qed. + +(** ** Elements *) + +Lemma elements_spec1' : forall s acc x, + InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc. +Proof. + induction s as [ | c l Hl x r Hr ]; simpl; auto. + intuition. + inversion H0. + intros. + rewrite Hl. + destruct (Hr acc x0); clear Hl Hr. + intuition; inversion_clear H3; intuition. +Qed. + +Lemma elements_spec1 : forall s x, InA X.eq x (elements s) <-> InT x s. +Proof. + intros; generalize (elements_spec1' s nil x); intuition. + inversion_clear H0. +Qed. + +Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc -> + (forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) -> + sort X.lt (elements_aux acc s). +Proof. + induction s as [ | c l Hl y r Hr]; simpl; intuition. + inv. + apply Hl; auto. + constructor. + apply Hr; auto. + eapply InA_InfA; eauto with *. + intros. + destruct (elements_spec1' r acc y0); intuition. + intros. + inversion_clear H. + order. + destruct (elements_spec1' r acc x); intuition eauto. +Qed. + +Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s). +Proof. + intros; unfold elements; apply elements_spec2'; auto. + intros; inversion H0. +Qed. +Local Hint Resolve elements_spec2. + +Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s). +Proof. + intros. eapply SortA_NoDupA; eauto with *. +Qed. + +Lemma elements_aux_cardinal : + forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s). +Proof. + simple induction s; simpl; intuition. + rewrite <- H. + simpl. + rewrite <- H0. rewrite (Nat.add_comm (cardinal t0)). + now rewrite <- Nat.add_succ_r, Nat.add_assoc. +Qed. + +Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s). +Proof. + exact (fun s => elements_aux_cardinal s nil). +Qed. + +Definition cardinal_spec (s:tree)(Hs:Ok s) := elements_cardinal s. + +Lemma elements_app : + forall s acc, elements_aux acc s = elements s ++ acc. +Proof. + induction s; simpl; intros; auto. + rewrite IHs1, IHs2. + unfold elements; simpl. + rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto. +Qed. + +Lemma elements_node c l x r : + elements (Node c l x r) = elements l ++ x :: elements r. +Proof. + unfold elements; simpl. + now rewrite !elements_app, !app_nil_r. +Qed. + +Lemma rev_elements_app : + forall s acc, rev_elements_aux acc s = rev_elements s ++ acc. +Proof. + induction s; simpl; intros; auto. + rewrite IHs1, IHs2. + unfold rev_elements; simpl. + rewrite IHs1, 2 IHs2, !app_nil_r, !app_ass; auto. +Qed. + +Lemma rev_elements_node c l x r : + rev_elements (Node c l x r) = rev_elements r ++ x :: rev_elements l. +Proof. + unfold rev_elements; simpl. + now rewrite !rev_elements_app, !app_nil_r. +Qed. + +Lemma rev_elements_rev s : rev_elements s = rev (elements s). +Proof. + induction s as [|c l IHl x r IHr]; trivial. + rewrite elements_node, rev_elements_node, IHl, IHr, rev_app_distr. + simpl. now rewrite !app_ass. +Qed. + +(** The converse of [elements_spec2], used in MSetRBT *) + +(* TODO: TO MIGRATE ELSEWHERE... *) + +Lemma sorted_app_inv l1 l2 : + sort X.lt (l1++l2) -> + sort X.lt l1 /\ sort X.lt l2 /\ + forall x1 x2, InA X.eq x1 l1 -> InA X.eq x2 l2 -> X.lt x1 x2. +Proof. + induction l1 as [|a1 l1 IHl1]. + - simpl; repeat split; auto. + intros. now rewrite InA_nil in *. + - simpl. inversion_clear 1 as [ | ? ? Hs Hhd ]. + destruct (IHl1 Hs) as (H1 & H2 & H3). + repeat split. + * constructor; auto. + destruct l1; simpl in *; auto; inversion_clear Hhd; auto. + * trivial. + * intros x1 x2 Hx1 Hx2. rewrite InA_cons in Hx1. destruct Hx1. + + rewrite H. + apply SortA_InfA_InA with (eqA:=X.eq)(l:=l1++l2); auto_tc. + rewrite InA_app_iff; auto_tc. + + auto. +Qed. + +Lemma elements_sort_ok s : sort X.lt (elements s) -> Ok s. +Proof. + induction s as [|c l IHl x r IHr]. + - auto. + - rewrite elements_node. + intros H. destruct (sorted_app_inv _ _ H) as (H1 & H2 & H3). + inversion_clear H2. + constructor; ok. + * intros y Hy. apply H3. + + now rewrite elements_spec1. + + rewrite InA_cons. now left. + * intros y Hy. + apply SortA_InfA_InA with (eqA:=X.eq)(l:=elements r); auto_tc. + now rewrite elements_spec1. +Qed. + +(** ** [for_all] and [exists] *) + +Lemma for_all_spec s f : Proper (X.eq==>eq) f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). +Proof. + intros Hf; unfold For_all. + induction s as [|i l IHl x r IHr]; simpl; auto. + - split; intros; inv; auto. + - rewrite <- !andb_lazy_alt, !andb_true_iff, IHl, IHr. clear IHl IHr. + intuition_in. eauto. +Qed. + +Lemma exists_spec s f : Proper (X.eq==>eq) f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). +Proof. + intros Hf; unfold Exists. + induction s as [|i l IHl x r IHr]; simpl; auto. + - split. + * discriminate. + * intros (y,(H,_)); inv. + - rewrite <- !orb_lazy_alt, !orb_true_iff, IHl, IHr. clear IHl IHr. + split; [intros [[H|(y,(H,H'))]|(y,(H,H'))]|intros (y,(H,H'))]. + * exists x; auto. + * exists y; auto. + * exists y; auto. + * inv; [left;left|left;right|right]; try (exists y); eauto. +Qed. + +(** ** Fold *) + +Lemma fold_spec' {A} (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt) : + fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i). +Proof. + revert i acc. + induction s as [|c l IHl x r IHr]; simpl; intros; auto. + rewrite IHl. + simpl. unfold flip at 2. + apply IHr. +Qed. + +Lemma fold_spec (s:tree) {A} (i : A) (f : elt -> A -> A) : + fold f s i = fold_left (flip f) (elements s) i. +Proof. + revert i. unfold elements. + induction s as [|c l IHl x r IHr]; simpl; intros; auto. + rewrite fold_spec'. + rewrite IHr. + simpl; auto. +Qed. + + +(** ** Subset *) + +Lemma subsetl_spec : forall subset_l1 l1 x1 c1 s2 + `{Ok (Node c1 l1 x1 Leaf), Ok s2}, + (forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) -> + (subsetl subset_l1 x1 s2 = true <-> Subset (Node c1 l1 x1 Leaf) s2 ). +Proof. + induction s2 as [|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros. + unfold Subset; intuition; try discriminate. + assert (H': InT x1 Leaf) by auto; inversion H'. + specialize (IHl2 H). + specialize (IHr2 H). + inv. + elim_compare x1 x2. + + rewrite H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (X.eq a x2) by order; intuition_in. + assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + + rewrite IHl2 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + + rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto. + rewrite mem_spec; auto. + assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order. +Qed. + + +Lemma subsetr_spec : forall subset_r1 r1 x1 c1 s2, + bst (Node c1 Leaf x1 r1) -> bst s2 -> + (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) -> + (subsetr subset_r1 x1 s2 = true <-> Subset (Node c1 Leaf x1 r1) s2). +Proof. + induction s2 as [|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros. + unfold Subset; intuition; try discriminate. + assert (H': InT x1 Leaf) by auto; inversion H'. + specialize (IHl2 H). + specialize (IHr2 H). + inv. + elim_compare x1 x2. + + rewrite H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (X.eq a x2) by order; intuition_in. + assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + + rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto. + rewrite mem_spec; auto. + assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order. + + rewrite IHr2 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. +Qed. + +Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2}, + (subset s1 s2 = true <-> Subset s1 s2). +Proof. + induction s1 as [|c1 l1 IHl1 x1 r1 IHr1]; simpl; intros. + unfold Subset; intuition_in. + destruct s2 as [|c2 l2 x2 r2]; simpl; intros. + unfold Subset; intuition_in; try discriminate. + assert (H': InT x1 Leaf) by auto; inversion H'. + inv. + elim_compare x1 x2. + + rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + assert (X.eq a x2) by order; intuition_in. + assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + + rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto. + rewrite (@subsetl_spec (subset l1) l1 x1 c1) by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + + rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto. + rewrite (@subsetr_spec (subset r1) r1 x1 c1) by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. + assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order. +Qed. + + +(** ** Comparison *) + +(** Relations [eq] and [lt] over trees *) + +Module L := MSetInterface.MakeListOrdering X. + +Definition eq := Equal. +Instance eq_equiv : Equivalence eq. +Proof. firstorder. Qed. + +Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s'). +Proof. + unfold eq, Equal, L.eq; intros. + setoid_rewrite elements_spec1; firstorder. +Qed. + +Definition lt (s1 s2 : tree) : Prop := + exists s1' s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2' + /\ L.lt (elements s1') (elements s2'). + +Instance lt_strorder : StrictOrder lt. +Proof. + split. + intros s (s1 & s2 & B1 & B2 & E1 & E2 & L). + assert (eqlistA X.eq (elements s1) (elements s2)). + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *. + rewrite <- eq_Leq. transitivity s; auto. symmetry; auto. + rewrite H in L. + apply (StrictOrder_Irreflexive (elements s2)); auto. + intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12) + (s2'' & s3' & B2' & B3 & E2' & E3 & L23). + exists s1', s3'; do 4 (split; trivial). + assert (eqlistA X.eq (elements s2') (elements s2'')). + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *. + rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto. + transitivity (elements s2'); auto. + rewrite H; auto. +Qed. + +Instance lt_compat : Proper (eq==>eq==>iff) lt. +Proof. + intros s1 s2 E12 s3 s4 E34. split. + intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). + exists s1', s3'; do 2 (split; trivial). + split. transitivity s1; auto. symmetry; auto. + split; auto. transitivity s3; auto. symmetry; auto. + intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). + exists s1', s3'; do 2 (split; trivial). + split. transitivity s2; auto. + split; auto. transitivity s4; auto. +Qed. + + +(** Proof of the comparison algorithm *) + +(** [flatten_e e] returns the list of elements of [e] i.e. the list + of elements actually compared *) + +Fixpoint flatten_e (e : enumeration) : list elt := match e with + | End => nil + | More x t r => x :: elements t ++ flatten_e r + end. + +Lemma flatten_e_elements : + forall l x r c e, + elements l ++ flatten_e (More x r e) = elements (Node c l x r) ++ flatten_e e. +Proof. + intros; simpl. now rewrite elements_node, app_ass. +Qed. + +Lemma cons_1 : forall s e, + flatten_e (cons s e) = elements s ++ flatten_e e. +Proof. + induction s; simpl; auto; intros. + rewrite IHs1; apply flatten_e_elements. +Qed. + +(** Correctness of this comparison *) + +Definition Cmp c x y := CompSpec L.eq L.lt x y c. + +Local Hint Unfold Cmp flip. + +Lemma compare_end_Cmp : + forall e2, Cmp (compare_end e2) nil (flatten_e e2). +Proof. + destruct e2; simpl; constructor; auto. reflexivity. +Qed. + +Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, + Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> + Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l) + (flatten_e (More x2 r2 e2)). +Proof. + simpl; intros; elim_compare x1 x2; simpl; red; auto. +Qed. + +Lemma compare_cont_Cmp : forall s1 cont e2 l, + (forall e, Cmp (cont e) l (flatten_e e)) -> + Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2). +Proof. + induction s1 as [|c1 l1 Hl1 x1 r1 Hr1]; simpl; intros; auto. + rewrite elements_node, app_ass; simpl. + apply Hl1; auto. clear e2. intros [|x2 r2 e2]. + simpl; auto. + apply compare_more_Cmp. + rewrite <- cons_1; auto. +Qed. + +Lemma compare_Cmp : forall s1 s2, + Cmp (compare s1 s2) (elements s1) (elements s2). +Proof. + intros; unfold compare. + rewrite (app_nil_end (elements s1)). + replace (elements s2) with (flatten_e (cons s2 End)) by + (rewrite cons_1; simpl; rewrite <- app_nil_end; auto). + apply compare_cont_Cmp; auto. + intros. + apply compare_end_Cmp; auto. +Qed. + +Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2}, + CompSpec eq lt s1 s2 (compare s1 s2). +Proof. + intros. + destruct (compare_Cmp s1 s2); constructor. + rewrite eq_Leq; auto. + intros; exists s1, s2; repeat split; auto. + intros; exists s2, s1; repeat split; auto. +Qed. + + +(** ** Equality test *) + +Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2}, + equal s1 s2 = true <-> eq s1 s2. +Proof. +unfold equal; intros s1 s2 B1 B2. +destruct (@compare_spec s1 s2 B1 B2) as [H|H|H]; + split; intros H'; auto; try discriminate. +rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto. +rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto. +Qed. + +(** ** A few results about [mindepth] and [maxdepth] *) + +Lemma mindepth_maxdepth s : mindepth s <= maxdepth s. +Proof. + induction s; simpl; auto. + rewrite <- Nat.succ_le_mono. + transitivity (mindepth s1). apply Nat.le_min_l. + transitivity (maxdepth s1). trivial. apply Nat.le_max_l. +Qed. + +Lemma maxdepth_cardinal s : cardinal s < 2^(maxdepth s). +Proof. + unfold Peano.lt. + induction s as [|c l IHl x r IHr]. + - auto. + - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r. + apply Nat.add_le_mono; etransitivity; + try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto. + * apply Nat.le_max_l. + * apply Nat.le_max_r. +Qed. + +Lemma mindepth_cardinal s : 2^(mindepth s) <= S (cardinal s). +Proof. + unfold Peano.lt. + induction s as [|c l IHl x r IHr]. + - auto. + - simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r. + apply Nat.add_le_mono; etransitivity; + try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto. + * apply Nat.le_min_l. + * apply Nat.le_min_r. +Qed. + +Lemma maxdepth_log_cardinal s : s <> Leaf -> + log2 (cardinal s) < maxdepth s. +Proof. + intros H. + apply Nat.log2_lt_pow2. destruct s; simpl; intuition. + apply maxdepth_cardinal. +Qed. + +Lemma mindepth_log_cardinal s : mindepth s <= log2 (S (cardinal s)). +Proof. + apply Nat.log2_le_pow2. auto with arith. + apply mindepth_cardinal. +Qed. + +End Props.
\ No newline at end of file diff --git a/theories/MSets/MSetRBT.v b/theories/MSets/MSetRBT.v new file mode 100644 index 00000000..b53c0392 --- /dev/null +++ b/theories/MSets/MSetRBT.v @@ -0,0 +1,1931 @@ +(***********************************************************************) +(* 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 *) +(***********************************************************************) + +(** * MSetRBT : Implementation of MSetInterface via Red-Black trees *) + +(** Initial author: Andrew W. Appel, 2011. + Extra modifications by: Pierre Letouzey + +The design decisions behind this implementation are described here: + + - Efficient Verified Red-Black Trees, by Andrew W. Appel, September 2011. + http://www.cs.princeton.edu/~appel/papers/redblack.pdf + +Additional suggested reading: + + - Red-Black Trees in a Functional Setting by Chris Okasaki. + Journal of Functional Programming, 9(4):471-477, July 1999. + http://www.eecs.usma.edu/webs/people/okasaki/jfp99redblack.pdf + + - Red-black trees with types, by Stefan Kahrs. + Journal of Functional Programming, 11(4), 425-432, 2001. + + - Functors for Proofs and Programs, by J.-C. Filliatre and P. Letouzey. + ESOP'04: European Symposium on Programming, pp. 370-384, 2004. + http://www.lri.fr/~filliatr/ftp/publis/fpp.ps.gz +*) + +Require MSetGenTree. +Require Import Bool List BinPos Pnat Setoid SetoidList NPeano Psatz. +Local Open Scope list_scope. + +(* For nicer extraction, we create induction principles + only when needed *) +Local Unset Elimination Schemes. +Local Unset Case Analysis Schemes. + +(** An extra function not (yet?) in MSetInterface.S *) + +Module Type MSetRemoveMin (Import M:MSetInterface.S). + + Parameter remove_min : t -> option (elt * t). + + Axiom remove_min_spec1 : forall s k s', + remove_min s = Some (k,s') -> + min_elt s = Some k /\ remove k s [=] s'. + + Axiom remove_min_spec2 : forall s, remove_min s = None -> Empty s. + +End MSetRemoveMin. + +(** The type of color annotation. *) + +Inductive color := Red | Black. + +Module Color. + Definition t := color. +End Color. + +(** * Ops : the pure functions *) + +Module Ops (X:Orders.OrderedType) <: MSetInterface.Ops X. + +(** ** Generic trees instantiated with color *) + +(** We reuse a generic definition of trees where the information + parameter is a color. Functions like mem or fold are also + provided by this generic functor. *) + +Include MSetGenTree.Ops X Color. + +Definition t := tree. +Local Notation Rd := (Node Red). +Local Notation Bk := (Node Black). + +(** ** Basic tree *) + +Definition singleton (k: elt) : tree := Bk Leaf k Leaf. + +(** ** Changing root color *) + +Definition makeBlack t := + match t with + | Leaf => Leaf + | Node _ a x b => Bk a x b + end. + +Definition makeRed t := + match t with + | Leaf => Leaf + | Node _ a x b => Rd a x b + end. + +(** ** Balancing *) + +(** We adapt when one side is not a true red-black tree. + Both sides have the same black depth. *) + +Definition lbal l k r := + match l with + | Rd (Rd a x b) y c => Rd (Bk a x b) y (Bk c k r) + | Rd a x (Rd b y c) => Rd (Bk a x b) y (Bk c k r) + | _ => Bk l k r + end. + +Definition rbal l k r := + match r with + | Rd (Rd b y c) z d => Rd (Bk l k b) y (Bk c z d) + | Rd b y (Rd c z d) => Rd (Bk l k b) y (Bk c z d) + | _ => Bk l k r + end. + +(** A variant of [rbal], with reverse pattern order. + Is it really useful ? Should we always use it ? *) + +Definition rbal' l k r := + match r with + | Rd b y (Rd c z d) => Rd (Bk l k b) y (Bk c z d) + | Rd (Rd b y c) z d => Rd (Bk l k b) y (Bk c z d) + | _ => Bk l k r + end. + +(** Balancing with different black depth. + One side is almost a red-black tree, while the other is + a true red-black tree, but with black depth + 1. + Used in deletion. *) + +Definition lbalS l k r := + match l with + | Rd a x b => Rd (Bk a x b) k r + | _ => + match r with + | Bk a y b => rbal' l k (Rd a y b) + | Rd (Bk a y b) z c => Rd (Bk l k a) y (rbal' b z (makeRed c)) + | _ => Rd l k r (* impossible *) + end + end. + +Definition rbalS l k r := + match r with + | Rd b y c => Rd l k (Bk b y c) + | _ => + match l with + | Bk a x b => lbal (Rd a x b) k r + | Rd a x (Bk b y c) => Rd (lbal (makeRed a) x b) y (Bk c k r) + | _ => Rd l k r (* impossible *) + end + end. + +(** ** Insertion *) + +Fixpoint ins x s := + match s with + | Leaf => Rd Leaf x Leaf + | Node c l y r => + match X.compare x y with + | Eq => s + | Lt => + match c with + | Red => Rd (ins x l) y r + | Black => lbal (ins x l) y r + end + | Gt => + match c with + | Red => Rd l y (ins x r) + | Black => rbal l y (ins x r) + end + end + end. + +Definition add x s := makeBlack (ins x s). + +(** ** Deletion *) + +Fixpoint append (l:tree) : tree -> tree := + match l with + | Leaf => fun r => r + | Node lc ll lx lr => + fix append_l (r:tree) : tree := + match r with + | Leaf => l + | Node rc rl rx rr => + match lc, rc with + | Red, Red => + let lrl := append lr rl in + match lrl with + | Rd lr' x rl' => Rd (Rd ll lx lr') x (Rd rl' rx rr) + | _ => Rd ll lx (Rd lrl rx rr) + end + | Black, Black => + let lrl := append lr rl in + match lrl with + | Rd lr' x rl' => Rd (Bk ll lx lr') x (Bk rl' rx rr) + | _ => lbalS ll lx (Bk lrl rx rr) + end + | Black, Red => Rd (append_l rl) rx rr + | Red, Black => Rd ll lx (append lr r) + end + end + end. + +Fixpoint del x t := + match t with + | Leaf => Leaf + | Node _ a y b => + match X.compare x y with + | Eq => append a b + | Lt => + match a with + | Bk _ _ _ => lbalS (del x a) y b + | _ => Rd (del x a) y b + end + | Gt => + match b with + | Bk _ _ _ => rbalS a y (del x b) + | _ => Rd a y (del x b) + end + end + end. + +Definition remove x t := makeBlack (del x t). + +(** ** Removing minimal element *) + +Fixpoint delmin l x r : (elt * tree) := + match l with + | Leaf => (x,r) + | Node lc ll lx lr => + let (k,l') := delmin ll lx lr in + match lc with + | Black => (k, lbalS l' x r) + | Red => (k, Rd l' x r) + end + end. + +Definition remove_min t : option (elt * tree) := + match t with + | Leaf => None + | Node _ l x r => + let (k,t) := delmin l x r in + Some (k, makeBlack t) + end. + +(** ** Tree-ification + + We rebuild a tree of size [if pred then n-1 else n] as soon + as the list [l] has enough elements *) + +Definition bogus : tree * list elt := (Leaf, nil). + +Notation treeify_t := (list elt -> tree * list elt). + +Definition treeify_zero : treeify_t := + fun acc => (Leaf,acc). + +Definition treeify_one : treeify_t := + fun acc => match acc with + | x::acc => (Rd Leaf x Leaf, acc) + | _ => bogus + end. + +Definition treeify_cont (f g : treeify_t) : treeify_t := + fun acc => + match f acc with + | (l, x::acc) => + match g acc with + | (r, acc) => (Bk l x r, acc) + end + | _ => bogus + end. + +Fixpoint treeify_aux (pred:bool)(n: positive) : treeify_t := + match n with + | xH => if pred then treeify_zero else treeify_one + | xO n => treeify_cont (treeify_aux pred n) (treeify_aux true n) + | xI n => treeify_cont (treeify_aux false n) (treeify_aux pred n) + end. + +Fixpoint plength (l:list elt) := match l with + | nil => 1%positive + | _::l => Psucc (plength l) +end. + +Definition treeify (l:list elt) := + fst (treeify_aux true (plength l) l). + +(** ** Filtering *) + +Fixpoint filter_aux (f: elt -> bool) s acc := + match s with + | Leaf => acc + | Node _ l k r => + let acc := filter_aux f r acc in + if f k then filter_aux f l (k::acc) + else filter_aux f l acc + end. + +Definition filter (f: elt -> bool) (s: t) : t := + treeify (filter_aux f s nil). + +Fixpoint partition_aux (f: elt -> bool) s acc1 acc2 := + match s with + | Leaf => (acc1,acc2) + | Node _ sl k sr => + let (acc1, acc2) := partition_aux f sr acc1 acc2 in + if f k then partition_aux f sl (k::acc1) acc2 + else partition_aux f sl acc1 (k::acc2) + end. + +Definition partition (f: elt -> bool) (s:t) : t*t := + let (ok,ko) := partition_aux f s nil nil in + (treeify ok, treeify ko). + +(** ** Union, intersection, difference *) + +(** union of the elements of [l1] and [l2] into a third [acc] list. *) + +Fixpoint union_list l1 : list elt -> list elt -> list elt := + match l1 with + | nil => @rev_append _ + | x::l1' => + fix union_l1 l2 acc := + match l2 with + | nil => rev_append l1 acc + | y::l2' => + match X.compare x y with + | Eq => union_list l1' l2' (x::acc) + | Lt => union_l1 l2' (y::acc) + | Gt => union_list l1' l2 (x::acc) + end + end + end. + +Definition linear_union s1 s2 := + treeify (union_list (rev_elements s1) (rev_elements s2) nil). + +Fixpoint inter_list l1 : list elt -> list elt -> list elt := + match l1 with + | nil => fun _ acc => acc + | x::l1' => + fix inter_l1 l2 acc := + match l2 with + | nil => acc + | y::l2' => + match X.compare x y with + | Eq => inter_list l1' l2' (x::acc) + | Lt => inter_l1 l2' acc + | Gt => inter_list l1' l2 acc + end + end + end. + +Definition linear_inter s1 s2 := + treeify (inter_list (rev_elements s1) (rev_elements s2) nil). + +Fixpoint diff_list l1 : list elt -> list elt -> list elt := + match l1 with + | nil => fun _ acc => acc + | x::l1' => + fix diff_l1 l2 acc := + match l2 with + | nil => rev_append l1 acc + | y::l2' => + match X.compare x y with + | Eq => diff_list l1' l2' acc + | Lt => diff_l1 l2' acc + | Gt => diff_list l1' l2 (x::acc) + end + end + end. + +Definition linear_diff s1 s2 := + treeify (diff_list (rev_elements s1) (rev_elements s2) nil). + +(** [compare_height] returns: + - [Lt] if [height s2] is at least twice [height s1]; + - [Gt] if [height s1] is at least twice [height s2]; + - [Eq] if heights are approximately equal. + Warning: this is not an equivalence relation! but who cares.... *) + +Definition skip_red t := + match t with + | Rd t' _ _ => t' + | _ => t + end. + +Definition skip_black t := + match skip_red t with + | Bk t' _ _ => t' + | t' => t' + end. + +Fixpoint compare_height (s1x s1 s2 s2x: tree) : comparison := + match skip_red s1x, skip_red s1, skip_red s2, skip_red s2x with + | Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Node _ s2x' _ _ => + compare_height (skip_black s2x') s1' s2' (skip_black s2x') + | _, Leaf, _, Node _ _ _ _ => Lt + | Node _ _ _ _, _, Leaf, _ => Gt + | Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Leaf => + compare_height (skip_black s1x') s1' s2' Leaf + | Leaf, Node _ s1' _ _, Node _ s2' _ _, Node _ s2x' _ _ => + compare_height Leaf s1' s2' (skip_black s2x') + | _, _, _, _ => Eq + end. + +(** When one tree is quite smaller than the other, we simply + adds repeatively all its elements in the big one. + For trees of comparable height, we rather use [linear_union]. *) + +Definition union (t1 t2: t) : t := + match compare_height t1 t1 t2 t2 with + | Lt => fold add t1 t2 + | Gt => fold add t2 t1 + | Eq => linear_union t1 t2 + end. + +Definition diff (t1 t2: t) : t := + match compare_height t1 t1 t2 t2 with + | Lt => filter (fun k => negb (mem k t2)) t1 + | Gt => fold remove t2 t1 + | Eq => linear_diff t1 t2 + end. + +Definition inter (t1 t2: t) : t := + match compare_height t1 t1 t2 t2 with + | Lt => filter (fun k => mem k t2) t1 + | Gt => filter (fun k => mem k t1) t2 + | Eq => linear_inter t1 t2 + end. + +End Ops. + +(** * MakeRaw : the pure functions and their specifications *) + +Module Type MakeRaw (X:Orders.OrderedType) <: MSetInterface.RawSets X. +Include Ops X. + +(** Generic definition of binary-search-trees and proofs of + specifications for generic functions such as mem or fold. *) + +Include MSetGenTree.Props X Color. + +Local Notation Rd := (Node Red). +Local Notation Bk := (Node Black). + +Local Hint Immediate MX.eq_sym. +Local Hint Unfold In lt_tree gt_tree Ok. +Local Hint Constructors InT bst. +Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok. +Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. +Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. +Local Hint Resolve elements_spec2. + +(** ** Singleton set *) + +Lemma singleton_spec x y : InT y (singleton x) <-> X.eq y x. +Proof. + unfold singleton; intuition_in. +Qed. + +Instance singleton_ok x : Ok (singleton x). +Proof. + unfold singleton; auto. +Qed. + +(** ** makeBlack, MakeRed *) + +Lemma makeBlack_spec s x : InT x (makeBlack s) <-> InT x s. +Proof. + destruct s; simpl; intuition_in. +Qed. + +Lemma makeRed_spec s x : InT x (makeRed s) <-> InT x s. +Proof. + destruct s; simpl; intuition_in. +Qed. + +Instance makeBlack_ok s `{Ok s} : Ok (makeBlack s). +Proof. + destruct s; simpl; ok. +Qed. + +Instance makeRed_ok s `{Ok s} : Ok (makeRed s). +Proof. + destruct s; simpl; ok. +Qed. + +(** ** Generic handling for red-matching and red-red-matching *) + +Definition isblack t := + match t with Bk _ _ _ => True | _ => False end. + +Definition notblack t := + match t with Bk _ _ _ => False | _ => True end. + +Definition notred t := + match t with Rd _ _ _ => False | _ => True end. + +Definition rcase {A} f g t : A := + match t with + | Rd a x b => f a x b + | _ => g t + end. + +Inductive rspec {A} f g : tree -> A -> Prop := + | rred a x b : rspec f g (Rd a x b) (f a x b) + | relse t : notred t -> rspec f g t (g t). + +Fact rmatch {A} f g t : rspec (A:=A) f g t (rcase f g t). +Proof. +destruct t as [|[|] l x r]; simpl; now constructor. +Qed. + +Definition rrcase {A} f g t : A := + match t with + | Rd (Rd a x b) y c => f a x b y c + | Rd a x (Rd b y c) => f a x b y c + | _ => g t + end. + +Notation notredred := (rrcase (fun _ _ _ _ _ => False) (fun _ => True)). + +Inductive rrspec {A} f g : tree -> A -> Prop := + | rrleft a x b y c : rrspec f g (Rd (Rd a x b) y c) (f a x b y c) + | rrright a x b y c : rrspec f g (Rd a x (Rd b y c)) (f a x b y c) + | rrelse t : notredred t -> rrspec f g t (g t). + +Fact rrmatch {A} f g t : rrspec (A:=A) f g t (rrcase f g t). +Proof. +destruct t as [|[|] l x r]; simpl; try now constructor. +destruct l as [|[|] ll lx lr], r as [|[|] rl rx rr]; now constructor. +Qed. + +Definition rrcase' {A} f g t : A := + match t with + | Rd a x (Rd b y c) => f a x b y c + | Rd (Rd a x b) y c => f a x b y c + | _ => g t + end. + +Fact rrmatch' {A} f g t : rrspec (A:=A) f g t (rrcase' f g t). +Proof. +destruct t as [|[|] l x r]; simpl; try now constructor. +destruct l as [|[|] ll lx lr], r as [|[|] rl rx rr]; now constructor. +Qed. + +(** Balancing operations are instances of generic match *) + +Fact lbal_match l k r : + rrspec + (fun a x b y c => Rd (Bk a x b) y (Bk c k r)) + (fun l => Bk l k r) + l + (lbal l k r). +Proof. + exact (rrmatch _ _ _). +Qed. + +Fact rbal_match l k r : + rrspec + (fun a x b y c => Rd (Bk l k a) x (Bk b y c)) + (fun r => Bk l k r) + r + (rbal l k r). +Proof. + exact (rrmatch _ _ _). +Qed. + +Fact rbal'_match l k r : + rrspec + (fun a x b y c => Rd (Bk l k a) x (Bk b y c)) + (fun r => Bk l k r) + r + (rbal' l k r). +Proof. + exact (rrmatch' _ _ _). +Qed. + +Fact lbalS_match l x r : + rspec + (fun a y b => Rd (Bk a y b) x r) + (fun l => + match r with + | Bk a y b => rbal' l x (Rd a y b) + | Rd (Bk a y b) z c => Rd (Bk l x a) y (rbal' b z (makeRed c)) + | _ => Rd l x r + end) + l + (lbalS l x r). +Proof. + exact (rmatch _ _ _). +Qed. + +Fact rbalS_match l x r : + rspec + (fun a y b => Rd l x (Bk a y b)) + (fun r => + match l with + | Bk a y b => lbal (Rd a y b) x r + | Rd a y (Bk b z c) => Rd (lbal (makeRed a) y b) z (Bk c x r) + | _ => Rd l x r + end) + r + (rbalS l x r). +Proof. + exact (rmatch _ _ _). +Qed. + +(** ** Balancing for insertion *) + +Lemma lbal_spec l x r y : + InT y (lbal l x r) <-> X.eq y x \/ InT y l \/ InT y r. +Proof. + case lbal_match; intuition_in. +Qed. + +Instance lbal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : + Ok (lbal l x r). +Proof. + destruct (lbal_match l x r); ok. +Qed. + +Lemma rbal_spec l x r y : + InT y (rbal l x r) <-> X.eq y x \/ InT y l \/ InT y r. +Proof. + case rbal_match; intuition_in. +Qed. + +Instance rbal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : + Ok (rbal l x r). +Proof. + destruct (rbal_match l x r); ok. +Qed. + +Lemma rbal'_spec l x r y : + InT y (rbal' l x r) <-> X.eq y x \/ InT y l \/ InT y r. +Proof. + case rbal'_match; intuition_in. +Qed. + +Instance rbal'_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : + Ok (rbal' l x r). +Proof. + destruct (rbal'_match l x r); ok. +Qed. + +Hint Rewrite In_node_iff In_leaf_iff + makeRed_spec makeBlack_spec lbal_spec rbal_spec rbal'_spec : rb. + +Ltac descolor := destruct_all Color.t. +Ltac destree t := destruct t as [|[|] ? ? ?]. +Ltac autorew := autorewrite with rb. +Tactic Notation "autorew" "in" ident(H) := autorewrite with rb in H. + +(** ** Insertion *) + +Lemma ins_spec : forall s x y, + InT y (ins x s) <-> X.eq y x \/ InT y s. +Proof. + induct s x. + - intuition_in. + - intuition_in. setoid_replace y with x; eauto. + - descolor; autorew; rewrite IHl; intuition_in. + - descolor; autorew; rewrite IHr; intuition_in. +Qed. +Hint Rewrite ins_spec : rb. + +Instance ins_ok s x `{Ok s} : Ok (ins x s). +Proof. + induct s x; auto; descolor; + (apply lbal_ok || apply rbal_ok || ok); auto; + intros y; autorew; intuition; order. +Qed. + +Lemma add_spec' s x y : + InT y (add x s) <-> X.eq y x \/ InT y s. +Proof. + unfold add. now autorew. +Qed. + +Hint Rewrite add_spec' : rb. + +Lemma add_spec s x y `{Ok s} : + InT y (add x s) <-> X.eq y x \/ InT y s. +Proof. + apply add_spec'. +Qed. + +Instance add_ok s x `{Ok s} : Ok (add x s). +Proof. + unfold add; auto_tc. +Qed. + +(** ** Balancing for deletion *) + +Lemma lbalS_spec l x r y : + InT y (lbalS l x r) <-> X.eq y x \/ InT y l \/ InT y r. +Proof. + case lbalS_match. + - intros; autorew; intuition_in. + - clear l. intros l _. + destruct r as [|[|] rl rx rr]. + * autorew. intuition_in. + * destree rl; autorew; intuition_in. + * autorew. intuition_in. +Qed. + +Instance lbalS_ok l x r : + forall `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (lbalS l x r). +Proof. + case lbalS_match; intros. + - ok. + - destruct r as [|[|] rl rx rr]. + * ok. + * destruct rl as [|[|] rll rlx rlr]; intros; ok. + + apply rbal'_ok; ok. + intros w; autorew; auto. + + intros w; autorew. + destruct 1 as [Hw|[Hw|Hw]]; try rewrite Hw; eauto. + * ok. autorew. apply rbal'_ok; ok. +Qed. + +Lemma rbalS_spec l x r y : + InT y (rbalS l x r) <-> X.eq y x \/ InT y l \/ InT y r. +Proof. + case rbalS_match. + - intros; autorew; intuition_in. + - intros t _. + destruct l as [|[|] ll lx lr]. + * autorew. intuition_in. + * destruct lr as [|[|] lrl lrx lrr]; autorew; intuition_in. + * autorew. intuition_in. +Qed. + +Instance rbalS_ok l x r : + forall `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (rbalS l x r). +Proof. + case rbalS_match; intros. + - ok. + - destruct l as [|[|] ll lx lr]. + * ok. + * destruct lr as [|[|] lrl lrx lrr]; intros; ok. + + apply lbal_ok; ok. + intros w; autorew; auto. + + intros w; autorew. + destruct 1 as [Hw|[Hw|Hw]]; try rewrite Hw; eauto. + * ok. apply lbal_ok; ok. +Qed. + +Hint Rewrite lbalS_spec rbalS_spec : rb. + +(** ** Append for deletion *) + +Ltac append_tac l r := + induction l as [| lc ll _ lx lr IHlr]; + [intro r; simpl + |induction r as [| rc rl IHrl rx rr _]; + [simpl + |destruct lc, rc; + [specialize (IHlr rl); clear IHrl + |simpl; + assert (Hr:notred (Bk rl rx rr)) by (simpl; trivial); + set (r:=Bk rl rx rr) in *; clearbody r; clear IHrl rl rx rr; + specialize (IHlr r) + |change (append _ _) with (Rd (append (Bk ll lx lr) rl) rx rr); + assert (Hl:notred (Bk ll lx lr)) by (simpl; trivial); + set (l:=Bk ll lx lr) in *; clearbody l; clear IHlr ll lx lr + |specialize (IHlr rl); clear IHrl]]]. + +Fact append_rr_match ll lx lr rl rx rr : + rspec + (fun a x b => Rd (Rd ll lx a) x (Rd b rx rr)) + (fun t => Rd ll lx (Rd t rx rr)) + (append lr rl) + (append (Rd ll lx lr) (Rd rl rx rr)). +Proof. + exact (rmatch _ _ _). +Qed. + +Fact append_bb_match ll lx lr rl rx rr : + rspec + (fun a x b => Rd (Bk ll lx a) x (Bk b rx rr)) + (fun t => lbalS ll lx (Bk t rx rr)) + (append lr rl) + (append (Bk ll lx lr) (Bk rl rx rr)). +Proof. + exact (rmatch _ _ _). +Qed. + +Lemma append_spec l r x : + InT x (append l r) <-> InT x l \/ InT x r. +Proof. + revert r. + append_tac l r; autorew; try tauto. + - (* Red / Red *) + revert IHlr; case append_rr_match; + [intros a y b | intros t Ht]; autorew; tauto. + - (* Black / Black *) + revert IHlr; case append_bb_match; + [intros a y b | intros t Ht]; autorew; tauto. +Qed. + +Hint Rewrite append_spec : rb. + +Lemma append_ok : forall x l r `{Ok l, Ok r}, + lt_tree x l -> gt_tree x r -> Ok (append l r). +Proof. + append_tac l r. + - (* Leaf / _ *) + trivial. + - (* _ / Leaf *) + trivial. + - (* Red / Red *) + intros; inv. + assert (IH : Ok (append lr rl)) by (apply IHlr; eauto). clear IHlr. + assert (X.lt lx rx) by (transitivity x; eauto). + assert (G : gt_tree lx (append lr rl)). + { intros w. autorew. destruct 1; [|transitivity x]; eauto. } + assert (L : lt_tree rx (append lr rl)). + { intros w. autorew. destruct 1; [transitivity x|]; eauto. } + revert IH G L; case append_rr_match; intros; ok. + - (* Red / Black *) + intros; ok. + intros w; autorew; destruct 1; eauto. + - (* Black / Red *) + intros; ok. + intros w; autorew; destruct 1; eauto. + - (* Black / Black *) + intros; inv. + assert (IH : Ok (append lr rl)) by (apply IHlr; eauto). clear IHlr. + assert (X.lt lx rx) by (transitivity x; eauto). + assert (G : gt_tree lx (append lr rl)). + { intros w. autorew. destruct 1; [|transitivity x]; eauto. } + assert (L : lt_tree rx (append lr rl)). + { intros w. autorew. destruct 1; [transitivity x|]; eauto. } + revert IH G L; case append_bb_match; intros; ok. + apply lbalS_ok; ok. +Qed. + +(** ** Deletion *) + +Lemma del_spec : forall s x y `{Ok s}, + InT y (del x s) <-> InT y s /\ ~X.eq y x. +Proof. +induct s x. +- intuition_in. +- autorew; intuition_in. + assert (X.lt y x') by eauto. order. + assert (X.lt x' y) by eauto. order. + order. +- destruct l as [|[|] ll lx lr]; autorew; + rewrite ?IHl by trivial; intuition_in; order. +- destruct r as [|[|] rl rx rr]; autorew; + rewrite ?IHr by trivial; intuition_in; order. +Qed. + +Hint Rewrite del_spec : rb. + +Instance del_ok s x `{Ok s} : Ok (del x s). +Proof. +induct s x. +- trivial. +- eapply append_ok; eauto. +- assert (lt_tree x' (del x l)). + { intro w. autorew; trivial. destruct 1. eauto. } + destruct l as [|[|] ll lx lr]; auto_tc. +- assert (gt_tree x' (del x r)). + { intro w. autorew; trivial. destruct 1. eauto. } + destruct r as [|[|] rl rx rr]; auto_tc. +Qed. + +Lemma remove_spec s x y `{Ok s} : + InT y (remove x s) <-> InT y s /\ ~X.eq y x. +Proof. +unfold remove. now autorew. +Qed. + +Hint Rewrite remove_spec : rb. + +Instance remove_ok s x `{Ok s} : Ok (remove x s). +Proof. +unfold remove; auto_tc. +Qed. + +(** ** Removing the minimal element *) + +Lemma delmin_spec l y r c x s' `{O : Ok (Node c l y r)} : + delmin l y r = (x,s') -> + min_elt (Node c l y r) = Some x /\ del x (Node c l y r) = s'. +Proof. + revert y r c x s' O. + induction l as [|lc ll IH ly lr _]. + - simpl. intros y r _ x s' _. injection 1; intros; subst. + now rewrite MX.compare_refl. + - intros y r c x s' O. + simpl delmin. + specialize (IH ly lr). destruct delmin as (x0,s0). + destruct (IH lc x0 s0); clear IH; [ok|trivial|]. + remember (Node lc ll ly lr) as l. + simpl min_elt in *. + intros E. + replace x0 with x in * by (destruct lc; now injection E). + split. + * subst l; intuition. + * assert (X.lt x y). + { inversion_clear O. + assert (InT x l) by now apply min_elt_spec1. auto. } + simpl. case X.compare_spec; try order. + destruct lc; injection E; clear E; intros; subst l s0; auto. +Qed. + +Lemma remove_min_spec1 s x s' `{Ok s}: + remove_min s = Some (x,s') -> + min_elt s = Some x /\ remove x s = s'. +Proof. + unfold remove_min. + destruct s as [|c l y r]; try easy. + generalize (delmin_spec l y r c). + destruct delmin as (x0,s0). intros D. + destruct (D x0 s0) as (->,<-); auto. + fold (remove x0 (Node c l y r)). + inversion_clear 1; auto. +Qed. + +Lemma remove_min_spec2 s : remove_min s = None -> Empty s. +Proof. + unfold remove_min. + destruct s as [|c l y r]. + - easy. + - now destruct delmin. +Qed. + +Lemma remove_min_ok (s:t) `{Ok s}: + match remove_min s with + | Some (_,s') => Ok s' + | None => True + end. +Proof. + generalize (remove_min_spec1 s). + destruct remove_min as [(x0,s0)|]; auto. + intros R. destruct (R x0 s0); auto. subst s0. auto_tc. +Qed. + +(** ** Treeify *) + +Notation ifpred p n := (if p then pred n else n%nat). + +Definition treeify_invariant size (f:treeify_t) := + forall acc, + size <= length acc -> + let (t,acc') := f acc in + cardinal t = size /\ acc = elements t ++ acc'. + +Lemma treeify_zero_spec : treeify_invariant 0 treeify_zero. +Proof. + intro. simpl. auto. +Qed. + +Lemma treeify_one_spec : treeify_invariant 1 treeify_one. +Proof. + intros [|x acc]; simpl; auto; inversion 1. +Qed. + +Lemma treeify_cont_spec f g size1 size2 size : + treeify_invariant size1 f -> + treeify_invariant size2 g -> + size = S (size1 + size2) -> + treeify_invariant size (treeify_cont f g). +Proof. + intros Hf Hg EQ acc LE. unfold treeify_cont. + specialize (Hf acc). + destruct (f acc) as (t1,acc1). + destruct Hf as (Hf1,Hf2). + { lia. } + destruct acc1 as [|x acc1]. + { exfalso. subst acc. + rewrite <- app_nil_end, <- elements_cardinal in LE. lia. } + specialize (Hg acc1). + destruct (g acc1) as (t2,acc2). + destruct Hg as (Hg1,Hg2). + { subst acc. rewrite app_length, <- elements_cardinal in LE. + simpl in LE. unfold elt in *. lia. } + simpl. split. + * lia. + * rewrite elements_node, app_ass. simpl. unfold elt in *; congruence. +Qed. + +Lemma treeify_aux_spec n (p:bool) : + treeify_invariant (ifpred p (Pos.to_nat n)) (treeify_aux p n). +Proof. + revert p. + induction n as [n|n|]; intros p; simpl treeify_aux. + - eapply treeify_cont_spec; [ apply (IHn false) | apply (IHn p) | ]. + rewrite Pos2Nat.inj_xI. generalize (Pos2Nat.is_pos n). + destruct p; simpl; lia. + - eapply treeify_cont_spec; [ apply (IHn p) | apply (IHn true) | ]. + rewrite Pos2Nat.inj_xO. generalize (Pos2Nat.is_pos n). + destruct p; simpl; lia. + - destruct p; [ apply treeify_zero_spec | apply treeify_one_spec ]. +Qed. + +Lemma plength_spec l : Pos.to_nat (plength l) = S (length l). +Proof. + induction l; simpl; now rewrite ?Pos2Nat.inj_succ, ?IHl. +Qed. + +Lemma treeify_elements l : elements (treeify l) = l. +Proof. + assert (H := treeify_aux_spec (plength l) true l). + unfold treeify. destruct treeify_aux as (t,acc); simpl in *. + destruct H as (H,H'). { now rewrite plength_spec. } + subst l. rewrite plength_spec, app_length, <- elements_cardinal in *. + destruct acc. + * now rewrite app_nil_r. + * simpl in H. lia. +Qed. + +Lemma treeify_spec x l : InT x (treeify l) <-> InA X.eq x l. +Proof. + intros. now rewrite <- elements_spec1, treeify_elements. +Qed. + +Lemma treeify_ok l : sort X.lt l -> Ok (treeify l). +Proof. + intros. apply elements_sort_ok. rewrite treeify_elements; auto. +Qed. + + +(** ** Filter *) + +Lemma filter_app A f (l l':list A) : + List.filter f (l ++ l') = List.filter f l ++ List.filter f l'. +Proof. + induction l as [|x l IH]; simpl; trivial. + destruct (f x); simpl; now rewrite IH. +Qed. + +Lemma filter_aux_elements s f acc : + filter_aux f s acc = List.filter f (elements s) ++ acc. +Proof. + revert acc. + induction s as [|c l IHl x r IHr]; simpl; trivial. + intros acc. + rewrite elements_node, filter_app. simpl. + destruct (f x); now rewrite IHl, IHr, app_ass. +Qed. + +Lemma filter_elements s f : + elements (filter f s) = List.filter f (elements s). +Proof. + unfold filter. + now rewrite treeify_elements, filter_aux_elements, app_nil_r. +Qed. + +Lemma filter_spec s x f : + Proper (X.eq==>Logic.eq) f -> + (InT x (filter f s) <-> InT x s /\ f x = true). +Proof. + intros Hf. + rewrite <- elements_spec1, filter_elements, filter_InA, elements_spec1; + now auto_tc. +Qed. + +Instance filter_ok s f `(Ok s) : Ok (filter f s). +Proof. + apply elements_sort_ok. + rewrite filter_elements. + apply filter_sort with X.eq; auto_tc. +Qed. + +(** ** Partition *) + +Lemma partition_aux_spec s f acc1 acc2 : + partition_aux f s acc1 acc2 = + (filter_aux f s acc1, filter_aux (fun x => negb (f x)) s acc2). +Proof. + revert acc1 acc2. + induction s as [ | c l Hl x r Hr ]; simpl. + - trivial. + - intros acc1 acc2. + destruct (f x); simpl; now rewrite Hr, Hl. +Qed. + +Lemma partition_spec s f : + partition f s = (filter f s, filter (fun x => negb (f x)) s). +Proof. + unfold partition, filter. now rewrite partition_aux_spec. +Qed. + +Lemma partition_spec1 s f : + Proper (X.eq==>Logic.eq) f -> + Equal (fst (partition f s)) (filter f s). +Proof. now rewrite partition_spec. Qed. + +Lemma partition_spec2 s f : + Proper (X.eq==>Logic.eq) f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). +Proof. now rewrite partition_spec. Qed. + +Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)). +Proof. rewrite partition_spec; now apply filter_ok. Qed. + +Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)). +Proof. rewrite partition_spec; now apply filter_ok. Qed. + + +(** ** An invariant for binary list functions with accumulator. *) + +Ltac inA := + rewrite ?InA_app_iff, ?InA_cons, ?InA_nil, ?InA_rev in *; auto_tc. + +Record INV l1 l2 acc : Prop := { + l1_sorted : sort X.lt (rev l1); + l2_sorted : sort X.lt (rev l2); + acc_sorted : sort X.lt acc; + l1_lt_acc x y : InA X.eq x l1 -> InA X.eq y acc -> X.lt x y; + l2_lt_acc x y : InA X.eq x l2 -> InA X.eq y acc -> X.lt x y}. +Local Hint Resolve l1_sorted l2_sorted acc_sorted. + +Lemma INV_init s1 s2 `(Ok s1, Ok s2) : + INV (rev_elements s1) (rev_elements s2) nil. +Proof. + rewrite !rev_elements_rev. + split; rewrite ?rev_involutive; auto; intros; now inA. +Qed. + +Lemma INV_sym l1 l2 acc : INV l1 l2 acc -> INV l2 l1 acc. +Proof. + destruct 1; now split. +Qed. + +Lemma INV_drop x1 l1 l2 acc : + INV (x1 :: l1) l2 acc -> INV l1 l2 acc. +Proof. + intros (l1s,l2s,accs,l1a,l2a). simpl in *. + destruct (sorted_app_inv _ _ l1s) as (U & V & W); auto. + split; auto. +Qed. + +Lemma INV_eq x1 x2 l1 l2 acc : + INV (x1 :: l1) (x2 :: l2) acc -> X.eq x1 x2 -> + INV l1 l2 (x1 :: acc). +Proof. + intros (U,V,W,X,Y) EQ. simpl in *. + destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. + destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. + split; auto. + - constructor; auto. apply InA_InfA with X.eq; auto_tc. + - intros x y; inA; intros Hx [Hy|Hy]. + + apply U3; inA. + + apply X; inA. + - intros x y; inA; intros Hx [Hy|Hy]. + + rewrite Hy, EQ; apply V3; inA. + + apply Y; inA. +Qed. + +Lemma INV_lt x1 x2 l1 l2 acc : + INV (x1 :: l1) (x2 :: l2) acc -> X.lt x1 x2 -> + INV (x1 :: l1) l2 (x2 :: acc). +Proof. + intros (U,V,W,X,Y) EQ. simpl in *. + destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. + destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. + split; auto. + - constructor; auto. apply InA_InfA with X.eq; auto_tc. + - intros x y; inA; intros Hx [Hy|Hy]. + + rewrite Hy; clear Hy. destruct Hx; [order|]. + transitivity x1; auto. apply U3; inA. + + apply X; inA. + - intros x y; inA; intros Hx [Hy|Hy]. + + rewrite Hy. apply V3; inA. + + apply Y; inA. +Qed. + +Lemma INV_rev l1 l2 acc : + INV l1 l2 acc -> Sorted X.lt (rev_append l1 acc). +Proof. + intros. rewrite rev_append_rev. + apply SortA_app with X.eq; eauto with *. + intros x y. inA. eapply l1_lt_acc; eauto. +Qed. + +(** ** union *) + +Lemma union_list_ok l1 l2 acc : + INV l1 l2 acc -> sort X.lt (union_list l1 l2 acc). +Proof. + revert l2 acc. + induction l1 as [|x1 l1 IH1]; + [intro l2|induction l2 as [|x2 l2 IH2]]; + intros acc inv. + - eapply INV_rev, INV_sym; eauto. + - eapply INV_rev; eauto. + - simpl. case X.compare_spec; intro C. + * apply IH1. eapply INV_eq; eauto. + * apply (IH2 (x2::acc)). eapply INV_lt; eauto. + * apply IH1. eapply INV_sym, INV_lt; eauto. now apply INV_sym. +Qed. + +Instance linear_union_ok s1 s2 `(Ok s1, Ok s2) : + Ok (linear_union s1 s2). +Proof. + unfold linear_union. now apply treeify_ok, union_list_ok, INV_init. +Qed. + +Instance fold_add_ok s1 s2 `(Ok s1, Ok s2) : + Ok (fold add s1 s2). +Proof. + rewrite fold_spec, <- fold_left_rev_right. + unfold elt in *. + induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. +Qed. + +Instance union_ok s1 s2 `(Ok s1, Ok s2) : Ok (union s1 s2). +Proof. + unfold union. destruct compare_height; auto_tc. +Qed. + +Lemma union_list_spec x l1 l2 acc : + InA X.eq x (union_list l1 l2 acc) <-> + InA X.eq x l1 \/ InA X.eq x l2 \/ InA X.eq x acc. +Proof. + revert l2 acc. + induction l1 as [|x1 l1 IH1]. + - intros l2 acc; simpl. rewrite rev_append_rev. inA. tauto. + - induction l2 as [|x2 l2 IH2]; intros acc; simpl. + * rewrite rev_append_rev. inA. tauto. + * case X.compare_spec; intro C. + + rewrite IH1, !InA_cons, C; tauto. + + rewrite (IH2 (x2::acc)), !InA_cons. tauto. + + rewrite IH1, !InA_cons; tauto. +Qed. + +Lemma linear_union_spec s1 s2 x : + InT x (linear_union s1 s2) <-> InT x s1 \/ InT x s2. +Proof. + unfold linear_union. + rewrite treeify_spec, union_list_spec, !rev_elements_rev. + rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. + tauto. +Qed. + +Lemma fold_add_spec s1 s2 x : + InT x (fold add s1 s2) <-> InT x s1 \/ InT x s2. +Proof. + rewrite fold_spec, <- fold_left_rev_right. + rewrite <- (elements_spec1 s1), <- InA_rev by auto_tc. + unfold elt in *. + induction (rev (elements s1)); simpl. + - rewrite InA_nil. tauto. + - unfold flip. rewrite add_spec', IHl, InA_cons. tauto. +Qed. + +Lemma union_spec' s1 s2 x : + InT x (union s1 s2) <-> InT x s1 \/ InT x s2. +Proof. + unfold union. destruct compare_height. + - apply linear_union_spec. + - apply fold_add_spec. + - rewrite fold_add_spec. tauto. +Qed. + +Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2}, + (InT y (union s1 s2) <-> InT y s1 \/ InT y s2). +Proof. + intros; apply union_spec'. +Qed. + +(** ** inter *) + +Lemma inter_list_ok l1 l2 acc : + INV l1 l2 acc -> sort X.lt (inter_list l1 l2 acc). +Proof. + revert l2 acc. + induction l1 as [|x1 l1 IH1]; [|induction l2 as [|x2 l2 IH2]]; simpl. + - eauto. + - eauto. + - intros acc inv. + case X.compare_spec; intro C. + * apply IH1. eapply INV_eq; eauto. + * apply (IH2 acc). eapply INV_sym, INV_drop, INV_sym; eauto. + * apply IH1. eapply INV_drop; eauto. +Qed. + +Instance linear_inter_ok s1 s2 `(Ok s1, Ok s2) : + Ok (linear_inter s1 s2). +Proof. + unfold linear_inter. now apply treeify_ok, inter_list_ok, INV_init. +Qed. + +Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2). +Proof. + unfold inter. destruct compare_height; auto_tc. +Qed. + +Lemma inter_list_spec x l1 l2 acc : + sort X.lt (rev l1) -> + sort X.lt (rev l2) -> + (InA X.eq x (inter_list l1 l2 acc) <-> + (InA X.eq x l1 /\ InA X.eq x l2) \/ InA X.eq x acc). +Proof. + revert l2 acc. + induction l1 as [|x1 l1 IH1]. + - intros l2 acc; simpl. inA. tauto. + - induction l2 as [|x2 l2 IH2]; intros acc. + * simpl. inA. tauto. + * simpl. intros U V. + destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. + destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. + case X.compare_spec; intro C. + + rewrite IH1, !InA_cons, C; tauto. + + rewrite (IH2 acc); auto. inA. intuition; try order. + assert (X.lt x x1) by (apply U3; inA). order. + + rewrite IH1; auto. inA. intuition; try order. + assert (X.lt x x2) by (apply V3; inA). order. +Qed. + +Lemma linear_inter_spec s1 s2 x `(Ok s1, Ok s2) : + InT x (linear_inter s1 s2) <-> InT x s1 /\ InT x s2. +Proof. + unfold linear_inter. + rewrite !rev_elements_rev, treeify_spec, inter_list_spec + by (rewrite rev_involutive; auto_tc). + rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. tauto. +Qed. + +Local Instance mem_proper s `(Ok s) : + Proper (X.eq ==> Logic.eq) (fun k => mem k s). +Proof. + intros x y EQ. apply Bool.eq_iff_eq_true; rewrite !mem_spec; auto. + now rewrite EQ. +Qed. + +Lemma inter_spec s1 s2 y `{Ok s1, Ok s2} : + InT y (inter s1 s2) <-> InT y s1 /\ InT y s2. +Proof. + unfold inter. destruct compare_height. + - now apply linear_inter_spec. + - rewrite filter_spec, mem_spec by auto_tc; tauto. + - rewrite filter_spec, mem_spec by auto_tc; tauto. +Qed. + +(** ** difference *) + +Lemma diff_list_ok l1 l2 acc : + INV l1 l2 acc -> sort X.lt (diff_list l1 l2 acc). +Proof. + revert l2 acc. + induction l1 as [|x1 l1 IH1]; + [intro l2|induction l2 as [|x2 l2 IH2]]; + intros acc inv. + - eauto. + - unfold diff_list. eapply INV_rev; eauto. + - simpl. case X.compare_spec; intro C. + * apply IH1. eapply INV_drop, INV_sym, INV_drop, INV_sym; eauto. + * apply (IH2 acc). eapply INV_sym, INV_drop, INV_sym; eauto. + * apply IH1. eapply INV_sym, INV_lt; eauto. now apply INV_sym. +Qed. + +Instance diff_inter_ok s1 s2 `(Ok s1, Ok s2) : + Ok (linear_diff s1 s2). +Proof. + unfold linear_inter. now apply treeify_ok, diff_list_ok, INV_init. +Qed. + +Instance fold_remove_ok s1 s2 `(Ok s2) : + Ok (fold remove s1 s2). +Proof. + rewrite fold_spec, <- fold_left_rev_right. + unfold elt in *. + induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. +Qed. + +Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2). +Proof. + unfold diff. destruct compare_height; auto_tc. +Qed. + +Lemma diff_list_spec x l1 l2 acc : + sort X.lt (rev l1) -> + sort X.lt (rev l2) -> + (InA X.eq x (diff_list l1 l2 acc) <-> + (InA X.eq x l1 /\ ~InA X.eq x l2) \/ InA X.eq x acc). +Proof. + revert l2 acc. + induction l1 as [|x1 l1 IH1]. + - intros l2 acc; simpl. inA. tauto. + - induction l2 as [|x2 l2 IH2]; intros acc. + * intros; simpl. rewrite rev_append_rev. inA. tauto. + * simpl. intros U V. + destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto. + destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto. + case X.compare_spec; intro C. + + rewrite IH1; auto. f_equiv. inA. intuition; try order. + assert (X.lt x x1) by (apply U3; inA). order. + + rewrite (IH2 acc); auto. f_equiv. inA. intuition; try order. + assert (X.lt x x1) by (apply U3; inA). order. + + rewrite IH1; auto. inA. intuition; try order. + left; split; auto. destruct 1. order. + assert (X.lt x x2) by (apply V3; inA). order. +Qed. + +Lemma linear_diff_spec s1 s2 x `(Ok s1, Ok s2) : + InT x (linear_diff s1 s2) <-> InT x s1 /\ ~InT x s2. +Proof. + unfold linear_diff. + rewrite !rev_elements_rev, treeify_spec, diff_list_spec + by (rewrite rev_involutive; auto_tc). + rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. tauto. +Qed. + +Lemma fold_remove_spec s1 s2 x `(Ok s2) : + InT x (fold remove s1 s2) <-> InT x s2 /\ ~InT x s1. +Proof. + rewrite fold_spec, <- fold_left_rev_right. + rewrite <- (elements_spec1 s1), <- InA_rev by auto_tc. + unfold elt in *. + induction (rev (elements s1)); simpl; intros. + - rewrite InA_nil. intuition. + - unfold flip in *. rewrite remove_spec, IHl, InA_cons. tauto. + clear IHl. induction l; simpl; auto_tc. +Qed. + +Lemma diff_spec s1 s2 y `{Ok s1, Ok s2} : + InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2. +Proof. + unfold diff. destruct compare_height. + - now apply linear_diff_spec. + - rewrite filter_spec, Bool.negb_true_iff, + <- Bool.not_true_iff_false, mem_spec; + intuition. + intros x1 x2 EQ. f_equal. now apply mem_proper. + - now apply fold_remove_spec. +Qed. + +End MakeRaw. + +(** * Balancing properties + + We now prove that all operations preserve a red-black invariant, + and that trees have hence a logarithmic depth. +*) + +Module BalanceProps(X:Orders.OrderedType)(Import M : MakeRaw X). + +Local Notation Rd := (Node Red). +Local Notation Bk := (Node Black). +Import M.MX. + +(** ** Red-Black invariants *) + +(** In a red-black tree : + - a red node has no red children + - the black depth at each node is the same along all paths. + The black depth is here an argument of the predicate. *) + +Inductive rbt : nat -> tree -> Prop := + | RB_Leaf : rbt 0 Leaf + | RB_Rd n l k r : + notred l -> notred r -> rbt n l -> rbt n r -> rbt n (Rd l k r) + | RB_Bk n l k r : rbt n l -> rbt n r -> rbt (S n) (Bk l k r). + +(** A red-red tree is almost a red-black tree, except that it has + a _red_ root node which _may_ have red children. Note that a + red-red tree is hence non-empty, and all its strict subtrees + are red-black. *) + +Inductive rrt (n:nat) : tree -> Prop := + | RR_Rd l k r : rbt n l -> rbt n r -> rrt n (Rd l k r). + +(** An almost-red-black tree is almost a red-black tree, except that + it's permitted to have two red nodes in a row at the very root (only). + We implement this notion by saying that a quasi-red-black tree + is either a red-black tree or a red-red tree. *) + +Inductive arbt (n:nat)(t:tree) : Prop := + | ARB_RB : rbt n t -> arbt n t + | ARB_RR : rrt n t -> arbt n t. + +(** The main exported invariant : being a red-black tree for some + black depth. *) + +Class Rbt (t:tree) := RBT : exists d, rbt d t. + +(** ** Basic tactics and results about red-black *) + +Scheme rbt_ind := Induction for rbt Sort Prop. +Local Hint Constructors rbt rrt arbt. +Local Hint Extern 0 (notred _) => (exact I). +Ltac invrb := intros; invtree rrt; invtree rbt; try contradiction. +Ltac desarb := match goal with H:arbt _ _ |- _ => destruct H end. +Ltac nonzero n := destruct n as [|n]; [try split; invrb|]. + +Lemma rr_nrr_rb n t : + rrt n t -> notredred t -> rbt n t. +Proof. + destruct 1 as [l x r Hl Hr]. + destruct l, r; descolor; invrb; auto. +Qed. + +Local Hint Resolve rr_nrr_rb. + +Lemma arb_nrr_rb n t : + arbt n t -> notredred t -> rbt n t. +Proof. + destruct 1; auto. +Qed. + +Lemma arb_nr_rb n t : + arbt n t -> notred t -> rbt n t. +Proof. + destruct 1; destruct t; descolor; invrb; auto. +Qed. + +Local Hint Resolve arb_nrr_rb arb_nr_rb. + +(** ** A Red-Black tree has indeed a logarithmic depth *) + +Definition redcarac s := rcase (fun _ _ _ => 1) (fun _ => 0) s. + +Lemma rb_maxdepth s n : rbt n s -> maxdepth s <= 2*n + redcarac s. +Proof. + induction 1. + - simpl; auto. + - replace (redcarac l) with 0 in * by now destree l. + replace (redcarac r) with 0 in * by now destree r. + simpl maxdepth. simpl redcarac. + rewrite Nat.add_succ_r, <- Nat.succ_le_mono. + now apply Nat.max_lub. + - simpl. Nat.nzsimpl. rewrite <- Nat.succ_le_mono. + apply Nat.max_lub; eapply Nat.le_trans; eauto. + destree l; simpl; lia. + destree r; simpl; lia. +Qed. + +Lemma rb_mindepth s n : rbt n s -> n + redcarac s <= mindepth s. +Proof. + induction 1; simpl. + - trivial. + - rewrite Nat.add_succ_r. + apply -> Nat.succ_le_mono. + replace (redcarac l) with 0 in * by now destree l. + replace (redcarac r) with 0 in * by now destree r. + now apply Nat.min_glb. + - apply -> Nat.succ_le_mono. apply Nat.min_glb; lia. +Qed. + +Lemma maxdepth_upperbound s : Rbt s -> + maxdepth s <= 2 * log2 (S (cardinal s)). +Proof. + intros (n,H). + eapply Nat.le_trans; [eapply rb_maxdepth; eauto|]. + generalize (rb_mindepth s n H). + generalize (mindepth_log_cardinal s). lia. +Qed. + +Lemma maxdepth_lowerbound s : s<>Leaf -> + log2 (cardinal s) < maxdepth s. +Proof. + apply maxdepth_log_cardinal. +Qed. + + +(** ** Singleton *) + +Lemma singleton_rb x : Rbt (singleton x). +Proof. + unfold singleton. exists 1; auto. +Qed. + +(** ** [makeBlack] and [makeRed] *) + +Lemma makeBlack_rb n t : arbt n t -> Rbt (makeBlack t). +Proof. + destruct t as [|[|] l x r]. + - exists 0; auto. + - destruct 1; invrb; exists (S n); simpl; auto. + - exists n; auto. +Qed. + +Lemma makeRed_rr t n : + rbt (S n) t -> notred t -> rrt n (makeRed t). +Proof. + destruct t as [|[|] l x r]; invrb; simpl; auto. +Qed. + +(** ** Balancing *) + +Lemma lbal_rb n l k r : + arbt n l -> rbt n r -> rbt (S n) (lbal l k r). +Proof. +case lbal_match; intros; desarb; invrb; auto. +Qed. + +Lemma rbal_rb n l k r : + rbt n l -> arbt n r -> rbt (S n) (rbal l k r). +Proof. +case rbal_match; intros; desarb; invrb; auto. +Qed. + +Lemma rbal'_rb n l k r : + rbt n l -> arbt n r -> rbt (S n) (rbal' l k r). +Proof. +case rbal'_match; intros; desarb; invrb; auto. +Qed. + +Lemma lbalS_rb n l x r : + arbt n l -> rbt (S n) r -> notred r -> rbt (S n) (lbalS l x r). +Proof. + intros Hl Hr Hr'. + destruct r as [|[|] rl rx rr]; invrb. clear Hr'. + revert Hl. + case lbalS_match. + - destruct 1; invrb; auto. + - intros. apply rbal'_rb; auto. +Qed. + +Lemma lbalS_arb n l x r : + arbt n l -> rbt (S n) r -> arbt (S n) (lbalS l x r). +Proof. + case lbalS_match. + - destruct 1; invrb; auto. + - clear l. intros l Hl Hl' Hr. + destruct r as [|[|] rl rx rr]; invrb. + * destruct rl as [|[|] rll rlx rlr]; invrb. + right; auto using rbal'_rb, makeRed_rr. + * left; apply rbal'_rb; auto. +Qed. + +Lemma rbalS_rb n l x r : + rbt (S n) l -> notred l -> arbt n r -> rbt (S n) (rbalS l x r). +Proof. + intros Hl Hl' Hr. + destruct l as [|[|] ll lx lr]; invrb. clear Hl'. + revert Hr. + case rbalS_match. + - destruct 1; invrb; auto. + - intros. apply lbal_rb; auto. +Qed. + +Lemma rbalS_arb n l x r : + rbt (S n) l -> arbt n r -> arbt (S n) (rbalS l x r). +Proof. + case rbalS_match. + - destruct 2; invrb; auto. + - clear r. intros r Hr Hr' Hl. + destruct l as [|[|] ll lx lr]; invrb. + * destruct lr as [|[|] lrl lrx lrr]; invrb. + right; auto using lbal_rb, makeRed_rr. + * left; apply lbal_rb; auto. +Qed. + + +(** ** Insertion *) + +(** The next lemmas combine simultaneous results about rbt and arbt. + A first solution here: statement with [if ... then ... else] *) + +Definition ifred s (A B:Prop) := rcase (fun _ _ _ => A) (fun _ => B) s. + +Lemma ifred_notred s A B : notred s -> (ifred s A B <-> B). +Proof. + destruct s; descolor; simpl; intuition. +Qed. + +Lemma ifred_or s A B : ifred s A B -> A\/B. +Proof. + destruct s; descolor; simpl; intuition. +Qed. + +Lemma ins_rr_rb x s n : rbt n s -> + ifred s (rrt n (ins x s)) (rbt n (ins x s)). +Proof. +induction 1 as [ | n l k r | n l k r Hl IHl Hr IHr ]. +- simpl; auto. +- simpl. rewrite ifred_notred in * by trivial. + elim_compare x k; auto. +- rewrite ifred_notred by trivial. + unfold ins; fold ins. (* simpl is too much here ... *) + elim_compare x k. + * auto. + * apply lbal_rb; trivial. apply ifred_or in IHl; intuition. + * apply rbal_rb; trivial. apply ifred_or in IHr; intuition. +Qed. + +Lemma ins_arb x s n : rbt n s -> arbt n (ins x s). +Proof. + intros H. apply (ins_rr_rb x), ifred_or in H. intuition. +Qed. + +Instance add_rb x s : Rbt s -> Rbt (add x s). +Proof. + intros (n,H). unfold add. now apply (makeBlack_rb n), ins_arb. +Qed. + +(** ** Deletion *) + +(** A second approach here: statement with ... /\ ... *) + +Lemma append_arb_rb n l r : rbt n l -> rbt n r -> + (arbt n (append l r)) /\ + (notred l -> notred r -> rbt n (append l r)). +Proof. +revert r n. +append_tac l r. +- split; auto. +- split; auto. +- (* Red / Red *) + intros n. invrb. + case (IHlr n); auto; clear IHlr. + case append_rr_match. + + intros a x b _ H; split; invrb. + assert (rbt n (Rd a x b)) by auto. invrb. auto. + + split; invrb; auto. +- (* Red / Black *) + split; invrb. destruct (IHlr n) as (_,IH); auto. +- (* Black / Red *) + split; invrb. destruct (IHrl n) as (_,IH); auto. +- (* Black / Black *) + nonzero n. + invrb. + destruct (IHlr n) as (IH,_); auto; clear IHlr. + revert IH. + case append_bb_match. + + intros a x b IH; split; destruct IH; invrb; auto. + + split; [left | invrb]; auto using lbalS_rb. +Qed. + +(** A third approach : Lemma ... with ... *) + +Lemma del_arb s x n : rbt (S n) s -> isblack s -> arbt n (del x s) +with del_rb s x n : rbt n s -> notblack s -> rbt n (del x s). +Proof. +{ revert n. + induct s x; try destruct c; try contradiction; invrb. + - apply append_arb_rb; assumption. + - assert (IHl' := del_rb l x). clear IHr del_arb del_rb. + destruct l as [|[|] ll lx lr]; auto. + nonzero n. apply lbalS_arb; auto. + - assert (IHr' := del_rb r x). clear IHl del_arb del_rb. + destruct r as [|[|] rl rx rr]; auto. + nonzero n. apply rbalS_arb; auto. } +{ revert n. + induct s x; try assumption; try destruct c; try contradiction; invrb. + - apply append_arb_rb; assumption. + - assert (IHl' := del_arb l x). clear IHr del_arb del_rb. + destruct l as [|[|] ll lx lr]; auto. + nonzero n. destruct n as [|n]; [invrb|]; apply lbalS_rb; auto. + - assert (IHr' := del_arb r x). clear IHl del_arb del_rb. + destruct r as [|[|] rl rx rr]; auto. + nonzero n. apply rbalS_rb; auto. } +Qed. + +Instance remove_rb s x : Rbt s -> Rbt (remove x s). +Proof. + intros (n,H). unfold remove. + destruct s as [|[|] l y r]. + - apply (makeBlack_rb n). auto. + - apply (makeBlack_rb n). left. apply del_rb; simpl; auto. + - nonzero n. apply (makeBlack_rb n). apply del_arb; simpl; auto. +Qed. + +(** ** Treeify *) + +Definition treeify_rb_invariant size depth (f:treeify_t) := + forall acc, + size <= length acc -> + rbt depth (fst (f acc)) /\ + size + length (snd (f acc)) = length acc. + +Lemma treeify_zero_rb : treeify_rb_invariant 0 0 treeify_zero. +Proof. + intros acc _; simpl; auto. +Qed. + +Lemma treeify_one_rb : treeify_rb_invariant 1 0 treeify_one. +Proof. + intros [|x acc]; simpl; auto; inversion 1. +Qed. + +Lemma treeify_cont_rb f g size1 size2 size d : + treeify_rb_invariant size1 d f -> + treeify_rb_invariant size2 d g -> + size = S (size1 + size2) -> + treeify_rb_invariant size (S d) (treeify_cont f g). +Proof. + intros Hf Hg H acc Hacc. + unfold treeify_cont. + specialize (Hf acc). + destruct (f acc) as (l, acc1). simpl in *. + destruct Hf as (Hf1, Hf2). { lia. } + destruct acc1 as [|x acc2]; simpl in *. { lia. } + specialize (Hg acc2). + destruct (g acc2) as (r, acc3). simpl in *. + destruct Hg as (Hg1, Hg2). { lia. } + split; [auto | lia]. +Qed. + +Lemma treeify_aux_rb n : + exists d, forall (b:bool), + treeify_rb_invariant (ifpred b (Pos.to_nat n)) d (treeify_aux b n). +Proof. + induction n as [n (d,IHn)|n (d,IHn)| ]. + - exists (S d). intros b. + eapply treeify_cont_rb; [ apply (IHn false) | apply (IHn b) | ]. + rewrite Pos2Nat.inj_xI. generalize (Pos2Nat.is_pos n). + destruct b; simpl; lia. + - exists (S d). intros b. + eapply treeify_cont_rb; [ apply (IHn b) | apply (IHn true) | ]. + rewrite Pos2Nat.inj_xO. generalize (Pos2Nat.is_pos n). + destruct b; simpl; lia. + - exists 0; destruct b; + [ apply treeify_zero_rb | apply treeify_one_rb ]. +Qed. + +(** The black depth of [treeify l] is actually a log2, but + we don't need to mention that. *) + +Instance treeify_rb l : Rbt (treeify l). +Proof. + unfold treeify. + destruct (treeify_aux_rb (plength l)) as (d,H). + exists d. + apply H. + now rewrite plength_spec. +Qed. + +(** ** Filtering *) + +Instance filter_rb f s : Rbt (filter f s). +Proof. + unfold filter; auto_tc. +Qed. + +Instance partition_rb1 f s : Rbt (fst (partition f s)). +Proof. + unfold partition. destruct partition_aux. simpl. auto_tc. +Qed. + +Instance partition_rb2 f s : Rbt (snd (partition f s)). +Proof. + unfold partition. destruct partition_aux. simpl. auto_tc. +Qed. + +(** ** Union, intersection, difference *) + +Instance fold_add_rb s1 s2 : Rbt s2 -> Rbt (fold add s1 s2). +Proof. + intros. rewrite fold_spec, <- fold_left_rev_right. unfold elt in *. + induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. +Qed. + +Instance fold_remove_rb s1 s2 : Rbt s2 -> Rbt (fold remove s1 s2). +Proof. + intros. rewrite fold_spec, <- fold_left_rev_right. unfold elt in *. + induction (rev (elements s1)); simpl; unfold flip in *; auto_tc. +Qed. + +Lemma union_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (union s1 s2). +Proof. + intros. unfold union, linear_union. destruct compare_height; auto_tc. +Qed. + +Lemma inter_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (inter s1 s2). +Proof. + intros. unfold inter, linear_inter. destruct compare_height; auto_tc. +Qed. + +Lemma diff_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (diff s1 s2). +Proof. + intros. unfold diff, linear_diff. destruct compare_height; auto_tc. +Qed. + +End BalanceProps. + +(** * Final Encapsulation + + Now, in order to really provide a functor implementing [S], we + need to encapsulate everything into a type of binary search trees. + They also happen to be well-balanced, but this has no influence + on the correctness of operations, so we won't state this here, + see [BalanceProps] if you need more than just the MSet interface. +*) + +Module Type MSetInterface_S_Ext := MSetInterface.S <+ MSetRemoveMin. + +Module Make (X: Orders.OrderedType) <: + MSetInterface_S_Ext with Module E := X. + Module Raw. Include MakeRaw X. End Raw. + Include MSetInterface.Raw2Sets X Raw. + + Definition opt_ok (x:option (elt * Raw.t)) := + match x with Some (_,s) => Raw.Ok s | None => True end. + + Definition mk_opt_t (x: option (elt * Raw.t))(P: opt_ok x) : + option (elt * t) := + match x as o return opt_ok o -> option (elt * t) with + | Some (k,s') => fun P : Raw.Ok s' => Some (k, Mkt s') + | None => fun _ => None + end P. + + Definition remove_min s : option (elt * t) := + mk_opt_t (Raw.remove_min (this s)) (Raw.remove_min_ok s). + + Lemma remove_min_spec1 s x s' : + remove_min s = Some (x,s') -> + min_elt s = Some x /\ Equal (remove x s) s'. + Proof. + destruct s as (s,Hs). + unfold remove_min, mk_opt_t, min_elt, remove, Equal, In; simpl. + generalize (fun x s' => @Raw.remove_min_spec1 s x s' Hs). + set (P := Raw.remove_min_ok s). clearbody P. + destruct (Raw.remove_min s) as [(x0,s0)|]; try easy. + intros H U. injection U. clear U; intros; subst. simpl. + destruct (H x s0); auto. subst; intuition. + Qed. + + Lemma remove_min_spec2 s : remove_min s = None -> Empty s. + Proof. + destruct s as (s,Hs). + unfold remove_min, mk_opt_t, Empty, In; simpl. + generalize (Raw.remove_min_spec2 s). + set (P := Raw.remove_min_ok s). clearbody P. + destruct (Raw.remove_min s) as [(x0,s0)|]; now intuition. + Qed. + +End Make. diff --git a/theories/MSets/vo.itarget b/theories/MSets/vo.itarget index 14429b81..7c5b6899 100644 --- a/theories/MSets/vo.itarget +++ b/theories/MSets/vo.itarget @@ -1,4 +1,6 @@ +MSetGenTree.vo MSetAVL.vo +MSetRBT.vo MSetDecide.vo MSetEqProperties.vo MSetFacts.vo diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index 06ff7cd1..d408845e 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -28,7 +28,7 @@ Hint Extern 10 => is_ground_goal ; progress exfalso : exfalso. Definition block {A : Type} (a : A) := a. Ltac block_goal := match goal with [ |- ?T ] => change (block T) end. -Ltac unblock_goal := cbv beta delta [block]. +Ltac unblock_goal := unfold block in *. (** Notation for heterogenous equality. *) @@ -214,7 +214,8 @@ Ltac simplify_eqs := Ltac simplify_IH_hyps := repeat match goal with - | [ hyp : _ |- _ ] => specialize_eqs hyp + | [ hyp : context [ block _ ] |- _ ] => + specialize_eqs hyp end. (** We split substitution tactics in the two directions depending on which @@ -377,14 +378,23 @@ Ltac is_introduced H := end. Tactic Notation "intro_block" hyp(H) := - (is_introduced H ; block_goal ; revert_until H) || + (is_introduced H ; block_goal ; revert_until H ; block_goal) || (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal). Tactic Notation "intro_block_id" ident(H) := - (is_introduced H ; block_goal ; revert_until H) || + (is_introduced H ; block_goal ; revert_until H; block_goal) || (let H' := fresh H in intros until H' ; block_goal) || (intros ; block_goal). -Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_goal. +Ltac unblock_dep_elim := + match goal with + | |- block ?T => + match T with context [ block _ ] => + change T ; intros ; unblock_goal + end + | _ => unblock_goal + end. + +Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_dep_elim. Ltac do_intros H := (try intros until H) ; (intro_block_id H || intro_block H). @@ -395,7 +405,7 @@ Ltac do_depelim tac H := do_depelim_nosimpl tac H ; simpl_dep_elim. Ltac do_depind tac H := (try intros until H) ; intro_block H ; - generalize_eqs_vars H ; tac H ; simplify_dep_elim ; simplify_IH_hyps ; unblock_goal. + generalize_eqs_vars H ; tac H ; simpl_dep_elim. (** To dependent elimination on some hyp. *) @@ -412,8 +422,8 @@ 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 ; generalize_eqs H ; tac H ; simplify_dep_elim ; - simplify_IH_hyps ; unblock_goal. + (try intros until H) ; block_goal ; rev H ; + (try revert_until H ; block_goal) ; generalize_eqs 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. *) diff --git a/theories/Unicode/Utf8_core.v b/theories/Unicode/Utf8_core.v index 31724b3c..13387f30 100644 --- a/theories/Unicode/Utf8_core.v +++ b/theories/Unicode/Utf8_core.v @@ -17,7 +17,9 @@ Notation "∃ x .. y , P" := (exists x, .. (exists y, P) ..) Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope. Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope. -Notation "x → y" := (x -> y) (at level 90, right associativity): type_scope. +Notation "x → y" := (x -> y) + (at level 90, y at level 200, right associativity): type_scope. + Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope. Notation "¬ x" := (~x) (at level 75, right associativity) : type_scope. Notation "x ≠y" := (x <> y) (at level 70) : type_scope. diff --git a/theories/Vectors/Fin.v b/theories/Vectors/Fin.v index 28e355fb..a5e37f34 100644 --- a/theories/Vectors/Fin.v +++ b/theories/Vectors/Fin.v @@ -14,7 +14,7 @@ Require Arith_base. the n-uplet and [FS] set (n-1)-uplet of all the element but the first. Author: Pierre Boutillier - Institution: PPS, INRIA 12/2010 + Institution: PPS, INRIA 12/2010-01/2012 *) Inductive t : nat -> Set := @@ -69,6 +69,13 @@ match a with end. End SCHEMES. +Definition FS_inj {n} (x y: t n) (eq: FS x = FS y): x = y := +match eq in _ = a return + match a as a' in t m return match m with |0 => Prop |S n' => t n' -> Prop end + with @F1 _ => fun _ => True |@FS _ y => fun x' => x' = y end x with + eq_refl => eq_refl +end. + (** [to_nat f] = p iff [f] is the p{^ th} element of [fin m]. *) Fixpoint to_nat {m} (n : t m) : {i | i < m} := match n in t k return {i | i< k} with @@ -167,6 +174,7 @@ end. Lemma depair_sanity {m n} (o : t m) (p : t n) : proj1_sig (to_nat (depair o p)) = n * (proj1_sig (to_nat o)) + (proj1_sig (to_nat p)). +Proof. induction o ; simpl. rewrite L_sanity. now rewrite Mult.mult_0_r. diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index 0fee50ff..30c0d4c0 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -40,17 +40,17 @@ Definition rectS {A} (P:forall {n}, t A (S n) -> Type) (rect: forall a {n} (v: t A (S n)), P v -> P (a :: v)) := fix rectS_fix {n} (v: t A (S n)) : P v := match v with - |nil => @id + |nil => fun devil => False_rect (@ID) devil |cons a 0 v => match v as vnn in t _ nn return match nn,vnn with |0,vm => P (a :: vm) - |S _,_ => ID + |S _,_ => _ end with |nil => bas a - |_ :: _ => @id + |_ :: _ => fun devil => False_rect (@ID) devil end |cons a (S nn') v => rect a v (rectS_fix v) end. @@ -66,11 +66,11 @@ match v1 as v1' in t _ n1 |[] => fun v2 => match v2 with |[] => bas - |_ :: _ => @id + |_ :: _ => fun devil => False_rect (@ID) devil end |h1 :: t1 => fun v2 => match v2 with - |[] => @id + |[] => fun devil => False_rect (@ID) devil |h2 :: t2 => fun t1' => rect (rect2_fix t1' t2) h1 h2 end t1 @@ -83,10 +83,10 @@ match v with end. (** A vector of length [S _] is [cons] *) -Definition caseS {A} (P : forall n, t A (S n) -> Type) - (H : forall h {n} t, @P n (h :: t)) {n} v : P n v := -match v with - |[] => @id (* Why needed ? *) +Definition caseS {A} (P : forall {n}, t A (S n) -> Type) + (H : forall h {n} t, @P n (h :: t)) {n} (v: t A (S n)) : P v := +match v as v' in t _ m return match m, v' with |0, _ => False -> True |S _, v0 => P v' end with + |[] => fun devil => False_rect _ devil (* subterm !!! *) |h :: t => H h t end. End SCHEMES. @@ -111,11 +111,12 @@ Fixpoint const {A} (a:A) (n:nat) := Computational behavior of this function should be the same as ocaml function. *) -Fixpoint nth {A} {m} (v' : t A m) (p : Fin.t m) {struct p} : A := +Definition nth {A} := +fix nth_fix {m} (v' : t A m) (p : Fin.t m) {struct v'} : A := match p in Fin.t m' return t A m' -> A with |Fin.F1 q => fun v => caseS (fun n v' => A) (fun h n t => h) v |Fin.FS q p' => fun v => (caseS (fun n v' => Fin.t n -> A) - (fun h n t p0 => nth t p0) v) p' + (fun h n t p0 => nth_fix t p0) v) p' end v'. (** An equivalent definition of [nth]. *) diff --git a/theories/Vectors/VectorSpec.v b/theories/Vectors/VectorSpec.v index a576315e..2f4086e5 100644 --- a/theories/Vectors/VectorSpec.v +++ b/theories/Vectors/VectorSpec.v @@ -16,6 +16,12 @@ Require Fin. Require Import VectorDef. Import VectorNotations. +Definition cons_inj A a1 a2 n (v1 v2 : t A n) + (eq : a1 :: v1 = a2 :: v2) : a1 = a2 /\ v1 = v2 := + match eq in _ = x return caseS _ (fun a2' _ v2' => fun v1' => a1 = a2' /\ v1' = v2') x v1 + with | eq_refl => conj eq_refl eq_refl + end. + (** Lemmas are done for functions that use [Fin.t] but thanks to [Peano_dec.le_unique], all is true for the one that use [lt] *) diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v index ce0fee71..0e096100 100644 --- a/theories/Wellfounded/Lexicographic_Product.v +++ b/theories/Wellfounded/Lexicographic_Product.v @@ -54,7 +54,7 @@ Section WfLexicographic_Product. subst x1. apply IHAcc0. elim inj_pair2 with A B x y' x0; assumption. - Qed. + Defined. Theorem wf_lexprod : well_founded leA -> @@ -65,7 +65,7 @@ Section WfLexicographic_Product. apply acc_A_B_lexprod; auto with sets; intros. red in wfB. auto with sets. - Qed. + Defined. End WfLexicographic_Product. @@ -88,7 +88,7 @@ Section Wf_Symmetric_Product. inversion_clear H5; auto with sets. apply IHAcc; auto. apply Acc_intro; trivial. - Qed. + Defined. Lemma wf_symprod : @@ -97,7 +97,7 @@ Section Wf_Symmetric_Product. red in |- *. destruct a. apply Acc_symprod; auto with sets. - Qed. + Defined. End Wf_Symmetric_Product. @@ -128,7 +128,7 @@ Section Swap. apply sp_noswap. apply left_sym; auto with sets. - Qed. + Defined. Lemma Acc_swapprod : @@ -156,7 +156,7 @@ Section Swap. apply right_sym; auto with sets. auto with sets. - Qed. + Defined. Lemma wf_swapprod : well_founded R -> well_founded SwapProd. @@ -164,6 +164,6 @@ Section Swap. red in |- *. destruct a; intros. apply Acc_swapprod; auto with sets. - Qed. + Defined. End Swap. diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index bac50fc4..7c840c56 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -16,28 +16,29 @@ Require Import ZArith. Delimit Scope Int_scope with I. - +Local Open Scope Int_scope. (** * a specification of integers *) Module Type Int. - Open Scope Int_scope. + Parameter t : Set. + Bind Scope Int_scope with t. - Parameter int : Set. + (** For compatibility *) + Definition int := t. - Parameter i2z : int -> Z. - Arguments i2z _%I. + Parameter i2z : t -> Z. - Parameter _0 : int. - Parameter _1 : int. - Parameter _2 : int. - Parameter _3 : int. - Parameter plus : int -> int -> int. - Parameter opp : int -> int. - Parameter minus : int -> int -> int. - Parameter mult : int -> int -> int. - Parameter max : int -> int -> int. + Parameter _0 : t. + Parameter _1 : t. + Parameter _2 : t. + Parameter _3 : t. + Parameter plus : t -> t -> t. + Parameter opp : t -> t. + Parameter minus : t -> t -> t. + Parameter mult : t -> t -> t. + Parameter max : t -> t -> t. Notation "0" := _0 : Int_scope. Notation "1" := _1 : Int_scope. @@ -54,10 +55,10 @@ Module Type Int. Notation "x == y" := (i2z x = i2z y) (at level 70, y at next level, no associativity) : Int_scope. - Notation "x <= y" := (Zle (i2z x) (i2z y)): Int_scope. - Notation "x < y" := (Zlt (i2z x) (i2z y)) : Int_scope. - Notation "x >= y" := (Zge (i2z x) (i2z y)) : Int_scope. - Notation "x > y" := (Zgt (i2z x) (i2z y)): Int_scope. + Notation "x <= y" := (i2z x <= i2z y)%Z : Int_scope. + Notation "x < y" := (i2z x < i2z y)%Z : Int_scope. + Notation "x >= y" := (i2z x >= i2z y)%Z : Int_scope. + Notation "x > y" := (i2z x > i2z y)%Z : Int_scope. Notation "x <= y <= z" := (x <= y /\ y <= z) : Int_scope. Notation "x <= y < z" := (x <= y /\ y < z) : Int_scope. Notation "x < y < z" := (x < y /\ y < z) : Int_scope. @@ -65,41 +66,39 @@ Module Type Int. (** Some decidability fonctions (informative). *) - Axiom gt_le_dec : forall x y: int, {x > y} + {x <= y}. - Axiom ge_lt_dec : forall x y : int, {x >= y} + {x < y}. - Axiom eq_dec : forall x y : int, { x == y } + {~ x==y }. + Axiom gt_le_dec : forall x y : t, {x > y} + {x <= y}. + Axiom ge_lt_dec : forall x y : t, {x >= y} + {x < y}. + Axiom eq_dec : forall x y : t, { x == y } + {~ x==y }. (** Specifications *) (** First, we ask [i2z] to be injective. Said otherwise, our ad-hoc equality [==] and the generic [=] are in fact equivalent. We define [==] - nonetheless since the translation to [Z] for using automatic tactic is easier. *) + nonetheless since the translation to [Z] for using automatic tactic + is easier. *) - Axiom i2z_eq : forall n p : int, n == p -> n = p. + Axiom i2z_eq : forall n p : t, n == p -> n = p. (** Then, we express the specifications of the above parameters using their Z counterparts. *) - Open Scope Z_scope. - Axiom i2z_0 : i2z _0 = 0. - Axiom i2z_1 : i2z _1 = 1. - Axiom i2z_2 : i2z _2 = 2. - Axiom i2z_3 : i2z _3 = 3. - Axiom i2z_plus : forall n p, i2z (n + p) = i2z n + i2z p. - Axiom i2z_opp : forall n, i2z (-n) = -i2z n. - Axiom i2z_minus : forall n p, i2z (n - p) = i2z n - i2z p. - Axiom i2z_mult : forall n p, i2z (n * p) = i2z n * i2z p. - Axiom i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p). + Axiom i2z_0 : i2z _0 = 0%Z. + 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_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_max : forall n p, i2z (max n p) = Z.max (i2z n) (i2z p). End Int. (** * Facts and tactics using [Int] *) -Module MoreInt (I:Int). - Import I. - - Open Scope Int_scope. +Module MoreInt (Import I:Int). + Local Notation int := I.t. (** A magic (but costly) tactic that goes from [int] back to the [Z] friendly world ... *) @@ -108,13 +107,14 @@ Module MoreInt (I:Int). i2z_0 i2z_1 i2z_2 i2z_3 i2z_plus i2z_opp i2z_minus i2z_mult i2z_max : i2z. Ltac i2z := match goal with - | H : (eq (A:=int) ?a ?b) |- _ => - generalize (f_equal i2z H); - try autorewrite with i2z; clear H; intro H; i2z - | |- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); try autorewrite with i2z; i2z - | H : _ |- _ => progress autorewrite with i2z in H; i2z - | _ => try autorewrite with i2z - end. + | H : ?a = ?b |- _ => + generalize (f_equal i2z H); + try autorewrite with i2z; clear H; intro H; i2z + | |- ?a = ?b => + apply (i2z_eq a b); try autorewrite with i2z; i2z + | H : _ |- _ => progress autorewrite with i2z in H; i2z + | _ => try autorewrite with i2z + end. (** A reflexive version of the [i2z] tactic *) @@ -124,14 +124,14 @@ Module MoreInt (I:Int). Anyhow, [i2z_refl] is enough for applying [romega]. *) Ltac i2z_gen := match goal with - | |- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); i2z_gen - | H : (eq (A:=int) ?a ?b) |- _ => + | |- ?a = ?b => apply (i2z_eq a b); i2z_gen + | H : ?a = ?b |- _ => generalize (f_equal i2z H); clear H; i2z_gen - | H : (eq (A:=Z) ?a ?b) |- _ => revert H; i2z_gen - | H : (Zlt ?a ?b) |- _ => revert H; i2z_gen - | H : (Zle ?a ?b) |- _ => revert H; i2z_gen - | H : (Zgt ?a ?b) |- _ => revert H; i2z_gen - | H : (Zge ?a ?b) |- _ => revert H; i2z_gen + | H : eq (A:=Z) ?a ?b |- _ => revert H; i2z_gen + | H : Z.lt ?a ?b |- _ => revert H; i2z_gen + | H : Z.le ?a ?b |- _ => revert H; i2z_gen + | H : Z.gt ?a ?b |- _ => revert H; i2z_gen + | H : Z.ge ?a ?b |- _ => revert H; i2z_gen | H : _ -> ?X |- _ => (* A [Set] or [Type] part cannot be dealt with easily using the [ExprP] datatype. So we forget it, leaving @@ -201,11 +201,11 @@ Module MoreInt (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) - | (Zmax ?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) + | (?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) + | (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) | ?x => constr:(EZraw x) end. @@ -360,8 +360,9 @@ End MoreInt. (** It's always nice to know that our [Int] interface is realizable :-) *) Module Z_as_Int <: Int. - Open Scope Z_scope. - Definition int := Z. + Local Open Scope Z_scope. + Definition t := Z. + Definition int := t. Definition _0 := 0. Definition _1 := 1. Definition _2 := 2. @@ -380,10 +381,9 @@ Module Z_as_Int <: Int. 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 : forall n p, i2z (n + p) = i2z n + i2z p. Proof. auto. Qed. - Lemma i2z_opp : forall n, i2z (- n) = - i2z n. Proof. auto. Qed. - Lemma i2z_minus : forall n p, i2z (n - p) = i2z n - i2z p. Proof. auto. Qed. - Lemma i2z_mult : forall n p, i2z (n * p) = i2z n * i2z p. Proof. auto. Qed. - Lemma i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p). 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) = Zmax (i2z n) (i2z p). Proof. auto. Qed. End Z_as_Int. - diff --git a/theories/ZArith/ZOdiv.v b/theories/ZArith/ZOdiv.v new file mode 100644 index 00000000..17c5bae3 --- /dev/null +++ b/theories/ZArith/ZOdiv.v @@ -0,0 +1,88 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Export ZOdiv_def. +Require Import BinInt Zquot. + +Notation ZO_div_mod_eq := Z.quot_rem' (only parsing). +Notation ZOmod_lt := Zrem_lt (only parsing). +Notation ZOmod_sgn := Zrem_sgn (only parsing). +Notation ZOmod_sgn2 := Zrem_sgn2 (only parsing). +Notation ZOmod_lt_pos := Zrem_lt_pos (only parsing). +Notation ZOmod_lt_neg := Zrem_lt_neg (only parsing). +Notation ZOmod_lt_pos_pos := Zrem_lt_pos_pos (only parsing). +Notation ZOmod_lt_pos_neg := Zrem_lt_pos_neg (only parsing). +Notation ZOmod_lt_neg_pos := Zrem_lt_neg_pos (only parsing). +Notation ZOmod_lt_neg_neg := Zrem_lt_neg_neg (only parsing). + +Notation ZOdiv_opp_l := Zquot_opp_l (only parsing). +Notation ZOdiv_opp_r := Zquot_opp_r (only parsing). +Notation ZOmod_opp_l := Zrem_opp_l (only parsing). +Notation ZOmod_opp_r := Zrem_opp_r (only parsing). +Notation ZOdiv_opp_opp := Zquot_opp_opp (only parsing). +Notation ZOmod_opp_opp := Zrem_opp_opp (only parsing). + +Notation Remainder := Remainder (only parsing). +Notation Remainder_alt := Remainder_alt (only parsing). +Notation Remainder_equiv := Remainder_equiv (only parsing). +Notation ZOdiv_mod_unique_full := Zquot_mod_unique_full (only parsing). +Notation ZOdiv_unique_full := Zquot_unique_full (only parsing). +Notation ZOdiv_unique := Zquot_unique (only parsing). +Notation ZOmod_unique_full := Zrem_unique_full (only parsing). +Notation ZOmod_unique := Zrem_unique (only parsing). + +Notation ZOmod_0_l := Zrem_0_l (only parsing). +Notation ZOmod_0_r := Zrem_0_r (only parsing). +Notation ZOdiv_0_l := Zquot_0_l (only parsing). +Notation ZOdiv_0_r := Zquot_0_r (only parsing). +Notation ZOmod_1_r := Zrem_1_r (only parsing). +Notation ZOdiv_1_r := Zquot_1_r (only parsing). +Notation ZOdiv_1_l := Zquot_1_l (only parsing). +Notation ZOmod_1_l := Zrem_1_l (only parsing). +Notation ZO_div_same := Z_quot_same (only parsing). +Notation ZO_mod_same := Z_rem_same (only parsing). +Notation ZO_mod_mult := Z_rem_mult (only parsing). +Notation ZO_div_mult := Z_quot_mult (only parsing). + +Notation ZO_div_pos := Z_quot_pos (only parsing). +Notation ZO_div_lt := Z_quot_lt (only parsing). +Notation ZOdiv_small := Zquot_small (only parsing). +Notation ZOmod_small := Zrem_small (only parsing). +Notation ZO_div_monotone := Z_quot_monotone (only parsing). +Notation ZO_mult_div_le := Z_mult_quot_le (only parsing). +Notation ZO_mult_div_ge := Z_mult_quot_ge (only parsing). +Definition ZO_div_exact_full_1 a b := proj1 (Z_quot_exact_full a b). +Definition ZO_div_exact_full_2 a b := proj2 (Z_quot_exact_full a b). +Notation ZOmod_le := Zrem_le (only parsing). +Notation ZOdiv_le_upper_bound := Zquot_le_upper_bound (only parsing). +Notation ZOdiv_lt_upper_bound := Zquot_lt_upper_bound (only parsing). +Notation ZOdiv_le_lower_bound := Zquot_le_lower_bound (only parsing). +Notation ZOdiv_sgn := Zquot_sgn (only parsing). + +Notation ZO_mod_plus := Z_rem_plus (only parsing). +Notation ZO_div_plus := Z_quot_plus (only parsing). +Notation ZO_div_plus_l := Z_quot_plus_l (only parsing). +Notation ZOdiv_mult_cancel_r := Zquot_mult_cancel_r (only parsing). +Notation ZOdiv_mult_cancel_l := Zquot_mult_cancel_l (only parsing). +Notation ZOmult_mod_distr_l := Zmult_rem_distr_l (only parsing). +Notation ZOmult_mod_distr_r := Zmult_rem_distr_r (only parsing). +Notation ZOmod_mod := Zrem_rem (only parsing). +Notation ZOmult_mod := Zmult_rem (only parsing). +Notation ZOplus_mod := Zplus_rem (only parsing). +Notation ZOplus_mod_idemp_l := Zplus_rem_idemp_l (only parsing). +Notation ZOplus_mod_idemp_r := Zplus_rem_idemp_r (only parsing). +Notation ZOmult_mod_idemp_l := Zmult_rem_idemp_l (only parsing). +Notation ZOmult_mod_idemp_r := Zmult_rem_idemp_r (only parsing). +Notation ZOdiv_ZOdiv := Zquot_Zquot (only parsing). +Notation ZOdiv_mult_le := Zquot_mult_le (only parsing). +Notation ZOmod_divides := Zrem_divides (only parsing). + +Notation ZOdiv_eucl_Zdiv_eucl_pos := Zquotrem_Zdiv_eucl_pos (only parsing). +Notation ZOdiv_Zdiv_pos := Zquot_Zdiv_pos (only parsing). +Notation ZOmod_Zmod_pos := Zrem_Zmod_pos (only parsing). +Notation ZOmod_Zmod_zero := Zrem_Zmod_zero (only parsing). diff --git a/theories/ZArith/ZOdiv_def.v b/theories/ZArith/ZOdiv_def.v new file mode 100644 index 00000000..38d25797 --- /dev/null +++ b/theories/ZArith/ZOdiv_def.v @@ -0,0 +1,15 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import BinInt. + +Notation ZOdiv_eucl := Z.quotrem (only parsing). +Notation ZOdiv := Z.quot (only parsing). +Notation ZOmod := Z.rem (only parsing). + +Notation ZOdiv_eucl_correct := Z.quotrem_eq. diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v index 550b66f7..f4d702b2 100644 --- a/theories/ZArith/Zeven.v +++ b/theories/ZArith/Zeven.v @@ -197,14 +197,12 @@ Qed. Lemma Zquot2_quot n : Z.quot2 n = n ÷ 2. Proof. assert (AUX : forall m, 0 < m -> Z.quot2 m = m ÷ 2). - BeginSubproof. - intros m Hm. + { intros m Hm. apply Z.quot_unique with (if Z.odd m then Z.sgn m else 0). now apply Z.lt_le_incl. rewrite Z.sgn_pos by trivial. destruct (Z.odd m); now split. - apply Zquot2_odd_eqn. - EndSubproof. + apply Zquot2_odd_eqn. } destruct (Z.lt_trichotomy 0 n) as [POS|[NUL|NEG]]. - now apply AUX. - now subst. diff --git a/theories/ZArith/vo.itarget b/theories/ZArith/vo.itarget index 178111cd..88751cc0 100644 --- a/theories/ZArith/vo.itarget +++ b/theories/ZArith/vo.itarget @@ -23,6 +23,8 @@ Zmin.vo Zmisc.vo Znat.vo Znumtheory.vo +ZOdiv_def.vo +ZOdiv.vo Zquot.vo Zorder.vo Zpow_def.vo diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index a685d6ea..20117ca6 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -315,10 +315,10 @@ in print "%.vo %.glob: %.v\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) $*\n\n"; print "%.vi: %.v\n\t$(COQC) -i $(COQDEBUG) $(COQFLAGS) $*\n\n"; print "%.g: %.v\n\t$(GALLINA) $<\n\n"; - print "%.tex: %.v\n\t$(COQDOC) -latex $< -o $@\n\n"; - print "%.html: %.v %.glob\n\t$(COQDOC) -html $< -o $@\n\n"; - print "%.g.tex: %.v\n\t$(COQDOC) -latex -g $< -o $@\n\n"; - print "%.g.html: %.v %.glob\n\t$(COQDOC) -html -g $< -o $@\n\n"; + print "%.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@\n\n"; + print "%.html: %.v %.glob\n\t$(COQDOC) $(COQDOCFLAGS) -html $< -o $@\n\n"; + print "%.g.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@\n\n"; + print "%.g.html: %.v %.glob\n\t$(COQDOC)$(COQDOCFLAGS) -html -g $< -o $@\n\n"; print "%.v.d: %.v\n"; print "\t$(COQDEP) -slash $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"; print "%.v.beautified:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $*\n\n" @@ -349,11 +349,13 @@ let variables is_install opt (args,defs) = print "\n"; end; (* Coq executables and relative variables *) + if !some_vfile || !some_mlpackfile || !some_mllibfile then + print "COQDEP?=$(COQBIN)coqdep -c\n"; if !some_vfile then begin print "COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)\n"; print "COQCHKFLAGS?=-silent -o\n"; + print "COQDOCFLAGS?=-interpolate -utf8\n"; print "COQC?=$(COQBIN)coqc\n"; - print "COQDEP?=$(COQBIN)coqdep -c\n"; print "GALLINA?=$(COQBIN)gallina\n"; print "COQDOC?=$(COQBIN)coqdoc\n"; print "COQCHK?=$(COQBIN)coqchk\n\n"; @@ -374,7 +376,7 @@ let variables is_install opt (args,defs) = print "CAMLOPTLINK?=$(OCAMLOPT) -rectypes\n"; print "GRAMMARS?=grammar.cma\n"; print "CAMLP4EXTEND?=pa_extend.cmo pa_macro.cmo q_MLast.cmo\n"; - print "CAMLP4OPTIONS?=\n"; + print "CAMLP4OPTIONS?=-loc loc\n"; print "PP?=-pp \"$(CAMLP4BIN)$(CAMLP4)o -I $(CAMLLIB) -I . $(COQSRCLIBS) $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl\"\n\n"; end; match is_install with @@ -564,18 +566,18 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other print "gallina: $(GFILES)\n\n"; print "html: $(GLOBFILES) $(VFILES)\n"; print "\t- mkdir -p html\n"; - print "\t$(COQDOC) -toc -html $(COQDOCLIBS) -d html $(VFILES)\n\n"; + print "\t$(COQDOC) -toc $(COQDOCFLAGS) -html $(COQDOCLIBS) -d html $(VFILES)\n\n"; print "gallinahtml: $(GLOBFILES) $(VFILES)\n"; print "\t- mkdir -p html\n"; - print "\t$(COQDOC) -toc -html -g $(COQDOCLIBS) -d html $(VFILES)\n\n"; + print "\t$(COQDOC) -toc $(COQDOCFLAGS) -html -g $(COQDOCLIBS) -d html $(VFILES)\n\n"; print "all.ps: $(VFILES)\n"; - print "\t$(COQDOC) -toc -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; + print "\t$(COQDOC) -toc $(COQDOCFLAGS) -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; print "all-gal.ps: $(VFILES)\n"; - print "\t$(COQDOC) -toc -ps -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; + print "\t$(COQDOC) -toc $(COQDOCFLAGS) -ps -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; print "all.pdf: $(VFILES)\n"; - print "\t$(COQDOC) -toc -pdf $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; + print "\t$(COQDOC) -toc $(COQDOCFLAGS) -pdf $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; print "all-gal.pdf: $(VFILES)\n"; - print "\t$(COQDOC) -toc -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; + print "\t$(COQDOC) -toc $(COQDOCFLAGS) -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; print "validate: $(VOFILES)\n"; print "\t$(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $(notdir $(^:.vo=))\n\n"; print "beautify: $(VFILES:=.beautified)\n"; diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index 89047e83..925f5258 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -306,7 +306,12 @@ let thm_token = let prf_token = "Next" space+ "Obligation" - | "Proof" (space* "." | space+ "with") + | "Proof" (space* "." | space+ "with" | space+ "using") + +let immediate_prf_token = + (* Approximation of a proof term, if not in the prf_token case *) + (* To be checked after prf_token *) + "Proof" space* [^ '.' 'w' 'u'] let def_token = "Definition" @@ -382,7 +387,8 @@ let commands = | ("Hypothesis" | "Hypotheses") | "End" -let end_kw = "Qed" | "Defined" | "Save" | "Admitted" | "Abort" +let end_kw = + immediate_prf_token | "Qed" | "Defined" | "Save" | "Admitted" | "Abort" let extraction = "Extraction" @@ -504,7 +510,7 @@ rule coq_bol = parse output_indented_keyword s lexbuf; let eol= body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } - | space* notation_kw space* + | space* notation_kw { let s = lexeme lexbuf in output_indented_keyword s lexbuf; let eol= start_notation_string lexbuf in @@ -605,7 +611,7 @@ and coq = parse | prf_token { let eol = if not !Cdglobals.gallina then - begin backtrack lexbuf; body_bol lexbuf end + begin backtrack lexbuf; body lexbuf end else let s = lexeme lexbuf in let eol = @@ -631,7 +637,7 @@ and coq = parse Output.ident s (lexeme_start lexbuf); let eol = body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } - | notation_kw space* + | notation_kw { let s = lexeme lexbuf in Output.ident s (lexeme_start lexbuf); let eol= start_notation_string lexbuf in @@ -1096,7 +1102,7 @@ and body = parse if eol then begin if not !Cdglobals.parse_comments then Output.line_break(); body_bol lexbuf end else body lexbuf } - | "where" space* + | "where" { Tokens.flush_sublexer(); Output.ident (lexeme lexbuf) (lexeme_start lexbuf); start_notation_string lexbuf } @@ -1120,6 +1126,8 @@ and body = parse body lexbuf } and start_notation_string = parse + | space { Tokens.flush_sublexer(); Output.char (lexeme_char lexbuf 0); + start_notation_string lexbuf } | '"' (* a true notation *) { Output.sublexer '"' (lexeme_start lexbuf); notation_string lexbuf; diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml index c8e7770a..f19433e9 100644 --- a/tools/coqdoc/index.ml +++ b/tools/coqdoc/index.ml @@ -62,7 +62,7 @@ let add_def loc1 loc2 ty sp id = for loc = loc1 to loc2 do Hashtbl.add reftable (!current_library, loc) (Def (full_ident sp id, ty)) done; - Hashtbl.add deftable id (Ref (!current_library, full_ident sp id, ty)) + Hashtbl.add deftable id (Def (full_ident sp id, ty)) let add_ref m loc m' sp id ty = if Hashtbl.mem reftable (m, loc) then () @@ -289,11 +289,11 @@ let all_entries () = let l = try Hashtbl.find bt t with Not_found -> [] in Hashtbl.replace bt t ((s,m) :: l) in - let classify (m,_) e = match e with + let classify m e = match e with | Def (s,t) -> add_g s m t; add_bt t s m | Ref _ | Mod _ -> () in - Hashtbl.iter classify reftable; + Hashtbl.iter classify deftable; Hashtbl.iter (fun id m -> add_g id m Library; add_bt Library id m) modules; { idx_name = "global"; idx_entries = sort_entries !gl; diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index e3d5741a..3aed28b4 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -29,14 +29,14 @@ let build_table l = let is_keyword = build_table - [ "AddPath"; "Axiom"; "Abort"; "Chapter"; "Check"; "Coercion"; "CoFixpoint"; + [ "About"; "AddPath"; "Axiom"; "Abort"; "Chapter"; "Check"; "Coercion"; "Compute"; "CoFixpoint"; "CoInductive"; "Corollary"; "Defined"; "Definition"; "End"; "Eval"; "Example"; - "Export"; "Fact"; "Fix"; "Fixpoint"; "Global"; "Grammar"; "Goal"; "Hint"; + "Export"; "Fact"; "Fix"; "Fixpoint"; "Function"; "Generalizable"; "Global"; "Grammar"; "Goal"; "Hint"; "Hypothesis"; "Hypotheses"; "Resolve"; "Unfold"; "Immediate"; "Extern"; "Implicit"; "Import"; "Inductive"; "Infix"; "Lemma"; "Let"; "Load"; "Local"; "Ltac"; "Module"; "Module Type"; "Declare Module"; "Include"; - "Mutual"; "Parameter"; "Parameters"; "Print"; "Proof"; "Proof with"; "Qed"; + "Mutual"; "Parameter"; "Parameters"; "Print"; "Printing"; "Proof"; "Proof with"; "Qed"; "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme"; "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; "Set"; "Types"; "Undo"; "Unset"; "Variable"; "Variables"; "Context"; @@ -44,7 +44,7 @@ let is_keyword = "Delimit"; "Bind"; "Open"; "Scope"; "Inline"; "Implicit Arguments"; "Add"; "Strict"; "Typeclasses"; "Instance"; "Global Instance"; "Class"; "Instantiation"; - "subgoal"; + "subgoal"; "vm_compute"; "Opaque"; "Transparent"; (* Program *) "Program Definition"; "Program Example"; "Program Fixpoint"; "Program Lemma"; diff --git a/tools/win32hack.mllib b/tools/win32hack.mllib new file mode 100644 index 00000000..42395f65 --- /dev/null +++ b/tools/win32hack.mllib @@ -0,0 +1 @@ +Win32hack_filename
\ No newline at end of file diff --git a/tools/win32hack_filename.ml b/tools/win32hack_filename.ml new file mode 100644 index 00000000..74f70686 --- /dev/null +++ b/tools/win32hack_filename.ml @@ -0,0 +1,4 @@ +(* The mingw32-ocaml cross-compiler currently uses Filename.dir_sep="/". + Let's tweak that... *) + +let _ = Filename.dir_sep.[0] <- '\\' diff --git a/toplevel/backtrack.ml b/toplevel/backtrack.ml new file mode 100644 index 00000000..24a056d7 --- /dev/null +++ b/toplevel/backtrack.ml @@ -0,0 +1,225 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Vernacexpr + +(** Command history stack + + We maintain a stack of the past states of the system. Each + successfully interpreted command adds an [info] element + to this stack, storing what were the (label / current proof / ...) + just _after_ the interpretation of this command. + + - A label is just an integer, starting from Lib.first_command_label + initially, and incremented at each new successful command. + - If some proofs are opened, we have their number in [nproofs], + the name of the current proof in [prfname], the current depth in + [prfdepth]. + - Otherwise, [nproofs = 0], [prfname = None], [prfdepth = 0] + - The text of the command is stored (for Show Script currently). + - A command can be tagged later as non-"reachable" when the current proof + at the time of this command has been ended by Qed/Abort/Restart, + meaning we can't backtrack there. +*) + +type info = { + label : int; + nproofs : int; + prfname : identifier option; + prfdepth : int; + cmd : vernac_expr; + mutable reachable : bool; +} + +let history : info Stack.t = Stack.create () + +(** For debug purpose, a dump of the history *) + +let dump_history () = + let l = ref [] in + Stack.iter (fun i -> l:=i::!l) history; + !l + +(** Basic manipulation of the command history stack *) + +exception Invalid + +let pop () = ignore (Stack.pop history) + +let npop n = + (* Since our history stack always contains an initial entry, + it's invalid to try to completely empty it *) + if n < 0 || n >= Stack.length history then raise Invalid + else for i = 1 to n do pop () done + +let top () = + try Stack.top history with Stack.Empty -> raise Invalid + +(** Search the history stack for a suitable location. We perform first + a non-destructive search: in case of search failure, the stack is + unchanged. *) + +exception Found of info + +let search test = + try + Stack.iter (fun i -> if test i then raise (Found i)) history; + raise Invalid + with Found i -> + while i != Stack.top history do pop () done + +(** Register the end of a command and store the current state *) + +let mark_command ast = + Lib.add_frozen_state(); + Lib.mark_end_of_command(); + Stack.push + { label = Lib.current_command_label (); + nproofs = List.length (Pfedit.get_all_proof_names ()); + prfname = (try Some (Pfedit.get_current_proof_name ()) with _ -> None); + prfdepth = max 0 (Pfedit.current_proof_depth ()); + reachable = true; + cmd = ast } + history + +(** Backtrack by aborting [naborts] proofs, then setting proof-depth back to + [pnum] and finally going to state number [snum]. *) + +let raw_backtrack snum pnum naborts = + for i = 1 to naborts do Pfedit.delete_current_proof () done; + Pfedit.undo_todepth pnum; + Lib.reset_label snum + +(** Re-sync the state of the system (label, proofs) with the top + of the history stack. We may end on some earlier state to avoid + re-opening proofs. This function will return the final label + and the number of extra backtracking steps performed. *) + +let sync nb_opened_proofs = + (* Backtrack by enough additional steps to avoid re-opening proofs. + Typically, when a Qed has been crossed, we backtrack to the proof start. + NB: We cannot reach the empty stack, since the first entry in the + stack has no opened proofs and is tagged as reachable. + *) + let extra = ref 0 in + while not (top()).reachable do incr extra; pop () done; + let target = top () + in + (* Now the opened proofs at target is a subset of the opened proofs before + the backtrack, we simply abort the extra proofs (if any). + NB: It is critical here that proofs are nested in a regular way + (i.e. no more Resume or Suspend commands as earlier). This way, we can + simply count the extra proofs to abort instead of taking care of their + names. + *) + let naborts = nb_opened_proofs - target.nproofs in + (* We are now ready to do a low-level backtrack *) + raw_backtrack target.label target.prfdepth naborts; + (target.label, !extra) + +(** Backtracking by a certain number of (non-state-preserving) commands. + This is used by Coqide. + It may actually undo more commands than asked : for instance instead + of jumping back in the middle of a finished proof, we jump back before + this proof. The number of extra backtracked command is returned at + the end. *) + +let back count = + if count = 0 then 0 + else + let nb_opened_proofs = List.length (Pfedit.get_all_proof_names ()) in + npop count; + snd (sync nb_opened_proofs) + +(** Backtracking to a certain state number, and reset proofs accordingly. + We may end on some earlier state if needed to avoid re-opening proofs. + Return the final state number. *) + +let backto snum = + if snum = Lib.current_command_label () then snum + else + let nb_opened_proofs = List.length (Pfedit.get_all_proof_names ()) in + search (fun i -> i.label = snum); + fst (sync nb_opened_proofs) + +(** Old [Backtrack] code with corresponding update of the history stack. + [Backtrack] is now deprecated (in favor of [BackTo]) but is kept for + compatibility with ProofGeneral. It's completely up to ProofGeneral + to decide where to go and how to adapt proofs. Note that the choices + of ProofGeneral are currently not always perfect (for instance when + backtracking an Undo). *) + +let backtrack snum pnum naborts = + raw_backtrack snum pnum naborts; + search (fun i -> i.label = snum) + +(** [reset_initial] resets the system and clears the command history + stack, only pushing back the initial entry. It should be equivalent + to [backto Lib.first_command_label], but sligthly more efficient. *) + +let reset_initial () = + let init_label = Lib.first_command_label in + if Lib.current_command_label () = init_label then () + else begin + Pfedit.delete_all_proofs (); + Lib.reset_label init_label; + Stack.clear history; + Stack.push + { label = init_label; + nproofs = 0; + prfname = None; + prfdepth = 0; + reachable = true; + cmd = VernacNop } + history + end + +(** Reset to the last known state just before defining [id] *) + +let reset_name id = + let lbl = + try Lib.label_before_name id with Not_found -> raise Invalid + in + ignore (backto lbl) + +(** When a proof is ended (via either Qed/Admitted/Restart/Abort), + old proof steps should be marked differently to avoid jumping back + to them: + - either this proof isn't there anymore in the proof engine + - either it's there but it's a more recent attempt after a Restart, + so we shouldn't mix the two. + We also mark as unreachable the proof steps cancelled via a Undo. *) + +let mark_unreachable ?(after=0) prf_lst = + let fix i = match i.prfname with + | None -> raise Not_found (* stop hacking the history outside of proofs *) + | Some p -> + if List.mem p prf_lst && i.prfdepth > after + then i.reachable <- false + in + try Stack.iter fix history with Not_found -> () + +(** Parse the history stack for printing the script of a proof *) + +let get_script prf = + let script = ref [] in + let select i = match i.prfname with + | None -> raise Not_found + | Some p when p=prf && i.reachable -> script := i :: !script + | _ -> () + in + (try Stack.iter select history with Not_found -> ()); + (* Get rid of intermediate commands which don't grow the depth *) + let rec filter n = function + | [] -> [] + | {prfdepth=d; cmd=c}::l when n < d -> c :: filter d l + | {prfdepth=d}::l -> filter d l + in + (* initial proof depth (after entering the lemma statement) is 1 *) + filter 1 !script diff --git a/toplevel/backtrack.mli b/toplevel/backtrack.mli new file mode 100644 index 00000000..3fde5b11 --- /dev/null +++ b/toplevel/backtrack.mli @@ -0,0 +1,93 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Command history stack + + We maintain a stack of the past states of the system after each + (non-state-preserving) interpreted commands +*) + +(** [mark_command ast] marks the end of a command: + - it stores a frozen state and a end of command in the Lib stack, + - it stores the current state information in the command history + stack *) + +val mark_command : Vernacexpr.vernac_expr -> unit + +(** The [Invalid] exception is raised when one of the following function + tries to empty the history stack, or reach an unknown states, etc. + The stack is preserved in these cases. *) + +exception Invalid + +(** Nota Bene: it is critical for the following functions that proofs + are nested in a regular way (i.e. no more Resume or Suspend commands + as earlier). *) + +(** Backtracking by a certain number of (non-state-preserving) commands. + This is used by Coqide. + It may actually undo more commands than asked : for instance instead + of jumping back in the middle of a finished proof, we jump back before + this proof. The number of extra backtracked command is returned at + the end. *) + +val back : int -> int + +(** Backtracking to a certain state number, and reset proofs accordingly. + We may end on some earlier state if needed to avoid re-opening proofs. + Return the state number on which we finally end. *) + +val backto : int -> int + +(** Old [Backtrack] code with corresponding update of the history stack. + [Backtrack] is now deprecated (in favor of [BackTo]) but is kept for + compatibility with ProofGeneral. It's completely up to ProofGeneral + to decide where to go and how to adapt proofs. Note that the choices + of ProofGeneral are currently not always perfect (for instance when + backtracking an Undo). *) + +val backtrack : int -> int -> int -> unit + +(** [reset_initial] resets the system and clears the command history + stack, only pushing back the initial entry. It should be equivalent + to [backto Lib.first_command_label], but sligthly more efficient. *) + +val reset_initial : unit -> unit + +(** Reset to the last known state just before defining [id] *) + +val reset_name : Names.identifier Util.located -> unit + +(** When a proof is ended (via either Qed/Admitted/Restart/Abort), + old proof steps should be marked differently to avoid jumping back + to them: + - either this proof isn't there anymore in the proof engine + - either a proof with the same name is there, but it's a more recent + attempt after a Restart/Abort, we shouldn't mix the two. + We also mark as unreachable the proof steps cancelled via a Undo. +*) + +val mark_unreachable : ?after:int -> Names.identifier list -> unit + +(** Parse the history stack for printing the script of a proof *) + +val get_script : Names.identifier -> Vernacexpr.vernac_expr list + + +(** For debug purpose, a dump of the history *) + +type info = { + label : int; + nproofs : int; + prfname : Names.identifier option; + prfdepth : int; + cmd : Vernacexpr.vernac_expr; + mutable reachable : bool; +} + +val dump_history : unit -> info list diff --git a/toplevel/class.ml b/toplevel/class.ml index ebaa19b6..c328cc91 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -255,7 +255,7 @@ let add_new_coercion_core coef stre source target isid = in check_source (Some cls); if not (uniform_cond (llp-ind) lvs) then - raise (CoercionError NotUniform); + warning (Pp.string_of_ppcmds (explain_coercion_error coef NotUniform)); let clt = try get_target tg ind diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 1e83e4b8..18f12582 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -252,6 +252,14 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props let term = Termops.it_mkLambda_or_LetIn def ctx in Some term, termtype in + let _ = + evars := Evarutil.nf_evar_map !evars; + evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true + env !evars; + (* Try resolving fields that are typeclasses automatically. *) + evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false + env !evars + in let termtype = Evarutil.nf_evar !evars termtype in let term = Option.map (Evarutil.nf_evar !evars) term in let evm = undefined_evars !evars in @@ -259,7 +267,6 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props if Evd.is_empty evm && term <> None then declare_instance_constant k pri global imps ?hook id (Option.get term) termtype else begin - evars := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:true env !evars; let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in Flags.silently (fun () -> Lemmas.start_proof id kind termtype (fun _ -> instance_hook k pri global imps ?hook); diff --git a/toplevel/command.ml b/toplevel/command.ml index eca53ae7..dfb1a1b5 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -87,7 +87,11 @@ let interp_definition bl red_option c ctypopt = let typ = nf_evar !evdref (it_mkProd_or_LetIn ty ctx) in check_evars env Evd.empty !evdref body; check_evars env Evd.empty !evdref typ; - imps1@(Impargs.lift_implicits nb_args imps2), + (* Check that all implicit arguments inferable from the term is inferable from the type *) + if not (try List.for_all (fun (key,va) -> List.assoc key impsty = va) imps2 with Not_found -> false) + then warn (str "Implicit arguments declaration relies on type." ++ + spc () ++ str "The term declares more implicits than the type here."); + imps1@(Impargs.lift_implicits nb_args impsty), { const_entry_body = body; const_entry_secctx = None; const_entry_type = Some typ; @@ -250,7 +254,7 @@ let interp_mutual_inductive (paramsl,indl) notations finite = let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in let constructors = - States.with_state_protection (fun () -> + Metasyntax.with_syntax_protection (fun () -> (* Temporary declaration of notations and scopes *) List.iter (Metasyntax.set_notation_for_interpretation impls) notations; (* Interpret the constructor types *) @@ -259,7 +263,7 @@ let interp_mutual_inductive (paramsl,indl) notations finite = (* Instantiate evars and check all are resolved *) let evd = consider_remaining_unif_problems env_params !evdref in - let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env_params evd in + let evd = Typeclasses.resolve_typeclasses ~filter:(Typeclasses.no_goals) ~fail:true env_params evd in let sigma = evd in let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map (nf_evar sigma) cl,impsl)) constructors in let ctx_params = Sign.map_rel_context (nf_evar sigma) ctx_params in @@ -459,12 +463,12 @@ type structured_fixpoint_expr = { let interp_fix_context evdref env isfix fix = let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in let impl_env, ((env', ctx), imps) = interp_context_evars evdref env before in - let _, ((env'', ctx'), imps') = interp_context_evars ~impl_env evdref env' after in + let impl_env', ((env'', ctx'), imps') = interp_context_evars ~impl_env evdref env' after in let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in - ((env'', ctx' @ ctx), imps @ imps', annot) - -let interp_fix_ccl evdref (env,_) fix = - interp_type_evars evdref env fix.fix_type + ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) + +let interp_fix_ccl evdref impls (env,_) fix = + interp_type_evars_impls ~impls ~evdref ~fail_evar:false env fix.fix_type let interp_fix_body evdref env_rec impls (_,ctx) fix ccl = Option.map (fun body -> @@ -514,11 +518,15 @@ let interp_recursive isfix fixl notations = (* Interp arities allowing for unresolved types *) let evdref = ref Evd.empty in - let fixctxs, fiximps, fixannots = + let fixctxs, fiximppairs, fixannots = list_split3 (List.map (interp_fix_context evdref env isfix) fixl) in - let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in + let fixctximpenvs, fixctximps = List.split fiximppairs in + let fixccls,fixcclimps = List.split (list_map3 (interp_fix_ccl evdref) fixctximpenvs fixctxs fixl) in let fixtypes = List.map2 build_fix_type fixctxs fixccls in let fixtypes = List.map (nf_evar !evdref) fixtypes in + let fiximps = list_map3 + (fun ctximps cclimps (_,ctx) -> ctximps@(Impargs.lift_implicits (List.length ctx) cclimps)) + fixctximps fixcclimps fixctxs in let env_rec = push_named_types env fixnames fixtypes in (* Get interpretation metadatas *) @@ -526,9 +534,11 @@ let interp_recursive isfix fixl notations = (* Interp bodies with rollback because temp use of notations/implicit *) let fixdefs = - States.with_state_protection (fun () -> + Metasyntax.with_syntax_protection (fun () -> List.iter (Metasyntax.set_notation_for_interpretation impls) notations; - list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls) + list_map4 + (fun fixctximpenv -> interp_fix_body evdref env_rec (Idmap.fold Idmap.add fixctximpenv impls)) + fixctximpenvs fixctxs fixl fixccls) () in (* Instantiate evars and check all are resolved *) @@ -536,7 +546,7 @@ let interp_recursive isfix fixl notations = let fixdefs = List.map (Option.map (nf_evar evd)) fixdefs in let fixtypes = List.map (nf_evar evd) fixtypes in let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in - let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env evd in + let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in List.iter (Option.iter (check_evars env_rec Evd.empty evd)) fixdefs; List.iter (check_evars env Evd.empty evd) fixtypes; if not (List.mem None fixdefs) then begin diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 76e9c2fe..a60e0d82 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -247,10 +247,13 @@ let parse_args arglist = | "-compat" :: [] -> usage () | "-vm" :: rem -> use_vm := true; parse rem - | "-emacs" :: rem -> Flags.print_emacs := true; Pp.make_pp_emacs(); parse rem + | "-emacs" :: rem -> + Flags.print_emacs := true; Pp.make_pp_emacs(); + Vernacentries.qed_display_script := false; + parse rem | "-emacs-U" :: rem -> warning "Obsolete option \"-emacs-U\", use -emacs instead."; - Flags.print_emacs := true; Pp.make_pp_emacs(); parse rem + parse ("-emacs" :: rem) | "-unicode" :: rem -> add_require "Utf8_core"; parse rem @@ -326,6 +329,7 @@ let init arglist = if_verbose print_header (); init_load_path (); inputstate (); + Mltop.init_known_plugins (); set_vm_opt (); engage (); if (not !batch_mode|| !compile_list=[]) && Global.env_is_empty() then @@ -349,7 +353,8 @@ let init arglist = Pp.ppnl (with_option raw_print Prettyp.print_full_pure_context ()); Profile.print_profile (); exit 0); - Lib.declare_initial_state () + (* We initialize the command history stack with a first entry *) + Backtrack.mark_command Vernacexpr.VernacNop let init_toplevel = init diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 1bd68014..958e3dcb 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -31,7 +31,6 @@ open Evd let pr_lconstr c = quote (pr_lconstr c) let pr_lconstr_env e c = quote (pr_lconstr_env e c) -let pr_lconstr_env_at_top e c = quote (pr_lconstr_env_at_top e c) let pr_ljudge_env e c = let v,t = pr_ljudge_env e c in (quote v,quote t) let pr_db env i = @@ -696,8 +695,14 @@ let explain_no_instance env (_,id) l = str "applied to arguments" ++ spc () ++ prlist_with_sep pr_spc (pr_lconstr_env env) l +let is_goal_evar evi = match evi.evar_source with (_, GoalEvar) -> true | _ -> false + let pr_constraints printenv env evm = let evm = Evd.undefined_evars (Evarutil.nf_evar_map_undefined evm) in + let evm = fold_undefined + (fun ev evi evm' -> + if is_goal_evar evi then Evd.remove evm' ev else evm') evm evm + in let l = Evd.to_list evm in let (ev, evi) = List.hd l in if List.for_all (fun (ev', evi') -> @@ -819,8 +824,12 @@ let error_ill_formed_constructor env id c v nparams nargs = else mt()) ++ str "." +let pr_ltype_using_barendregt_convention_env env c = + (* Use goal_concl_style as an approximation of Barendregt's convention (?) *) + quote (pr_goal_concl_style_env env c) + let error_bad_ind_parameters env c n v1 v2 = - let pc = pr_lconstr_env_at_top env c in + let pc = pr_ltype_using_barendregt_convention_env env c in let pv1 = pr_lconstr_env env v1 in let pv2 = pr_lconstr_env env v2 in str "Last occurrence of " ++ pv2 ++ str " must have " ++ pv1 ++ @@ -978,7 +987,8 @@ let explain_pattern_matching_error env = function let explain_reduction_tactic_error = function | Tacred.InvalidAbstraction (env,c,(env',e)) -> - str "The abstracted term" ++ spc () ++ pr_lconstr_env_at_top env c ++ + str "The abstracted term" ++ spc () ++ + quote (pr_goal_concl_style_env env c) ++ spc () ++ str "is not well typed." ++ fnl () ++ explain_type_error env' Evd.empty e diff --git a/toplevel/ide_intf.ml b/toplevel/ide_intf.ml index fc8ffa25..9ba3d8b4 100644 --- a/toplevel/ide_intf.ml +++ b/toplevel/ide_intf.ml @@ -6,6 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** Protocol version of this file. This is the date of the last modification. *) + +(** WARNING: TO BE UPDATED WHEN MODIFIED! *) + +let protocol_version = "20120511" + (** * Interface of calls to Coq by CoqIde *) open Xml_parser @@ -22,10 +28,32 @@ type 'a call = | Evars | Hints | Status + | Search of search_flags | GetOptions | SetOptions of (option_name * option_value) list | InLoadPath of string | MkCases of string + | Quit + | About + +(** The structure that coqtop should implement *) + +type handler = { + interp : raw * verbose * string -> string; + rewind : int -> int; + goals : unit -> goals option; + evars : unit -> evar list option; + hints : unit -> (hint list * hint) option; + status : unit -> status; + search : search_flags -> search_answer list; + get_options : unit -> (option_name * option_state) list; + set_options : (option_name * option_value) list -> unit; + inloadpath : string -> bool; + mkcases : string -> string list list; + quit : unit -> unit; + about : unit -> coq_info; + handle_exn : exn -> location * string; +} (** The actual calls *) @@ -35,10 +63,12 @@ let goals : goals option call = Goal let evars : evar list option call = Evars let hints : (hint list * hint) option call = Hints let status : status call = Status +let search flags : search_answer list call = Search flags let get_options : (option_name * option_state) list call = GetOptions let set_options l : unit call = SetOptions l let inloadpath s : bool call = InLoadPath s let mkcases s : string list list call = MkCases s +let quit : unit call = Quit (** * Coq answers to CoqIde *) @@ -51,10 +81,13 @@ let abstract_eval_call handler c = | Evars -> Obj.magic (handler.evars () : evar list option) | Hints -> Obj.magic (handler.hints () : (hint list * hint) option) | Status -> Obj.magic (handler.status () : status) + | Search flags -> Obj.magic (handler.search flags : search_answer list) | GetOptions -> Obj.magic (handler.get_options () : (option_name * option_state) list) | SetOptions opts -> Obj.magic (handler.set_options opts : unit) | InLoadPath s -> Obj.magic (handler.inloadpath s : bool) | MkCases s -> Obj.magic (handler.mkcases s : string list list) + | Quit -> Obj.magic (handler.quit () : unit) + | About -> Obj.magic (handler.about () : coq_info) in Good res with e -> let (l, str) = handler.handle_exn e in @@ -178,6 +211,44 @@ let to_option_state = function } | _ -> raise Marshal_error +let of_search_constraint = function +| Name_Pattern s -> + constructor "search_constraint" "name_pattern" [of_string s] +| Type_Pattern s -> + constructor "search_constraint" "type_pattern" [of_string s] +| SubType_Pattern s -> + constructor "search_constraint" "subtype_pattern" [of_string s] +| In_Module m -> + constructor "search_constraint" "in_module" [of_list of_string m] +| Include_Blacklist -> + constructor "search_constraint" "include_blacklist" [] + +let to_search_constraint xml = do_match xml "search_constraint" + (fun s args -> match s with + | "name_pattern" -> Name_Pattern (to_string (singleton args)) + | "type_pattern" -> Type_Pattern (to_string (singleton args)) + | "subtype_pattern" -> SubType_Pattern (to_string (singleton args)) + | "in_module" -> In_Module (to_list to_string (singleton args)) + | "include_blacklist" -> Include_Blacklist + | _ -> raise Marshal_error) + +let of_search_answer ans = + let path = of_list of_string ans.search_answer_full_path in + let name = of_string ans.search_answer_base_name in + let tpe = of_string ans.search_answer_type in + Element ("search_answer", [], [path; name; tpe]) + +let to_search_answer = function +| Element ("search_answer", [], [path; name; tpe]) -> + let path = to_list to_string path in + let name = to_string name in + let tpe = to_string tpe in { + search_answer_full_path = path; + search_answer_base_name = name; + search_answer_type = tpe; + } +| _ -> raise Marshal_error + let of_value f = function | Good x -> Element ("value", ["val", "good"], [f x]) | Fail (loc, msg) -> @@ -218,6 +289,9 @@ let of_call = function Element ("call", ["val", "hints"], []) | Status -> Element ("call", ["val", "status"], []) +| Search flags -> + let args = List.map (of_pair of_search_constraint of_bool) flags in + Element ("call", ["val", "search"], args) | GetOptions -> Element ("call", ["val", "getoptions"], []) | SetOptions opts -> @@ -227,6 +301,10 @@ let of_call = function Element ("call", ["val", "inloadpath"], [PCData file]) | MkCases ind -> Element ("call", ["val", "mkcases"], [PCData ind]) +| Quit -> + Element ("call", ["val", "quit"], []) +| About -> + Element ("call", ["val", "about"], []) let to_call = function | Element ("call", attrs, l) -> @@ -242,6 +320,9 @@ let to_call = function | "goal" -> Goal | "evars" -> Evars | "status" -> Status + | "search" -> + let args = List.map (to_pair to_search_constraint to_bool) l in + Search args | "getoptions" -> GetOptions | "setoptions" -> let args = List.map (to_pair (to_list to_string) to_option_value) l in @@ -249,6 +330,8 @@ let to_call = function | "inloadpath" -> InLoadPath (raw_string l) | "mkcases" -> MkCases (raw_string l) | "hints" -> Hints + | "quit" -> Quit + | "about" -> About | _ -> raise Marshal_error end | _ -> raise Marshal_error @@ -275,13 +358,15 @@ let to_evar = function let of_goal g = let hyp = of_list of_string g.goal_hyp in let ccl = of_string g.goal_ccl in - Element ("goal", [], [hyp; ccl]) + let id = of_string g.goal_id in + Element ("goal", [], [id; hyp; ccl]) let to_goal = function -| Element ("goal", [], [hyp; ccl]) -> +| Element ("goal", [], [id; hyp; ccl]) -> let hyp = to_list to_string hyp in let ccl = to_string ccl in - { goal_hyp = hyp; goal_ccl = ccl } + let id = to_string id in + { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; } | _ -> raise Marshal_error let of_goals g = @@ -296,6 +381,23 @@ let to_goals = function { fg_goals = fg; bg_goals = bg; } | _ -> raise Marshal_error +let of_coq_info info = + let version = of_string info.coqtop_version in + let protocol = of_string info.protocol_version in + let release = of_string info.release_date in + let compile = of_string info.compile_date in + Element ("coq_info", [], [version; protocol; release; compile]) + +let to_coq_info = function +| Element ("coq_info", [], [version; protocol; release; compile]) -> + { + coqtop_version = to_string version; + protocol_version = to_string protocol; + release_date = to_string release; + compile_date = to_string compile; + } +| _ -> raise Marshal_error + let of_hints = let of_hint = of_list (of_pair of_string of_string) in of_option (of_pair (of_list of_hint) of_hint) @@ -308,10 +410,13 @@ let of_answer (q : 'a call) (r : 'a value) = | Evars -> Obj.magic (of_option (of_list of_evar) : evar list option -> xml) | Hints -> Obj.magic (of_hints : (hint list * hint) option -> xml) | Status -> Obj.magic (of_status : status -> xml) + | Search _ -> Obj.magic (of_list of_search_answer : search_answer list -> xml) | GetOptions -> Obj.magic (of_list (of_pair (of_list of_string) of_option_state) : (option_name * option_state) list -> xml) | SetOptions _ -> Obj.magic (fun _ -> Element ("unit", [], [])) | InLoadPath _ -> Obj.magic (of_bool : bool -> xml) | MkCases _ -> Obj.magic (of_list (of_list of_string) : string list list -> xml) + | Quit -> Obj.magic (fun _ -> Element ("unit", [], [])) + | About -> Obj.magic (of_coq_info : coq_info -> xml) in of_value convert r @@ -331,6 +436,8 @@ let to_answer xml = | "evar" -> Obj.magic (to_evar elt : evar) | "option_value" -> Obj.magic (to_option_value elt : option_value) | "option_state" -> Obj.magic (to_option_state elt : option_state) + | "coq_info" -> Obj.magic (to_coq_info elt : coq_info) + | "search_answer" -> Obj.magic (to_search_answer elt : search_answer) | _ -> raise Marshal_error end | _ -> raise Marshal_error @@ -370,10 +477,13 @@ let pr_call = function | Evars -> "EVARS" | Hints -> "HINTS" | Status -> "STATUS" + | Search _ -> "SEARCH" | GetOptions -> "GETOPTIONS" | SetOptions l -> "SETOPTIONS" ^ " [" ^ pr_setoptions l ^ "]" | InLoadPath s -> "INLOADPATH "^s | MkCases s -> "MKCASES "^s + | Quit -> "QUIT" + | About -> "ABOUT" let pr_value_gen pr = function | Good v -> "GOOD " ^ pr v @@ -428,7 +538,11 @@ let pr_full_value call value = | Evars -> pr_value_gen pr_evars (Obj.magic value : evar list option value) | Hints -> pr_value value | Status -> pr_value_gen pr_status (Obj.magic value : status value) + | Search _ -> pr_value value | GetOptions -> pr_value_gen pr_getoptions (Obj.magic value : (option_name * option_state) list value) | SetOptions _ -> pr_value value | InLoadPath s -> pr_value_gen pr_bool (Obj.magic value : bool value) | MkCases s -> pr_value_gen pr_mkcases (Obj.magic value : string list list value) + | Quit -> pr_value value + | About -> pr_value value + diff --git a/toplevel/ide_intf.mli b/toplevel/ide_intf.mli index 69204da1..deee50e5 100644 --- a/toplevel/ide_intf.mli +++ b/toplevel/ide_intf.mli @@ -65,8 +65,34 @@ val get_options : (option_name * option_state) list call to check that everything is correct. *) val set_options : (option_name * option_value) list -> unit call +(** Quit gracefully the interpreter. *) +val quit : unit call + +(** The structure that coqtop should implement *) + +type handler = { + interp : raw * verbose * string -> string; + rewind : int -> int; + goals : unit -> goals option; + evars : unit -> evar list option; + hints : unit -> (hint list * hint) option; + status : unit -> status; + search : search_flags -> search_answer list; + get_options : unit -> (option_name * option_state) list; + set_options : (option_name * option_value) list -> unit; + inloadpath : string -> bool; + mkcases : string -> string list list; + quit : unit -> unit; + about : unit -> coq_info; + handle_exn : exn -> location * string; +} + val abstract_eval_call : handler -> 'a call -> 'a value +(** * Protocol version *) + +val protocol_version : string + (** * XML data marshalling *) exception Marshal_error diff --git a/toplevel/ide_slave.ml b/toplevel/ide_slave.ml index 42ecb75b..93ad052c 100644 --- a/toplevel/ide_slave.ml +++ b/toplevel/ide_slave.ml @@ -20,12 +20,6 @@ open Namegen the only one using this mode, but we try here to be as generic as possible, so this may change in the future... *) - -(** Comment the next line for displaying some more debug messages *) - -let prerr_endline _ = () - - (** Signal handling: we postpone ^C during input and output phases, but make it directly raise a Sys.Break during evaluation of the request. *) @@ -59,6 +53,8 @@ let init_stdout,read_stdout = let r = Buffer.contents out_buff in Buffer.clear out_buff; r) +let pr_debug s = + if !Flags.debug then Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s (** Categories of commands *) @@ -73,202 +69,29 @@ let coqide_known_option table = List.mem table [ ["Printing";"Existential";"Instances"]; ["Printing";"Universes"]] -type command_attribute = - NavigationCommand | QueryCommand | DebugCommand | KnownOptionCommand - | OtherStatePreservingCommand | GoalStartingCommand | SolveCommand - | ProofEndingCommand - -let rec attribute_of_vernac_command = function - (* Control *) - | VernacTime com -> attribute_of_vernac_command com - | VernacTimeout(_,com) -> attribute_of_vernac_command com - | VernacFail com -> attribute_of_vernac_command com - | VernacList _ -> [] (* unsupported *) - | VernacLoad _ -> [] - - (* Syntax *) - | VernacTacticNotation _ -> [] - | VernacSyntaxExtension _ -> [] - | VernacDelimiters _ -> [] - | VernacBindScope _ -> [] - | VernacOpenCloseScope _ -> [] - | VernacArgumentsScope _ -> [] - | VernacInfix _ -> [] - | VernacNotation _ -> [] - - (* Gallina *) - | VernacDefinition (_,_,DefineBody _,_) -> [] - | VernacDefinition (_,_,ProveBody _,_) -> [GoalStartingCommand] - | VernacStartTheoremProof _ -> [GoalStartingCommand] - | VernacEndProof _ -> [ProofEndingCommand] - | VernacExactProof _ -> [ProofEndingCommand] - - | VernacAssumption _ -> [] - | VernacInductive _ -> [] - | VernacFixpoint _ -> [] - | VernacCoFixpoint _ -> [] - | VernacScheme _ -> [] - | VernacCombinedScheme _ -> [] - - (* Modules *) - | VernacDeclareModule _ -> [] - | VernacDefineModule _ -> [] - | VernacDeclareModuleType _ -> [] - | VernacInclude _ -> [] - - (* Gallina extensions *) - | VernacBeginSection _ -> [] - | VernacEndSegment _ -> [] - | VernacRequire _ -> [] - | VernacImport _ -> [] - | VernacCanonical _ -> [] - | VernacCoercion _ -> [] - | VernacIdentityCoercion _ -> [] - - (* Type classes *) - | VernacInstance _ -> [] - | VernacContext _ -> [] - | VernacDeclareInstances _ -> [] - | VernacDeclareClass _ -> [] - - (* Solving *) - | VernacSolve _ -> [SolveCommand] - | VernacSolveExistential _ -> [SolveCommand] - - (* Auxiliary file and library management *) - | VernacRequireFrom _ -> [] - | VernacAddLoadPath _ -> [] - | VernacRemoveLoadPath _ -> [] - | VernacAddMLPath _ -> [] - | VernacDeclareMLModule _ -> [] - | VernacChdir o -> - (* TODO: [Chdir d] is currently not undo-able (not stored in coq state). - But if we register [Chdir] in the state, loading [initial.coq] will - wrongly cd to the compile-time directory at each coqtop launch. *) - if o = None then [QueryCommand] else [] - - (* State management *) - | VernacWriteState _ -> [] - | VernacRestoreState _ -> [] - - (* Resetting *) - | VernacRemoveName _ -> [NavigationCommand] - | VernacResetName _ -> [NavigationCommand] - | VernacResetInitial -> [NavigationCommand] - | VernacBack _ -> [NavigationCommand] - | VernacBackTo _ -> [NavigationCommand] - - (* Commands *) - | VernacDeclareTacticDefinition _ -> [] - | VernacCreateHintDb _ -> [] - | VernacRemoveHints _ -> [] - | VernacHints _ -> [] - | VernacSyntacticDefinition _ -> [] - | VernacDeclareImplicits _ -> [] - | VernacArguments _ -> [] - | VernacDeclareReduction _ -> [] - | VernacReserve _ -> [] - | VernacGeneralizable _ -> [] - | VernacSetOpacity _ -> [] - | VernacSetOption (_,["Ltac";"Debug"], _) -> [DebugCommand] - | VernacSetOption (_,o,BoolValue true) | VernacUnsetOption (_,o) -> - if coqide_known_option o then [KnownOptionCommand] else [] - | VernacSetOption _ -> [] - | VernacRemoveOption _ -> [] - | VernacAddOption _ -> [] - | VernacMemOption _ -> [QueryCommand] - - | VernacPrintOption _ -> [QueryCommand] - | VernacCheckMayEval _ -> [QueryCommand] - | VernacGlobalCheck _ -> [QueryCommand] - | VernacPrint _ -> [QueryCommand] - | VernacSearch _ -> [QueryCommand] - | VernacLocate _ -> [QueryCommand] - - | VernacComments _ -> [OtherStatePreservingCommand] - | VernacNop -> [OtherStatePreservingCommand] - - (* Proof management *) - | VernacGoal _ -> [GoalStartingCommand] - - | VernacAbort _ -> [] - | VernacAbortAll -> [NavigationCommand] - | VernacRestart -> [NavigationCommand] - | VernacSuspend -> [NavigationCommand] - | VernacResume _ -> [NavigationCommand] - | VernacUndo _ -> [NavigationCommand] - | VernacUndoTo _ -> [NavigationCommand] - | VernacBacktrack _ -> [NavigationCommand] - - | VernacFocus _ -> [SolveCommand] - | VernacUnfocus -> [SolveCommand] - | VernacShow _ -> [OtherStatePreservingCommand] - | VernacCheckGuard -> [OtherStatePreservingCommand] - | VernacProof (None, None) -> [OtherStatePreservingCommand] - | VernacProof _ -> [] - - | VernacProofMode _ -> [] - | VernacBullet _ -> [SolveCommand] - | VernacSubproof _ -> [SolveCommand] - | VernacEndSubproof -> [SolveCommand] - - (* Toplevel control *) - | VernacToplevelControl _ -> [] - - (* Extensions *) - | VernacExtend ("Subtac_Obligations", _) -> [GoalStartingCommand] - | VernacExtend _ -> [] - -let is_vernac_navigation_command com = - List.mem NavigationCommand (attribute_of_vernac_command com) - -let is_vernac_query_command com = - List.mem QueryCommand (attribute_of_vernac_command com) - -let is_vernac_known_option_command com = - List.mem KnownOptionCommand (attribute_of_vernac_command com) - -let is_vernac_debug_command com = - List.mem DebugCommand (attribute_of_vernac_command com) - -let is_vernac_goal_printing_command com = - let attribute = attribute_of_vernac_command com in - List.mem GoalStartingCommand attribute or - List.mem SolveCommand attribute - -let is_vernac_state_preserving_command com = - let attribute = attribute_of_vernac_command com in - List.mem OtherStatePreservingCommand attribute or - List.mem QueryCommand attribute - -let is_vernac_tactic_command com = - List.mem SolveCommand (attribute_of_vernac_command com) - -let is_vernac_proof_ending_command com = - List.mem ProofEndingCommand (attribute_of_vernac_command com) - - -(** Command history stack - - We maintain a stack of the past states of the system. Each - successfully interpreted command adds a [reset_info] element - to this stack, storing what were the (label / open proofs / - current proof depth) just _before_ the interpretation of this - command. A label is just an integer (cf. BackTo and Bactrack - vernac commands). -*) - -type reset_info = { label : int; proofs : identifier list; depth : int } - -let com_stk = Stack.create () - -let compute_reset_info () = - { label = Lib.current_command_label (); - proofs = Pfedit.get_all_proof_names (); - depth = max 0 (Pfedit.current_proof_depth ()) } - - -(** Interpretation (cf. [Ide_intf.interp]) *) +let is_known_option cmd = match cmd with + | VernacSetOption (_,o,BoolValue true) + | VernacUnsetOption (_,o) -> coqide_known_option o + | _ -> false + +let is_debug cmd = match cmd with + | VernacSetOption (_,["Ltac";"Debug"], _) -> true + | _ -> false + +let is_query cmd = match cmd with + | VernacChdir None + | VernacMemOption _ + | VernacPrintOption _ + | VernacCheckMayEval _ + | VernacGlobalCheck _ + | VernacPrint _ + | VernacSearch _ + | VernacLocate _ -> true + | _ -> false + +let is_undo cmd = match cmd with + | VernacUndo _ | VernacUndoTo _ -> true + | _ -> false (** Check whether a command is forbidden by CoqIDE *) @@ -276,82 +99,28 @@ let coqide_cmd_checks (loc,ast) = let user_error s = raise (Loc.Exc_located (loc, Util.UserError ("CoqIde", str s))) in - if is_vernac_debug_command ast then + if is_debug ast then user_error "Debug mode not available within CoqIDE"; - if is_vernac_navigation_command ast then - user_error "Use CoqIDE navigation instead"; - if is_vernac_known_option_command ast then + if is_known_option ast then user_error "Use CoqIDE display menu instead"; - if is_vernac_query_command ast then + if is_navigation_vernac ast then + user_error "Use CoqIDE navigation instead"; + if is_undo ast then + msgerrnl (str "Warning: rather use CoqIDE navigation instead"); + if is_query ast then msgerrnl (str "Warning: query commands should not be inserted in scripts") -let raw_eval_expr = Vernac.eval_expr - -let eval_expr loc_ast = - let rewind_info = compute_reset_info () in - raw_eval_expr loc_ast; - Stack.push rewind_info com_stk +(** Interpretation (cf. [Ide_intf.interp]) *) let interp (raw,verbosely,s) = - if not raw then (prerr_endline "Starting interp..."; prerr_endline s); let pa = Pcoq.Gram.parsable (Stream.of_string s) in let loc_ast = Vernac.parse_sentence (pa,None) in if not raw then coqide_cmd_checks loc_ast; - (* We run tactics silently, since we will query the goal state later. - Otherwise, we honor the IDE verbosity flag. *) - Flags.make_silent - (is_vernac_goal_printing_command (snd loc_ast) || not verbosely); - if raw then raw_eval_expr loc_ast else eval_expr loc_ast; + Flags.make_silent (not verbosely); + Vernac.eval_expr ~preserving:raw loc_ast; Flags.make_silent true; - if not raw then prerr_endline ("...Done with interp of : "^s); read_stdout () - -(** Backtracking (cf. [Ide_intf.rewind]). - We now rely on the [Backtrack] command just as ProofGeneral. *) - -let rewind count = - if count = 0 then 0 - else - let current_proofs = Pfedit.get_all_proof_names () - in - (* 1) First, let's pop the history stack exactly [count] times. - NB: Normally, the IDE will not rewind by more than the numbers - of already interpreted commands, hence no risk of [Stack.Empty]. - *) - let initial_target = - for i = 1 to count - 1 do ignore (Stack.pop com_stk) done; - Stack.pop com_stk - in - (* 2) Backtrack by enough additional steps to avoid re-opening proofs. - Typically, when a Qed has been crossed, we backtrack to the proof start. - NB: We cannot reach the empty stack, since the oldest [reset_info] - in the history cannot have opened proofs. - *) - let already_opened p = List.mem p current_proofs in - let rec extra_back n target = - if List.for_all already_opened target.proofs then n,target - else extra_back (n+1) (Stack.pop com_stk) - in - let extra_count, target = extra_back 0 initial_target - in - (* 3) Now that [target.proofs] is a subset of the opened proofs before - the rewind, we simply abort the extra proofs (if any). - NB: It is critical here that proofs are nested in a regular way - (i.e. no Resume or Suspend, as enforced above). This way, we can simply - count the extra proofs to abort instead of taking care of their names. - *) - let naborts = List.length current_proofs - List.length target.proofs - in - (* 4) We are now ready to call [Backtrack] *) - prerr_endline ("Rewind to state "^string_of_int target.label^ - ", proof depth "^string_of_int target.depth^ - ", num of aborts "^string_of_int naborts); - Vernacentries.vernac_backtrack target.label target.depth naborts; - Lib.mark_end_of_command (); (* We've short-circuited Vernac.eval_expr *) - extra_count - - (** Goal display *) let hyp_next_tac sigma env (id,_,ast) = @@ -404,16 +173,17 @@ let concl_next_tac sigma concl = let process_goal sigma g = let env = Goal.V82.env sigma g in + let id = Goal.uid g in let ccl = let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in - string_of_ppcmds (pr_ltype_env_at_top env norm_constr) in + string_of_ppcmds (pr_goal_concl_style_env env norm_constr) in let process_hyp h_env d acc = let d = Term.map_named_declaration (Reductionops.nf_evar sigma) d in (string_of_ppcmds (pr_var_decl h_env d)) :: acc in (* (string_of_ppcmds (pr_var_decl h_env d), hyp_next_tac sigma h_env d)::acc in *) let hyps = List.rev (Environ.fold_named_context process_hyp env ~init: []) in - { Interface.goal_hyp = hyps; Interface.goal_ccl = ccl } + { Interface.goal_hyp = hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; } (* hyps,(ccl,concl_next_tac sigma g)) *) let goals () = @@ -472,6 +242,82 @@ let status () = in { Interface.status_path = path; Interface.status_proofname = proof } +(** This should be elsewhere... *) +let search flags = + let env = Global.env () in + let rec extract_flags name tpe subtpe mods blacklist = function + | [] -> (name, tpe, subtpe, mods, blacklist) + | (Interface.Name_Pattern s, b) :: l -> + let regexp = + try Str.regexp s + with _ -> Util.error ("Invalid regexp: " ^ s) + in + extract_flags ((regexp, b) :: name) tpe subtpe mods blacklist l + | (Interface.Type_Pattern s, b) :: l -> + let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in + let (_, pat) = Constrintern.intern_constr_pattern Evd.empty env constr in + extract_flags name ((pat, b) :: tpe) subtpe mods blacklist l + | (Interface.SubType_Pattern s, b) :: l -> + let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in + let (_, pat) = Constrintern.intern_constr_pattern Evd.empty env constr in + extract_flags name tpe ((pat, b) :: subtpe) mods blacklist l + | (Interface.In_Module m, b) :: l -> + let path = String.concat "." m in + let m = Pcoq.parse_string Pcoq.Constr.global path in + let (_, qid) = Libnames.qualid_of_reference m in + let id = + try Nametab.full_name_module qid + with Not_found -> + Util.error ("Module " ^ path ^ " not found.") + in + extract_flags name tpe subtpe ((id, b) :: mods) blacklist l + | (Interface.Include_Blacklist, b) :: l -> + extract_flags name tpe subtpe mods b l + in + let (name, tpe, subtpe, mods, blacklist) = + extract_flags [] [] [] [] false flags + in + let filter_function ref env constr = + let id = Names.string_of_id (Nametab.basename_of_global ref) in + let path = Libnames.dirpath (Nametab.path_of_global ref) in + let toggle x b = if x then b else not b in + let match_name (regexp, flag) = + toggle (Str.string_match regexp id 0) flag + in + let match_type (pat, flag) = + toggle (Matching.is_matching pat constr) flag + in + let match_subtype (pat, flag) = + toggle (Matching.is_matching_appsubterm ~closed:false pat constr) flag + in + let match_module (mdl, flag) = + toggle (Libnames.is_dirpath_prefix_of mdl path) flag + in + let in_blacklist = + blacklist || (Search.filter_blacklist ref env constr) + in + List.for_all match_name name && + List.for_all match_type tpe && + List.for_all match_subtype subtpe && + List.for_all match_module mods && in_blacklist + in + let ans = ref [] in + let print_function ref env constr = + let name = Names.string_of_id (Nametab.basename_of_global ref) in + let make_path = Names.string_of_id in + let path = + List.rev_map make_path (Names.repr_dirpath (Nametab.dirpath_of_global ref)) + in + let answer = { + Interface.search_answer_full_path = path; + Interface.search_answer_base_name = name; + Interface.search_answer_type = string_of_ppcmds (pr_lconstr_env env constr); + } in + ans := answer :: !ans; + in + let () = Search.gen_filtered_search filter_function print_function in + !ans + let get_options () = let table = Goptions.get_tables () in let fold key state accu = (key, state) :: accu in @@ -485,13 +331,31 @@ let set_options options = in List.iter iter options +let about () = { + Interface.coqtop_version = Coq_config.version; + Interface.protocol_version = Ide_intf.protocol_version; + Interface.release_date = Coq_config.date; + Interface.compile_date = Coq_config.compile_date; +} + (** Grouping all call handlers together + error handling *) +exception Quit + let eval_call c = let rec handle_exn e = catch_break := false; - let pr_exn e = string_of_ppcmds (Errors.print e) in + let pr_exn e = (read_stdout ())^("\n"^(string_of_ppcmds (Errors.print e))) in match e with + | Quit -> + (* Here we do send an acknowledgement message to prove everything went + OK. *) + let dummy = Interface.Good () in + let xml_answer = Ide_intf.of_answer Ide_intf.quit dummy in + let () = Xml_utils.print_xml !orig_stdout xml_answer in + let () = flush !orig_stdout in + let () = pr_debug "Exiting gracefully." in + exit 0 | Vernacexpr.Drop -> None, "Drop is not allowed by coqide!" | Vernacexpr.Quit -> None, "Quit is not allowed by coqide!" | Vernac.DuringCommandInterp (_,inner) -> handle_exn inner @@ -508,17 +372,20 @@ let eval_call c = r in let handler = { - Interface.interp = interruptible interp; - Interface.rewind = interruptible rewind; - Interface.goals = interruptible goals; - Interface.evars = interruptible evars; - Interface.hints = interruptible hints; - Interface.status = interruptible status; - Interface.inloadpath = interruptible inloadpath; - Interface.get_options = interruptible get_options; - Interface.set_options = interruptible set_options; - Interface.mkcases = interruptible Vernacentries.make_cases; - Interface.handle_exn = handle_exn; } + Ide_intf.interp = interruptible interp; + Ide_intf.rewind = interruptible Backtrack.back; + Ide_intf.goals = interruptible goals; + Ide_intf.evars = interruptible evars; + Ide_intf.hints = interruptible hints; + Ide_intf.status = interruptible status; + Ide_intf.search = interruptible search; + Ide_intf.inloadpath = interruptible inloadpath; + Ide_intf.get_options = interruptible get_options; + Ide_intf.set_options = interruptible set_options; + Ide_intf.mkcases = interruptible Vernacentries.make_cases; + Ide_intf.quit = (fun () -> raise Quit); + Ide_intf.about = interruptible about; + Ide_intf.handle_exn = handle_exn; } in (* If the messages of last command are still there, we remove them *) ignore (read_stdout ()); @@ -534,9 +401,6 @@ let eval_call c = between coqtop and ide. With marshalling, reading an answer to a different request could hang the ide... *) -let pr_debug s = - if !Flags.debug then Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s - let fail err = Ide_intf.of_value (fun _ -> assert false) (Interface.Fail (None, err)) @@ -545,9 +409,9 @@ let loop () = let () = Xml_parser.check_eof p false in init_signal_handler (); catch_break := false; - (* ensure we have a command separator object (DOT) so that the first - command can be reseted. *) - Lib.mark_end_of_command(); + (* We'll handle goal fetching and display in our own way *) + Vernacentries.enable_goal_printing := false; + Vernacentries.qed_display_script := false; try while true do let xml_answer = diff --git a/toplevel/interface.mli b/toplevel/interface.mli index e1410f5b..f3374ab4 100644 --- a/toplevel/interface.mli +++ b/toplevel/interface.mli @@ -15,6 +15,8 @@ type verbose = bool (** The type of coqtop goals *) type goal = { + goal_id : string; + (** Unique goal identifier *) goal_hyp : string list; (** List of hypotheses *) goal_ccl : string; @@ -62,6 +64,35 @@ type option_state = Goptionstyp.option_state = { (** The current value of the option *) } +type search_constraint = +(** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) +| Name_Pattern of string +(** Whether the object type satisfies a pattern *) +| Type_Pattern of string +(** Whether some subtype of object type satisfies a pattern *) +| SubType_Pattern of string +(** Whether the object pertains to a module *) +| In_Module of string list +(** Bypass the Search blacklist *) +| Include_Blacklist + +(** A list of search constraints; the boolean flag is set to [false] whenever + the flag should be negated. *) +type search_flags = (search_constraint * bool) list + +type search_answer = { + search_answer_full_path : string list; + search_answer_base_name : string; + search_answer_type : string; +} + +type coq_info = { + coqtop_version : string; + protocol_version : string; + release_date : string; + compile_date : string; +} + (** * Coq answers to CoqIde *) type location = (int * int) option (* start and end of the error *) @@ -69,19 +100,3 @@ type location = (int * int) option (* start and end of the error *) type 'a value = | Good of 'a | Fail of (location * string) - -(** * The structure that coqtop should implement *) - -type handler = { - interp : raw * verbose * string -> string; - rewind : int -> int; - goals : unit -> goals option; - evars : unit -> evar list option; - hints : unit -> (hint list * hint) option; - status : unit -> status; - get_options : unit -> (option_name * option_state) list; - set_options : (option_name * option_value) list -> unit; - inloadpath : string -> bool; - mkcases : string -> string list list; - handle_exn : exn -> location * string; -} diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 6a4d7251..cdeff601 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -986,6 +986,18 @@ let inNotation : notation_obj -> obj = classify_function = classify_notation} (**********************************************************************) + +let with_lib_stk_protection f x = + let fs = Lib.freeze () in + try let a = f x in Lib.unfreeze fs; a + with e -> Lib.unfreeze fs; raise e + +let with_syntax_protection f x = + with_lib_stk_protection + (with_grammar_rule_protection + (with_notation_protection f)) x + +(**********************************************************************) (* Recovering existing syntax *) let contract_notation ntn = diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index 4ee1310a..32568854 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -61,3 +61,5 @@ val add_syntactic_definition : identifier -> identifier list * constr_expr -> val print_grammar : string -> unit val check_infix_modifiers : syntax_modifier list -> unit + +val with_syntax_protection : ('a -> 'b) -> 'a -> 'b diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4 index ff3ce8a0..025c972f 100644 --- a/toplevel/mltop.ml4 +++ b/toplevel/mltop.ml4 @@ -235,9 +235,24 @@ let add_known_module mname = let module_is_known mname = Stringset.mem (String.capitalize mname) !known_loaded_modules +let known_loaded_plugins = ref Stringmap.empty + +let init_ml_object mname = + try Stringmap.find mname !known_loaded_plugins () + with Not_found -> () + let load_ml_object mname fname= dir_ml_load fname; - add_known_module mname + add_known_module mname; + init_ml_object mname + +let add_known_plugin init name = + let name = String.capitalize name in + add_known_module name; + known_loaded_plugins := Stringmap.add name init !known_loaded_plugins + +let init_known_plugins () = + Stringmap.iter (fun _ f -> f()) !known_loaded_plugins (* Summary of declared ML Modules *) @@ -260,7 +275,8 @@ let unfreeze_ml_modules x = load_ml_object mname fname else errorlabstrm "Mltop.unfreeze_ml_modules" - (str"Loading of ML object file forbidden in a native Coq."); + (str"Loading of ML object file forbidden in a native Coq.") + else init_ml_object mname; add_loaded_module mname) x @@ -290,7 +306,8 @@ let cache_ml_module_object (_,{mnames=mnames}) = raise e else (if_verbose msgnl (str" failed]"); - error ("Dynamic link not supported (module "^name^")"))) + error ("Dynamic link not supported (module "^name^")")) + else init_ml_object mname) mnames let classify_ml_module_object ({mlocal=mlocal} as o) = diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli index 1e9c3b03..99b96ed7 100644 --- a/toplevel/mltop.mli +++ b/toplevel/mltop.mli @@ -51,6 +51,16 @@ val add_known_module : string -> unit val module_is_known : string -> bool val load_ml_object : string -> string -> unit +(* Declare a plugin and its initialization function. + * A plugin is just an ML module with an initialization function. + * Adding a known plugin implies adding it as a known ML module. + * The initialization function is granted to be called after Coq is fully + * bootstrapped, even if the plugin is statically linked with the toplevel *) +val add_known_plugin : (unit -> unit) -> string -> unit + +(* Calls all initialization functions in a non-specified order *) +val init_known_plugins : unit -> unit + (** Summary of Declared ML Modules *) val get_loaded_modules : unit -> string list val add_loaded_module : string -> unit diff --git a/toplevel/record.ml b/toplevel/record.ml index 86849cbb..0c55861f 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -81,8 +81,8 @@ let typecheck_params_and_fields id t ps nots fs = let newps = Evarutil.nf_rel_context_evar sigma newps in let newfs = Evarutil.nf_rel_context_evar sigma newfs in let ce t = Evarutil.check_evars env0 Evd.empty evars t in - List.iter (fun (n, b, t) -> Option.iter ce b; ce t) newps; - List.iter (fun (n, b, t) -> Option.iter ce b; ce t) newfs; + List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newps); + List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newfs); imps, newps, impls, newfs let degenerate_decl (na,b,t) = @@ -263,7 +263,7 @@ let declare_structure finite infer id idbuild paramimpls params arity fieldimpls begin match finite with | BiFinite -> if Termops.dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) then - error "Records declared with the keyword Record or Structure cannot be recursive. Maybe you meant to define an Inductive or CoInductive record." + error "Records declared with the keyword Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command." | _ -> () end; let mie = diff --git a/toplevel/search.mli b/toplevel/search.mli index d2d5c538..95827d54 100644 --- a/toplevel/search.mli +++ b/toplevel/search.mli @@ -33,6 +33,8 @@ val search_about : val filter_by_module_from_list : dir_path list * bool -> global_reference -> env -> 'a -> bool +val filter_blacklist : global_reference -> env -> constr -> bool + (** raw search functions can be used for various extensions. They are also used for pcoq. *) val gen_filtered_search : (global_reference -> env -> constr -> bool) -> diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml index 699fd12f..8514872b 100644 --- a/toplevel/toplevel.ml +++ b/toplevel/toplevel.ml @@ -367,9 +367,6 @@ let do_vernac () = let rec loop () = Sys.catch_break true; - (* ensure we have a command separator object (DOT) so that the first - command can be reseted. *) - Lib.mark_end_of_command(); try reset_input_buffer stdin top_buffer; while true do do_vernac() done diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib index 8b03e938..e1e349a6 100644 --- a/toplevel/toplevel.mllib +++ b/toplevel/toplevel.mllib @@ -13,6 +13,7 @@ Command Classes Record Ppvernac +Backtrack Vernacinterp Mltop Vernacentries diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 84e20f5e..ed20fc60 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -51,6 +51,8 @@ let real_error = function | Error_in_file (_, _, e) -> e | e -> e +let user_error loc s = Util.user_err_loc (loc,"_",str s) + (** Timeout handling *) (** A global default timeout, controled by option "Set Default Timeout n". @@ -97,6 +99,18 @@ let restore_timeout = function (* restore handler *) Sys.set_signal Sys.sigalrm psh + +(* Open an utf-8 encoded file and skip the byte-order mark if any *) + +let open_utf8_file_in fname = + let is_bom s = + Char.code s.[0] = 0xEF && Char.code s.[1] = 0xBB && Char.code s.[2] = 0xBF + in + let in_chan = open_in fname in + let s = " " in + if input in_chan s 0 3 < 3 || not (is_bom s) then seek_in in_chan 0; + in_chan + (* Opening and closing a channel. Open it twice when verbose: the first channel is used to read the commands, and the second one to print them. Note: we could use only one thanks to seek_in, but seeking on and on in @@ -106,8 +120,9 @@ let open_file_twice_if verbosely fname = let paths = Library.get_load_paths () in let _,longfname = find_file_in_path ~warn:(Flags.is_verbose()) paths fname in - let in_chan = open_in longfname in - let verb_ch = if verbosely then Some (open_in longfname) else None in + let in_chan = open_utf8_file_in longfname in + let verb_ch = + if verbosely then Some (open_utf8_file_in longfname) else None in let po = Pcoq.Gram.parsable (Stream.of_channel in_chan) in (in_chan, longfname, (po, verb_ch)) @@ -166,7 +181,7 @@ let pr_new_syntax loc ocom = States.unfreeze fs; Format.set_formatter_out_channel stdout -let rec vernac_com interpfun (loc,com) = +let rec vernac_com interpfun checknav (loc,com) = let rec interp = function | VernacLoad (verbosely, fname) -> let fname = expand_path_macros fname in @@ -204,9 +219,13 @@ let rec vernac_com interpfun (loc,com) = | VernacList l -> List.iter (fun (_,v) -> interp v) l + | v when !just_parsing -> () + | VernacFail v -> - if not !just_parsing then begin try - interp v; raise HasNotFailed + begin try + (* If the command actually works, ignore its effects on the state *) + States.with_state_protection + (fun v -> interp v; raise HasNotFailed) v with e -> match real_error e with | HasNotFailed -> errorlabstrm "Fail" (str "The command has not failed !") @@ -219,22 +238,17 @@ let rec vernac_com interpfun (loc,com) = end | VernacTime v -> - if not !just_parsing then begin let tstart = System.get_time() in interp v; let tend = System.get_time() in msgnl (str"Finished transaction in " ++ System.fmt_time_difference tstart tend) - end | VernacTimeout(n,v) -> - if not !just_parsing then begin current_timeout := Some n; interp v - end | v -> - if not !just_parsing then let psh = default_set_timeout () in try States.with_heavy_rollback interpfun @@ -243,6 +257,7 @@ let rec vernac_com interpfun (loc,com) = with e -> restore_timeout psh; raise e in try + checknav loc com; current_timeout := !default_timeout; if do_beautify () then pr_new_syntax loc (Some com); interp com @@ -256,13 +271,17 @@ and read_vernac_file verbosely s = if verbosely then Vernacentries.interp else Flags.silently Vernacentries.interp in + let checknav loc cmd = + if is_navigation_vernac cmd then + user_error loc "Navigation commands forbidden in files" + in let (in_chan, fname, input) = open_file_twice_if verbosely s in try (* we go out of the following infinite loop when a End_of_input is * raised, which means that we raised the end of the file being loaded *) while true do - vernac_com interpfun (parse_sentence input); + vernac_com interpfun checknav (parse_sentence input); pp_flush () done with e -> (* whatever the exception *) @@ -273,15 +292,21 @@ and read_vernac_file verbosely s = if do_beautify () then pr_new_syntax (make_loc (max_int,max_int)) None | _ -> raise_with_file fname e +(** [eval_expr : ?preserving:bool -> Pp.loc * Vernacexpr.vernac_expr -> unit] + It executes one vernacular command. By default the command is + considered as non-state-preserving, in which case we add it to the + Backtrack stack (triggering a save of a frozen state and the generation + of a new state label). An example of state-preserving command is one coming + from the query panel of Coqide. *) -(* eval_expr : Util.loc * Vernacexpr.vernac_expr -> unit - * execute one vernacular command. Marks the end of the command in the lib_stk - * with a new label to make vernac undoing easier. Also freeze state to speed up - * backtracking. *) -let eval_expr last = - vernac_com Vernacentries.interp last; - Lib.add_frozen_state(); - Lib.mark_end_of_command() +let checknav loc ast = + if is_deep_navigation_vernac ast then + user_error loc "Navigation commands forbidden in nested commands" + +let eval_expr ?(preserving=false) loc_ast = + vernac_com Vernacentries.interp checknav loc_ast; + if not preserving && not (is_navigation_vernac (snd loc_ast)) then + Backtrack.mark_command (snd loc_ast) (* raw_do_vernac : Pcoq.Gram.parsable -> unit * vernac_step . parse_sentence *) @@ -317,5 +342,3 @@ let compile verbosely f = if !Flags.xml_export then !xml_end_library (); Dumpglob.end_dump_glob (); Library.save_library_to ldir (long_f_dot_v ^ "o") - - diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index d89e90d0..bcfe9b71 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -21,7 +21,14 @@ exception DuringCommandInterp of Util.loc * exn exception End_of_input val just_parsing : bool ref -val eval_expr : Util.loc * Vernacexpr.vernac_expr -> unit + +(** [eval_expr] executes one vernacular command. By default the command is + considered as non-state-preserving, in which case we add it to the + Backtrack stack (triggering a save of a frozen state and the generation + of a new state label). An example of state-preserving command is one coming + from the query panel of Coqide. *) + +val eval_expr : ?preserving:bool -> Util.loc * Vernacexpr.vernac_expr -> unit val raw_do_vernac : Pcoq.Gram.parsable -> unit (** Set XML hooks *) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 5787feb0..2324e3e9 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -73,8 +73,9 @@ let show_node () = () let show_script () = - (* spiwack: show_script is currently not working *) - () + let prf = Pfedit.get_current_proof_name () in + let cmds = Backtrack.get_script prf in + msgnl (Util.prlist_with_sep Pp.fnl Ppvernac.pr_vernac cmds) let show_thesis () = msgnl (anomaly "TODO" ) @@ -91,7 +92,16 @@ let show_prooftree () = (* Spiwack: proof tree is currently not working *) () -let print_subgoals () = if_verbose (fun () -> msg (pr_open_subgoals ())) () +let enable_goal_printing = ref true + +let print_subgoals () = + if !enable_goal_printing && is_verbose () + then msg (pr_open_subgoals ()) + +let try_print_subgoals () = + Pp.flush_all(); + try print_subgoals () with Proof_global.NoCurrentProof | UserError _ -> () + (* Simulate the Intro(s) tactic *) @@ -341,7 +351,7 @@ let vernac_definition (local,k) (loc,id as lid) def hook = | None -> None | Some r -> let (evc,env)= get_current_context () in - Some (interp_redexp env evc r) in + Some (snd (interp_redexp env evc r)) in let ce,imps = interp_definition bl red_option c typ_opt in declare_definition id (local,k) ce imps hook) @@ -357,14 +367,21 @@ let vernac_start_proof kind l lettop hook = (str "Let declarations can only be used in proof editing mode."); start_proof_and_print (Global, Proof kind) l hook +let qed_display_script = ref true + let vernac_end_proof = function - | Admitted -> admit () + | Admitted -> + Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()]; + admit () | Proved (is_opaque,idopt) -> - if not !Flags.print_emacs then if_verbose show_script (); - match idopt with + let prf = Pfedit.get_current_proof_name () in + if is_verbose () && !qed_display_script then (show_script (); msg (fnl())); + begin match idopt with | None -> save_named is_opaque | Some ((_,id),None) -> save_anonymous is_opaque id | Some ((_,id),Some kind) -> save_anonymous_with_strength kind is_opaque id + end; + Backtrack.mark_unreachable [prf] (* A stupid macro that should be replaced by ``Exact c. Save.'' all along the theories [??] *) @@ -723,28 +740,14 @@ let vernac_chdir = function (********************) (* State management *) -let abort_refine f x = - if Pfedit.refining() then delete_all_proofs (); - f x - (* used to be: error "Must save or abort current goal first" *) - -let vernac_write_state file = abort_refine States.extern_state file - -let vernac_restore_state file = abort_refine States.intern_state file - - -(*************) -(* Resetting *) - -let vernac_reset_name id = abort_refine Lib.reset_name id +let vernac_write_state file = + Pfedit.delete_all_proofs (); + States.extern_state file -let vernac_reset_initial () = abort_refine Lib.reset_initial () +let vernac_restore_state file = + Pfedit.delete_all_proofs (); + States.intern_state file -let vernac_back n = Lib.back n - -let vernac_backto n = Lib.reset_label n - -(* see also [vernac_backtrack] which combines undoing and resetting *) (************) (* Commands *) @@ -772,8 +775,10 @@ let vernac_declare_implicits local r = function (List.map (List.map (fun (ex,b,f) -> ex, (b,true,f))) imps) let vernac_declare_arguments local r l nargs flags = + let extra_scope_flag = List.mem `ExtraScopes flags in let names = List.map (List.map (fun (id, _,_,_,_) -> id)) l in let names, rest = List.hd names, List.tl names in + let scopes = List.map (List.map (fun (_,_, s, _,_) -> s)) l in if List.exists ((<>) names) rest then error "All arguments lists must declare the same names."; if not (Util.list_distinct (List.filter ((<>) Anonymous) names)) then @@ -782,14 +787,26 @@ let vernac_declare_arguments local r l nargs flags = let inf_names = Impargs.compute_implicits_names (Global.env()) (Global.type_of_global sr) in let string_of_name = function Anonymous -> "_" | Name id -> string_of_id id in - let rec check li ld = match li, ld with - | [], [] -> () - | [], x::_ -> error ("Extra argument " ^ string_of_name x ^ ".") - | l, [] -> error ("The following arguments are not declared: " ^ + let rec check li ld ls = match li, ld, ls with + | [], [], [] -> () + | [], Anonymous::ld, (Some _)::ls when extra_scope_flag -> check li ld ls + | [], _::_, (Some _)::ls when extra_scope_flag -> + error "Extra notation scopes can be set on anonymous arguments only" + | [], x::_, _ -> error ("Extra argument " ^ string_of_name x ^ ".") + | l, [], _ -> error ("The following arguments are not declared: " ^ (String.concat ", " (List.map string_of_name l)) ^ ".") - | _::li, _::ld -> check li ld in + | _::li, _::ld, _::ls -> check li ld ls + | _ -> assert false in if l <> [[]] then - List.iter (fun l -> check inf_names l) (names :: rest); + List.iter2 (fun l -> check inf_names l) (names :: rest) scopes; + (* we take extra scopes apart, and we check they are consistent *) + let l, scopes = + let scopes, rest = List.hd scopes, List.tl scopes in + if List.exists (List.exists ((<>) None)) rest then + error "Notation scopes can be given only once"; + if not extra_scope_flag then l, scopes else + let l, _ = List.split (List.map (list_chop (List.length inf_names)) l) in + l, scopes in (* we interpret _ as the inferred names *) let l = if l = [[]] then l else let name_anons = function @@ -822,10 +839,10 @@ let vernac_declare_arguments local r l nargs flags = let l = List.hd l in let some_implicits_specified = implicits <> [[]] in let scopes = List.map (function - | (_,_, None,_,_) -> None - | (_,_, Some (o, k), _,_) -> + | None -> None + | Some (o, k) -> try Some(ignore(Notation.find_scope k); k) - with _ -> Some (Notation.find_delimiters_scope o k)) l in + with _ -> Some (Notation.find_delimiters_scope o k)) scopes in let some_scopes_specified = List.exists ((<>) None) scopes in let rargs = Util.list_map_filter (function (n, true) -> Some n | _ -> None) @@ -952,6 +969,7 @@ let _ = optkey = ["Printing";"Existential";"Instances"]; optread = (fun () -> !Constrextern.print_evar_arguments); optwrite = (:=) Constrextern.print_evar_arguments } + let _ = declare_bool_option { optsync = true; @@ -1095,6 +1113,15 @@ let _ = optread = (fun () -> get_debug () <> Tactic_debug.DebugOff); optwrite = vernac_debug } +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "explicitly parsing implicit arguments"; + optkey = ["Parsing";"Explicit"]; + optread = (fun () -> !Constrintern.parsing_explicit); + optwrite = (fun b -> Constrintern.parsing_explicit := b) } + let vernac_set_opacity local str = let glob_ref r = match smart_global r with @@ -1150,6 +1177,7 @@ let vernac_check_may_eval redexp glopt rc = let module P = Pretype_errors in let (sigma, env) = get_current_context_of_args glopt in let sigma', c = interp_open_constr sigma env rc in + let sigma' = Evarconv.consider_remaining_unif_problems env sigma' in let j = try Evarutil.check_evars env sigma sigma' c; @@ -1162,13 +1190,14 @@ let vernac_check_may_eval redexp glopt rc = if !pcoq <> None then (Option.get !pcoq).print_check env j else msg (print_judgment env j) | Some r -> - let redfun = fst (reduction_of_red_expr (interp_redexp env sigma' r)) in + let (sigma',r_interp) = interp_redexp env sigma' r in + let redfun = fst (reduction_of_red_expr r_interp) in if !pcoq <> None then (Option.get !pcoq).print_eval redfun env sigma' rc j else msg (print_eval redfun env sigma' rc j) let vernac_declare_reduction locality s r = - declare_red_expr locality s (interp_redexp (Global.env()) Evd.empty r) + declare_red_expr locality s (snd (interp_redexp (Global.env()) Evd.empty r)) (* The same but avoiding the current goal context if any *) let vernac_global_check c = @@ -1286,15 +1315,54 @@ let vernac_locate = function | LocateTactic qid -> print_located_tactic qid | LocateFile f -> locate_file f +(****************) +(* Backtracking *) + +(** NB: these commands are now forbidden in non-interactive use, + e.g. inside VernacLoad, VernacList, ... *) + +let vernac_backto lbl = + try + let lbl' = Backtrack.backto lbl in + if lbl <> lbl' then + Pp.msg_warning + (str "Actually back to state "++ Pp.int lbl' ++ str "."); + try_print_subgoals () + with Backtrack.Invalid -> error "Invalid backtrack." + +let vernac_back n = + try + let extra = Backtrack.back n in + if extra <> 0 then + Pp.msg_warning + (str "Actually back by " ++ Pp.int (extra+n) ++ str " steps."); + try_print_subgoals () + with Backtrack.Invalid -> error "Invalid backtrack." + +let vernac_reset_name id = + try Backtrack.reset_name id; try_print_subgoals () + with Backtrack.Invalid -> error "Invalid Reset." + +let vernac_reset_initial () = Backtrack.reset_initial () + +(* For compatibility with ProofGeneral: *) + +let vernac_backtrack snum pnum naborts = + Backtrack.backtrack snum pnum naborts; + try_print_subgoals () + + (********************) (* Proof management *) let vernac_abort = function | None -> + Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()]; delete_current_proof (); if_verbose message "Current goal aborted"; if !pcoq <> None then (Option.get !pcoq).abort "" | Some id -> + Backtrack.mark_unreachable [snd id]; delete_proof id; let s = string_of_id (snd id) in if_verbose message ("Goal "^s^" aborted"); @@ -1302,49 +1370,45 @@ let vernac_abort = function let vernac_abort_all () = if refining() then begin + Backtrack.mark_unreachable (Pfedit.get_all_proof_names ()); delete_all_proofs (); message "Current goals aborted" end else error "No proof-editing in progress." -let vernac_restart () = restart_proof(); print_subgoals () - - (* Proof switching *) - -let vernac_suspend = suspend_proof - -let vernac_resume = function - | None -> resume_last_proof () - | Some id -> resume_proof id +let vernac_restart () = + Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()]; + restart_proof(); print_subgoals () let vernac_undo n = - undo n; - print_subgoals () - -(* backtrack with [naborts] abort, then undo_todepth to [pnum], then - back-to state number [snum]. This allows to backtrack proofs and - state with one command (easier for proofgeneral). *) -let vernac_backtrack snum pnum naborts = - for i = 1 to naborts do vernac_abort None done; - undo_todepth pnum; - vernac_backto snum; - Pp.flush_all(); - (* there may be no proof in progress, even if no abort *) - (try print_subgoals () with Proof_global.NoCurrentProof | UserError _ -> ()) + let d = Pfedit.current_proof_depth () - n in + Backtrack.mark_unreachable ~after:d [Pfedit.get_current_proof_name ()]; + Pfedit.undo n; print_subgoals () +let vernac_undoto n = + Backtrack.mark_unreachable ~after:n [Pfedit.get_current_proof_name ()]; + Pfedit.undo_todepth n; + print_subgoals () let vernac_focus gln = let p = Proof_global.give_me_the_proof () in - match gln with - | None -> Proof.focus focus_command_cond () 1 p; print_subgoals () - | Some n -> Proof.focus focus_command_cond () n p; print_subgoals () - + let n = match gln with None -> 1 | Some n -> n in + Proof.focus focus_command_cond () n p; print_subgoals () (* Unfocuses one step in the focus stack. *) let vernac_unfocus () = let p = Proof_global.give_me_the_proof () in Proof.unfocus command_focus p; print_subgoals () +(* Checks that a proof is fully unfocused. Raises an error if not. *) +let vernac_unfocused () = + let p = Proof_global.give_me_the_proof () in + if Proof.unfocused p then + msg (str"The proof is indeed fully unfocused.") + else + error "The proof is not fully unfocused." + + (* BeginSubproof / EndSubproof. BeginSubproof (vernac_subproof) focuses on the first goal, or the goal given as argument. @@ -1483,7 +1547,6 @@ let interp c = match c with | VernacRestoreState s -> vernac_restore_state s (* Resetting *) - | VernacRemoveName id -> Lib.remove_name id | VernacResetName id -> vernac_reset_name id | VernacResetInitial -> vernac_reset_initial () | VernacBack n -> vernac_back n @@ -1520,13 +1583,12 @@ let interp c = match c with | VernacAbort id -> vernac_abort id | VernacAbortAll -> vernac_abort_all () | VernacRestart -> vernac_restart () - | VernacSuspend -> vernac_suspend () - | VernacResume id -> vernac_resume id | VernacUndo n -> vernac_undo n - | VernacUndoTo n -> undo_todepth n + | VernacUndoTo n -> vernac_undoto n | VernacBacktrack (snum,pnum,naborts) -> vernac_backtrack snum pnum naborts | VernacFocus n -> vernac_focus n | VernacUnfocus -> vernac_unfocus () + | VernacUnfocused -> vernac_unfocused () | VernacBullet b -> vernac_bullet b | VernacSubproof n -> vernac_subproof n | VernacEndSubproof -> vernac_end_subproof () diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli index 8fb6f466..a9d384ea 100644 --- a/toplevel/vernacentries.mli +++ b/toplevel/vernacentries.mli @@ -23,13 +23,6 @@ val show_node : unit -> unit in the context of the current goal, as for instance in pcoq *) val get_current_context_of_args : int option -> Evd.evar_map * Environ.env -(*i - -(** this function is used to analyse the extra arguments in search commands. - It is used in pcoq. *) (*i anciennement: inside_outside i*) -val interp_search_restriction : search_restriction -> dir_path list * bool -i*) - type pcoq_hook = { start_proof : unit -> unit; solve : int -> unit; @@ -44,21 +37,27 @@ type pcoq_hook = { val set_pcoq_hook : pcoq_hook -> unit -(** This function makes sure that the function given in argument is preceded - by a command aborting all proofs if necessary. - It is used in pcoq. *) -val abort_refine : ('a -> unit) -> 'a -> unit;; +(** The main interpretation function of vernacular expressions *) val interp : Vernacexpr.vernac_expr -> unit -val vernac_reset_name : identifier Util.located -> unit +(** Print subgoals when the verbose flag is on. + Meant to be used inside vernac commands from plugins. *) -val vernac_backtrack : int -> int -> int -> unit - -(* Print subgoals when the verbose flag is on. Meant to be used inside - vernac commands from plugins. *) val print_subgoals : unit -> unit +(** The printing of goals via [print_subgoals] or during + [interp] can be controlled by the following flag. + Used for instance by coqide, since it has its own + goal-fetching mechanism. *) + +val enable_goal_printing : bool ref + +(** Should Qed try to display the proof script ? + True by default, but false in ProofGeneral and coqIDE *) + +val qed_display_script : bool ref + (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name followed by enough pattern variables. diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml index 850bc111..d9f15337 100644 --- a/toplevel/vernacexpr.ml +++ b/toplevel/vernacexpr.ml @@ -114,8 +114,6 @@ type hints_expr = | HintsTransparency of reference list * bool | HintsConstructors of reference list | HintsExtern of int * constr_expr option * raw_tactic_expr - | HintsDestruct of identifier * - int * (bool,unit) location * constr_expr * raw_tactic_expr type search_restriction = | SearchInside of reference list @@ -300,7 +298,6 @@ type vernac_expr = | VernacRestoreState of string (* Resetting *) - | VernacRemoveName of lident | VernacResetName of lident | VernacResetInitial | VernacBack of int @@ -318,7 +315,7 @@ type vernac_expr = (explicitation * bool * bool) list list | VernacArguments of locality_flag * reference or_by_notation * ((name * bool * (loc * string) option * bool * bool) list) list * - int * [ `SimplDontExposeCase | `SimplNeverUnfold | `Rename + int * [ `SimplDontExposeCase | `SimplNeverUnfold | `Rename | `ExtraScopes | `ClearImplicits | `ClearScopes | `DefaultImplicits ] list | VernacArgumentsScope of locality_flag * reference or_by_notation * scope_name option list @@ -346,13 +343,12 @@ type vernac_expr = | VernacAbort of lident option | VernacAbortAll | VernacRestart - | VernacSuspend - | VernacResume of lident option | VernacUndo of int | VernacUndoTo of int | VernacBacktrack of int*int*int | VernacFocus of int option | VernacUnfocus + | VernacUnfocused | VernacBullet of bullet | VernacSubproof of int option | VernacEndSubproof @@ -368,6 +364,26 @@ type vernac_expr = and located_vernac_expr = loc * vernac_expr + +(** Categories of [vernac_expr] *) + +let rec strip_vernac = function + | VernacTime c | VernacTimeout(_,c) | VernacFail c -> strip_vernac c + | c -> c (* TODO: what about VernacList ? *) + +let rec is_navigation_vernac = function + | VernacResetInitial + | VernacResetName _ + | VernacBacktrack _ + | VernacBackTo _ + | VernacBack _ -> true + | c -> is_deep_navigation_vernac c + +and is_deep_navigation_vernac = function + | VernacTime c | VernacTimeout (_,c) | VernacFail c -> is_navigation_vernac c + | VernacList l -> List.exists (fun (_,c) -> is_navigation_vernac c) l + | _ -> false + (* Locating errors raised just after the dot is parsed but before the interpretation phase *) |